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 } #}}}
  24
  25 sub checkconfig () { #{{{
  26         if (exists $config{mercurial_wrapper} && length $config{mercurial_wrapper}) {
  27                 push @{$config{wrappers}}, {
  28                         wrapper => $config{mercurial_wrapper},
  29                         wrappermode => (defined $config{mercurial_wrappermode} ? $config{mercurial_wrappermode} : "06755"),
  30                 };
  31         }
  32 } #}}}
  33
  34 sub getsetup () { #{{{
  35         return
  36                 mercurial_wrapper => {
  37                         type => "string",
  38                         #example => # FIXME add example
  39                         description => "mercurial post-commit executable to generate",
  40                         safe => 0, # file
  41                         rebuild => 0,
  42                 },
  43                 mercurial_wrappermode => {
  44                         type => "string",
  45                         example => '06755',
  46                         description => "mode for mercurial_wrapper (can safely be made suid)",
  47                         safe => 0,
  48                         rebuild => 0,
  49                 },
  50                 historyurl => {
  51                         type => "string",
  52                         example => "http://example.com:8000/log/tip/[[file]]",
  53                         description => "url to hg serve'd repository, to show file history ([[file]] substituted)",
  54                         safe => 1,
  55                         rebuild => 1,
  56                 },
  57                 diffurl => {
  58                         type => "string",
  59                         example => "http://localhost:8000/?fd=[[r2]];file=[[file]]",
  60                         description => "url to hg serve'd repository, to show diff ([[file]] and [[r2]] substituted)",
  61                         safe => 1,
  62                         rebuild => 1,
  63                 },
  64 } #}}}
  65
  66 sub mercurial_log ($) { #{{{
  67         my $out = shift;
  68         my @infos;
  69
  70         while (<$out>) {
  71                 my $line = $_;
  72                 my ($key, $value);
  73
  74                 if (/^description:/) {
  75                         $key = "description";
  76                         $value = "";
  77
  78                         # slurp everything as the description text
  79                         # until the next changeset
  80                         while (<$out>) {
  81                                 if (/^changeset: /) {
  82                                         $line = $_;
  83                                         last;
  84                                 }
  85
  86                                 $value .= $_;
  87                         }
  88
  89                         local $/ = "";
  90                         chomp $value;
  91                         $infos[$#infos]{$key} = $value;
  92                 }
  93
  94                 chomp $line;
  95                 ($key, $value) = split /: +/, $line, 2;
  96
  97                 if ($key eq "changeset") {
  98                         push @infos, {};
  99
 100                         # remove the revision index, which is strictly
 101                         # local to the repository
 102                         $value =~ s/^\d+://;
 103                 }
 104
 105                 $infos[$#infos]{$key} = $value;
 106         }
 107         close $out;
 108
 109         return @infos;
 110 } #}}}
 111
 112 sub rcs_update () { #{{{
 113         my @cmdline = ("hg", "-q", "-R", "$config{srcdir}", "update");
 114         if (system(@cmdline) != 0) {
 115                 warn "'@cmdline' failed: $!";
 116         }
 117 } #}}}
 118
 119 sub rcs_prepedit ($) { #{{{
 120         return "";
 121 } #}}}
 122
 123 sub rcs_commit ($$$;$$) { #{{{
 124         my ($file, $message, $rcstoken, $user, $ipaddr) = @_;
 125
 126         if (defined $user) {
 127                 $user = IkiWiki::possibly_foolish_untaint($user);
 128         }
 129         elsif (defined $ipaddr) {
 130                 $user = "Anonymous from ".IkiWiki::possibly_foolish_untaint($ipaddr);
 131         }
 132         else {
 133                 $user = "Anonymous";
 134         }
 135
 136         $message = IkiWiki::possibly_foolish_untaint($message);
 137         if (! length $message) {
 138                 $message = "no message given";
 139         }
 140
 141         my @cmdline = ("hg", "-q", "-R", $config{srcdir}, "commit",
 142                        "-m", $message, "-u", $user);
 143         if (system(@cmdline) != 0) {
 144                 warn "'@cmdline' failed: $!";
 145         }
 146
 147         return undef; # success
 148 } #}}}
 149
 150 sub rcs_commit_staged ($$$) {
 151         # Commits all staged changes. Changes can be staged using rcs_add,
 152         # rcs_remove, and rcs_rename.
 153         my ($message, $user, $ipaddr)=@_;
 154
 155         error("rcs_commit_staged not implemented for mercurial"); # TODO
 156 }
 157
 158 sub rcs_add ($) { # {{{
 159         my ($file) = @_;
 160
 161         my @cmdline = ("hg", "-q", "-R", "$config{srcdir}", "add", "$config{srcdir}/$file");
 162         if (system(@cmdline) != 0) {
 163                 warn "'@cmdline' failed: $!";
 164         }
 165 } #}}}
 166
 167 sub rcs_remove ($) { # {{{
 168         my ($file) = @_;
 169
 170         error("rcs_remove not implemented for mercurial"); # TODO
 171 } #}}}
 172
 173 sub rcs_rename ($$) { # {{{
 174         my ($src, $dest) = @_;
 175
 176         error("rcs_rename not implemented for mercurial"); # TODO
 177 } #}}}
 178
 179 sub rcs_recentchanges ($) { #{{{
 180         my ($num) = @_;
 181
 182         my @cmdline = ("hg", "-R", $config{srcdir}, "log", "-v", "-l", $num,
 183                 "--style", "default");
 184         open (my $out, "@cmdline |");
 185
 186         eval q{use Date::Parse};
 187         error($@) if $@;
 188
 189         my @ret;
 190         foreach my $info (mercurial_log($out)) {
 191                 my @pages = ();
 192                 my @message = ();
 193
 194                 foreach my $msgline (split(/\n/, $info->{description})) {
 195                         push @message, { line => $msgline };
 196                 }
 197
 198                 foreach my $file (split / /,$info->{files}) {
 199                         my $diffurl = defined $config{diffurl} ? $config{'diffurl'} : "";
 200                         $diffurl =~ s/\[\[file\]\]/$file/go;
 201                         $diffurl =~ s/\[\[r2\]\]/$info->{changeset}/go;
 202
 203                         push @pages, {
 204                                 page => pagename($file),
 205                                 diffurl => $diffurl,
 206                         };
 207                 }
 208
 209                 my $user = $info->{"user"};
 210                 $user =~ s/\s*<.*>\s*$//;
 211                 $user =~ s/^\s*//;
 212
 213                 push @ret, {
 214                         rev        => $info->{"changeset"},
 215                         user       => $user,
 216                         committype => "mercurial",
 217                         when       => str2time($info->{"date"}),
 218                         message    => [@message],
 219                         pages      => [@pages],
 220                 };
 221         }
 222
 223         return @ret;
 224 } #}}}
 225
 226 sub rcs_diff ($) { #{{{
 227         # TODO
 228 } #}}}
 229
 230 sub rcs_getctime ($) { #{{{
 231         my ($file) = @_;
 232
 233         # XXX filename passes through the shell here, should try to avoid
 234         # that just in case
 235         my @cmdline = ("hg", "-R", $config{srcdir}, "log", "-v", "-l", '1',
 236                 "--style", "default", "$config{srcdir}/$file");
 237         open (my $out, "@cmdline |");
 238
 239         my @log = mercurial_log($out);
 240
 241         if (length @log < 1) {
 242                 return 0;
 243         }
 244
 245         eval q{use Date::Parse};
 246         error($@) if $@;
 247
 248         my $ctime = str2time($log[0]->{"date"});
 249         return $ctime;
 250 } #}}}
 251
 252 1