Merge branch 'tova' into autoconfig
[ikiwiki.git] / IkiWiki / Plugin / tla.pm
1 #!/usr/bin/perl
2 package IkiWiki::Plugin::tla;
3
4 use warnings;
5 use strict;
6 use IkiWiki;
7
8 sub import { #{{{
9         hook(type => "checkconfig", id => "tla", call => \&checkconfig);
10         hook(type => "getsetup", id => "tla", call => \&getsetup);
11         hook(type => "rcs", id => "rcs_update", call => \&rcs_update);
12         hook(type => "rcs", id => "rcs_prepedit", call => \&rcs_prepedit);
13         hook(type => "rcs", id => "rcs_commit", call => \&rcs_commit);
14         hook(type => "rcs", id => "rcs_commit_staged", call => \&rcs_commit_staged);
15         hook(type => "rcs", id => "rcs_add", call => \&rcs_add);
16         hook(type => "rcs", id => "rcs_remove", call => \&rcs_remove);
17         hook(type => "rcs", id => "rcs_rename", call => \&rcs_rename);
18         hook(type => "rcs", id => "rcs_recentchanges", call => \&rcs_recentchanges);
19         hook(type => "rcs", id => "rcs_diff", call => \&rcs_diff);
20         hook(type => "rcs", id => "rcs_getctime", call => \&rcs_getctime);
21 } #}}}
22
23 sub checkconfig () { #{{{
24         if (defined $config{tla_wrapper} && length $config{tla_wrapper}) {
25                 push @{$config{wrappers}}, {
26                         wrapper => $config{tla_wrapper},
27                         wrappermode => (defined $config{tla_wrappermode} ? $config{tla_wrappermode} : "06755"),
28                 };
29         }
30 } #}}}
31
32 sub getsetup () { #{{{
33         return
34                 tla_wrapper => {
35                         type => "string",
36                         #example => "", # TODO example
37                         description => "tla post-commit executable to generate",
38                         safe => 0, # file
39                         rebuild => 0,
40                 },
41                 tla_wrappermode => {
42                         type => "string",
43                         example => '06755',
44                         description => "mode for tla_wrapper (can safely be made suid)",
45                         safe => 0,
46                         rebuild => 0,
47                 },
48                 historyurl => {
49                         type => "string",
50                         #example => "", # TODO example
51                         description => "url to show file history ([[file]] substituted)",
52                         safe => 1,
53                         rebuild => 1,
54                 },
55                 diffurl => {
56                         type => "string",
57                         #example => "", # TODO example
58                         description => "url to show a diff ([[file]] and [[rev]] substituted)",
59                         safe => 1,
60                         rebuild => 1,
61                 },
62 } #}}}
63
64 sub quiet_system (@) { #{{{
65         # See Debian bug #385939.
66         open (SAVEOUT, ">&STDOUT");
67         close STDOUT;
68         open (STDOUT, ">/dev/null");
69         my $ret=system(@_);
70         close STDOUT;
71         open (STDOUT, ">&SAVEOUT");
72         close SAVEOUT;
73         return $ret;
74 } #}}}
75
76 sub rcs_update () { #{{{
77         if (-d "$config{srcdir}/{arch}") {
78                 if (quiet_system("tla", "replay", "-d", $config{srcdir}) != 0) {
79                         warn("tla replay failed\n");
80                 }
81         }
82 } #}}}
83
84 sub rcs_prepedit ($) { #{{{
85         my $file=shift;
86
87         if (-d "$config{srcdir}/{arch}") {
88                 # For Arch, return the tree-id of archive when
89                 # editing begins.
90                 my $rev=`tla tree-id $config{srcdir}`;
91                 return defined $rev ? $rev : "";
92         }
93 } #}}}
94
95 sub rcs_commit ($$$;$$) { #{{{
96         my $file=shift;
97         my $message=shift;
98         my $rcstoken=shift;
99         my $user=shift;
100         my $ipaddr=shift;
101
102         if (defined $user) {
103                 $message="web commit by $user".(length $message ? ": $message" : "");
104         }
105         elsif (defined $ipaddr) {
106                 $message="web commit from $ipaddr".(length $message ? ": $message" : "");
107         }
108
109         if (-d "$config{srcdir}/{arch}") {
110                 # Check to see if the page has been changed by someone
111                 # else since rcs_prepedit was called.
112                 my ($oldrev)=$rcstoken=~/^([A-Za-z0-9@\/._-]+)$/; # untaint
113                 my $rev=`tla tree-id $config{srcdir}`;
114                 if (defined $rev && defined $oldrev && $rev ne $oldrev) {
115                         # Merge their changes into the file that we've
116                         # changed.
117                         if (quiet_system("tla", "update", "-d",
118                                    "$config{srcdir}") != 0) {
119                                 warn("tla update failed\n");
120                         }
121                 }
122
123                 if (quiet_system("tla", "commit",
124                            "-L".IkiWiki::possibly_foolish_untaint($message),
125                            '-d', $config{srcdir}) != 0) {
126                         my $conflict=readfile("$config{srcdir}/$file");
127                         if (system("tla", "undo", "-n", "--quiet", "-d", "$config{srcdir}") != 0) {
128                                 warn("tla undo failed\n");
129                         }
130                         return $conflict;
131                 }
132         }
133         return undef # success
134 } #}}}
135
136 sub rcs_commit_staged ($$$) {
137         # Commits all staged changes. Changes can be staged using rcs_add,
138         # rcs_remove, and rcs_rename.
139         my ($message, $user, $ipaddr)=@_;
140         
141         error("rcs_commit_staged not implemented for tla"); # TODO
142 }
143
144 sub rcs_add ($) { #{{{
145         my $file=shift;
146
147         if (-d "$config{srcdir}/{arch}") {
148                 if (quiet_system("tla", "add", "$config{srcdir}/$file") != 0) {
149                         warn("tla add failed\n");
150                 }
151         }
152 } #}}}
153
154 sub rcs_remove ($) { # {{{
155         my $file = shift;
156
157         error("rcs_remove not implemented for tla"); # TODO
158 } #}}}
159
160 sub rcs_rename ($$) { # {{{a
161         my ($src, $dest) = @_;
162
163         error("rcs_rename not implemented for tla"); # TODO
164 } #}}}
165
166 sub rcs_recentchanges ($) {
167         my $num=shift;
168         my @ret;
169
170         return unless -d "$config{srcdir}/{arch}";
171
172         eval q{use Date::Parse};
173         error($@) if $@;
174         eval q{use Mail::Header};
175         error($@) if $@;
176
177         my $logs = `tla logs -d $config{srcdir}`;
178         my @changesets = reverse split(/\n/, $logs);
179
180         for (my $i=0; $i<$num && $i<$#changesets; $i++) {
181                 my ($change)=$changesets[$i]=~/^([A-Za-z0-9@\/._-]+)$/; # untaint
182
183                 open(LOG, "tla cat-log -d $config{srcdir} $change|");
184                 my $head = Mail::Header->new(\*LOG);
185                 close(LOG);
186
187                 my $rev = $head->get("Revision");
188                 my $summ = $head->get("Summary");
189                 my $newfiles = $head->get("New-files");
190                 my $modfiles = $head->get("Modified-files");
191                 my $remfiles = $head->get("Removed-files");
192                 my $user = $head->get("Creator");
193
194                 my @paths = grep { !/^(.*\/)?\.arch-ids\/.*\.id$/ }
195                         split(/ /, "$newfiles $modfiles .arch-ids/fake.id");
196
197                 my $sdate = $head->get("Standard-date");
198                 my $when = str2time($sdate, 'UTC');
199
200                 my $committype = "web";
201                 if (defined $summ && $summ =~ /$config{web_commit_regexp}/) {
202                         $user = defined $2 ? "$2" : "$3";
203                         $summ = $4;
204                 }
205                 else {
206                         $committype="tla";
207                 }
208
209                 my @message;
210                 push @message, { line => $summ };
211
212                 my @pages;
213
214                 foreach my $file (@paths) {
215                         my $diffurl=defined $config{diffurl} ? $config{diffurl} : "";
216                         $diffurl=~s/\[\[file\]\]/$file/g;
217                         $diffurl=~s/\[\[rev\]\]/$change/g;
218                         push @pages, {
219                                 page => pagename($file),
220                                 diffurl => $diffurl,
221                         } if length $file;
222                 }
223                 push @ret, {
224                         rev => $change,
225                         user => $user,
226                         committype => $committype,
227                         when => $when,
228                         message => [@message],
229                         pages => [@pages],
230                 } if @pages;
231
232                 last if $i == $num;
233         }
234
235         return @ret;
236 }
237
238 sub rcs_diff ($) { #{{{
239         my $rev=shift;
240         my $logs = `tla logs -d $config{srcdir}`;
241         my @changesets = reverse split(/\n/, $logs);
242         my $i;
243
244         for($i=0;$i<$#changesets;$i++) {
245                 last if $changesets[$i] eq $rev;
246         }
247
248         my $revminusone = $changesets[$i+1];
249         return `tla diff -d $config{srcdir} $revminusone`;
250 } #}}}
251
252 sub rcs_getctime ($) { #{{{
253         my $file=shift;
254         eval q{use Date::Parse};
255         error($@) if $@;
256         eval q{use Mail::Header};
257         error($@) if $@;
258
259         my $logs = `tla logs -d $config{srcdir}`;
260         my @changesets = reverse split(/\n/, $logs);
261         my $sdate;
262
263         for (my $i=0; $i<$#changesets; $i++) {
264                 my $change = $changesets[$i];
265
266                 open(LOG, "tla cat-log -d $config{srcdir} $change|");
267                 my $head = Mail::Header->new(\*LOG);
268                 close(LOG);
269
270                 $sdate = $head->get("Standard-date");
271                 my $newfiles = $head->get("New-files");
272
273                 my ($lastcreation) = grep {/^$file$/} split(/ /, "$newfiles");
274                 last if defined($lastcreation);
275         }
276
277         my $date=str2time($sdate, 'UTC');
278         debug("found ctime ".localtime($date)." for $file");
279         return $date;
280 } #}}}
281
282 1