]> git.vanrenterghem.biz Git - git.ikiwiki.info.git/blob - IkiWiki/Plugin/mercurial.pm
(no commit message)
[git.ikiwiki.info.git] / IkiWiki / Plugin / mercurial.pm
1 #!/usr/bin/perl
2 package IkiWiki::Plugin::mercurial;
4 use warnings;
5 use strict;
6 use IkiWiki;
7 use Encode;
8 use open qw{:utf8 :std};
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 }
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 }
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 }
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.
77         my ($error_handler, $data_handler, @cmdline) = @_;
79         my $pid = open my $OUT, "-|";
81         error("Cannot fork: $!") if !defined $pid;
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}: $!");
89                 exec @cmdline or error("Cannot exec '@cmdline': $!");
90         }
91         # In parent.
93         my @lines;
94         while (<$OUT>) {
95                 chomp;
97                 if (! defined $data_handler) {
98                         push @lines, $_;
99                 }
100                 else {
101                         last unless $data_handler->($_);
102                 }
103         }
105         close $OUT;
107         $error_handler->("'@cmdline' failed: $!") if $? && $error_handler;
109         return wantarray ? @lines : ($? == 0);
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, @_) }
116 sub mercurial_log ($) {
117         my $out = shift;
118         my @infos;
120         while (<$out>) {
121                 my $line = $_;
122                 my ($key, $value);
124                 if (/^description:/) {
125                         $key = "description";
126                         $value = "";
128                         # slurp everything as the description text 
129                         # until the next changeset
130                         while (<$out>) {
131                                 if (/^changeset: /) {
132                                         $line = $_;
133                                         last;
134                                 }
136                                 $value .= $_;
137                         }
139                         local $/ = "";
140                         chomp $value;
141                         $infos[$#infos]{$key} = $value;
142                 }
144                 chomp $line;
145                 ($key, $value) = split /: +/, $line, 2;
147                 if ($key eq "changeset") {
148                         push @infos, {};
150                         # remove the revision index, which is strictly 
151                         # local to the repository
152                         $value =~ s/^\d+://;
153                 }
155                 $infos[$#infos]{$key} = $value;
156         }
157         close $out;
159         return @infos;
162 sub rcs_update () {
163         run_or_cry('hg', '-q', 'update');
166 sub rcs_prepedit ($) {
167         return "";
170 sub rcs_commit (@) {
171         my %params=@_;
173         return rcs_commit_helper(@_);
176 sub rcs_commit_helper (@) {
177         my %params=@_;
179         my %env=%ENV;
180         $ENV{HGENCODING} = 'utf-8';
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                 }
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         }
200         if (! length $params{message}) {
201                 $params{message} = "no message given";
202         }
204         $params{message} = IkiWiki::possibly_foolish_untaint($params{message});
206         my @opts;
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);
215         %ENV=%env;
216         return undef; # success
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(@_);
225 sub rcs_add ($) {
226         my ($file) = @_;
228         run_or_cry('hg', 'add', $file);
231 sub rcs_remove ($) {
232         # Remove file from archive.
233         my ($file) = @_;
235         run_or_cry('hg', 'remove', '-f', $file);
238 sub rcs_rename ($$) {
239         my ($src, $dest) = @_;
241         run_or_cry('hg', 'rename', '-f', $src, $dest);
244 sub rcs_recentchanges ($) {
245         my ($num) = @_;
247         my %env=%ENV;
248         $ENV{HGENCODING} = 'utf-8';
250         my @cmdline = ("hg", "-R", $config{srcdir}, "log", "-v", "-l", $num,
251                 "--style", "default");
252         open (my $out, "@cmdline |");
254         eval q{use Date::Parse};
255         error($@) if $@;
257         my @ret;
258         foreach my $info (mercurial_log($out)) {
259                 my @pages = ();
260                 my @message = ();
262                 foreach my $msgline (split(/\n/, $info->{description})) {
263                         push @message, { line => $msgline };
264                 }
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;
271                         push @pages, {
272                                 page => pagename($file),
273                                 diffurl => $diffurl,
274                         };
275                 }
277                 #"user <email@domain.net>": parse out "user".
278                 my $user = $info->{"user"};
279                 $user =~ s/\s*<.*>\s*$//;
280                 $user =~ s/^\s*//;
282                 #"user <nickname@web>": if "@web" hits, set $web_commit=true.
283                 my $web_commit = ($info->{'user'} =~ /\@web>/);
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                 }
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         }
304         %ENV=%env;
306         return @ret;
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         }
330 my %time_cache;
332 sub findtimes ($$) {
333         my $file=shift;
334         my $id=shift; # 0 = mtime ; 1 = ctime
336         if (! keys %time_cache) {
337                 my $date;
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;
373                                 if (! $time_cache{$f}) {
374                                         $time_cache{$f}[0]=$date; # mtime
375                                 }
376                                 $time_cache{$f}[1]=$date; # ctime
377                         }
378                 }
379         }
381         return exists $time_cache{$file} ? $time_cache{$file}[$id] : 0;
386 sub rcs_getctime ($) {
387         my $file = shift;
389         return findtimes($file, 1);
392 sub rcs_getmtime ($) {
393         my $file = shift;
395         return findtimes($file, 0);