IkiWiki/Plugin/bzr.pm

   1 #!/usr/bin/perl
   2 package IkiWiki::Plugin::bzr;
   3
   4 use warnings;
   5 use strict;
   6 use IkiWiki;
   7 use Encode;
   8 use open qw{:utf8 :std};
   9
  10 sub import { #{{{
  11         hook(type => "checkconfig", id => "bzr", call => \&checkconfig);
  12         hook(type => "getsetup", id => "bzr", call => \&getsetup);
  13         hook(type => "rcs", id => "rcs_update", call => \&rcs_update);
  14         hook(type => "rcs", id => "rcs_prepedit", call => \&rcs_prepedit);
  15         hook(type => "rcs", id => "rcs_commit", call => \&rcs_commit);
  16         hook(type => "rcs", id => "rcs_commit_staged", call => \&rcs_commit_staged);
  17         hook(type => "rcs", id => "rcs_add", call => \&rcs_add);
  18         hook(type => "rcs", id => "rcs_remove", call => \&rcs_remove);
  19         hook(type => "rcs", id => "rcs_rename", call => \&rcs_rename);
  20         hook(type => "rcs", id => "rcs_recentchanges", call => \&rcs_recentchanges);
  21         hook(type => "rcs", id => "rcs_diff", call => \&rcs_diff);
  22         hook(type => "rcs", id => "rcs_getctime", call => \&rcs_getctime);
  23 } #}}}
  24
  25 sub checkconfig () { #{{{
  26         if (defined $config{bzr_wrapper} && length $config{bzr_wrapper}) {
  27                 push @{$config{wrappers}}, {
  28                         wrapper => $config{bzr_wrapper},
  29                         wrappermode => (defined $config{bzr_wrappermode} ? $config{bzr_wrappermode} : "06755"),
  30                 };
  31         }
  32 } #}}}
  33
  34 sub getsetup () { #{{{
  35         return
  36                 bzr_wrapper => {
  37                         type => "string",
  38                         #example => "", # FIXME add example
  39                         description => "bzr post-commit hook to generate",
  40                         safe => 0, # file
  41                         rebuild => 0,
  42                 },
  43                 bzr_wrappermode => {
  44                         type => "string",
  45                         example => '06755',
  46                         description => "mode for bzr_wrapper (can safely be made suid)",
  47                         safe => 0,
  48                         rebuild => 0,
  49                 },
  50                 historyurl => {
  51                         type => "string",
  52                         #example => "", # FIXME add example
  53                         description => "url to show file history, using loggerhead ([[file]] substituted)",
  54                         safe => 1,
  55                         rebuild => 1,
  56                 },
  57                 diffurl => {
  58                         type => "string",
  59                         example => "http://example.com/revision?start_revid=[[r2]]#[[file]]-s",
  60                         description => "url to view a diff, using loggerhead ([[file]] and [[r2]] substituted)",
  61                         safe => 1,
  62                         rebuild => 1,
  63                 },
  64 } #}}}
  65
  66 sub bzr_log ($) { #{{{
  67         my $out = shift;
  68         my @infos = ();
  69         my $key = undef;
  70
  71         while (<$out>) {
  72                 my $line = $_;
  73                 my ($value);
  74                 if ($line =~ /^message:/) {
  75                         $key = "message";
  76                         $infos[$#infos]{$key} = "";
  77                 }
  78                 elsif ($line =~ /^(modified|added|renamed|renamed and modified|removed):/) {
  79                         $key = "files";
  80                         unless (defined($infos[$#infos]{$key})) { $infos[$#infos]{$key} = ""; }
  81                 }
  82                 elsif (defined($key) and $line =~ /^  (.*)/) {
  83                         $infos[$#infos]{$key} .= "$1\n";
  84                 }
  85                 elsif ($line eq "------------------------------------------------------------\n") {
  86                         $key = undef;
  87                         push (@infos, {});
  88                 }
  89                 else {
  90                         chomp $line;
  91                                 ($key, $value) = split /: +/, $line, 2;
  92                         $infos[$#infos]{$key} = $value;
  93                 }
  94         }
  95         close $out;
  96
  97         return @infos;
  98 } #}}}
  99
 100 sub rcs_update () { #{{{
 101         my @cmdline = ("bzr", "update", "--quiet", $config{srcdir});
 102         if (system(@cmdline) != 0) {
 103                 warn "'@cmdline' failed: $!";
 104         }
 105 } #}}}
 106
 107 sub rcs_prepedit ($) { #{{{
 108         return "";
 109 } #}}}
 110
 111 sub bzr_author ($$) { #{{{
 112         my ($user, $ipaddr) = @_;
 113
 114         if (defined $user) {
 115                 return IkiWiki::possibly_foolish_untaint($user);
 116         }
 117         elsif (defined $ipaddr) {
 118                 return "Anonymous from ".IkiWiki::possibly_foolish_untaint($ipaddr);
 119         }
 120         else {
 121                 return "Anonymous";
 122         }
 123 } #}}}
 124
 125 sub rcs_commit ($$$;$$) { #{{{
 126         my ($file, $message, $rcstoken, $user, $ipaddr) = @_;
 127
 128         $user = bzr_author($user, $ipaddr);
 129
 130         $message = IkiWiki::possibly_foolish_untaint($message);
 131         if (! length $message) {
 132                 $message = "no message given";
 133         }
 134
 135         my @cmdline = ("bzr", "commit", "--quiet", "-m", $message, "--author", $user,
 136                        $config{srcdir}."/".$file);
 137         if (system(@cmdline) != 0) {
 138                 warn "'@cmdline' failed: $!";
 139         }
 140
 141         return undef; # success
 142 } #}}}
 143
 144 sub rcs_commit_staged ($$$) {
 145         # Commits all staged changes. Changes can be staged using rcs_add,
 146         # rcs_remove, and rcs_rename.
 147         my ($message, $user, $ipaddr)=@_;
 148
 149         $user = bzr_author($user, $ipaddr);
 150
 151         $message = IkiWiki::possibly_foolish_untaint($message);
 152         if (! length $message) {
 153                 $message = "no message given";
 154         }
 155
 156         my @cmdline = ("bzr", "commit", "--quiet", "-m", $message, "--author", $user,
 157                        $config{srcdir});
 158         if (system(@cmdline) != 0) {
 159                 warn "'@cmdline' failed: $!";
 160         }
 161
 162         return undef; # success
 163 } #}}}
 164
 165 sub rcs_add ($) { # {{{
 166         my ($file) = @_;
 167
 168         my @cmdline = ("bzr", "add", "--quiet", "$config{srcdir}/$file");
 169         if (system(@cmdline) != 0) {
 170                 warn "'@cmdline' failed: $!";
 171         }
 172 } #}}}
 173
 174 sub rcs_remove ($) { # {{{
 175         my ($file) = @_;
 176
 177         my @cmdline = ("bzr", "rm", "--force", "--quiet", "$config{srcdir}/$file");
 178         if (system(@cmdline) != 0) {
 179                 warn "'@cmdline' failed: $!";
 180         }
 181 } #}}}
 182
 183 sub rcs_rename ($$) { # {{{
 184         my ($src, $dest) = @_;
 185
 186         my $parent = IkiWiki::dirname($dest);
 187         if (system("bzr", "add", "--quiet", "$config{srcdir}/$parent") != 0) {
 188                 warn("bzr add $parent failed\n");
 189         }
 190
 191         my @cmdline = ("bzr", "mv", "--quiet", "$config{srcdir}/$src", "$config{srcdir}/$dest");
 192         if (system(@cmdline) != 0) {
 193                 warn "'@cmdline' failed: $!";
 194         }
 195 } #}}}
 196
 197 sub rcs_recentchanges ($) { #{{{
 198         my ($num) = @_;
 199
 200         my @cmdline = ("bzr", "log", "-v", "--show-ids", "--limit", $num,
 201                            $config{srcdir});
 202         open (my $out, "@cmdline |");
 203
 204         eval q{use Date::Parse};
 205         error($@) if $@;
 206
 207         my @ret;
 208         foreach my $info (bzr_log($out)) {
 209                 my @pages = ();
 210                 my @message = ();
 211
 212                 foreach my $msgline (split(/\n/, $info->{message})) {
 213                         push @message, { line => $msgline };
 214                 }
 215
 216                 foreach my $file (split(/\n/, $info->{files})) {
 217                         my ($filename, $fileid) = ($file =~ /^(.*?) +([^ ]+)$/);
 218
 219                         # Skip directories
 220                         next if ($filename =~ /\/$/);
 221
 222                         # Skip source name in renames
 223                         $filename =~ s/^.* => //;
 224
 225                         my $diffurl = defined $config{'diffurl'} ? $config{'diffurl'} : "";
 226                         $diffurl =~ s/\[\[file\]\]/$filename/go;
 227                         $diffurl =~ s/\[\[file-id\]\]/$fileid/go;
 228                         $diffurl =~ s/\[\[r2\]\]/$info->{revno}/go;
 229
 230                         push @pages, {
 231                                 page => pagename($filename),
 232                                 diffurl => $diffurl,
 233                         };
 234                 }
 235
 236                 my $user = $info->{"committer"};
 237                 if (defined($info->{"author"})) { $user = $info->{"author"}; }
 238                 $user =~ s/\s*<.*>\s*$//;
 239                 $user =~ s/^\s*//;
 240
 241                 push @ret, {
 242                         rev        => $info->{"revno"},
 243                         user       => $user,
 244                         committype => "bzr",
 245                         when       => time - str2time($info->{"timestamp"}),
 246                         message    => [@message],
 247                         pages      => [@pages],
 248                 };
 249         }
 250
 251         return @ret;
 252 } #}}}
 253
 254 sub rcs_getctime ($) { #{{{
 255         my ($file) = @_;
 256
 257         # XXX filename passes through the shell here, should try to avoid
 258         # that just in case
 259         my @cmdline = ("bzr", "log", "--limit", '1', "$config{srcdir}/$file");
 260         open (my $out, "@cmdline |");
 261
 262         my @log = bzr_log($out);
 263
 264         if (length @log < 1) {
 265                 return 0;
 266         }
 267
 268         eval q{use Date::Parse};
 269         error($@) if $@;
 270
 271         my $ctime = str2time($log[0]->{"timestamp"});
 272         return $ctime;
 273 } #}}}
 274
 275 1