IkiWiki/Plugin/mercurial.pm

   1 #!/usr/bin/perl
   2 package IkiWiki::Plugin::mercurial;
   3
   4 use warnings;
   5 use strict;
   6 use IkiWiki;
   7 use Encode;
   8 use open qw{:utf8 :std};
   9
  10 sub import {
  11         hook(type => "checkconfig", id => "mercurial", call => \&checkconfig);
  12         hook(type => "getsetup", id => "mercurial", call => \&getsetup);
  13         hook(type => "rcs", id => "rcs_update", call => \&rcs_update);
  14         hook(type => "rcs", id => "rcs_prepedit", call => \&rcs_prepedit);
  15         hook(type => "rcs", id => "rcs_commit", call => \&rcs_commit);
  16         hook(type => "rcs", id => "rcs_commit_staged", call => \&rcs_commit_staged);
  17         hook(type => "rcs", id => "rcs_add", call => \&rcs_add);
  18         hook(type => "rcs", id => "rcs_remove", call => \&rcs_remove);
  19         hook(type => "rcs", id => "rcs_rename", call => \&rcs_rename);
  20         hook(type => "rcs", id => "rcs_recentchanges", call => \&rcs_recentchanges);
  21         hook(type => "rcs", id => "rcs_diff", call => \&rcs_diff);
  22         hook(type => "rcs", id => "rcs_getctime", call => \&rcs_getctime);
  23         hook(type => "rcs", id => "rcs_getmtime", call => \&rcs_getmtime);
  24 }
  25
  26 sub checkconfig () {
  27         if (exists $config{mercurial_wrapper} && length $config{mercurial_wrapper}) {
  28                 push @{$config{wrappers}}, {
  29                         wrapper => $config{mercurial_wrapper},
  30                         wrappermode => (defined $config{mercurial_wrappermode} ? $config{mercurial_wrappermode} : "06755"),
  31                 };
  32         }
  33 }
  34
  35 sub getsetup () {
  36         return
  37                 plugin => {
  38                         safe => 0, # rcs plugin
  39                         rebuild => undef,
  40                         section => "rcs",
  41                 },
  42                 mercurial_wrapper => {
  43                         type => "string",
  44                         #example => # FIXME add example
  45                         description => "mercurial post-commit hook to generate",
  46                         safe => 0, # file
  47                         rebuild => 0,
  48                 },
  49                 mercurial_wrappermode => {
  50                         type => "string",
  51                         example => '06755',
  52                         description => "mode for mercurial_wrapper (can safely be made suid)",
  53                         safe => 0,
  54                         rebuild => 0,
  55                 },
  56                 historyurl => {
  57                         type => "string",
  58                         example => "http://example.com:8000/log/tip/[[file]]",
  59                         description => "url to hg serve'd repository, to show file history ([[file]] substituted)",
  60                         safe => 1,
  61                         rebuild => 1,
  62                 },
  63                 diffurl => {
  64                         type => "string",
  65                         example => "http://localhost:8000/?fd=[[r2]];file=[[file]]",
  66                         description => "url to hg serve'd repository, to show diff ([[file]] and [[r2]] substituted)",
  67                         safe => 1,
  68                         rebuild => 1,
  69                 },
  70 }
  71
  72 sub safe_hg (&@) {
  73         # Start a child process safely without resorting to /bin/sh.
  74         # Returns command output (in list content) or success state
  75         # (in scalar context), or runs the specified data handler.
  76
  77         my ($error_handler, $data_handler, @cmdline) = @_;
  78
  79         my $pid = open my $OUT, "-|";
  80
  81         error("Cannot fork: $!") if !defined $pid;
  82
  83         if (!$pid) {
  84                 # In child.
  85                 # hg commands want to be in wc.
  86                 chdir $config{srcdir}
  87                     or error("cannot chdir to $config{srcdir}: $!");
  88
  89                 exec @cmdline or error("Cannot exec '@cmdline': $!");
  90         }
  91         # In parent.
  92
  93         my @lines;
  94         while (<$OUT>) {
  95                 chomp;
  96
  97                 if (! defined $data_handler) {
  98                         push @lines, $_;
  99                 }
 100                 else {
 101                         last unless $data_handler->($_);
 102                 }
 103         }
 104
 105         close $OUT;
 106
 107         $error_handler->("'@cmdline' failed: $!") if $? && $error_handler;
 108
 109         return wantarray ? @lines : ($? == 0);
 110 }
 111 # Convenient wrappers.
 112 sub run_or_die ($@) { safe_hg(\&error, undef, @_) }
 113 sub run_or_cry ($@) { safe_hg(sub { warn @_ }, undef, @_) }
 114 sub run_or_non ($@) { safe_hg(undef, undef, @_) }
 115
 116 sub mercurial_log ($) {
 117         my $out = shift;
 118         my @infos;
 119
 120         while (<$out>) {
 121                 my $line = $_;
 122                 my ($key, $value);
 123
 124                 if (/^description:/) {
 125                         $key = "description";
 126                         $value = "";
 127
 128                         # slurp everything as the description text
 129                         # until the next changeset
 130                         while (<$out>) {
 131                                 if (/^changeset: /) {
 132                                         $line = $_;
 133                                         last;
 134                                 }
 135
 136                                 $value .= $_;
 137                         }
 138
 139                         local $/ = "";
 140                         chomp $value;
 141                         $infos[$#infos]{$key} = $value;
 142                 }
 143
 144                 chomp $line;
 145                 ($key, $value) = split /: +/, $line, 2;
 146
 147                 if ($key eq "changeset") {
 148                         push @infos, {};
 149
 150                         # remove the revision index, which is strictly
 151                         # local to the repository
 152                         $value =~ s/^\d+://;
 153                 }
 154
 155                 $infos[$#infos]{$key} = $value;
 156         }
 157         close $out;
 158
 159         return @infos;
 160 }
 161
 162 sub rcs_update () {
 163         run_or_cry('hg', '-q', 'update');
 164 }
 165
 166 sub rcs_prepedit ($) {
 167         return "";
 168 }
 169
 170 sub rcs_commit (@) {
 171         my %params=@_;
 172
 173         return rcs_commit_helper(@_);
 174 }
 175
 176 sub rcs_commit_helper (@) {
 177         my %params=@_;
 178
 179         my %env=%ENV;
 180         $ENV{HGENCODING} = 'utf-8';
 181
 182         my $user="Anonymous";
 183         if (defined $params{session}) {
 184                 if (defined $params{session}->param("name")) {
 185                         $user = $params{session}->param("name");
 186                 }
 187                 elsif (defined $params{session}->remote_addr()) {
 188                         $user = $params{session}->remote_addr();
 189                 }
 190
 191                 my $nickname=$user;
 192                 if (defined $params{session}->param("nickname")) {
 193                         $nickname=encode_utf8($params{session}->param("nickname"));
 194                         $nickname=~s/\s+/_/g;
 195                         $nickname=~s/[^-_0-9[:alnum:]]+//g;
 196                 }
 197                 $ENV{HGUSER} = encode_utf8($user . ' <' . $nickname . '@web>');
 198         }
 199
 200         if (! length $params{message}) {
 201                 $params{message} = "no message given";
 202         }
 203
 204         $params{message} = IkiWiki::possibly_foolish_untaint($params{message});
 205
 206         my @opts;
 207
 208         if (exists $params{file}) {
 209                 push @opts, '--', $params{file};
 210         }
 211         # hg commit returns non-zero if nothing really changed.
 212         # So we should ignore its exit status (hence run_or_non).
 213         run_or_non('hg', 'commit', '-m', $params{message}, '-q', @opts);
 214
 215         %ENV=%env;
 216         return undef; # success
 217 }
 218
 219 sub rcs_commit_staged (@) {
 220         # Commits all staged changes. Changes can be staged using rcs_add,
 221         # rcs_remove, and rcs_rename.
 222         return rcs_commit_helper(@_);
 223 }
 224
 225 sub rcs_add ($) {
 226         my ($file) = @_;
 227
 228         run_or_cry('hg', 'add', $file);
 229 }
 230
 231 sub rcs_remove ($) {
 232         # Remove file from archive.
 233         my ($file) = @_;
 234
 235         run_or_cry('hg', 'remove', '-f', $file);
 236 }
 237
 238 sub rcs_rename ($$) {
 239         my ($src, $dest) = @_;
 240
 241         run_or_cry('hg', 'rename', '-f', $src, $dest);
 242 }
 243
 244 sub rcs_recentchanges ($) {
 245         my ($num) = @_;
 246
 247         my %env=%ENV;
 248         $ENV{HGENCODING} = 'utf-8';
 249
 250         my @cmdline = ("hg", "-R", $config{srcdir}, "log", "-v", "-l", $num,
 251                 "--style", "default");
 252         open (my $out, "@cmdline |");
 253
 254         eval q{use Date::Parse};
 255         error($@) if $@;
 256
 257         my @ret;
 258         foreach my $info (mercurial_log($out)) {
 259                 my @pages = ();
 260                 my @message = ();
 261
 262                 foreach my $msgline (split(/\n/, $info->{description})) {
 263                         push @message, { line => $msgline };
 264                 }
 265
 266                 foreach my $file (split / /,$info->{files}) {
 267                         my $diffurl = defined $config{diffurl} ? $config{'diffurl'} : "";
 268                         $diffurl =~ s/\[\[file\]\]/$file/go;
 269                         $diffurl =~ s/\[\[r2\]\]/$info->{changeset}/go;
 270
 271                         push @pages, {
 272                                 page => pagename($file),
 273                                 diffurl => $diffurl,
 274                         };
 275                 }
 276
 277                 #"user <email@domain.net>": parse out "user".
 278                 my $user = $info->{"user"};
 279                 $user =~ s/\s*<.*>\s*$//;
 280                 $user =~ s/^\s*//;
 281
 282                 #"user <nickname@web>": if "@web" hits, set $web_commit=true.
 283                 my $web_commit = ($info->{'user'} =~ /\@web>/);
 284
 285                 #"user <nickname@web>": if user is a URL (hits "://") and "@web"
 286                 #was present, parse out nick.
 287                 my $nickname;
 288                 if ($user =~ /:\/\// && $web_commit) {
 289                         $nickname = $info->{'user'};
 290                         $nickname =~ s/^[^<]*<([^\@]+)\@web>\s*$/$1/;
 291                 }
 292
 293                 push @ret, {
 294                         rev        => $info->{"changeset"},
 295                         user       => $user,
 296                         nickname   => $nickname,
 297                         committype => $web_commit ? "web" : "hg",
 298                         when       => str2time($info->{"date"}),
 299                         message    => [@message],
 300                         pages      => [@pages],
 301                 };
 302         }
 303
 304         %ENV=%env;
 305
 306         return @ret;
 307 }
 308
 309 sub rcs_diff ($;$) {
 310         my $rev=shift;
 311         my $maxlines=shift;
 312         my @lines;
 313         my $addlines=sub {
 314                 my $line=shift;
 315                 return if defined $maxlines && @lines == $maxlines;
 316                 push @lines, $line."\n"
 317                         if (@lines || $line=~/^diff --git/);
 318                 return 1;
 319         };
 320         safe_hg(undef, $addlines, "hg", "diff", "-c", $rev, "-g");
 321         if (wantarray) {
 322                 return @lines;
 323         }
 324         else {
 325                 return join("", @lines);
 326         }
 327 }
 328
 329 {
 330 my %time_cache;
 331
 332 sub findtimes ($$) {
 333         my $file=shift;
 334         my $id=shift; # 0 = mtime ; 1 = ctime
 335
 336         if (! keys %time_cache) {
 337                 my $date;
 338
 339                 # It doesn't seem possible to specify the format wanted for the
 340                 # changelog (same format as is generated in git.pm:findtimes(),
 341                 # though the date differs slightly) without using a style
 342                 # _file_. There is a "hg log" switch "--template" to directly
 343                 # control simple output formatting, but in this case, the
 344                 # {file} directive must be redefined, which can only be done
 345                 # with "--style".
 346                 #
 347                 # If {file} is not redefined, all files are output on a single
 348                 # line separated with a space. It is not possible to conclude
 349                 # if the space is part of a filename or just a separator, and
 350                 # thus impossible to use in this case.
 351                 #
 352                 # Some output filters are available in hg, but they are not fit
 353                 # for this cause (and would slow down the process
 354                 # unnecessarily).
 355
 356                 eval q{use File::Temp};
 357                 error $@ if $@;
 358                 my ($tmpl_fh, $tmpl_filename) = File::Temp::tempfile(UNLINK => 1);
 359
 360                 print $tmpl_fh 'changeset = "{date}\\n{files}\\n"' . "\n";
 361                 print $tmpl_fh 'file = "{file}\\n"' . "\n";
 362
 363                 foreach my $line (run_or_die('hg', 'log', '--style', $tmpl_filename)) {
 364                         if (! defined $date && $line =~ /^(\d+)/) {
 365                                 $date=$1;
 366                         }
 367                         elsif (! length $line) {
 368                                 $date=undef;
 369                         }
 370                         else {
 371                                 my $f=$line;
 372
 373                                 if (! $time_cache{$f}) {
 374                                         $time_cache{$f}[0]=$date; # mtime
 375                                 }
 376                                 $time_cache{$f}[1]=$date; # ctime
 377                         }
 378                 }
 379         }
 380
 381         return exists $time_cache{$file} ? $time_cache{$file}[$id] : 0;
 382 }
 383
 384 }
 385
 386 sub rcs_getctime ($) {
 387         my $file = shift;
 388
 389         return findtimes($file, 1);
 390 }
 391
 392 sub rcs_getmtime ($) {
 393         my $file = shift;
 394
 395         return findtimes($file, 0);
 396 }
 397
 398 1