[Vcfbuilder-cvs-development] CVSROOT ciabot_cvs.pl,NONE,1.1 checkoutlist,1.1,1.2 loginfo,1.3,1.4

[Jim C. <dd...@us...>]

Update of /cvsroot/vcfbuilder/CVSROOT
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17022

Modified Files:
	checkoutlist loginfo 
Added Files:
	ciabot_cvs.pl 
Log Message:
added support for cia project tracking.

Index: checkoutlist
===================================================================
RCS file: /cvsroot/vcfbuilder/CVSROOT/checkoutlist,v
retrieving revision 1.1
retrieving revision 1.2
diff -C2 -d -r1.1 -r1.2
*** checkoutlist	27 May 2003 14:12:05 -0000	1.1
--- checkoutlist	10 Mar 2006 01:55:44 -0000	1.2
***************
*** 12,13 ****
--- 12,14 ----
  #
  # comment lines begin with '#'
+ ciabot_cvs.pl

Index: loginfo
===================================================================
RCS file: /cvsroot/vcfbuilder/CVSROOT/loginfo,v
retrieving revision 1.3
retrieving revision 1.4
diff -C2 -d -r1.3 -r1.4
*** loginfo	26 Feb 2006 21:16:44 -0000	1.3
--- loginfo	10 Mar 2006 01:55:44 -0000	1.4
***************
*** 26,27 ****
--- 26,28 ----
  #DEFAULT (echo ""; id; echo %{sVv}; date; cat) >> $CVSROOT/CVSROOT/commitlog
  DEFAULT /cvsroot/sitedocs/CVSROOT/cvstools/syncmail %{sVv} vcf...@li...
+ ALL /usr/bin/perl $CVSROOT/CVSROOT/ciabot_cvs.pl %{,,,s} $USER

--- NEW FILE: ciabot_cvs.pl ---
#!/usr/bin/perl -w
#
# ciabot -- Mail a CVS log message to a given address, for the purposes of CIA
#
# Loosely based on cvslog by Russ Allbery <rr...@st...>
# Copyright 1998  Board of Trustees, Leland Stanford Jr. University
#
# Copyright 2001, 2003, 2004  Petr Baudis <pa...@uc...>
#
# This program is free software; you can redistribute it and/or modify it under
# the terms of the GNU General Public License version 2, as published by the
# Free Software Foundation.
#
# The master location of this file is
#   http://pasky.or.cz/~pasky/dev/cvs/ciabot.pl.
#
# This version has been modified a bit, and is available on CIA's web site:
#   http://cia.navi.cx/clients/cvs/ciabot_cvs.pl
#
# This program is designed to run from the loginfo CVS administration file. It
# takes a log message, massaging it and mailing it to the address given below.
#
# Its record in the loginfo file should look like:
#
#     ALL /usr/bin/perl $CVSROOT/CVSROOT/ciabot_cvs.pl %{,,,s} $USER project from_email dest_email ignore_regexp
#
# IMPORTANT: The %{,,,s} in loginfo is new, and is required for proper operation.
#
#            Make sure that you add the script to 'checkoutlist' before
#            committing it. You may need to change /usr/bin/perl to point to your
#            system's perl binary.
#
#            Note that the last four parameters are optional, you can alternatively
#            change the defaults below in the configuration section.
#

use strict;
use vars qw ($project $from_email $dest_email $rpc_uri $sendmail $sync_delay
		$xml_rpc $ignore_regexp $alt_local_message_target);


### Configuration

# Project name (as known to CIA).
#
# NOTE: This shouldn't be a long description of your project. Ideally
#       it is a short identifier with no spaces, punctuation, or
#       unnecessary capitalization. This will be used in URLs related
#       to your project, as an internal identifier, and in IRC messages.
#       If you want a longer name shown for your project on the web
#       interface, please use the "title" metadata key rather than
#       putting that here.
#
$project = 'vcfbuilder';

# The from address in generated mails.
$from_email = 'dd...@us...';

# Mail all reports to this address.
$dest_email = 'ci...@ci...';

