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