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