# If using XML-RPC, connect to this URI.
$rpc_uri = 'http://cia.navi.cx/RPC2';

# Path to your USCD sendmail compatible binary (your mailer daemon created this
# program somewhere).
$sendmail = '/usr/sbin/sendmail';

# Number of seconds to wait for possible concurrent instances. CVS calls up
# this script for each involved directory separately and this is the sync
# delay. 5s looks as a safe value, but feel free to increase if you are running
# this on a slower (or overloaded) machine or if you have really a lot of
# directories.
# Increasing this could be a very good idea if you're on Sourceforge ;)
$sync_delay = 5;

# This script can communicate with CIA either by mail or by an XML-RPC
# interface. The XML-RPC interface is faster and more efficient, however you
# need to have RPC::XML perl module installed, and some large CVS hosting sites
# (like Savannah or Sourceforge) might not allow outgoing HTTP connections
# while they allow outgoing mail. Also, this script will hang and eventually
# not deliver the event at all if CIA server happens to be down, which is
# unfortunately not an uncommon condition.
$xml_rpc = 0;

# You can make this bot to totally ignore events concerning the objects
# specified below. Each object is composed of <module>/<path>/<filename>,
# therefore file Manifest in root directory of module gentoo will be called
# "gentoo/Manifest", while file src/bfu/inphist.c of module elinks will be
# called "elinks/src/bfu/inphist.c". Easy, isn't it?
#
# This variable should contain regexp, against which will each object be
# checked, and if the regexp is matched, the file is ignored. Therefore ie.  to
# ignore all changes in the two files above and everything concerning module
# 'admin', use:
#
# $ignore_regexp = "^(gentoo/Manifest|elinks/src/bfu/inphist.c|admin/)";
$ignore_regexp = "";

# It can be useful to also grab the generated XML message by some other
# programs and ie. autogenerate some content based on it. Here you can specify
# a file to which it will be appended.
$alt_local_message_target = "";




### The code itself

use vars qw ($user $module $tag @files $logmsg $message);

my @dir; # This array stores all the affected directories
my @dirfiles;  # This array is mapped to the @dir array and contains files
               # affected in each directory


# A nice nonprinting character we can use as a separator relatively safely.
# The commas in loginfo above give us 4 commas and a space between file
# names given to us on the command line. This is the separator used internally.
# Now we can handle filenames containing spaces, and probably anything except
# strings of 4 commas or the ASCII bell character.
#
# This was inspired by the suggestion in:
#  http://mail.gnu.org/archive/html/info-cvs/2003-04/msg00267.html
#
$" = "\7";

### Input data loading


# These arguments are from %s; first the relative path in the repository
# and then the list of files modified.

@files = split (' ,,,', ($ARGV[0] or ''));
$dir[0] = shift @files or die "$0: no directory specified\n";
$dirfiles[0] = "@files" or die "$0: no files specified\n";


# Guess module name.

$module = $dir[0]; $module =~ s#/.*##;


# Figure out who is doing the update.

$user = $ARGV[1];


# Use the optional parameters, if supplied.

$project = $ARGV[2] if $ARGV[2];
$from_email = $ARGV[3] if $ARGV[3];
$dest_email = $ARGV[4] if $ARGV[4];
$ignore_regexp = $ARGV[5] if $ARGV[5];


# Parse stdin (what's interesting is the tag and log message)

while (<STDIN>) {
  $tag = $1 if /^\s*Tag: ([a-zA-Z0-9_-]+)/;
  last if /^Log Message/;
}

$logmsg = "";
while (<STDIN>) {
  next unless ($_ and $_ ne "\n" and $_ ne "\r\n");
  s/&/&amp;/g;
  s/</&lt;/g;
  s/>/&gt;/g;
  $logmsg .= $_;
}

### Remove to-be-ignored files

$dirfiles[0] = join (' ',
  grep {
    my $f = "$dir[0]/$_";
    $f !~ m/$ignore_regexp/;
  } split (/\s+/, $dirfiles[0])
) if ($ignore_regexp);
exit unless $dirfiles[0];



