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