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