### Sync between the multiple instances potentially being ran simultanously

my $sum; # _VERY_ simple hash of the log message. It is really weak, but I'm
         # lazy and it's really sorta exceptional to even get more commits
         # running simultanously anyway.
$sum = 0;
map { $sum += ord $_ } split(//, $logmsg);

my $syncfile; # Name of the file used for syncing
$syncfile = "/tmp/cvscia.$project.$module.$sum";


if (-f $syncfile and -w $syncfile) {
  # The synchronization file for this file already exists, so we are not the
  # first ones. So let's just dump what we know and exit.

  open(FF, ">>$syncfile") or die "aieee... can't log, can't log! $syncfile blocked!";
  print FF "$dirfiles[0]!@!$dir[0]\n";
  close(FF);
  exit;

} else {
  # We are the first one! Thus, we'll fork, exit the original instance, and
  # wait a bit with the new one. Then we'll grab what the others collected and
  # go on.

  # We don't need to care about permissions since all the instances of the one
  # commit will obviously live as the same user.

  # system("touch") in a different way
  open(FF, ">>$syncfile") or die "aieee... can't log, can't log! $syncfile blocked!";
  close(FF);

  exit if (fork);
  sleep($sync_delay);

  open(FF, $syncfile);
  my ($dirnum) = 1; # 0 is the one we got triggerred for
  while (<FF>) {
    chomp;
    ($dirfiles[$dirnum], $dir[$dirnum]) = split(/!@!/);
    $dirnum++;
  }
  close(FF);

  unlink($syncfile);
}



### Compose the mail message


my ($VERSION) = '2.4';
my ($URL) = 'http://cia.navi.cx/clients/cvs/ciabot_cvs.pl';
my $ts = time;

$message = <<EM
<message>
   <generator>
       <name>CIA Perl client for CVS</name>
       <version>$VERSION</version>
       <url>$URL</url>
   </generator>
   <source>
       <project>$project</project>
       <module>$module</module>
EM
;
$message .= "       <branch>$tag</branch>" if ($tag);
$message .= <<EM
   </source>
   <timestamp>
       $ts
   </timestamp>
   <body>
       <commit>
           <author>$user</author>
           <files>
EM
;

for (my $dirnum = 0; $dirnum < @dir; $dirnum++) {
  map {
    $_ = $dir[$dirnum] . '/' . $_;
    s#^.*?/##; # weed out the module name
    s/&/&amp;/g;
    s/</&lt;/g;
    s/>/&gt;/g;
    $message .= "  <file>$_</file>\n";
  } split($", $dirfiles[$dirnum]);
}

$message .= <<EM
           </files>
           <log>
$logmsg
           </log>
       </commit>
   </body>
</message>
EM
;



### Write the message to an alt-target

if ($alt_local_message_target and open (ALT, ">>$alt_local_message_target")) {
  print ALT $message;
  close ALT;
}



### Send out the XML-RPC message


if ($xml_rpc) {
  # We gotta be careful from now on. We silence all the warnings because
  # RPC::XML code is crappy and works with undefs etc.
  $^W = 0;
  $RPC::XML::ERROR if (0); # silence perl's compile-time warning

  require RPC::XML;
  require RPC::XML::Client;

  my $rpc_client = new RPC::XML::Client $rpc_uri;
  my $rpc_request = RPC::XML::request->new('hub.deliver', $message);
  my $rpc_response = $rpc_client->send_request($rpc_request);

  unless (ref $rpc_response) {
    die "XML-RPC Error: $RPC::XML::ERROR\n";
  }
  exit;
}



### Send out the mail


# Open our mail program

open (MAIL, "| $sendmail -t -oi -oem") or die "Cannot execute $sendmail : " . ($?>>8);


# The mail header

print MAIL <<EOM;
From: $from_email
To: $dest_email
Content-type: text/xml
Subject: DeliverXML

EOM

print MAIL $message;


# Close the mail

close MAIL;
die "$0: sendmail exit status " . ($? >> 8) . "\n" unless ($? == 0);

# vi: set sw=2: