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