ikiwiki (3.20130711) unstable; urgency=low
[ikiwiki.git] / 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