#!/usr/bin/perl -w # # ciabot2 -- Mail a CVS log message to a given address, for purposes of CIA. # # Based on cvslog by Russ Allbery # Copyright 1998 Board of Trustees, Leland Stanford Jr. University # # Written by Petr Baudis # Copyright 2001, 2003 Sirius Labs. # GPL'ed # # This program is designed to run from CVS's loginfo administrative file and # takes a log message, massaging it and mailing it to the address given on # the command line. It's a modified version of the log script that comes # with CVS, but tries to do less (it doesn't do cvs status). # # It should be run from loginfo with something like: # # ^foo $CVSROOT/CVSROOT/cvslog %{sVv} $USER # # Note that it mails everything to the address configured at the top of this # file. use vars qw ($project $from $module $branch $logmsg @dir @ci); ### Configuration # Mail all reports to this address $rpc_uri = 'http://cia.navi.cx/RPC2'; $project = $ARGV[1]; ### Load input data $from = 'DEATH@ankh-morpork.com'; $module = 'unknown_module'; $branch = undef; $logmsg = ''; # Parse stdin my ($state); $state = 0; while () { chomp; if (/^Module name/) { my (@l) = split(/\s*:\s*/); $module = $l[1]; next; } if (/^Branch/) { my (@l) = split(/\s*:\s*/); $branch = $l[1]; next; } if (/^Changes by/) { s/@.*//; my (@l) = split(/\s*:\s*/); $from = $l[1]; next; } if (/^[^ ]+ files/) { $state = 2; next; } if (/^Log message/) { $state = 1; next; } if (/^Patches/) { last; } if ($state == 1) { s/&/&/g; s//>/g; $logmsg .= $_ . "\n"; } if ($state == 2) { s/^\s*//; if (s/^(\S+)\s*:\s*//) { push(@dir, $1); } $ci[@dir - 1] .= $_ . ' '; $ci[@dir - 1] =~ s/\s*$//; } } my $VERSION = '1.1'; my $message = ''; $message = < CIA Perl client for Cygnus-style CVS mails $VERSION Ask pasky\@ucw.cz. $project $module EM ; $message .= " $branch" if ($branch); $message .= < $from EM ; for (my $dirnum = 0; $dirnum < @dir; $dirnum++) { map { $_ = $dir[$dirnum] . '/' . $_; #s#^.*?/##; # weed out the module name s/&/&/g; s//>/g; $message .= " $_\n"; } split(/ /, $ci[$dirnum]); } $message .= < $logmsg EM ; ### Send out the XML-RPC message # 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; use RPC::XML; use 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"; }