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