IkiWiki/Rcs/mercurial.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 mercurial_log($) {
  12         my $out = shift;
  13         my @infos;
  14
  15         while (<$out>) {
  16                 my $line = $_;
  17                 my ($key, $value);
  18
  19                 if (/^description:/) {
  20                         $key = "description";
  21                         $value = "";
  22
  23                         # slurp everything as the description text
  24                         # until the next changeset
  25                         while (<$out>) {
  26                                 if (/^changeset: /) {
  27                                         $line = $_;
  28                                         last;
  29                                 }
  30
  31                                 $value .= $_;
  32                         }
  33
  34                         local $/ = "";
  35                         chomp $value;
  36                         $infos[$#infos]{$key} = $value;
  37                 }
  38
  39                 chomp $line;
  40                 ($key, $value) = split /: +/, $line, 2;
  41
  42                 if ($key eq "changeset") {
  43                         push @infos, {};
  44
  45                         # remove the revision index, which is strictly
  46                         # local to the repository
  47                         $value =~ s/^\d+://;
  48                 }
  49
  50                 $infos[$#infos]{$key} = $value;
  51         }
  52         close $out;
  53
  54         return @infos;
  55 }
  56
  57 sub rcs_update () { #{{{
  58         my @cmdline = ("hg", "-q", "-R", "$config{srcdir}", "update");
  59         if (system(@cmdline) != 0) {
  60                 warn "'@cmdline' failed: $!";
  61         }
  62 } #}}}
  63
  64 sub rcs_prepedit ($) { #{{{
  65         return "";
  66 } #}}}
  67
  68 sub rcs_commit ($$$;$$) { #{{{
  69         my ($file, $message, $rcstoken, $user, $ipaddr) = @_;
  70
  71         if (defined $user) {
  72                 $user = possibly_foolish_untaint($user);
  73         }
  74         elsif (defined $ipaddr) {
  75                 $user = "Anonymous from ".possibly_foolish_untaint($ipaddr);
  76         }
  77         else {
  78                 $user = "Anonymous";
  79         }
  80
  81         $message = possibly_foolish_untaint($message);
  82         if (! length $message) {
  83                 $message = "no message given";
  84         }
  85
  86         my @cmdline = ("hg", "-q", "-R", $config{srcdir}, "commit",
  87                        "-m", $message, "-u", $user);
  88         if (system(@cmdline) != 0) {
  89                 warn "'@cmdline' failed: $!";
  90         }
  91
  92         return undef; # success
  93 } #}}}
  94
  95 sub rcs_commit_staged ($$$) {
  96         # Commits all staged changes. Changes can be staged using rcs_add,
  97         # rcs_remove, and rcs_rename.
  98         my ($message, $user, $ipaddr)=@_;
  99
 100         error("rcs_commit_staged not implemented for mercurial"); # TODO
 101 }
 102
 103 sub rcs_add ($) { # {{{
 104         my ($file) = @_;
 105
 106         my @cmdline = ("hg", "-q", "-R", "$config{srcdir}", "add", "$config{srcdir}/$file");
 107         if (system(@cmdline) != 0) {
 108                 warn "'@cmdline' failed: $!";
 109         }
 110 } #}}}
 111
 112 sub rcs_remove ($) { # {{{
 113         my ($file) = @_;
 114
 115         error("rcs_remove not implemented for mercurial"); # TODO
 116 } #}}}
 117
 118 sub rcs_rename ($$) { # {{{
 119         my ($src, $dest) = @_;
 120
 121         error("rcs_rename not implemented for mercurial"); # TODO
 122 } #}}}
 123
 124 sub rcs_recentchanges ($) { #{{{
 125         my ($num) = @_;
 126
 127         my @cmdline = ("hg", "-R", $config{srcdir}, "log", "-v", "-l", $num,
 128                 "--style", "default");
 129         open (my $out, "@cmdline |");
 130
 131         eval q{use Date::Parse};
 132         error($@) if $@;
 133
 134         my @ret;
 135         foreach my $info (mercurial_log($out)) {
 136                 my @pages = ();
 137                 my @message = ();
 138
 139                 foreach my $msgline (split(/\n/, $info->{description})) {
 140                         push @message, { line => $msgline };
 141                 }
 142
 143                 foreach my $file (split / /,$info->{files}) {
 144                         my $diffurl = $config{'diffurl'};
 145                         $diffurl =~ s/\[\[file\]\]/$file/go;
 146                         $diffurl =~ s/\[\[r2\]\]/$info->{changeset}/go;
 147
 148                         push @pages, {
 149                                 page => pagename($file),
 150                                 diffurl => $diffurl,
 151                         };
 152                 }
 153
 154                 my $user = $info->{"user"};
 155                 $user =~ s/\s*<.*>\s*$//;
 156                 $user =~ s/^\s*//;
 157
 158                 push @ret, {
 159                         rev        => $info->{"changeset"},
 160                         user       => $user,
 161                         committype => "mercurial",
 162                         when       => str2time($info->{"date"}),
 163                         message    => [@message],
 164                         pages      => [@pages],
 165                 };
 166         }
 167
 168         return @ret;
 169 } #}}}
 170
 171 sub rcs_diff ($) { #{{{
 172         # TODO
 173 } #}}}
 174
 175 sub rcs_getctime ($) { #{{{
 176         my ($file) = @_;
 177
 178         # XXX filename passes through the shell here, should try to avoid
 179         # that just in case
 180         my @cmdline = ("hg", "-R", $config{srcdir}, "log", "-v", "-l", '1',
 181                 "--style", "default", "$config{srcdir}/$file");
 182         open (my $out, "@cmdline |");
 183
 184         my @log = mercurial_log($out);
 185
 186         if (length @log < 1) {
 187                 return 0;
 188         }
 189
 190         eval q{use Date::Parse};
 191         error($@) if $@;
 192
 193         my $ctime = str2time($log[0]->{"date"});
 194         return $ctime;
 195 } #}}}
 196
 197 1