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