Version control backends promoted to first-class plugins
[ikiwiki.git] / IkiWiki / Plugin / bzr.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 => "bzr", call => sub { #{{{
12         if (! defined $config{diffurl}) {
13                 $config{diffurl}="";
14         }
15         if (length $config{bzr_wrapper}) {
16                 push @{$config{wrappers}}, {
17                         wrapper => $config{bzr_wrapper},
18                         wrappermode => (defined $config{bzr_wrappermode} ? $config{bzr_wrappermode} : "06755"),
19                 };
20         }
21 }); #}}}
22
23 hook(type => "getsetup", id => "bzr", call => sub { #{{{
24         return
25                 bzr_wrapper => {
26                         type => "string",
27                         #example => "", # FIXME add example
28                         description => "bzr post-commit executable to generate",
29                         safe => 0, # file
30                         rebuild => 0,
31                 },
32                 bzr_wrappermode => {
33                         type => "string",
34                         example => '06755',
35                         description => "mode for bzr_wrapper (can safely be made suid)",
36                         safe => 0,
37                         rebuild => 0,
38                 },
39                 historyurl => {
40                         type => "string",
41                         #example => "", # FIXME add example
42                         description => "url to show file history, using loggerhead ([[file]] substituted)",
43                         safe => 1,
44                         rebuild => 1,
45                 },
46                 diffurl => {
47                         type => "string",
48                         example => "http://example.com/revision?start_revid=[[r2]]#[[file]]-s",
49                         description => "url to view a diff, using loggerhead ([[file]] and [[r2]] substituted)",
50                         safe => 1,
51                         rebuild => 1,
52                 },
53 }); #}}}
54
55 sub bzr_log ($) { #{{{
56         my $out = shift;
57         my @infos = ();
58         my $key = undef;
59
60         while (<$out>) {
61                 my $line = $_;
62                 my ($value);
63                 if ($line =~ /^message:/) {
64                         $key = "message";
65                         $infos[$#infos]{$key} = "";
66                 }
67                 elsif ($line =~ /^(modified|added|renamed|renamed and modified|removed):/) {
68                         $key = "files";
69                         unless (defined($infos[$#infos]{$key})) { $infos[$#infos]{$key} = ""; }
70                 }
71                 elsif (defined($key) and $line =~ /^  (.*)/) {
72                         $infos[$#infos]{$key} .= "$1\n";
73                 }
74                 elsif ($line eq "------------------------------------------------------------\n") {
75                         $key = undef;
76                         push (@infos, {});
77                 }
78                 else {
79                         chomp $line;
80                                 ($key, $value) = split /: +/, $line, 2;
81                         $infos[$#infos]{$key} = $value;
82                 } 
83         }
84         close $out;
85
86         return @infos;
87 } #}}}
88
89 sub rcs_update () { #{{{
90         my @cmdline = ("bzr", "update", "--quiet", $config{srcdir});
91         if (system(@cmdline) != 0) {
92                 warn "'@cmdline' failed: $!";
93         }
94 } #}}}
95
96 sub rcs_prepedit ($) { #{{{
97         return "";
98 } #}}}
99
100 sub bzr_author ($$) { #{{{
101         my ($user, $ipaddr) = @_;
102
103         if (defined $user) {
104                 return possibly_foolish_untaint($user);
105         }
106         elsif (defined $ipaddr) {
107                 return "Anonymous from ".possibly_foolish_untaint($ipaddr);
108         }
109         else {
110                 return "Anonymous";
111         }
112 } #}}}
113
114 sub rcs_commit ($$$;$$) { #{{{
115         my ($file, $message, $rcstoken, $user, $ipaddr) = @_;
116
117         $user = bzr_author($user, $ipaddr);
118
119         $message = possibly_foolish_untaint($message);
120         if (! length $message) {
121                 $message = "no message given";
122         }
123
124         my @cmdline = ("bzr", "commit", "--quiet", "-m", $message, "--author", $user,
125                        $config{srcdir}."/".$file);
126         if (system(@cmdline) != 0) {
127                 warn "'@cmdline' failed: $!";
128         }
129
130         return undef; # success
131 } #}}}
132
133 sub rcs_commit_staged ($$$) {
134         # Commits all staged changes. Changes can be staged using rcs_add,
135         # rcs_remove, and rcs_rename.
136         my ($message, $user, $ipaddr)=@_;
137
138         $user = bzr_author($user, $ipaddr);
139
140         $message = possibly_foolish_untaint($message);
141         if (! length $message) {
142                 $message = "no message given";
143         }
144
145         my @cmdline = ("bzr", "commit", "--quiet", "-m", $message, "--author", $user,
146                        $config{srcdir});
147         if (system(@cmdline) != 0) {
148                 warn "'@cmdline' failed: $!";
149         }
150
151         return undef; # success
152 } #}}}
153
154 sub rcs_add ($) { # {{{
155         my ($file) = @_;
156
157         my @cmdline = ("bzr", "add", "--quiet", "$config{srcdir}/$file");
158         if (system(@cmdline) != 0) {
159                 warn "'@cmdline' failed: $!";
160         }
161 } #}}}
162
163 sub rcs_remove ($) { # {{{
164         my ($file) = @_;
165
166         my @cmdline = ("bzr", "rm", "--force", "--quiet", "$config{srcdir}/$file");
167         if (system(@cmdline) != 0) {
168                 warn "'@cmdline' failed: $!";
169         }
170 } #}}}
171
172 sub rcs_rename ($$) { # {{{
173         my ($src, $dest) = @_;
174
175         my $parent = dirname($dest);
176         if (system("bzr", "add", "--quiet", "$config{srcdir}/$parent") != 0) {
177                 warn("bzr add $parent failed\n");
178         }
179
180         my @cmdline = ("bzr", "mv", "--quiet", "$config{srcdir}/$src", "$config{srcdir}/$dest");
181         if (system(@cmdline) != 0) {
182                 warn "'@cmdline' failed: $!";
183         }
184 } #}}}
185
186 sub rcs_recentchanges ($) { #{{{
187         my ($num) = @_;
188
189         my @cmdline = ("bzr", "log", "-v", "--show-ids", "--limit", $num, 
190                            $config{srcdir});
191         open (my $out, "@cmdline |");
192
193         eval q{use Date::Parse};
194         error($@) if $@;
195
196         my @ret;
197         foreach my $info (bzr_log($out)) {
198                 my @pages = ();
199                 my @message = ();
200         
201                 foreach my $msgline (split(/\n/, $info->{message})) {
202                         push @message, { line => $msgline };
203                 }
204
205                 foreach my $file (split(/\n/, $info->{files})) {
206                         my ($filename, $fileid) = ($file =~ /^(.*?) +([^ ]+)$/);
207
208                         # Skip directories
209                         next if ($filename =~ /\/$/);
210
211                         # Skip source name in renames
212                         $filename =~ s/^.* => //;
213
214                         my $diffurl = $config{'diffurl'};
215                         $diffurl =~ s/\[\[file\]\]/$filename/go;
216                         $diffurl =~ s/\[\[file-id\]\]/$fileid/go;
217                         $diffurl =~ s/\[\[r2\]\]/$info->{revno}/go;
218
219                         push @pages, {
220                                 page => pagename($filename),
221                                 diffurl => $diffurl,
222                         };
223                 }
224
225                 my $user = $info->{"committer"};
226                 if (defined($info->{"author"})) { $user = $info->{"author"}; }
227                 $user =~ s/\s*<.*>\s*$//;
228                 $user =~ s/^\s*//;
229
230                 push @ret, {
231                         rev        => $info->{"revno"},
232                         user       => $user,
233                         committype => "bzr",
234                         when       => time - str2time($info->{"timestamp"}),
235                         message    => [@message],
236                         pages      => [@pages],
237                 };
238         }
239
240         return @ret;
241 } #}}}
242
243 sub rcs_getctime ($) { #{{{
244         my ($file) = @_;
245
246         # XXX filename passes through the shell here, should try to avoid
247         # that just in case
248         my @cmdline = ("bzr", "log", "--limit", '1', "$config{srcdir}/$file");
249         open (my $out, "@cmdline |");
250
251         my @log = bzr_log($out);
252
253         if (length @log < 1) {
254                 return 0;
255         }
256
257         eval q{use Date::Parse};
258         error($@) if $@;
259         
260         my $ctime = str2time($log[0]->{"timestamp"});
261         return $ctime;
262 } #}}}
263
264 1