finish adding getsetup hooks to plugins
[ikiwiki.git] / 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