git.oblomov.eu Git - ikiwiki/blob - IkiWiki/Plugin/monotone.pm

   1 #!/usr/bin/perl
   2 package IkiWiki::Plugin::monotone;
   3
   4 use warnings;
   5 use strict;
   6 use IkiWiki;
   7 use Monotone;
   8 use Date::Parse qw(str2time);
   9 use Date::Format qw(time2str);
  10
  11 my $sha1_pattern = qr/[0-9a-fA-F]{40}/; # pattern to validate sha1sums
  12
  13 sub import { #{{{
  14         hook(type => "checkconfig", id => "monotone", call => \&checkconfig);
  15         hook(type => "getsetup", id => "monotone", call => \&getsetup);
  16         hook(type => "rcs", id => "rcs_update", call => \&rcs_update);
  17         hook(type => "rcs", id => "rcs_prepedit", call => \&rcs_prepedit);
  18         hook(type => "rcs", id => "rcs_commit", call => \&rcs_commit);
  19         hook(type => "rcs", id => "rcs_commit_staged", call => \&rcs_commit_staged);
  20         hook(type => "rcs", id => "rcs_add", call => \&rcs_add);
  21         hook(type => "rcs", id => "rcs_remove", call => \&rcs_remove);
  22         hook(type => "rcs", id => "rcs_rename", call => \&rcs_rename);
  23         hook(type => "rcs", id => "rcs_recentchanges", call => \&rcs_recentchanges);
  24         hook(type => "rcs", id => "rcs_diff", call => \&rcs_diff);
  25         hook(type => "rcs", id => "rcs_getctime", call => \&rcs_getctime);
  26 } #}}}
  27
  28 sub checkconfig () { #{{{
  29         if (!defined($config{mtnrootdir})) {
  30                 $config{mtnrootdir} = $config{srcdir};
  31         }
  32         if (! -d "$config{mtnrootdir}/_MTN") {
  33                 error("Ikiwiki srcdir does not seem to be a Monotone workspace (or set the mtnrootdir)!");
  34         }
  35
  36         my $child = open(MTN, "-|");
  37         if (! $child) {
  38                 open STDERR, ">/dev/null";
  39                 exec("mtn", "version") || error("mtn version failed to run");
  40         }
  41
  42         my $version=undef;
  43         while (<MTN>) {
  44                 if (/^monotone (\d+\.\d+) /) {
  45                         $version=$1;
  46                 }
  47         }
  48
  49         close MTN || debug("mtn version exited $?");
  50
  51         if (!defined($version)) {
  52                 error("Cannot determine monotone version");
  53         }
  54         if ($version < 0.38) {
  55                 error("Monotone version too old, is $version but required 0.38");
  56         }
  57
  58         if (defined $config{mtn_wrapper} && length $config{mtn_wrapper}) {
  59                 push @{$config{wrappers}}, {
  60                         wrapper => $config{mtn_wrapper},
  61                         wrappermode => (defined $config{mtn_wrappermode} ? $config{mtn_wrappermode} : "06755"),
  62                 };
  63         }
  64 } #}}}
  65
  66 sub getsetup () { #{{{
  67         return
  68                 plugin => {
  69                         safe => 0, # rcs plugin
  70                         rebuild => undef,
  71                 },
  72                 mtn_wrapper => {
  73                         type => "string",
  74                         example => "/srv/mtn/wiki/_MTN/ikiwiki-netsync-hook",
  75                         description => "monotone netsync hook to generate",
  76                         safe => 0, # file
  77                         rebuild => 0,
  78                 },
  79                 mtn_wrappermode => {
  80                         type => "string",
  81                         example => '06755',
  82                         description => "mode for mtn_wrapper (can safely be made suid)",
  83                         safe => 0,
  84                         rebuild => 0,
  85                 },
  86                 mtnkey => {
  87                         type => "string",
  88                         example => 'web@example.com',
  89                         description => "your monotone key",
  90                         safe => 1,
  91                         rebuild => 0,
  92                 },
  93                 historyurl => {
  94                         type => "string",
  95                         example => "http://viewmtn.example.com/branch/head/filechanges/com.example.branch/[[file]]",
  96                         description => "viewmtn url to show file history ([[file]] substituted)",
  97                         safe => 1,
  98                         rebuild => 1,
  99                 },
 100                 diffurl => {
 101                         type => "string",
 102                         example => "http://viewmtn.example.com/revision/diff/[[r1]]/with/[[r2]]/[[file]]",
 103                         description => "viewmtn url to show a diff ([[r1]], [[r2]], and [[file]] substituted)",
 104                         safe => 1,
 105                         rebuild => 1,
 106                 },
 107                 mtnsync => {
 108                         type => "boolean",
 109                         example => 0,
 110                         description => "sync on update and commit?",
 111                         safe => 0, # paranoia
 112                         rebuild => 0,
 113                 },
 114                 mtnrootdir => {
 115                         type => "string",
 116                         description => "path to your workspace (defaults to the srcdir; specify if the srcdir is a subdirectory of the workspace)",
 117                         safe => 0, # path
 118                         rebuild => 0,
 119                 },
 120 } #}}}
 121
 122 sub get_rev () { #{{{
 123         my $sha1 = `mtn --root=$config{mtnrootdir} automate get_base_revision_id`;
 124
 125         ($sha1) = $sha1 =~ m/($sha1_pattern)/; # sha1 is untainted now
 126         if (! $sha1) {
 127                 debug("Unable to get base revision for '$config{srcdir}'.")
 128         }
 129
 130         return $sha1;
 131 } #}}}
 132
 133 sub get_rev_auto ($) { #{{{
 134         my $automator=shift;
 135
 136         my @results = $automator->call("get_base_revision_id");
 137
 138         my $sha1 = $results[0];
 139         ($sha1) = $sha1 =~ m/($sha1_pattern)/; # sha1 is untainted now
 140         if (! $sha1) {
 141                 debug("Unable to get base revision for '$config{srcdir}'.")
 142         }
 143
 144         return $sha1;
 145 } #}}}
 146
 147 sub mtn_merge ($$$$) { #{{{
 148         my $leftRev=shift;
 149         my $rightRev=shift;
 150         my $branch=shift;
 151         my $author=shift;
 152
 153         my $mergeRev;
 154
 155         my $child = open(MTNMERGE, "-|");
 156         if (! $child) {
 157                 open STDERR, ">&STDOUT";
 158                 exec("mtn", "--root=$config{mtnrootdir}",
 159                      "explicit_merge", $leftRev, $rightRev,
 160                      $branch, "--author", $author, "--key",
 161                      $config{mtnkey}) || error("mtn merge failed to run");
 162         }
 163
 164         while (<MTNMERGE>) {
 165                 if (/^mtn.\s.merged.\s($sha1_pattern)$/) {
 166                         $mergeRev=$1;
 167                 }
 168         }
 169
 170         close MTNMERGE || return undef;
 171
 172         debug("merged $leftRev, $rightRev to make $mergeRev");
 173
 174         return $mergeRev;
 175 } #}}}
 176
 177 sub commit_file_to_new_rev ($$$$$$$$) { #{{{
 178         my $automator=shift;
 179         my $wsfilename=shift;
 180         my $oldFileID=shift;
 181         my $newFileContents=shift;
 182         my $oldrev=shift;
 183         my $branch=shift;
 184         my $author=shift;
 185         my $message=shift;
 186
 187         #store the file
 188         my ($out, $err) = $automator->call("put_file", $oldFileID, $newFileContents);
 189         my ($newFileID) = ($out =~ m/^($sha1_pattern)$/);
 190         error("Failed to store file data for $wsfilename in repository")
 191                 if (! defined $newFileID || length $newFileID != 40);
 192
 193         # get the mtn filename rather than the workspace filename
 194         ($out, $err) = $automator->call("get_corresponding_path", $oldrev, $wsfilename, $oldrev);
 195         my ($filename) = ($out =~ m/^file "(.*)"$/);
 196         error("Couldn't find monotone repository path for file $wsfilename") if (! $filename);
 197         debug("Converted ws filename of $wsfilename to repos filename of $filename");
 198
 199         # then stick in a new revision for this file
 200         my $manifest = "format_version \"1\"\n\n".
 201                        "new_manifest [0000000000000000000000000000000000000000]\n\n".
 202                        "old_revision [$oldrev]\n\n".
 203                        "patch \"$filename\"\n".
 204                        " from [$oldFileID]\n".
 205                        "   to [$newFileID]\n";
 206         ($out, $err) = $automator->call("put_revision", $manifest);
 207         my ($newRevID) = ($out =~ m/^($sha1_pattern)$/);
 208         error("Unable to make new monotone repository revision")
 209                 if (! defined $newRevID || length $newRevID != 40);
 210         debug("put revision: $newRevID");
 211
 212         # now we need to add certs for this revision...
 213         # author, branch, changelog, date
 214         $automator->call("cert", $newRevID, "author", $author);
 215         $automator->call("cert", $newRevID, "branch", $branch);
 216         $automator->call("cert", $newRevID, "changelog", $message);
 217         $automator->call("cert", $newRevID, "date",
 218                 time2str("%Y-%m-%dT%T", time, "UTC"));
 219
 220         debug("Added certs for rev: $newRevID");
 221         return $newRevID;
 222 } #}}}
 223
 224 sub read_certs ($$) { #{{{
 225         my $automator=shift;
 226         my $rev=shift;
 227         my @results = $automator->call("certs", $rev);
 228         my @ret;
 229
 230         my $line = $results[0];
 231         while ($line =~ m/\s+key\s"(.*?)"\nsignature\s"(ok|bad|unknown)"\n\s+name\s"(.*?)"\n\s+value\s"(.*?)"\n\s+trust\s"(trusted|untrusted)"\n/sg) {
 232                 push @ret, {
 233                         key => $1,
 234                         signature => $2,
 235                         name => $3,
 236                         value => $4,
 237                         trust => $5,
 238                 };
 239         }
 240
 241         return @ret;
 242 } #}}}
 243
 244 sub get_changed_files ($$) { #{{{
 245         my $automator=shift;
 246         my $rev=shift;
 247
 248         my @results = $automator->call("get_revision", $rev);
 249         my $changes=$results[0];
 250
 251         my @ret;
 252         my %seen = ();
 253
 254         while ($changes =~ m/\s*(add_file|patch|delete|rename)\s"(.*?)(?<!\\)"\n/sg) {
 255                 my $file = $2;
 256                 # don't add the same file multiple times
 257                 if (! $seen{$file}) {
 258                         push @ret, $file;
 259                         $seen{$file} = 1;
 260                 }
 261         }
 262
 263         return @ret;
 264 } #}}}
 265
 266 sub rcs_update () { #{{{
 267         chdir $config{srcdir}
 268             or error("Cannot chdir to $config{srcdir}: $!");
 269
 270         if (defined($config{mtnsync}) && $config{mtnsync}) {
 271                 if (system("mtn", "--root=$config{mtnrootdir}", "sync",
 272                            "--quiet", "--ticker=none",
 273                            "--key", $config{mtnkey}) != 0) {
 274                         debug("monotone sync failed before update");
 275                 }
 276         }
 277
 278         if (system("mtn", "--root=$config{mtnrootdir}", "update", "--quiet") != 0) {
 279                 debug("monotone update failed");
 280         }
 281 } #}}}
 282
 283 sub rcs_prepedit ($) { #{{{
 284         my $file=shift;
 285
 286         chdir $config{srcdir}
 287             or error("Cannot chdir to $config{srcdir}: $!");
 288
 289         # For monotone, return the revision of the file when
 290         # editing begins.
 291         return get_rev();
 292 } #}}}
 293
 294 sub rcs_commit ($$$;$$) { #{{{
 295         # Tries to commit the page; returns undef on _success_ and
 296         # a version of the page with the rcs's conflict markers on failure.
 297         # The file is relative to the srcdir.
 298         my $file=shift;
 299         my $message=shift;
 300         my $rcstoken=shift;
 301         my $user=shift;
 302         my $ipaddr=shift;
 303         my $author;
 304
 305         if (defined $user) {
 306                 $author="Web user: " . $user;
 307         }
 308         elsif (defined $ipaddr) {
 309                 $author="Web IP: " . $ipaddr;
 310         }
 311         else {
 312                 $author="Web: Anonymous";
 313         }
 314
 315         chdir $config{srcdir}
 316             or error("Cannot chdir to $config{srcdir}: $!");
 317
 318         my ($oldrev)= $rcstoken=~ m/^($sha1_pattern)$/; # untaint
 319         my $rev = get_rev();
 320         if (defined $rev && defined $oldrev && $rev ne $oldrev) {
 321                 my $automator = Monotone->new();
 322                 $automator->open_args("--root", $config{mtnrootdir}, "--key", $config{mtnkey});
 323
 324                 # Something has been committed, has this file changed?
 325                 my ($out, $err);
 326                 $automator->setOpts("r", $oldrev, "r", $rev);
 327                 ($out, $err) = $automator->call("content_diff", $file);
 328                 debug("Problem committing $file") if ($err ne "");
 329                 my $diff = $out;
 330
 331                 if ($diff) {
 332                         # Commit a revision with just this file changed off
 333                         # the old revision.
 334                         #
 335                         # first get the contents
 336                         debug("File changed: forming branch");
 337                         my $newfile=readfile("$config{srcdir}/$file");
 338
 339                         # then get the old content ID from the diff
 340                         if ($diff !~ m/^---\s$file\s+($sha1_pattern)$/m) {
 341                                 error("Unable to find previous file ID for $file");
 342                         }
 343                         my $oldFileID = $1;
 344
 345                         # get the branch we're working in
 346                         ($out, $err) = $automator->call("get_option", "branch");
 347                         chomp $out;
 348                         error("Illegal branch name in monotone workspace") if ($out !~ m/^([-\@\w\.]+)$/);
 349                         my $branch = $1;
 350
 351                         # then put the new content into the DB (and record the new content ID)
 352                         my $newRevID = commit_file_to_new_rev($automator, $file, $oldFileID, $newfile, $oldrev, $branch, $author, $message);
 353
 354                         $automator->close();
 355
 356                         # if we made it to here then the file has been committed... revert the local copy
 357                         if (system("mtn", "--root=$config{mtnrootdir}", "revert", $file) != 0) {
 358                                 debug("Unable to revert $file after merge on conflicted commit!");
 359                         }
 360                         debug("Divergence created! Attempting auto-merge.");
 361
 362                         # see if it will merge cleanly
 363                         $ENV{MTN_MERGE}="fail";
 364                         my $mergeResult = mtn_merge($newRevID, $rev, $branch, $author);
 365                         $ENV{MTN_MERGE}="";
 366
 367                         # push any changes so far
 368                         if (defined($config{mtnsync}) && $config{mtnsync}) {
 369                                 if (system("mtn", "--root=$config{mtnrootdir}", "push", "--quiet", "--ticker=none", "--key", $config{mtnkey}) != 0) {
 370                                         debug("monotone push failed");
 371                                 }
 372                         }
 373
 374                         if (defined($mergeResult)) {
 375                                 # everything is merged - bring outselves up to date
 376                                 if (system("mtn", "--root=$config{mtnrootdir}",
 377                                            "update", "-r", $mergeResult) != 0) {
 378                                         debug("Unable to update to rev $mergeResult after merge on conflicted commit!");
 379                                 }
 380                         }
 381                         else {
 382                                 debug("Auto-merge failed.  Using diff-merge to add conflict markers.");
 383
 384                                 $ENV{MTN_MERGE}="diffutils";
 385                                 $ENV{MTN_MERGE_DIFFUTILS}="partial=true";
 386                                 $mergeResult = mtn_merge($newRevID, $rev, $branch, $author);
 387                                 $ENV{MTN_MERGE}="";
 388                                 $ENV{MTN_MERGE_DIFFUTILS}="";
 389
 390                                 if (!defined($mergeResult)) {
 391                                         debug("Unable to insert conflict markers!");
 392                                         error("Your commit succeeded. Unfortunately, someone else committed something to the same ".
 393                                                 "part of the wiki at the same time. Both versions are stored in the monotone repository, ".
 394                                                 "but at present the different versions cannot be reconciled through the web interface. ".
 395                                                 "Please use the non-web interface to resolve the conflicts.");
 396                                 }
 397
 398                                 if (system("mtn", "--root=$config{mtnrootdir}",
 399                                            "update", "-r", $mergeResult) != 0) {
 400                                         debug("Unable to update to rev $mergeResult after conflict-enhanced merge on conflicted commit!");
 401                                 }
 402
 403                                 # return "conflict enhanced" file to the user
 404                                 # for cleanup note, this relies on the fact
 405                                 # that ikiwiki seems to call rcs_prepedit()
 406                                 # again after we return
 407                                 return readfile("$config{srcdir}/$file");
 408                         }
 409                         return undef;
 410                 }
 411                 $automator->close();
 412         }
 413
 414         # If we reached here then the file we're looking at hasn't changed
 415         # since $oldrev. Commit it.
 416
 417         if (system("mtn", "--root=$config{mtnrootdir}", "commit", "--quiet",
 418                    "--author", $author, "--key", $config{mtnkey}, "-m",
 419                    IkiWiki::possibly_foolish_untaint($message), $file) != 0) {
 420                 debug("Traditional commit failed! Returning data as conflict.");
 421                 my $conflict=readfile("$config{srcdir}/$file");
 422                 if (system("mtn", "--root=$config{mtnrootdir}", "revert",
 423                            "--quiet", $file) != 0) {
 424                         debug("monotone revert failed");
 425                 }
 426                 return $conflict;
 427         }
 428         if (defined($config{mtnsync}) && $config{mtnsync}) {
 429                 if (system("mtn", "--root=$config{mtnrootdir}", "push",
 430                            "--quiet", "--ticker=none", "--key",
 431                            $config{mtnkey}) != 0) {
 432                         debug("monotone push failed");
 433                 }
 434         }
 435
 436         return undef # success
 437 } #}}}
 438
 439 sub rcs_commit_staged ($$$) {
 440         # Commits all staged changes. Changes can be staged using rcs_add,
 441         # rcs_remove, and rcs_rename.
 442         my ($message, $user, $ipaddr)=@_;
 443
 444         # Note - this will also commit any spurious changes that happen to be
 445         # lying around in the working copy.  There shouldn't be any, but...
 446
 447         chdir $config{srcdir}
 448             or error("Cannot chdir to $config{srcdir}: $!");
 449
 450         my $author;
 451
 452         if (defined $user) {
 453                 $author="Web user: " . $user;
 454         }
 455         elsif (defined $ipaddr) {
 456                 $author="Web IP: " . $ipaddr;
 457         }
 458         else {
 459                 $author="Web: Anonymous";
 460         }
 461
 462         if (system("mtn", "--root=$config{mtnrootdir}", "commit", "--quiet",
 463                    "--author", $author, "--key", $config{mtnkey}, "-m",
 464                    IkiWiki::possibly_foolish_untaint($message)) != 0) {
 465                 error("Monotone commit failed");
 466         }
 467 }
 468
 469 sub rcs_add ($) { #{{{
 470         my $file=shift;
 471
 472         chdir $config{srcdir}
 473             or error("Cannot chdir to $config{srcdir}: $!");
 474
 475         if (system("mtn", "--root=$config{mtnrootdir}", "add", "--quiet",
 476                    $file) != 0) {
 477                 error("Monotone add failed");
 478         }
 479 } #}}}
 480
 481 sub rcs_remove ($) { # {{{
 482         my $file = shift;
 483
 484         chdir $config{srcdir}
 485             or error("Cannot chdir to $config{srcdir}: $!");
 486
 487         # Note: it is difficult to undo a remove in Monotone at the moment.
 488         # Until this is fixed, it might be better to make 'rm' move things
 489         # into an attic, rather than actually remove them.
 490         # To resurrect a file, you currently add a new file with the contents
 491         # you want it to have.  This loses all connectivity and automated
 492         # merging with the 'pre-delete' versions of the file.
 493
 494         if (system("mtn", "--root=$config{mtnrootdir}", "rm", "--quiet",
 495                    $file) != 0) {
 496                 error("Monotone remove failed");
 497         }
 498 } #}}}
 499
 500 sub rcs_rename ($$) { # {{{
 501         my ($src, $dest) = @_;
 502
 503         chdir $config{srcdir}
 504             or error("Cannot chdir to $config{srcdir}: $!");
 505
 506         if (system("mtn", "--root=$config{mtnrootdir}", "rename", "--quiet",
 507                    $src, $dest) != 0) {
 508                 error("Monotone rename failed");
 509         }
 510 } #}}}
 511
 512 sub rcs_recentchanges ($) { #{{{
 513         my $num=shift;
 514         my @ret;
 515
 516         chdir $config{srcdir}
 517             or error("Cannot chdir to $config{srcdir}: $!");
 518
 519         # use log --brief to get a list of revs, as this
 520         # gives the results in a nice order
 521         # (otherwise we'd have to do our own date sorting)
 522
 523         my @revs;
 524
 525         my $child = open(MTNLOG, "-|");
 526         if (! $child) {
 527                 exec("mtn", "log", "--root=$config{mtnrootdir}", "--no-graph",
 528                      "--brief") || error("mtn log failed to run");
 529         }
 530
 531         while (($num >= 0) and (my $line = <MTNLOG>)) {
 532                 if ($line =~ m/^($sha1_pattern)/) {
 533                         push @revs, $1;
 534                         $num -= 1;
 535                 }
 536         }
 537         close MTNLOG || debug("mtn log exited $?");
 538
 539         my $automator = Monotone->new();
 540         $automator->open(undef, $config{mtnrootdir});
 541
 542         while (@revs != 0) {
 543                 my $rev = shift @revs;
 544                 # first go through and figure out the messages, etc
 545
 546                 my $certs = [read_certs($automator, $rev)];
 547
 548                 my $user;
 549                 my $when;
 550                 my $committype;
 551                 my (@pages, @message);
 552
 553                 foreach my $cert (@$certs) {
 554                         if ($cert->{signature} eq "ok" &&
 555                             $cert->{trust} eq "trusted") {
 556                                 if ($cert->{name} eq "author") {
 557                                         $user = $cert->{value};
 558                                         # detect the source of the commit
 559                                         # from the changelog
 560                                         if ($cert->{key} eq $config{mtnkey}) {
 561                                                 $committype = "web";
 562                                         } else {
 563                                                 $committype = "monotone";
 564                                         }
 565                                 } elsif ($cert->{name} eq "date") {
 566                                         $when = str2time($cert->{value}, 'UTC');
 567                                 } elsif ($cert->{name} eq "changelog") {
 568                                         my $messageText = $cert->{value};
 569                                         # split the changelog into multiple
 570                                         # lines
 571                                         foreach my $msgline (split(/\n/, $messageText)) {
 572                                                 push @message, { line => $msgline };
 573                                         }
 574                                 }
 575                         }
 576                 }
 577
 578                 my @changed_files = get_changed_files($automator, $rev);
 579                 my $file;
 580
 581                 my ($out, $err) = $automator->call("parents", $rev);
 582                 my @parents = ($out =~ m/^($sha1_pattern)$/);
 583                 my $parent = $parents[0];
 584
 585                 foreach $file (@changed_files) {
 586                         next unless length $file;
 587
 588                         if (defined $config{diffurl} and (@parents == 1)) {
 589                                 my $diffurl=$config{diffurl};
 590                                 $diffurl=~s/\[\[r1\]\]/$parent/g;
 591                                 $diffurl=~s/\[\[r2\]\]/$rev/g;
 592                                 $diffurl=~s/\[\[file\]\]/$file/g;
 593                                 push @pages, {
 594                                         page => pagename($file),
 595                                         diffurl => $diffurl,
 596                                 };
 597                         }
 598                         else {
 599                                 push @pages, {
 600                                         page => pagename($file),
 601                                 }
 602                         }
 603                 }
 604
 605                 push @ret, {
 606                         rev => $rev,
 607                         user => $user,
 608                         committype => $committype,
 609                         when => $when,
 610                         message => [@message],
 611                         pages => [@pages],
 612                 } if @pages;
 613         }
 614
 615         $automator->close();
 616
 617         return @ret;
 618 } #}}}
 619
 620 sub rcs_diff ($) { #{{{
 621         my $rev=shift;
 622         my ($sha1) = $rev =~ /^($sha1_pattern)$/; # untaint
 623
 624         chdir $config{srcdir}
 625             or error("Cannot chdir to $config{srcdir}: $!");
 626
 627         my $child = open(MTNDIFF, "-|");
 628         if (! $child) {
 629                 exec("mtn", "diff", "--root=$config{mtnrootdir}", "-r", "p:".$sha1, "-r", $sha1) || error("mtn diff $sha1 failed to run");
 630         }
 631
 632         my (@lines) = <MTNDIFF>;
 633
 634         close MTNDIFF || debug("mtn diff $sha1 exited $?");
 635
 636         if (wantarray) {
 637                 return @lines;
 638         }
 639         else {
 640                 return join("", @lines);
 641         }
 642 } #}}}
 643
 644 sub rcs_getctime ($) { #{{{
 645         my $file=shift;
 646
 647         chdir $config{srcdir}
 648             or error("Cannot chdir to $config{srcdir}: $!");
 649
 650         my $child = open(MTNLOG, "-|");
 651         if (! $child) {
 652                 exec("mtn", "log", "--root=$config{mtnrootdir}", "--no-graph",
 653                      "--brief", $file) || error("mtn log $file failed to run");
 654         }
 655
 656         my $firstRev;
 657         while (<MTNLOG>) {
 658                 if (/^($sha1_pattern)/) {
 659                         $firstRev=$1;
 660                 }
 661         }
 662         close MTNLOG || debug("mtn log $file exited $?");
 663
 664         if (! defined $firstRev) {
 665                 debug "failed to parse mtn log for $file";
 666                 return 0;
 667         }
 668
 669         my $automator = Monotone->new();
 670         $automator->open(undef, $config{mtnrootdir});
 671
 672         my $certs = [read_certs($automator, $firstRev)];
 673
 674         $automator->close();
 675
 676         my $date;
 677
 678         foreach my $cert (@$certs) {
 679                 if ($cert->{signature} eq "ok" && $cert->{trust} eq "trusted") {
 680                         if ($cert->{name} eq "date") {
 681                                 $date = $cert->{value};
 682                         }
 683                 }
 684         }
 685
 686         if (! defined $date) {
 687                 debug "failed to find date cert for revision $firstRev when looking for creation time of $file";
 688                 return 0;
 689         }
 690
 691         $date=str2time($date, 'UTC');
 692         debug("found ctime ".localtime($date)." for $file");
 693         return $date;
 694 } #}}}
 695
 696 1