bug 1434118, scanner had a faulty behavior scanning variable names like 'retur*'
[phpeclipse.git] / CVSROOT / ciabot_cvs.pl
1 #!/usr/bin/perl -w
2 #
3 # ciabot -- Mail a CVS log message to a given address, for the purposes of CIA
4 #
5 # Loosely based on cvslog by Russ Allbery <rra@stanford.edu>
6 # Copyright 1998  Board of Trustees, Leland Stanford Jr. University
7 #
8 # Copyright 2001, 2003, 2004  Petr Baudis <pasky@ucw.cz>
9 #
10 # This program is free software; you can redistribute it and/or modify it under
11 # the terms of the GNU General Public License version 2, as published by the
12 # Free Software Foundation.
13 #
14 # The master location of this file is
15 #   http://pasky.or.cz/~pasky/dev/cvs/ciabot.pl.
16 #
17 # This version has been modified a bit, and is available on CIA's web site:
18 #   http://cia.navi.cx/clients/cvs/ciabot_cvs.pl
19 #
20 # This program is designed to run from the loginfo CVS administration file. It
21 # takes a log message, massaging it and mailing it to the address given below.
22 #
23 # Its record in the loginfo file should look like:
24 #
25 #     ALL /usr/bin/perl $CVSROOT/CVSROOT/ciabot_cvs.pl %{,,,s} $USER project from_email dest_email ignore_regexp
26 #
27 # IMPORTANT: The %{,,,s} in loginfo is new, and is required for proper operation.
28 #
29 #            Make sure that you add the script to 'checkoutlist' before
30 #            committing it. You may need to change /usr/bin/perl to point to your
31 #            system's perl binary.
32 #
33 #            Note that the last four parameters are optional, you can alternatively
34 #            change the defaults below in the configuration section.
35 #
36
37 use strict;
38 use vars qw ($project $from_email $dest_email $rpc_uri $sendmail $sync_delay
39                 $xml_rpc $ignore_regexp $alt_local_message_target);
40
41
42 ### Configuration
43
44 # Project name (as known to CIA).
45 #
46 # NOTE: This shouldn't be a long description of your project. Ideally
47 #       it is a short identifier with no spaces, punctuation, or
48 #       unnecessary capitalization. This will be used in URLs related
49 #       to your project, as an internal identifier, and in IRC messages.
50 #       If you want a longer name shown for your project on the web
51 #       interface, please use the "title" metadata key rather than
52 #       putting that here.
53 #
54 $project = 'phpeclipse';
55
56 # The from address in generated mails.
57 $from_email = 'bananeweizen@sourceforge.net';
58
59 # Mail all reports to this address.
60 $dest_email = 'cia@cia.navi.cx';
61
62 # If using XML-RPC, connect to this URI.
63 $rpc_uri = 'http://cia.navi.cx/RPC2';
64
65 # Path to your USCD sendmail compatible binary (your mailer daemon created this
66 # program somewhere).
67 $sendmail = '/usr/sbin/sendmail';
68
69 # Number of seconds to wait for possible concurrent instances. CVS calls up
70 # this script for each involved directory separately and this is the sync
71 # delay. 5s looks as a safe value, but feel free to increase if you are running
72 # this on a slower (or overloaded) machine or if you have really a lot of
73 # directories.
74 # Increasing this could be a very good idea if you're on Sourceforge ;)
75 $sync_delay = 5;
76
77 # This script can communicate with CIA either by mail or by an XML-RPC
78 # interface. The XML-RPC interface is faster and more efficient, however you
79 # need to have RPC::XML perl module installed, and some large CVS hosting sites
80 # (like Savannah or Sourceforge) might not allow outgoing HTTP connections
81 # while they allow outgoing mail. Also, this script will hang and eventually
82 # not deliver the event at all if CIA server happens to be down, which is
83 # unfortunately not an uncommon condition.
84 $xml_rpc = 0;
85
86 # You can make this bot to totally ignore events concerning the objects
87 # specified below. Each object is composed of <module>/<path>/<filename>,
88 # therefore file Manifest in root directory of module gentoo will be called
89 # "gentoo/Manifest", while file src/bfu/inphist.c of module elinks will be
90 # called "elinks/src/bfu/inphist.c". Easy, isn't it?
91 #
92 # This variable should contain regexp, against which will each object be
93 # checked, and if the regexp is matched, the file is ignored. Therefore ie.  to
94 # ignore all changes in the two files above and everything concerning module
95 # 'admin', use:
96 #
97 # $ignore_regexp = "^(gentoo/Manifest|elinks/src/bfu/inphist.c|admin/)";
98 $ignore_regexp = "";
99
100 # It can be useful to also grab the generated XML message by some other
101 # programs and ie. autogenerate some content based on it. Here you can specify
102 # a file to which it will be appended.
103 $alt_local_message_target = "";
104
105
106
107
108 ### The code itself
109
110 use vars qw ($user $module $tag @files $logmsg $message);
111
112 my @dir; # This array stores all the affected directories
113 my @dirfiles;  # This array is mapped to the @dir array and contains files
114                # affected in each directory
115
116
117 # A nice nonprinting character we can use as a separator relatively safely.
118 # The commas in loginfo above give us 4 commas and a space between file
119 # names given to us on the command line. This is the separator used internally.
120 # Now we can handle filenames containing spaces, and probably anything except
121 # strings of 4 commas or the ASCII bell character.
122 #
123 # This was inspired by the suggestion in:
124 #  http://mail.gnu.org/archive/html/info-cvs/2003-04/msg00267.html
125 #
126 $" = "\7";
127
128 ### Input data loading
129
130
131 # These arguments are from %s; first the relative path in the repository
132 # and then the list of files modified.
133
134 @files = split (' ,,,', ($ARGV[0] or ''));
135 $dir[0] = shift @files or die "$0: no directory specified\n";
136 $dirfiles[0] = "@files" or die "$0: no files specified\n";
137
138
139 # Guess module name.
140
141 $module = $dir[0]; $module =~ s#/.*##;
142
143
144 # Figure out who is doing the update.
145
146 $user = $ARGV[1];
147
148
149 # Use the optional parameters, if supplied.
150
151 $project = $ARGV[2] if $ARGV[2];
152 $from_email = $ARGV[3] if $ARGV[3];
153 $dest_email = $ARGV[4] if $ARGV[4];
154 $ignore_regexp = $ARGV[5] if $ARGV[5];
155
156
157 # Parse stdin (what's interesting is the tag and log message)
158
159 while (<STDIN>) {
160   $tag = $1 if /^\s*Tag: ([a-zA-Z0-9_-]+)/;
161   last if /^Log Message/;
162 }
163
164 $logmsg = "";
165 while (<STDIN>) {
166   next unless ($_ and $_ ne "\n" and $_ ne "\r\n");
167   s/&/&amp;/g;
168   s/</&lt;/g;
169   s/>/&gt;/g;
170   $logmsg .= $_;
171 }
172
173 ### Remove to-be-ignored files
174
175 $dirfiles[0] = join (' ',
176   grep {
177     my $f = "$dir[0]/$_";
178     $f !~ m/$ignore_regexp/;
179   } split (/\s+/, $dirfiles[0])
180 ) if ($ignore_regexp);
181 exit unless $dirfiles[0];
182
183
184
185 ### Sync between the multiple instances potentially being ran simultanously
186
187 my $sum; # _VERY_ simple hash of the log message. It is really weak, but I'm
188          # lazy and it's really sorta exceptional to even get more commits
189          # running simultanously anyway.
190 $sum = 0;
191 map { $sum += ord $_ } split(//, $logmsg);
192
193 my $syncfile; # Name of the file used for syncing
194 $syncfile = "/tmp/cvscia.$project.$module.$sum";
195
196
197 if (-f $syncfile and -w $syncfile) {
198   # The synchronization file for this file already exists, so we are not the
199   # first ones. So let's just dump what we know and exit.
200
201   open(FF, ">>$syncfile") or die "aieee... can't log, can't log! $syncfile blocked!";
202   print FF "$dirfiles[0]!@!$dir[0]\n";
203   close(FF);
204   exit;
205
206 } else {
207   # We are the first one! Thus, we'll fork, exit the original instance, and
208   # wait a bit with the new one. Then we'll grab what the others collected and
209   # go on.
210
211   # We don't need to care about permissions since all the instances of the one
212   # commit will obviously live as the same user.
213
214   # system("touch") in a different way
215   open(FF, ">>$syncfile") or die "aieee... can't log, can't log! $syncfile blocked!";
216   close(FF);
217
218   exit if (fork);
219   sleep($sync_delay);
220
221   open(FF, $syncfile);
222   my ($dirnum) = 1; # 0 is the one we got triggerred for
223   while (<FF>) {
224     chomp;
225     ($dirfiles[$dirnum], $dir[$dirnum]) = split(/!@!/);
226     $dirnum++;
227   }
228   close(FF);
229
230   unlink($syncfile);
231 }
232
233
234
235 ### Compose the mail message
236
237
238 my ($VERSION) = '2.4';
239 my ($URL) = 'http://cia.navi.cx/clients/cvs/ciabot_cvs.pl';
240 my $ts = time;
241
242 $message = <<EM
243 <message>
244    <generator>
245        <name>CIA Perl client for CVS</name>
246        <version>$VERSION</version>
247        <url>$URL</url>
248    </generator>
249    <source>
250        <project>$project</project>
251        <module>$module</module>
252 EM
253 ;
254 $message .= "       <branch>$tag</branch>" if ($tag);
255 $message .= <<EM
256    </source>
257    <timestamp>
258        $ts
259    </timestamp>
260    <body>
261        <commit>
262            <author>$user</author>
263            <files>
264 EM
265 ;
266
267 for (my $dirnum = 0; $dirnum < @dir; $dirnum++) {
268   map {
269     $_ = $dir[$dirnum] . '/' . $_;
270     s#^.*?/##; # weed out the module name
271     s/&/&amp;/g;
272     s/</&lt;/g;
273     s/>/&gt;/g;
274     $message .= "  <file>$_</file>\n";
275   } split($", $dirfiles[$dirnum]);
276 }
277
278 $message .= <<EM
279            </files>
280            <log>
281 $logmsg
282            </log>
283        </commit>
284    </body>
285 </message>
286 EM
287 ;
288
289
290
291 ### Write the message to an alt-target
292
293 if ($alt_local_message_target and open (ALT, ">>$alt_local_message_target")) {
294   print ALT $message;
295   close ALT;
296 }
297
298
299
300 ### Send out the XML-RPC message
301
302
303 if ($xml_rpc) {
304   # We gotta be careful from now on. We silence all the warnings because
305   # RPC::XML code is crappy and works with undefs etc.
306   $^W = 0;
307   $RPC::XML::ERROR if (0); # silence perl's compile-time warning
308
309   require RPC::XML;
310   require RPC::XML::Client;
311
312   my $rpc_client = new RPC::XML::Client $rpc_uri;
313   my $rpc_request = RPC::XML::request->new('hub.deliver', $message);
314   my $rpc_response = $rpc_client->send_request($rpc_request);
315
316   unless (ref $rpc_response) {
317     die "XML-RPC Error: $RPC::XML::ERROR\n";
318   }
319   exit;
320 }
321
322
323
324 ### Send out the mail
325
326
327 # Open our mail program
328
329 open (MAIL, "| $sendmail -t -oi -oem") or die "Cannot execute $sendmail : " . ($?>>8);
330
331
332 # The mail header
333
334 print MAIL <<EOM;
335 From: $from_email
336 To: $dest_email
337 Content-type: text/xml
338 Subject: DeliverXML
339
340 EOM
341
342 print MAIL $message;
343
344
345 # Close the mail
346
347 close MAIL;
348 die "$0: sendmail exit status " . ($? >> 8) . "\n" unless ($? == 0);
349
350 # vi: set sw=2: