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