IkiWiki/Rcs/bzr.pm

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