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