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