rcs_rename and rcs_remove also were in the big mercurial patch
[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 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         my $nickname;
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                 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         # TODO
311 }
312
313 {
314 my %time_cache;
315
316 sub findtimes ($$) {
317         my $file=shift;
318         my $id=shift; # 0 = mtime ; 1 = ctime
319
320         if (! keys %time_cache) {
321                 my $date;
322
323                 # It doesn't seem possible to specify the format wanted for the
324                 # changelog (same format as is generated in git.pm:findtimes(),
325                 # though the date differs slightly) without using a style
326                 # _file_. There is a "hg log" switch "--template" to directly
327                 # control simple output formatting, but in this case, the
328                 # {file} directive must be redefined, which can only be done
329                 # with "--style".
330                 #
331                 # If {file} is not redefined, all files are output on a single
332                 # line separated with a space. It is not possible to conclude
333                 # if the space is part of a filename or just a separator, and
334                 # thus impossible to use in this case.
335                 # 
336                 # Some output filters are available in hg, but they are not fit
337                 # for this cause (and would slow down the process
338                 # unnecessarily).
339                 
340                 eval q{use File::Temp};
341                 error $@ if $@;
342                 my ($tmpl_fh, $tmpl_filename) = File::Temp::tempfile(UNLINK => 1);
343                 
344                 print $tmpl_fh 'changeset = "{date}\\n{files}\\n"' . "\n";
345                 print $tmpl_fh 'file = "{file}\\n"' . "\n";
346                 
347                 foreach my $line (run_or_die('hg', 'log', '--style', $tmpl_filename)) {
348                         # {date} gives output on the form
349                         # 1310694511.0-7200
350                         # where the first number is UTC Unix timestamp with one
351                         # decimal (decimal always 0, at least on my system)
352                         # followed by local timezone offset from UTC in
353                         # seconds.
354                         if (! defined $date && $line =~ /^\d+\.\d[+-]\d*$/) {
355                                 $line =~ s/^(\d+).*/$1/;
356                                 $date=$line;
357                         }
358                         elsif (! length $line) {
359                                 $date=undef;
360                         }
361                         else {
362                                 my $f=$line;
363
364                                 if (! $time_cache{$f}) {
365                                         $time_cache{$f}[0]=$date; # mtime
366                                 }
367                                 $time_cache{$f}[1]=$date; # ctime
368                         }
369                 }
370         }
371
372         return exists $time_cache{$file} ? $time_cache{$file}[$id] : 0;
373 }
374
375 }
376
377 sub rcs_getctime ($) {
378         my $file = shift;
379
380         return findtimes($file, 1);
381 }
382
383 sub rcs_getmtime ($) {
384         my $file = shift;
385
386         return findtimes($file, 0);
387 }
388
389 1