ossp-pkg/shiela/shiela.pl
#!@PERL@ -w
##
## OSSP shiela - CVS Access Control and Logging Facility
## Copyright (c) 2000-2006 Ralf S. Engelschall <rse@engelschall.com>
## Copyright (c) 2000-2006 The OSSP Project <http://www.ossp.org/>
##
## This file is part of OSSP shiela, an access control and logging
## facility for Concurrent Versions System (CVS) repositories
## which can be found at http://www.ossp.org/pkg/tool/shiela/.
##
## This program is free software; you can redistribute it and/or
## modify it under the terms of the GNU General Public License
## as published by the Free Software Foundation; either version
## 2.0 of the License, or (at your option) any later version.
##
## This program is distributed in the hope that it will be useful,
## but WITHOUT ANY WARRANTY; without even the implied warranty of
## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
## General Public License for more details.
##
## You should have received a copy of the GNU General Public License
## along with this file; if not, write to the Free Software
## Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
## USA, or contact Ralf S. Engelschall <rse@engelschall.com>.
##
## shiela.pl: control program (syntax: Perl)
##
my $version = '1.1.7';
require 5.005;
use strict; # shipped with Perl since 5.000
use POSIX; # shipped with Perl since 5.000
use IO::File; # shipped with Perl since 5.003
use IO::Handle; # shipped with Perl since 5.003
use IPC::Open2; # shipped with Perl since 5.003
use Data::Dumper; # shipped with Perl since 5.005
use Cwd qw(abs_path); # shipped with Perl since 5.005
# DEBUGGING
$Data::Dumper::Purity = 1;
$Data::Dumper::Indent = 1;
$Data::Dumper::Terse = 1;
$Data::Dumper::Pad = "| ";
## _________________________________________________________________
##
## Main procedure.
## _________________________________________________________________
##
# Adjust program environment
$|++;
umask(002);
delete $ENV{TZ};
$ENV{PATH} = "/bin:/usr/bin:/sbin:/usr/sbin";
# Generic program error handler
$SIG{__DIE__} = sub {
my ($text) = @_;
$text =~ s|\s+at\s+.*||s;
print STDERR "cvs:shiela:ERROR: ". $text . ($! ? " ($!)" : "") . "\n";
exit(1);
};
# determine run-time and configuration information
my $PA = &pa_determine(@ARGV);
my $RT = &rt_determine_one($0, $version);
my $CF = &cf_determine(($PA->{OPT}->{config} || $RT->{cvsadmdir} . "/$RT->{name}.cfg"));
$RT = &rt_determine_two($RT, $CF);
# DEBUGGING
if ($PA->{OPT}->{debug}) {
print STDOUT "| \$PA =\n" . Data::Dumper::Dumper($PA);
print STDOUT "| \$CF =\n" . Data::Dumper::Dumper($CF);
print STDOUT "| \$RT =\n" . Data::Dumper::Dumper($RT);
}
# dispatch into the various commands
my $rv = 1;
if ($PA->{OPT}->{hook} eq 'taginfo') {
$rv = &hook_taginfo($PA, $RT, $CF);
}
elsif ($PA->{OPT}->{hook} eq 'admininfo') {
$rv = &hook_admininfo($PA, $RT, $CF);
}
elsif ($PA->{OPT}->{hook} eq 'importinfo') {
$rv = &hook_importinfo($PA, $RT, $CF);
}
elsif ($PA->{OPT}->{hook} eq 'commitinfo') {
$rv = &hook_commitinfo($PA, $RT, $CF);
}
elsif ($PA->{OPT}->{hook} eq 'verifymsg') {
$rv = &hook_verifymsg($PA, $RT, $CF);
}
elsif ($PA->{OPT}->{hook} eq 'loginfo') {
$rv = &hook_loginfo($PA, $RT, $CF);
}
else {
die "unknown processing stage (use --hook option)";
}
exit($rv);
## _________________________________________________________________
##
## Run-time information determination.
##
## This is a two-stage process, because we need parts of the
## information for parsing the configuration, but OTOH we need the
## configuration for determining other information. To simply solve
## this chicken and egg problem, we determine in two stages.
## _________________________________________________________________
##
# Determine run-time information (stage 1)
sub rt_determine_one {
my ($program, $version) = @_;
my $RT = {};
# program version and name
$RT->{vers} = $version;
$RT->{name} = ($program =~ m|^.*?([^/]+?)(?:\.[^/.]+)?$|)[0];
# program id and process group id
$RT->{pid} = $$;
$RT->{pgrp} = getpgrp();
# supplied arguments
$RT->{cvsroot} = $ENV{CVSROOT} or die 'unknown CVS root (set $CVSROOT variable)';
$RT->{userid} = ($ENV{CVSUSER} || $ENV{LOGNAME} || $ENV{LOGUSER} || $ENV{USER}) or die 'unknown CVS user';
# various directory paths
$RT->{tmpdir} = $ENV{TMPDIR} || $ENV{TEMPDIR} || '/tmp';
$RT->{cvstmpdir} = (-w "$RT->{cvsroot}/CVSTMP" ? "$RT->{cvsroot}/CVSTMP" : $RT->{tmpdir});
$RT->{cvsadmdir} = "$RT->{cvsroot}/CVSROOT";
$RT->{cvslogdir} = (-w "$RT->{cvsroot}/CVSLOG" ? "$RT->{cvsroot}/CVSLOG" : $RT->{cvsadmdir});
# various file paths
$RT->{logfile} = "$RT->{cvslogdir}/$RT->{name}.log";
$RT->{tmpfile} = "$RT->{cvstmpdir}/$RT->{name}.$RT->{pgrp}";
return $RT;
};
# Determine run-time information (stage 2)
sub rt_determine_two {
my ($RT, $CF) = @_;
# determine user information
$RT->{username} = $CF->{Project}->{User}->{$RT->{userid}}->{name} ||
die "CVS user `$RT->{userid}' not found in OSSP shiela configuration";
$RT->{usermail} = $CF->{Project}->{User}->{$RT->{userid}}->{mail} ||
"$RT->{userid}\@localhost";
# determine user's groups
my @G = ();
foreach my $group (keys(%{$CF->{Project}->{Group}})) {
my @U = @{$CF->{Project}->{Group}->{$group}->{users}};
if (grep(m/^$RT->{userid}$/, @U)) {
push(@G, $group);
}
}
$RT->{usergroups} = join(',', @G);
# optionally set environment variables (like PATH)
foreach my $var (keys(%{$CF->{Environment}->{Setenv}})) {
$ENV{PATH} = $CF->{Environment}->{Setenv}->{$var};
}
# determine various program paths
sub find_program {
my ($name) = @_;
my ($prog) = '';
foreach my $dir (split(/:/, $ENV{PATH})) {
if (-x "$dir/$name") {
$prog = "$dir/$name";
last;
}
}
return $prog;
}
$RT->{sendmail} = $CF->{Environment}->{Program}->{sendmail} ||
&find_program("ssmtp") ||
&find_program("sendmail") ||
die "unable to find `sendmail' program";
$RT->{cvs} = $CF->{Environment}->{Program}->{cvs} ||
&find_program("cvs") ||
die "unable to find `cvs' program";
$RT->{diff} = $CF->{Environment}->{Program}->{diff} ||
&find_program("diff") ||
'';
$RT->{xdelta} = $CF->{Environment}->{Program}->{xdelta} ||
&find_program("xdelta") ||
'';
$RT->{uuencode} = $CF->{Environment}->{Program}->{uuencode} ||
&find_program("uuencode") ||
'';
# pre-calculate a reasonable MIME boundary tag
my $randtag;
my @encode = (0..9, 'A'..'Z');
srand(time ^ $$ or time ^ ($$ + ($$ << 15)));
for (my $i = 0; $i < 20; $i++) {
$randtag .= $encode[rand($#encode+1)];
}
$RT->{mimeboundary} = $randtag;
# determine CVS version and capabilities
my $cmd = sprintf("%s --version 2>/dev/null", &qsa($RT->{cvs}));
my $v = `$cmd`;
$RT->{cvsvers} = '?';
$RT->{cvsvers} = $1 if ($v =~ m|Concurrent\s+Versions\s+System\s+\(CVS\)\s+([\d.p]+)\s+|s);
$RT->{cvsrse} = 0;
$RT->{cvsrse} = 1 if ($v =~ m|\[RSE\]|s);
die "$RT->{cvs} is not at least CVS 1.12" if ($RT->{cvsvers} !~ m|^1\.1[2-9]|);
$RT->{useserver} = 0;
$RT->{useserver} = 1 if ($v =~ m|server|s);
# determine path to history database
$RT->{historydb} = $CF->{Repository}->{History} || "$RT->{cvslogdir}/$RT->{name}.db";
$RT->{historydb} = $RT->{cvsroot}."/".$RT->{historydb} if ($RT->{historydb} !~ m|^/|);
return $RT;
}
## _________________________________________________________________
##
## C-style configuration syntax parsing.
##
## <config> ::= <directive>
## | <config> <directive>
## <directive> ::= <name> ';'
## | <name> <args> ';'
## <args> ::= <arg>
## | <args> <arg>
## <arg> ::= '{' <config> '}'
## | [^ \t\n]+
##
## Note: For this task we usually would fire up the lovely
## Parse::RecDescent or some other nifty grammar-based module which
## supports parsing of nested constructs. But we want to operate in a
## stand-alone environment (or at least an environment where we only
## use Perl modules which are already shipped with the required Perl
## version), so we have to do the parsing manually. Fortunately, in
## our configuration syntax there is only one nesting: braced blocks.
## So we do the crual approach and write a poor-man's parser which is
## stand-alone and just slightly inefficient (only nested blocks are
## re-parsed) by taking advantage of the fact that our syntax has this
## very simple nesting only.
## _________________________________________________________________
##
# parse a text into a Perl structure and optionally use callbacks
sub parse_config {
my ($t, $cb, $cba) = @_;
# pre-process syntax and strip comment and blank lines
$t =~ s|^\s*#.+?$||mg;
$t =~ s|^\s*$||mg;
my $C = &parse_config_block($t, $cb, $cba, 0);
# parse a configuration block
sub parse_config_block {
my ($t, $cb, $cba, $l) = @_;
my $B = [];
my $A;
while ($t ne '') {
$t =~ s|^\s+||s && next;
($A, $t) = &parse_config_directive($t, $cb, $cba, $l);
push(@{$B}, $A);
}
$B = $cb->($cba, 'B', $l, $B) if (defined($cb));
return $B;
}
# parse a single configuration directive
sub parse_config_directive {
my ($t, $cb, $cba, $l) = @_;
my $bcnt = 0;
my $qcnt = 0;
my $A = [];
my $a = '';
while ($t ne '') {
# escaped meta character
if ($t =~ m|^\\([^{}";])|s) {
$a .= $1;
$t = $';
}
# plain argument mode
elsif ($qcnt == 0 and $bcnt == 0) {
if ($t =~ m|^;|s) {
$t = $';
last;
}
elsif ($t =~ m|^\{|s) {
push(@{$A}, $a) if ($a ne '');
$a = '';
$bcnt++;
$t = $';
}
elsif ($t =~ m|^"|s) {
$qcnt++;
$t = $';
}
elsif ($t =~ m|^\s+|s) {
push(@{$A}, $a) if ($a ne '');
$a = '';
$t = $';
}
elsif ($t =~ m|^([^;\{"\s]+)|s) {
$a .= $1;
$t = $';
}
}
# block mode
elsif ($qcnt == 0 and $bcnt > 0) {
if ($t =~ m|^\{|s) {
$bcnt++;
$a .= '{';
$t = $';
}
elsif ($t =~ m|^\}|s) {
$bcnt--;
$t = $';
if ($bcnt == 0) {
if ($a ne '') {
# NESTING!
my $C = &parse_config_block($a, $cb, $cba, $l+1);
push(@{$A}, $C);
$a = '';
}
}
else {
$a .= '}';
}
}
elsif ($t =~ m|^([^\{\}]+)|s) {
$a .= $1;
$t = $';
}
}
# quoting mode
elsif ($qcnt > 0 and $bcnt == 0) {
if ($t =~ m|^\\"|s) {
$a .= '"';
$t = $';
}
elsif ($t =~ m|^"|s) {
$qcnt--;
$t = $';
}
elsif ($t =~ m|^([^"\\]+)|s) {
$a .= $1;
$t = $';
}
}
}
push(@{$A}, $a) if ($a ne '');
$A = $cb->($cba, 'CMD', $l, $A) if (defined($cb));
return ($A, $t);
}
return $C;
}
## _________________________________________________________________
##
## Determine OSSP shiela configuration.
##
## We theoretically could directly operate on the syntax tree as
## created by parse_config() above. But for convenience reasons and
## to greatly simplify the processing, we use callback functions for
## parse_config() and build an own configuration structure.
## _________________________________________________________________
##
sub cf_determine {
my ($file) = @_;
# read configuration file
my $io = new IO::File "<$file"
or die "unable to open configuration file `$file'";
my $t = '';
$t .= $_ while (<$io>);
$io->close;
# parse configuration syntax into nested internal structure and
# in parallel (through a callback function) create the final
# configuration structure.
my $CF = {
'Project' => {
'User' => {},
'Group' => {}
},
'Repository' => {
'Module' => {}
},
'Logging' => {
'Report' => {}
},
'Environment' => {
'Program' => {},
'Setenv' => {}
}
};
my $cf = &parse_config($t, \&parse_config_callback, $CF);
sub parse_config_callback {
my ($CF, $action, $level, $cf) = @_;
if ($action eq 'CMD' and $cf->[0] =~ m/(Project|Repository|Logging)/) {
my $a;
foreach $a (@{$cf->[1]}) {
$CF->{$1}->{$a->[0]} = $a->[1]
if ($a->[0] ne 'Users' and
$a->[0] ne 'Groups' and
$a->[0] ne 'Modules' and
$a->[0] ne 'Reports');
}
}
elsif ($action eq 'CMD' and $cf->[0] eq 'User') {
$CF->{Project}->{User}->{$cf->[1]} = {
'name' => $cf->[2],
'mail' => $cf->[3]
};
}
elsif ($action eq 'CMD' and $cf->[0] eq 'Group') {
$CF->{Project}->{Group}->{$cf->[1]} = {
'name' => $cf->[2],
'users' => $cf->[3]->[0]
};
}
elsif ($action eq 'CMD' and $cf->[0] eq 'Module') {
$CF->{Repository}->{Module}->{$cf->[1]} = {
'name' => $cf->[2],
'acl' => [],
'log' => [],
};
my $n = \$CF->{Repository}->{Module}->{$cf->[1]};
foreach $a (@{$cf->[3]}) {
if ($a->[0] eq 'Acl') {
push(@{${$n}->{acl}}, [ splice(@{$a}, 1) ]);
}
elsif ($a->[0] eq 'Log') {
push(@{${$n}->{log}}, [ splice(@{$a}, 1) ]);
}
}
}
elsif ($action eq 'CMD' and $cf->[0] eq 'Report') {
$CF->{Logging}->{Report}->{$cf->[1]} = {};
my $n = \$CF->{Logging}->{Report}->{$cf->[1]};
foreach $a (@{$cf->[2]}) {
if ($a->[0] eq 'Content') {
$$n->{Content} = [ splice(@{$a}, 1) ];
}
elsif ($a->[0] =~ m/^(Prefix|Details)$/) {
$$n->{$1} = $a->[1];
}
}
}
elsif ($action eq 'CMD' and $cf->[0] eq 'Program') {
$CF->{Environment}->{Program}->{$cf->[1]} = $cf->[2];
}
elsif ($action eq 'CMD' and $cf->[0] eq 'Setenv') {
$CF->{Environment}->{Setenv}->{$cf->[1]} = $cf->[2];
}
return $cf;
}
return $CF;
}
## _________________________________________________________________
##
## Determine program command line arguments.
##
## This is just a poor man's getopt() variant which provides just the
## functionality we really need. The benefit is that we don't require
## any extra modules.
## _________________________________________________________________
##
sub pa_determine {
my (@ARGV) = @_;
my $PA = {};
$PA->{OPT} = {};
while ($#ARGV >= 0) {
if ($ARGV[0] =~ m|--([a-zA-Z0-9-]+)$|) {
$PA->{OPT}->{$1} = 1;
}
elsif ($ARGV[0] =~ m|--([a-zA-Z0-9-]+)=(.*)$|) {
$PA->{OPT}->{$1} = $2;
}
else {
last;
}
shift(@ARGV);
}
$PA->{ARG} = [ @ARGV ];
return $PA;
}
## _________________________________________________________________
##
## Generalized pattern matching.
##
## In our configuration file we need patterns. But because in 95% of
## all cases, simply shell-style patterns are sufficient (and where
## regular expressions would just complicate the configuration) we
## need some sort of shell-style wildcard matching. For this if the
## pattern still isn't a regular expression, we treat the pattern as
## a shell-style wildcard expression and convert it into a regular
## expression before matching.
## _________________________________________________________________
##
sub pattern_match {
my ($pat, $str) = @_;
my $rv;
# prepare the pattern
if ($pat =~ m|^m(.)(.+)\1$| and $2 !~ m|$1|) {
# pattern is a regular expression,
# so just make sure it is anchored
$pat =~ s|^([^\^])|^$1|;
$pat =~ s|([^\$])$|$1\$|;
}
else {
# pattern is not a full regular expression,
# so treat it like a weaker shell pattern and
# convert it to the regular expression format.
my $braces = 0;
my $pat_orig = $pat;
$pat =~ s@(\\.|\*|.)@
if ($1 eq '?') { '[^/]'; }
elsif ($1 eq '*') { '.*'; }
elsif ($1 eq '{') { $braces++; '(?:'; }
elsif ($1 eq '}') { die "Unmatched `}' in `$pat_orig'" unless $braces--; ')'; }
elsif ($braces > 0 && $1 eq ',') { '|'; }
elsif (index('()', $1) != -1) { $1; }
else { quotemeta(substr($1, -1)); }
@ges;
$pat = "^$pat\$";
}
# perform the matching operation
$rv = ($str =~ m|$pat|s);
return $rv;
}
## _________________________________________________________________
##
## CVS server communication.
##
## We use this instead of calling the regular CVS client commands
## because we not always have a working directory available (which is
## required by most of the CVS client commands), e.g. when an import
## is done locally (no client/server). So we generally use the CVS
## client/server protocol to communicate with a spawned CVS server
## process and act as we would be a regular CVS client. For convenience
## reasons, the communication is encapsulated in a "CVS" class object.
## _________________________________________________________________
##
package CVS;
# communication constructor
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $program = (shift || "cvs");
my $cvsroot = (shift || $ENV{CVSROOT}) or die "unknown CVSROOT";
my $trace = shift || 0;
# spawn a CVS server process and establish a
# bidirectional communication path to it.
my $cvs = {};
$cvs->{cvsroot} = $cvsroot;
$cvs->{trace} = $trace;
STDOUT->flush; # because of fork() behind open2()!
STDERR->flush; # because of fork() behind open2()!
$cvs->{rfd} = new IO::Handle;
$cvs->{wfd} = new IO::Handle;
$cvs->{pid} = IPC::Open2::open2($cvs->{rfd}, $cvs->{wfd}, sprintf("%s -f -Q -n server", &main::qsa($program)))
or die "cannot spawn CVS server process `$program server'";
print STDERR "cvs server: spawned (pid $cvs->{pid})\n" if ($trace);
bless ($cvs, $class);
# perform a little bit of common initial operation.
# lie a little bit about our capabilities, but if we list
# too less responses the CVS server will dislike our request
$cvs->send(
"Valid-responses ok error Valid-requests Checked-in New-entry Checksum " .
"Copy-file Updated Created Update-existing Merged Patched Rcs-diff Mode " .
"Mod-time Removed Remove-entry Set-static-directory Clear-static-directory " .
"Set-sticky Clear-sticky Template Set-checkin-prog Set-update-prog Notified " .
"Module-expansion Wrapper-rcsOption M Mbinary E F");
$cvs->send("UseUnchanged");
$cvs->send("Root $cvsroot");
$cvs->send("noop");
my $status = $cvs->recv;
die "unexpected initial CVS server response `$status'" if ($status ne 'ok');
return $cvs;
}
# communication destructor
sub DESTROY {
my $cvs = shift;
$cvs->close;
undef $cvs;
return;
}
# close communication paths
sub close {
my $cvs = shift;
if (defined($cvs->{rfd})) {
close($cvs->{rfd});
close($cvs->{wfd});
waitpid($cvs->{pid}, 0);
print STDERR "cvs server: closed (pid $cvs->{pid})\n" if ($cvs->{trace});
$cvs->{rfd} = undef;
$cvs->{wfd} = undef;
$cvs->{pid} = undef;
}
}
# send one or more commands to the server
sub send {
my $cvs = shift;
my $data = join("\n", @_);
$data .= "\n" if ($data !~ m|\n$|s);
$cvs->{wfd}->print($data);
if ($cvs->{trace}) {
$data =~ s|^|cvs server: -> |mg;
print STDERR $data;
}
}
# recv one or more commands from the server
sub recv {
my $cvs = shift;
if (wantarray) {
my @lines = ($cvs->{rfd}->getlines || ());
my @nlines = ();
foreach my $line (@lines) {
print STDERR "cvs server: <- $line" if ($cvs->{trace});
$line =~ s|\n$||;
push(@nlines, $line);
}
return @nlines;
}
else {
my $line = ($cvs->{rfd}->getline || "");
print STDERR "cvs server: <- $line" if ($cvs->{trace});
$line =~ s|\n$||;
return $line;
}
}
# convenience wrapper: receive a response
sub result {
my $cvs = shift;
my $line;
my $res = '';
while (($line = $cvs->recv) =~ m/^(M|E) (.*)$/s) {
$res .= "$2\n" if ($1 eq 'M');
}
if (wantarray) {
return ($res, $line);
}
else {
return $res;
}
}
# convenience wrapper: provide a file entry
sub entry {
my $cvs = shift;
my @files = @_;
foreach my $file (@files) {
$cvs->send("Entry /$file////");
$cvs->send("Unchanged $file");
}
}
# convenience wrapper: provide one or more global options
sub global_options {
my $cvs = shift;
my @opts = @_;
foreach my $opt (@opts) {
$cvs->send("Global_option $opt");
}
}
# convenience wrapper: provide one or more arguments
sub arguments {
my $cvs = shift;
my @args = @_;
foreach my $arg (@args) {
$cvs->send("Argument $arg");
}
}
# convenience wrapper: configure a directory
sub directory {
my $cvs = shift;
my ($dir) = @_;
$cvs->send("Directory .\n".$cvs->{cvsroot}."/".$dir);
$cvs->send("Static-directory");
}
package main;
## _________________________________________________________________
##
## Send out an Electronic Mail.
##
## Again, there are nice Perl modules which provide mail creation and
## delivery services, but we both want to be maximum stand-alone and
## use a KISS solution. So we assume an existing Sendmail program
## (which is 99% safe, because even non-Sendmail MTAs like Qmail and
## Postfix provide a Sendmail compatibility frontend!) and deliver the
## mail directly to it.
## _________________________________________________________________
##
package Sendmail;
# communication constructor
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $RT = shift;
my $toaddr = shift;
my $trace = shift || 0;
my $sm = {};
bless ($sm, $class);
$sm->{trace} = $trace;
$sm->{fd} = new IO::Handle;
my $cmd = sprintf("%s -oi -oem %s", &main::qsa($RT->{sendmail}), &main::qsa($toaddr));
open($sm->{fd}, "|$cmd");
print "sendmail: spawned \"$cmd\"\n" if ($sm->{trace});
$sm->{header} =
"From: \"".$RT->{username}."\" <".$RT->{usermail}.">\n" .
"To: $toaddr\n" .
"User-Agent: OSSP shiela ".$RT->{vers}." [CVS ".$RT->{cvsvers}.($RT->{cvsrse} ? "+RSE" : "")."]\n" .
"Precedence: bulk\n" .
"Mime-Version: 1.0\n" .
"Content-Type: text/plain; charset=iso-8859-1\n" .
"Content-Transfer-Encoding: 8bit\n";
$sm->{body} = '';
return $sm;
}
# communication destructor
sub DESTROY {
my $sm = shift;
$sm->close;
undef $sm;
return;
}
# close communication
sub close {
my $sm = shift;
return if (not defined($sm->{body}));
$sm->{body} =~ s|\n$||s;
$sm->{body} .= "\n";
if ($sm->{header} !~ m|^Lines: |m) {
my $length = length($sm->{body});
my @lines = split(/\n/, $sm->{body});
my $lines = $#lines+1;
$sm->{header} .= sprintf("Lines: %d\n", $lines);
}
my $mail = $sm->{header} . "\n" . $sm->{body};
$sm->{fd}->print($mail);
if ($sm->{trace}) {
$mail =~ s|^|sendmail: -> |mg;
print STDERR $mail;
}
$sm->{fd}->close;
undef $sm->{body};
print STDERR "sendmail: closed connection\n" if ($sm->{trace});
}
# set a particular mail header
sub header {
my $sm = shift;
my ($name, $value) = @_;
if ($sm->{header} =~ m|^$name: .*?$|m) {
$value =~ s|^\s+||s;
$value =~ s|\s+$||s;
$sm->{header} =~ s|^$name: .*?$|$name: $value|m;
}
else {
$sm->{header} .= "$name: $value\n";
}
}
# set the mail body
sub body {
my $sm = shift;
my ($body) = @_;
$sm->{body} .= $body;
}
package main;
## _________________________________________________________________
##
## Common file operations.
##
## This is nothing more than a convenience function for
## the common file operations we have do.
## _________________________________________________________________
##
sub do_file {
my ($op, $file, $prefix, @lines) = @_;
# append to or override a file with lines from an array
if ($op eq 'append' or $op eq 'write') {
my $io = new IO::File ($op eq 'append' ? ">>$file" : ">$file")
or die "unable to open `$file' for operation `$op'";
foreach my $line (@lines) {
$line =~ s|\n+$||s;
$io->print($prefix . $line . "\n");
}
$io->close;
}
# read a file line by line into an array
elsif ($op eq 'read') {
my @text = ();
my $io = new IO::File "<$file"
or die "unable to open `$file' for $op";
while (<$io>) {
s|\n$||s;
push(@text, $prefix . $_);
}
$io->close;
return @text;
}
}
# quote shell argument
sub qsa {
my ($arg) = @_;
# remove NUL characters at all because
# - sh: removes silenty (strange)
# - bash: removes silenty (strange)
# - ksh: complains and aborts (problem)
# - zsh: keeps as-is (ok)
# all(!) other characters in the range 0x00-0xff are safe to be
# passed through the shell when single quoted as explicit tests
# with all(!) characters under sh, bash, ksh and zsh showed.
$arg =~ s/\x00//sg;
# single quote argument by
# 1. escape "single quote" character by
# - temporarily ending single quotation
# - double quoting "single quote" character
# - restarting single quotation
# 2. embedding remaining string into single quotes
$arg =~ s/'/'"'"'/sg;
$arg = "'$arg'";
return $arg;
}
## _________________________________________________________________
##
## History database support.
##
## The history database is a logfile to where the commit history is
## written by us. In short, in summarizes a particular commit and this
## way can be used later to find out the details of a commit again.
## _________________________________________________________________
##
sub history_save {
my ($PA, $RT, $CF, $IN) = @_;
my $O = '';
foreach my $file (keys(%{$IN->{file}})) {
my $e = $IN->{file}->{$file};
$O .= $IN->{handle};
$O .= "|".$RT->{userid};
$O .= "|".$file;
$O .= "|".$e->{oldrev};
$O .= "|".$e->{newrev};
$O .= "|".$e->{branch};
$O .= "|".$e->{op};
$O .= "|".$e->{keysub};
$O .= "|".$e->{date};
$O .= "|".$e->{delta};
$O .= "\n";
}
my $io = new IO::File ">>".$RT->{historydb}
or die "cannot store information to history db `$RT->{historydb}'";
$io->print($O);
$io->close;
return;
}
sub history_load {
my ($PA, $RT, $CF, $handle) = @_;
## STILL MISSING, BECAUSE CURRENTLY NOT USED AT ALL. ##
## WOULD HAVE TO RE-DETERMINE DIFF AND LOG INFORMATION. ##
return;
}
## _________________________________________________________________
##
## Provide Access Control.
##
## This function is called from many hooks to check access control.
## Whether access is allowed or denied depends entirely on the
## particular ACL configuration found in the configuration file.
## _________________________________________________________________
##
sub do_access_control {
my ($PA, $RT, $CF, @files) = @_;
my @denyfiles = ();
my $user = $RT->{userid};
my @groups = split(/,/, $RT->{usergroups});
my $file;
foreach $file (@files) {
$file =~ m|^([^/]+)/(.*):([^:]+)$|
or die "invalid file specification `$file' for access control";
my ($d, $f, $t) = ($1, $2, $3);
my $allow = 0;
foreach my $module (keys(%{$CF->{Repository}->{Module}})) {
if ($module eq $d) {
my $m = $CF->{Repository}->{Module}->{$module};
my $acl = $m->{acl};
foreach my $a (@{$acl}) {
my ($file, @require) = @{$a};
my $tag = 'HEAD';
if ($file =~ m|^(.+):([^:]+)$|) {
$file = $1;
$tag = $2;
}
if (($t eq '*' or &pattern_match($tag, $t))
and &pattern_match($file, $f)) {
foreach my $r (@require) {
my $not = 0;
if ($r =~ m|^!(.+)$|) {
$not = 1;
$r = $1;
}
my ($u, $g);
if ($r =~ m|^(.+):(.+)$|) {
($u, $g) = ($1, $2);
}
else {
($u, $g) = ($r, '*');
}
if ( ( not $not
and ($u eq '*' or $u eq $user)
and ($g eq '*' or grep(m/^$g$/, @groups)))
or ( $not
and ($u ne '*' and $u ne $user)
and ($g ne '*' and not grep(m/^$g$/, @groups)))) {
$allow = 1;
last;
}
}
last;
}
}
last;
}
}
if (not $allow) {
push(@denyfiles, $file);
}
}
return @denyfiles;
}
## _________________________________________________________________
##
## Compress a log message.
##
## This compresses a CVS log message by removing unnecessary
## whitespace, empty fields and CVS lines.
## _________________________________________________________________
##
sub compress_message {
my ($msg) = @_;
# make sure CVS: lines do not harm anyone
$msg =~ s/^CVS:.*?$//mg;
# remove common empty fields (FIXME: PERHAPS TOO HARD-CODED)
$msg =~ s/^(PR|Submitted by|Reviewed by|Approved by|Obtained from):\s*$//img;
# remove trailing whitespaces
$msg =~ s/[ \t]+$//mg;
# make optically empty lines really empty for next step
$msg =~ s/^[ \t]+$//mg;
# remove unnecessary empty lines
$msg =~ s/\n{3,}/\n\n/sg;
$msg =~ s/^\n+//s;
$msg =~ s/\n{2,}$/\n/s;
$msg =~ s/([^\n])$/$1\n/s;
return $msg;
}
## _________________________________________________________________
##
## Wrap a single-line log message.
##
## This line-wraps a single-line log message into a multi-line log
## message.
## _________________________________________________________________
##
sub wrap_message {
my ($columns, $text) = @_;
my $r = "";
my $nl = "";
my $left = "";
pos($text) = 0;
while ($text !~ m/\G\s*\Z/gc) {
if ($text =~ /\G([^\n]{0,$columns})(\s|\z)/xmgc) {
$r .= $nl . $1;
$left = $2;
} elsif ($text =~ /\G([^\n]*?)(\s|\z)/xmgc) {
$r .= $nl . $1;
$left = $2;
}
$nl = "\n";
}
$r .= $left;
$r .= substr($text, pos($text), length($text)-pos($text))
if (pos($text) ne length($text));
return $r;
}
## _________________________________________________________________
##
## Fit text into particular columns.
##
## This makes sure a text fits into a particular columns by
## truncating (and extending with "$") if necessary.
## _________________________________________________________________
##
sub fit_columns {
my ($col, $txt) = @_;
if (length($txt) > $col) {
$txt = substr($txt, 0, $col-1) . '$';
}
return $txt;
}
## _________________________________________________________________
##
## TAGINFO HOOK
##
## We hook into CVS via `taginfo' to check whether user is allowed to
## perform tag operation. Additionally we also could check whether the
## specified tag is a valid tag name.
##
## We are called by CVS with four or more arguments: the tagname, the
## operation (`add' for `cvs tag', `mov' for `cvs tag -F', and `del'
## for `cvs tag -d'), the repository path and one or more file and
## revisions pairs.
## _________________________________________________________________
##
sub hook_taginfo {
my ($PA, $RT, $CF) = @_;
my $rv = 0;
# take the arguments
my ($tagname, $tagop, $cvsdir, %cvsfiles) = @{$PA->{ARG}};
# strip absolute prefix
$cvsdir =~ s|^$RT->{cvsroot}/?||;
my $cvsdirphysical = Cwd::abs_path($RT->{cvsroot});
$cvsdir =~ s|^$cvsdirphysical/?||;
# provide access control
my @paths = ();
foreach my $cvsfile (keys(%cvsfiles)) {
push(@paths, "$cvsdir/$cvsfile:*");
}
my @denyfiles = &do_access_control($PA, $RT, $CF, @paths);
if ($#denyfiles > -1) {
# inform user
print "cvs tag: Access Denied - Insufficient Karma!\n";
print "cvs tag: Tagging access for the following file(s) was denied:\n";
foreach my $file (@denyfiles) {
print "cvs tag: `$file'\n";
}
print "cvs tag: Contact <".$CF->{Repository}->{Contact}."> for details.\n";
# inform administrator
my $subject = "[CVS] ".$CF->{Project}->{Tag}.": ACCESS DENIED: ".$RT->{username};
my $message = '';
$message .= "ATTENTION: ACCESS DENIED\n";
$message .= "\n";
$message .= $CF->{Repository}->{Name}. " denied TAGGING access for\n";
$message .= "user ".$RT->{username}." <".$RT->{usermail}."> on files:\n";
$message .= "\n";
foreach my $file (@denyfiles) {
$message .= " o $file\n";
}
my $sm = new Sendmail ($RT, $CF->{Repository}->{Contact});
$sm->header('Subject', $subject);
$sm->body($message);
$sm->close;
$rv = 1;
}
return $rv;
}
## _________________________________________________________________
##
## ADMININFO HOOK
##
## We hook into CVS via `admininfo' to check whether user is allowed to
## perform admin operations.
##
## We are called by CVS with two or more arguments: the (absolute)
## repository directory, followed by one or more names of files in this
## directory on which the admin operation should be performed.
## _________________________________________________________________
##
sub hook_admininfo {
my ($PA, $RT, $CF) = @_;
my $rv = 0;
# take the arguments
my ($cvsdir, @cvsfiles) = @{$PA->{ARG}};
$cvsdir =~ s|^$RT->{cvsroot}/?||;
# provide access control
my @paths = ();
foreach my $cvsfile (@cvsfiles) {
push(@paths, "$cvsdir/$cvsfile:*");
}
my @denyfiles = &do_access_control($PA, $RT, $CF, @paths);
if ($#denyfiles > -1) {
# inform user
print "cvs admin: Access Denied - Insufficient Karma!\n";
print "cvs admin: Admin access for the following file(s) was denied:\n";
foreach my $file (@denyfiles) {
print "cvs admin: `$file'\n";
}
print "cvs admin: Contact <".$CF->{Repository}->{Contact}."> for details.\n";
# inform administrator
my $subject = "[CVS] ".$CF->{Project}->{Tag}.": ACCESS DENIED: ".$RT->{username};
my $message = '';
$message .= "ATTENTION: ACCESS DENIED\n";
$message .= "\n";
$message .= $CF->{Repository}->{Name}. " denied ADMIN access for\n";
$message .= "user ".$RT->{username}." <".$RT->{usermail}."> on files:\n";
$message .= "\n";
foreach my $file (@denyfiles) {
$message .= " o $file\n";
}
my $sm = new Sendmail ($RT, $CF->{Repository}->{Contact});
$sm->header('Subject', $subject);
$sm->body($message);
$sm->close;
$rv = 1;
}
return $rv;
}
## _________________________________________________________________
##
## IMPORTINFO HOOK
##
## We hook into CVS via `importinfo' to check whether user is allowed to
## perform import operations.
##
## We are called by CVS with one argument: the (absolute) repository
## directory into which the import operation should be performed.
## _________________________________________________________________
##
sub hook_importinfo {
my ($PA, $RT, $CF) = @_;
my $rv = 0;
# take the arguments
my ($cvsbranch, $cvsdir, @cvsfiles) = @{$PA->{ARG}};
$cvsdir =~ s|^$RT->{cvsroot}/?||;
# provide access control
my @paths = ();
foreach my $cvsfile (@cvsfiles) {
push(@paths, "$cvsdir/$cvsfile:$cvsbranch");
}
my @denyfiles = &do_access_control($PA, $RT, $CF, @paths);
if ($#denyfiles > -1) {
# inform user
print "cvs import: Access Denied - Insufficient Karma!\n";
print "cvs import: Import access for the following files was denied:\n";
foreach my $file (@denyfiles) {
print "cvs import: `$file'\n";
}
print "cvs import: Contact <".$CF->{Repository}->{Contact}."> for details.\n";
# inform administrator
my $subject = "[CVS] ".$CF->{Project}->{Tag}.": ACCESS DENIED: ".$RT->{username};
my $message = '';
$message .= "ATTENTION: ACCESS DENIED\n";
$message .= "\n";
$message .= $CF->{Repository}->{Name}. " denied IMPORT access for\n";
$message .= "user ".$RT->{username}." <".$RT->{usermail}."> on files:\n";
$message .= "\n";
foreach my $file (@denyfiles) {
$message .= " o $file\n";
}
my $sm = new Sendmail ($RT, $CF->{Repository}->{Contact});
$sm->header('Subject', $subject);
$sm->body($message);
$sm->close;
$rv = 1;
}
return $rv;
}
## _________________________________________________________________
##
## COMMITINFO HOOK
##
## We hook into CVS via `commitinfo' to provide repository access
## control ("is user allowed to commit") and to provide preparations
## for logging in multi-directory commits. The general problem we have
## is just that CVS does not provide a single hook where the complete
## commit message is available. Instead for a single multi-directory
## commit, we are called multiple times. So in the `loginfo' hook below
## we have to accumlate all information and do the actual logging at
## the last call only. For this we need to know which call is the last
## call. So we use this `commitinfo' hook to determine the last call by
## remembering the directory of the multi-directory commit.
##
## We are called by CVS with the absolute path (prefixed with $CVSROOT)
## to the CVS directory as the first argument, followed by one or more
## names of files which are comitted in this directory.
## _________________________________________________________________
##
sub hook_commitinfo {
my ($PA, $RT, $CF) = @_;
my $rv = 0;
# take the arguments and make the directory relative
my ($cvsdir, @cvsfiles) = @{$PA->{ARG}};
$cvsdir =~ s|^$RT->{cvsroot}/?||;
# annotate the files with the branch they stay on
my $cvsstat = '';
if (not $RT->{useserver}) {
my $io = new IO::File sprintf("%s -f -Q -n status %s|", &qsa($RT->{cvs}), join(' ', map { &qsa($_) } @cvsfiles))
or die "unable to open CVS command pipe for reading";
$cvsstat .= $_ while (<$io>);
$io->close;
}
else {
my $cvs = new CVS ($RT->{cvs}, $RT->{cvsroot});
$cvs->global_options("-Q", "-n");
$cvs->directory($cvsdir);
foreach my $cvsfile (@cvsfiles) {
$cvs->entry($cvsfile);
$cvs->arguments($cvsfile);
}
$cvs->send("status");
$cvsstat .= scalar $cvs->result;
$cvs->close;
}
my @newfiles = ();
foreach my $cvsfile (@cvsfiles) {
my $branch = 'HEAD';
my $cvsfile_quoted = quotemeta($cvsfile);
if ($cvsstat =~ m|===+\nFile:\s+${cvsfile_quoted}.+?Sticky Tag:\s+(\S+)|s) {
$branch = $1;
$branch = 'HEAD' if ($branch eq '(none)');
}
$cvsfile .= ":$branch";
push(@newfiles, $cvsfile);
}
@cvsfiles = @newfiles;
# provide access control
my @paths = ();
foreach my $cvsfile (@cvsfiles) {
push(@paths, "$cvsdir/$cvsfile");
}
my @denyfiles = &do_access_control($PA, $RT, $CF, @paths);
if ($#denyfiles > -1) {
# inform user
print "cvs commit: Access Denied - Insufficient Karma!\n";
print "cvs commit: Commit access for the following file(s) was denied:\n";
foreach my $file (@denyfiles) {
print "cvs commit: `$file'\n";
}
print "cvs commit: Contact <".$CF->{Repository}->{Contact}."> for details.\n";
# inform administrator
my $subject = "[CVS] ".$CF->{Project}->{Tag}.": ACCESS DENIED: ".$RT->{username};
my $message = '';
$message .= "ATTENTION: ACCESS DENIED\n";
$message .= "\n";
$message .= $CF->{Repository}->{Name}. " denied COMMIT access for\n";
$message .= "user ".$RT->{username}." <".$RT->{usermail}."> on files:\n";
$message .= "\n";
foreach my $file (@denyfiles) {
$message .= " o $file\n";
}
my $sm = new Sendmail ($RT, $CF->{Repository}->{Contact});
$sm->header('Subject', $subject);
$sm->body($message);
$sm->close;
$rv = 1;
}
# remember the (last) directory
&do_file('write', $RT->{tmpfile}.".lastdir", '', $cvsdir);
return $rv;
}
## _________________________________________________________________
##
## VERIFYMSG HOOK
##
## We hook into CVS via `verifymsg' to post-process log messages. The
## intention is to sanitise the results of what the user may have
## `done' while editing the commit log message. If CVS is an anchient
## version, this check is advisory only. If CVS is at least version
## 1.11.2, the log message can be changed and CVS actually reads back
## the contents so that this script can actually make changes.
##
## We are called by CVS with a single argument: the path to the log
## message file.
## _________________________________________________________________
##
sub hook_verifymsg {
my ($PA, $RT, $CF) = @_;
my $rv = 0;
# suck in the log message
my $logfile = $PA->{ARG}->[0];
my $io = new IO::File "<$logfile"
or die "cannot open message file `$logfile' for reading";
my $data = '';
$data .= $_ while (<$io>);
$io->close;
# filter the log message
$data = &compress_message($data);
# update the log message
# (CVS with RSE patches reads in this again, stock CVS ignores it)
$io = new IO::File ">$logfile"
or die "cannot open message file `$logfile' for writing";
$io->print($data);
$io->close;
# nuke possibly existing editor backup files
unlink("${logfile}~");
unlink("${logfile}.bak");
return $rv;
}
## _________________________________________________________________
##
## LOGINFO HOOK
##
## We hook into CVS via `loginfo' to provide accumulated commit mails
## and logfile entries. For this we depend on the `commitinfo' hook,
## which has to determine the last directory. Only this way we can
## decide when to accumulate and when to perform the logging.
##
## We are called by CVS with a single argument which contains the
## ($CVSROOT relative) directory followed by the summary arguments
## about the committed files in this directory - all seperated by
## whitespace. The summary arguments are comma-seperated strings
## of the form <op>,<file>,
## _________________________________________________________________
##
sub hook_loginfo {
my ($PA, $RT, $CF) = @_;
my $rv = 0;
# collect the information of this particular call
my $cvsdir = &hook_loginfo_collect($PA, $RT, $CF);
# determine whether we are the last call
my $islastcall = ($RT->{cvsop} eq 'import' ? 1 : 0);
if (-f "$RT->{tmpfile}.lastdir") {
my ($lastdir) = &do_file('read', "$RT->{tmpfile}.lastdir", '');
$islastcall = 1 if ($lastdir eq $cvsdir);
}
# stop processing if we are still not the last call
exit(0) if (not $islastcall);
# cleanup
unlink("$RT->{tmpfile}.lastdir");
# accumulate the gathered information
my $IN = &hook_loginfo_accumulate($PA, $RT, $CF);
# DEBUGGING
if ($PA->{OPT}->{debug}) {
print STDOUT "| \$PA =\n" . Data::Dumper::Dumper($PA);
print STDOUT "| \$CF =\n" . Data::Dumper::Dumper($CF);
print STDOUT "| \$RT =\n" . Data::Dumper::Dumper($RT);
print STDOUT "| \$IN =\n" . Data::Dumper::Dumper($IN);
}
# remember the information (partly) in our history database
# for use by foreign application calls.
&history_save($PA, $RT, $CF, $IN);
# process the collected information
&hook_loginfo_process($PA, $RT, $CF, $IN);
return $rv;
}
# collect the information
sub hook_loginfo_collect {
my ($PA, $RT, $CF) = @_;
# take the arguments
my $cvsdir = $PA->{ARG}->[0];
my @cvsinfo = ();
my $k = ($RT->{cvsrse} ? 5 : 3);
for (my $i = 1; $i <= $#{$PA->{ARG}}; $i += $k) {
push(@cvsinfo, join(",", @{$PA->{ARG}}[$i..$i+$k-1]));
}
# suck in the standard log information which CVS provides
my $cvsmsg = '';
$cvsmsg .= $_ while (<STDIN>);
# usually the operation is a regular commit for files
$RT->{cvsop} = 'commit-file';
# handle special invocation under `cvs add <dir>'
if (defined($PA->{ARG}->[1]) and $PA->{ARG}->[1] eq '- New directory') { # see CVS' src/add.c
# Hmmm... we always just deal with files in OSSP shiela, so there
# is no obvious and consistent way to deal now with only a
# plain directory. And there is also no log message provided
# by CVS. Additionally, creating empty directories in the CVS
# repository doesn't harm anyone. A regular cronjob is usually
# used to get rid of them anyway. So we decided to not log
# `cvs add <dir>' commands at all. We are early in processing
# it is acceptable to just exit OSSP shiela immediately.
exit(0);
}
# handle special invocation under `cvs import <dir>'. Here
# CVS only calls us inside the loginfo hook and never in the
# commitinfo hook before. Additionally CVS doesn't provide us with
# the %{sVvto} information :(
if (defined($PA->{ARG}->[1]) and $PA->{ARG}->[1] eq '- Imported sources') { # see CVS' src/import.c
# I = ignored
# L = link (=error),
# N = new file
# U = updated w/o conflict
# C = updated w/ conflict
# T = touched/tagged only (RSE extension)
$RT->{cvsop} = 'import';
@cvsinfo = ();
$cvsmsg =~ s|Status:\n+Vendor Tag:\s+(\S+).*?\nRelease Tags:\s+(.+?)\s*\n(.+)$||s;
my ($It, $IT, $list) = ($1, $2, $3);
$cvsmsg .= sprintf("[Release Tag%s: %s]\n", ($IT =~ m|\s| ? 's' : ''), $IT);
while ($list =~ s|\n([ILNUCT])\s+(\S+)||s) {
my ($Io, $Is) = ($1, $2);
# canonicalize information
$Is =~ s|^$cvsdir/?||;
if ($Io eq 'I' or $Io eq 'L') { next; }
elsif ($Io eq 'N') { $Io = 'A'; }
elsif ($Io eq 'U' or $Io eq 'C') { $Io = 'M'; }
elsif ($Io eq 'T') { $Io = 'T'; }
# determine revisions
my $rcslog = '';
if (not $RT->{useserver}) {
if (not -d './CVS') {
# Oooopps, the user is doing a local import (no
# client server usage), or else CVS would have
# provided a temporary working area on the server
# side for us. Now we can only hope the CVS version
# is at least capable of server communications...
print STDERR "cvs import: Warning: OSSP shiela cannot process local imports\n";
print STDERR "cvs import: if the CVS version isn't at least capable of\n";
print STDERR "cvs import: server communications (which we're forced to use).\n";
print STDERR "cvs import: Ignoring this operation - don't expect log messages!\n";
exit(0);
}
my $io = new IO::File sprintf("%s -f -Q -n log -r%s %s|", &qsa($RT->{cvs}), &qsa($It), &qsa($Is))
or die "unable to open CVS command pipe for reading";
$rcslog = $_ while (<$io>);
$io->close;
}
else {
my $cvs = new CVS ($RT->{cvs}, $RT->{cvsroot});
my ($subdir, $file) = ($cvsdir, $Is);
if ($file =~ m|^(.+)/([^/]+)$|) {
($subdir, $file) = ($subdir."/".$1, $2);
}
$cvs->directory($subdir);
$cvs->entry($file);
$cvs->arguments("-r$It", $file);
$cvs->send("log");
$rcslog = scalar $cvs->result;
$cvs->close;
}
my ($IV, $Iv) = ($It, $It);
if ($Io eq 'A') {
if ($rcslog =~ m|^.*?\nrevision\s+([0-9.]+)|s) {
($IV, $Iv) = ('NONE', $1);
}
}
elsif ($Io eq 'M') {
if ($rcslog =~ m|^.*?\nrevision\s+([0-9.]+).*?\nrevision\s+([0-9.]+)|s) {
($IV, $Iv) = ($2, $1);
}
}
elsif ($Io eq 'T') {
($IV, $Iv) = ('NONE', 'NONE');
}
my $entry = "$Is,$IV,$Iv,$It,$Io";
push(@cvsinfo, $entry);
}
}
# parse out log description from provided CVS log information and
# strip leading and trailing blank lines from the log message.
# Also compress multiple blank lines in the body of the message
# down to a single blank line.
my $cvslog = $cvsmsg;
$cvslog =~ s|.*Log Message:\s*\n(.+)$|$1|s;
$cvslog = &compress_message($cvslog);
$cvslog = "*** empty log message ***" if ($cvslog eq '');
&do_file('write', "$RT->{tmpfile}.log", '', $cvslog);
# if we are using a stock CVS version, we have to determine
# extra information (which an RSE CVS version would provide).
if ( ( ( defined($cvsinfo[0])
and $cvsinfo[0] =~ m|^([^,]+),([^,]+),([^,]+)$|)
or not $RT->{cvsrse} )
and not $RT->{cvsop} eq 'import' ) {
# parse CVS commit information
my $tag = 'HEAD';
my $line;
my $state = '-';
my $files = {};
foreach $line (split(/\n/, $cvsmsg)) {
$line =~ s/[ \t\n]+$//;
if ($line =~ /^Revision\/Branch:\s*(.+)$/) {
$tag = $1;
next;
}
if ($line =~ m/^[ \t]+Tag:\s*(.+)$/) {
$tag = $1;
next;
}
if ($line =~ m/^[ \t]+No tag$/) {
$tag = 'HEAD';
next;
}
if ($line =~ m/^Added Files/) { $state = 'A'; next; }
if ($line =~ m/^Modified Files/) { $state = 'M'; next; }
if ($line =~ m/^Removed Files/) { $state = 'R'; next; }
if ($line =~ m/^Log Message/) { $state = '-'; next; }
if ($state =~ m/^[AMR]$/) {
my $file;
foreach $file (split(/\s+/, $line)) {
$files->{$file} = "$tag,$state";
}
}
}
# extend the CVS summary of each file
my @newinfo = ();
foreach my $info (@cvsinfo) {
$info =~ m|^([^,]+),([^,]+),([^,]+)|
or die "invalid loginfo argument `$info' while extending stock CVS information";
my ($Is, $IV, $Iv) = ($1, $2, $3);
my $It = '';
my $Io = '';
if ($files->{$Is} =~ m|^([^,]*),([^,]*)$|) {
($It, $Io) = ($1, $2);
}
$info = "$Is,$IV,$Iv,$It,$Io";
push(@newinfo, $info);
}
@cvsinfo = @newinfo;
}
# extend summary information
my $cvsdiff = '';
my @newinfo = ();
foreach my $info (@cvsinfo) {
$info =~ m|^([^,]+),([^,]+),([^,]+),([^,]*),([^,]*)$|
or die "invalid loginfo argument `$info' while extending summary information";
my ($Is, $IV, $Iv, $It, $Io) = ($1, $2, $3, $4, $5);
# fix branch/tag and accumulate information
$It = 'HEAD' if ($It eq '');
# manually determine next revision number for removed files
# by fetching the whole revision log and extracting the next
# number.
if ($Io eq 'R' and $Iv eq 'NONE') {
my $rcslog ='';
if (not $RT->{useserver}) {
my $io = new IO::File sprintf("%s -f -Q -n log %s|", &qsa($RT->{cvs}), &qsa($Is))
or die "unable to open CVS command pipe for reading";
$rcslog .= $_ while (<$io>);
$io->close;
}
else {
my $cvs = new CVS ($RT->{cvs}, $RT->{cvsroot});
$cvs->directory($cvsdir);
$cvs->entry($Is);
$cvs->arguments($Is);
$cvs->send("log");
$rcslog = scalar $cvs->result;
$cvs->close;
}
if ($rcslog =~ m|^head:\s+([\d.]+)|m) {
$Iv = $1;
}
}
# read file log entry
my $rcslog = '';
if ($Io eq 'A' or $Io eq 'M' or $Io eq 'R') {
if (not $RT->{useserver}) {
my $io = new IO::File sprintf("%s -f -Q -n log -r%s %s|", &qsa($RT->{cvs}), &qsa($Iv), &qsa($Is))
or die "unable to open CVS command pipe for reading";
$rcslog .= $_ while (<$io>);
$io->close;
}
else {
my $cvs = new CVS ($RT->{cvs}, $RT->{cvsroot});
$cvs->directory($cvsdir);
$cvs->entry($Is);
$cvs->arguments("-r$Iv", $Is);
$cvs->send("log");
$rcslog = scalar $cvs->result;
$cvs->close;
}
}
# determine keyword substitutions
my $Ik = 'kv';
if ($rcslog =~ m|keyword\s+substitution:\s+(\S+)|s) {
$Ik = $1;
}
# determine commit date
my $ID = 0;
if ($rcslog =~ m|\ndate:\s+(\d\d\d\d)[/-](\d\d)[/-](\d\d)\s+(\d\d):(\d\d):(\d\d)(?:\s+[+-]?\d+)?;|s) {
my ($Y,$M,$D,$h,$m,$s) = ($1,$2,$3,$4,$5,$6);
$ID = POSIX::mktime($s, $m, $h, $D, $M-1, $Y-1900);
}
# determine change delta
my $Id = '+0/-0';
if ($Ik eq 'b' or -B $Is) {
$Id = 'BLOB';
}
else {
if ($Io eq 'A') {
# determined later below when we have to read in the
# whole content anyway in order to create the difference.
}
elsif ($Io eq 'M') {
if ($rcslog =~ m|\ndate:.*lines:\s*([\d \t+-]+)|s) {
$Id = $1;
$Id =~ s|\s+|/|g;
}
}
elsif ($Io eq 'R') {
my $cvs = new CVS ($RT->{cvs}, $RT->{cvsroot});
$cvs->directory($cvsdir);
$cvs->entry($Is);
$cvs->arguments("-p", "-r$IV", $Is);
$cvs->send("update");
my $f = scalar $cvs->result;
$cvs->close;
my $l = 0;
$f =~ s|\n|$l++|sge;
$Id = sprintf("+%d/-%d", 0, $l);
}
}
# determine change difference summary
if ($Io eq 'A') {
##
## ADDED FILE
##
# retrieve whole file contents
unlink("$RT->{tmpfile}.all");
my $io = new IO::File ">$RT->{tmpfile}.all"
or die "unable to open temporary file $RT->{tmpfile}.all for writing";
my $l = 0;
if (not $RT->{useserver}) {
my $cvs = new IO::File sprintf("%s -f -Q -n update -p -r%s %s|", &qsa($RT->{cvs}), &qsa($Iv), &qsa($Is))
or die "unable to open CVS command pipe for reading";
while (<$cvs>) {
$io->print($_);
$l++;
}
$cvs->close;
}
else {
my $cvs = new CVS ($RT->{cvs}, $RT->{cvsroot});
$cvs->directory($cvsdir);
$cvs->entry($Is);
$cvs->arguments("-p", "-r$Iv", $Is);
$cvs->send("update");
my $r = scalar $cvs->result;
$io->print($r);
$cvs->close;
if ($r ne '') {
$l++ while ($r =~ m/^/mg);
}
}
$Id = sprintf("+%d/-%d", $l, 0) if (not ($Ik eq 'b' or -B $Is));
$io->close;
if ($Ik eq 'b' or -B $Is) {
# generate binary change patch script
if ($RT->{xdelta} and $RT->{uuencode}) {
$cvsdiff .=
"<shiela:patch $cvsdir/$Is>\n" .
"(cd $cvsdir && \\\n" .
" uudecode <<'@@ .' && \\\n" .
" xdelta patch $Is.xdelta /dev/null $Is && \\\n" .
" rm -f $Is.xdelta)\n" .
"Index: $cvsdir/$Is\n" .
("=" x 76) . "\n";
unlink("$RT->{tmpfile}.null");
unlink("$RT->{tmpfile}.xdelta");
my $io = new IO::File ">$RT->{tmpfile}.null"
or die "unable to open temporary file $RT->{tmpfile}.null for writing";
$io->close;
system(sprintf("%s delta %s.null %s.all %s.xdelta >/dev/null 2>&1",
&qsa($RT->{xdelta}), &qsa($RT->{tmpfile}), &qsa($RT->{tmpfile}), &qsa($RT->{tmpfile})));
$io = new IO::File sprintf("%s %s.xdelta %s.xdelta|", &qsa($RT->{uuencode}), &qsa($RT->{tmpfile}), &qsa($Is))
or die "unable to open uuencode command pipe for reading";
$cvsdiff .= $_ while (<$io>);
$io->close;
$cvsdiff .= "@@ .\n";
$cvsdiff .= "</shiela:patch>\n";
unlink("$RT->{tmpfile}.null");
unlink("$RT->{tmpfile}.xdelta");
}
}
else {
# generate textual change patch script
if ($RT->{diff}) {
$cvsdiff .=
"<shiela:patch $cvsdir/$Is>\n" .
"patch -p0 <<'@@ .'\n" .
"Index: $cvsdir/$Is\n" .
("=" x 76) . "\n" .
"\$ cvs diff -u -r0 -r$Iv $Is\n";
my $diff = '';
my $io = new IO::File sprintf("%s -u /dev/null %s.all|", &qsa($RT->{diff}), &qsa($RT->{tmpfile}))
or die "unable to open CVS command pipe for reading";
$diff .= $_ while (<$io>);
$io->close;
my $Is_quoted = quotemeta("$RT->{tmpfile}.all");
$diff =~ s|^(\+\+\+\s+)$Is_quoted|$1$Is|m;
$cvsdiff .= $diff;
$cvsdiff .= "@@ .\n";
$cvsdiff .= "</shiela:patch>\n";
}
}
# cleanup
unlink("$RT->{tmpfile}.all");
}
elsif ($Io eq 'M') {
##
## MODIFIED FILE
##
if ($Ik eq 'b' or -B $Is) {
# generate binary change patch script
if ($RT->{xdelta} and $RT->{uuencode}) {
# retrieve whole file contents (old revision)
unlink("$RT->{tmpfile}.old");
my $io = new IO::File ">$RT->{tmpfile}.old"
or die "unable to open temporary file $RT->{tmpfile}.old for writing";
if (not $RT->{useserver}) {
my $cvs = new IO::File sprintf("%s -f -Q -n update -p -r%s %s|", &qsa($RT->{cvs}), &qsa($IV), &qsa($Is))
or die "unable to open CVS command pipe for reading";
$io->print($_) while (<$cvs>);
$cvs->close;
}
else {
my $cvs = new CVS ($RT->{cvs}, $RT->{cvsroot});
$cvs->directory($cvsdir);
$cvs->entry($Is);
$cvs->arguments("-p", "-r$IV", $Is);
$cvs->send("update");
$io->print(scalar $cvs->result);
$cvs->close;
}
$io->close;
# retrieve whole file contents (new revision)
unlink("$RT->{tmpfile}.new");
$io = new IO::File ">$RT->{tmpfile}.new"
or die "unable to open temporary file $RT->{tmpfile}.new for writing";
if (not $RT->{useserver}) {
my $cvs = new IO::File sprintf("%s -f -Q -n update -p -r%s %s|", &qsa($RT->{cvs}), &qsa($Iv), &qsa($Is))
or die "unable to open CVS command pipe for reading";
$io->print($_) while (<$cvs>);
$cvs->close;
}
else {
my $cvs = new CVS ($RT->{cvs}, $RT->{cvsroot});
$cvs->directory($cvsdir);
$cvs->entry($Is);
$cvs->arguments("-p", "-r$Iv", $Is);
$cvs->send("update");
$io->print(scalar $cvs->result);
$cvs->close;
}
$io->close;
# generate change patch script
$cvsdiff .=
"<shiela:patch $cvsdir/$Is>\n" .
"(cd $cvsdir && \\\n" .
" uudecode <<'@@ .' && \\\n" .
" mv $Is $Is.orig && \\\n" .
" xdelta patch $Is.xdelta $Is.orig $Is && \\\n" .
" rm -f $Is.orig $Is.xdelta)\n" .
"Index: $cvsdir/$Is\n" .
("=" x 76) . "\n";
unlink("$RT->{tmpfile}.xdelta");
system(sprintf("%s delta %s.old %s.new %s.xdelta >/dev/null 2>&1",
&qsa($RT->{xdelta}), &qsa($RT->{tmpfile}), &qsa($RT->{tmpfile})));
$io = new IO::File sprintf("%s %s.xdelta %s.xdelta|", &qsa($RT->{uuencode}), &qsa($RT->{tmpfile}), &qsa($Is))
or die "unable to open uuencode command pipe for reading";
$cvsdiff .= $_ while (<$io>);
$io->close;
$cvsdiff .= "@@ .\n";
$cvsdiff .= "</shiela:patch>\n";
unlink("$RT->{tmpfile}.xdelta");
# cleanup
unlink("$RT->{tmpfile}.old");
unlink("$RT->{tmpfile}.new");
}
}
else {
# generate textual change patch script
my $d = '';
if (not $RT->{useserver}) {
my $io = new IO::File sprintf("%s -f -Q -n diff -u -r%s -r%s %s|", &qsa($RT->{cvs}), &qsa($IV), &qsa($Iv), &qsa($Is))
or die "unable to open CVS command pipe for reading";
$d .= $_ while (<$io>);
$io->close;
}
else {
my $cvs = new CVS ($RT->{cvs}, $RT->{cvsroot});
$cvs->directory($cvsdir);
$cvs->entry($Is);
$cvs->arguments("-u", "-r$IV", "-r$Iv", $Is);
$cvs->send("diff");
$d .= scalar $cvs->result;
$cvs->close;
}
my $Is_quoted = quotemeta($Is);
$d =~ s|^Index:.+?\ndiff\s+.*?\n||s;
$d =~ s|^(---\s+)${Is_quoted}(\s+)|$1$cvsdir/$Is$2|m;
$d =~ s|^(\+\+\+\s+)${Is_quoted}(\s+)|$1$cvsdir/$Is$2|m;
$cvsdiff .=
"<shiela:patch $cvsdir/$Is>\n" .
"patch -p0 <<'@@ .'\n" .
"Index: $cvsdir/$Is\n" .
("=" x 76) . "\n" .
"\$ cvs diff -u -r$IV -r$Iv $Is\n" .
$d .
"@@ .\n" .
"</shiela:patch>\n";
}
}
elsif ($Io eq 'R') {
##
## REMOVED FILE
##
# generate binary and textaual change patch script
$cvsdiff .=
"<shiela:patch $cvsdir/$Is>\n" .
"rm -f $cvsdir/$Is <<'@@ .'\n" .
"Index: $cvsdir/$Is\n" .
("=" x 76) . "\n" .
"[NO CHANGE SUMMARY BECAUSE FILE AS A WHOLE IS JUST REMOVED]\n" .
"@@ .\n" .
"</shiela:patch>\n";
}
$info = "$cvsdir/$Is,$IV,$Iv,$It,$Io,$Ik,$ID,$Id";
push(@newinfo, $info);
}
@cvsinfo = @newinfo;
# determine the temporary storage
my $storage;
for (my $i = 0; ; $i++) {
$storage = "$RT->{tmpfile}.$i";
last if (not -e "$storage.info");
#my @text = &file_read($storage, '');
#last if ($#text == -1);
#last if ($cvslogmsg eq join("\n", @text));
}
# store the information gathered in this pass
&do_file('write', "$storage.info", '', @cvsinfo);
&do_file('write', "$storage.diff", '', $cvsdiff);
return $cvsdir;
}
# accumulate the collected information
sub hook_loginfo_accumulate {
my ($PA, $RT, $CF) = @_;
# lumb together all information we remembered until now
my $cvslog = join("\n", &do_file('read', "$RT->{tmpfile}.log", ''))."\n";
unlink("$RT->{tmpfile}.log");
my @cvsinfo = ();
my $cvsdiff = '';
for (my $i = 0; ; $i++) {
my $storage = "$RT->{tmpfile}.$i";
last if (not -e "$storage.info");
push(@cvsinfo, &do_file('read', "$storage.info", ''));
$cvsdiff .= join("\n", &do_file('read', "$storage.diff", ''))."\n";
unlink("$storage.info");
unlink("$storage.diff");
}
# parse information into internal structure
my $IN = {
'file' => {},
'handle' => '',
'log' => $cvslog
};
$cvsdiff = "\n$cvsdiff\n"; # for easier parsing
my $handle_min; $handle_min = undef;
my $handle_max; $handle_max = undef;
foreach my $cvsinfo (@cvsinfo) {
$cvsinfo =~ m|^([^,]+),([^,]+),([^,]+),([^,]+),([^,]+),([^,]+),([^,]+),([^,]+)$|
or die "invalid loginfo argument `$cvsinfo' while accumulating information";
my ($Is, $IV, $Iv, $It, $Io, $Ik, $ID, $Id) = ($1, $2, $3, $4, $5, $6, $7, $8, $9);
my $e = {};
$e->{oldrev} = $IV;
$e->{newrev} = $Iv;
$e->{branch} = $It;
$e->{op} = $Io;
$e->{keysub} = $Ik;
$e->{date} = $ID;
$e->{delta} = $Id;
$e->{diff} = '';
my $Is_quoted = quotemeta($Is);
$cvsdiff =~ s|\n<shiela:patch\s+${Is_quoted}>\n(.+?\n)</shiela:patch>|$e->{diff} = $1, ''|se;
$IN->{file}->{$Is} = $e;
$handle_min = $ID if ($ID ne '' and $ID ne '0' and (not defined($handle_min) or $handle_min > $ID));
$handle_max = $ID if ($ID ne '' and $ID ne '0' and (not defined($handle_max) or $handle_max < $ID));
}
$IN->{handle} = '-NONE-';
if (defined($handle_min) and defined($handle_max)) {
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime($handle_min);
$IN->{handle} = sprintf("%04d%02d%02d%02d%02d%02d%02d",
1900+$year, $mon+1, $mday, $hour, $min, $sec,
$handle_max - $handle_min);
}
return $IN;
}
# process the accumulated information
sub hook_loginfo_process {
my ($PA, $RT, $CF, $IN) = @_;
# determine log locations and corresponding files
my $LG = {};
my $file;
foreach $file (sort(keys(%{$IN->{file}}))) {
my ($d, $f) = ($file =~ m|^([^/]+)/(.+)$|);
my $t = $IN->{file}->{$file}->{branch};
foreach my $module (keys(%{$CF->{Repository}->{Module}})) {
if ($module eq $d) {
my $m = $CF->{Repository}->{Module}->{$module};
foreach my $log (@{$m->{log}}) {
my ($file, @logloc) = @{$log};
my $tag = 'HEAD';
if ($file =~ m|^(.+):([^:]+)$|) {
$file = $1;
$tag = $2;
}
if ( &pattern_match($tag, $t)
and &pattern_match($file, $f)) {
foreach my $logloc (@logloc) {
$LG->{$logloc} = [] if (not defined($LG->{$logloc}));
push(@{$LG->{$logloc}}, $file);
}
}
}
}
}
}
# perform one or more logging operations
foreach my $logloc (sort(keys(%{$LG}))) {
next if ($logloc eq 'none');
my @files = @{$LG->{$logloc}};
if ($logloc =~ m|^([^:]+):(.+)$|) {
my ($logtype, $logurl) = ($1, $2);
if ($logurl =~ m|^.+@.+$|) {
# send log message as Email
my $logmsg = &produce_log_message($PA, $RT, $CF, $IN, $logtype, @files);
my $subject = "[CVS]";
$subject .= " ".$CF->{Project}->{Tag}.":";
my $dirlast = '';
my $branchlast = '';
foreach my $path (sort(keys(%{$IN->{file}}))) {
my ($dir, $file) = ($path =~ m|^(.+)/([^/]+)$|);
my $branch = $IN->{file}->{$path}->{branch} || 'HEAD';
if ($branchlast ne $branch) {
# prefix with branch
$branchlast = $branch;
$subject .= " $branch:" if ($branch ne 'HEAD');
}
if ($dirlast ne $dir) {
# prefix with directory
$dirlast = $dir;
$subject .= " $dir/";
}
$subject .= " $file";
}
$subject = substr($subject, 0, 70)."..." if (length($subject) > 70);
print "cvs commit: Mailing commit message to <$logurl>\n";
my $sm = new Sendmail ($RT, $logurl);
$sm->header('Subject', $subject);
if (defined($CF->{Logging}->{Report}->{$logtype}->{Details})) {
if ($CF->{Logging}->{Report}->{$logtype}->{Details} eq 'patch:mime') {
$sm->header('Content-Type',
"multipart/mixed; boundary=\"".$RT->{mimeboundary}."\"");
}
}
$sm->body($logmsg);
$sm->close;
}
else {
# append log message to file
my $logmsg = &produce_log_message($PA, $RT, $CF, $IN, $logtype, @files);
$logurl = $RT->{cvsroot}."/".$logurl if ($logurl !~ m|^/|);
print "cvs commit: Writing commit message to $logurl\n";
my $io = new IO::File ">>$logurl" or die "cannot append log message to `$logurl'";
$io->print($logmsg);
$io->close;
}
}
}
}
# produce a particular log messages
sub produce_log_message {
my ($PA, $RT, $CF, $IN, $type, @files) = @_;
#
# Parse out more details.
#
my $cvslist = {};
my %cvsmodules = ();
my %cvsbranches = ();
my $file;
foreach $file (sort(keys(%{$IN->{file}}))) {
my $e = $IN->{file}->{$file};
my ($d, $f) = ($file =~ m|^(.+)/([^/]+)$|);
# build lists
$cvslist->{$e->{op}} = {} if (not defined($cvslist->{$e->{op}}));
$cvslist->{$e->{op}}->{$e->{branch}} = {} if (not defined($cvslist->{$e->{op}}->{$e->{branch}}));
$cvslist->{$e->{op}}->{$e->{branch}}->{$d} = [] if (not defined($cvslist->{$e->{op}}->{$e->{branch}}->{$d}));
push(@{$cvslist->{$e->{op}}->{$e->{branch}}->{$d}}, $f);
# accumulate modules
($d, $f) = ($file =~ m|^([^/]+)/(.+)$|);
foreach my $m (sort(keys(%{$CF->{Repository}->{Module}}))) {
if ($m eq $d) {
$cvsmodules{$m} = 0 if (not defined($cvsmodules{$m}));
$cvsmodules{$m}++;
}
}
# accumulate branches
$cvsbranches{$e->{branch}} = 0 if (not defined($cvsbranches{$e->{branch}}));
$cvsbranches{$e->{branch}}++;
}
$IN->{cvsbranch} = join(' ', keys(%cvsbranches));
$IN->{cvsmodule} = join(' ', keys(%cvsmodules));
#
# Finally generate the logging message.
#
my $RP = $CF->{Logging}->{Report}->{$type} or die "No report of type `$type' defined";
my $prefix = $RP->{Prefix} || '';
my $style = $RP->{Details} || 'patch:plain';
my $O = '';
foreach my $content (@{$RP->{Content}}) {
# the title
if ($content eq 'title') {
$O .= "\n" .
$prefix . $CF->{Repository}->{Name} . "\n" .
$prefix . $CF->{Repository}->{Home} . "\n";
}
# a rule
elsif ($content eq 'rule') {
$O .= $prefix . ("_" x 76) . "\n";
}
# the header lines
elsif ($content eq 'header') {
my @moy = ( 'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec' );
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localtime(time());
my $txt_date = sprintf("%02d-%s-%04d %02d:%02d:%02d",
$mday, $moy[$mon], 1900+$year, $hour, $min, $sec);
my $txt_server = &fit_columns(32, $CF->{Repository}->{Host});
my $txt_root = &fit_columns(32, $CF->{Repository}->{Path});
my $txt_module = &fit_columns(32, $IN->{cvsmodule});
my $txt_branch = &fit_columns(32, $IN->{cvsbranch});
my $txt_name = &fit_columns(32, $RT->{username});
my $txt_email = &fit_columns(32, $RT->{usermail});
my $txt_handle = &fit_columns(32, $IN->{handle});
$O .= "\n" .
$prefix . sprintf("%-40s %s\n", "Server: ".$txt_server, "Name: ".$txt_name) .
$prefix . sprintf("%-40s %s\n", "Root: ".$txt_root, "Email: ".$txt_email) .
$prefix . sprintf("%-40s %s\n", "Module: ".$txt_module, "Date: ".$txt_date) .
$prefix . sprintf("%-40s %s\n", "Branch: ".$txt_branch, "Handle: ".$txt_handle);
}
# the file list
elsif ($content eq 'files') {
$O .= "\n";
$O .= &format_op($prefix, "Imported files", $cvslist->{I}) if (defined($cvslist->{I}));
$O .= &format_op($prefix, "Added files", $cvslist->{A}) if (defined($cvslist->{A}));
$O .= &format_op($prefix, "Modified files", $cvslist->{M}) if (defined($cvslist->{M}));
$O .= &format_op($prefix, "Touched files", $cvslist->{T}) if (defined($cvslist->{T}));
$O .= &format_op($prefix, "Removed files", $cvslist->{R}) if (defined($cvslist->{R}));
sub format_op {
my ($prefix, $header, $list) = @_;
my $O = '';
my $branch;
foreach $branch (sort(keys(%{$list}))) {
if ($branch eq 'HEAD') {
$O .= sprintf("%s%s\n", $prefix, "$header:");
}
else {
$O .= sprintf("%s%-25s %s\n", $prefix, "$header:", "(Branch: $branch)");
}
$O .= &format_branch($prefix, $header, $branch, $list->{$branch});
}
return $O;
}
sub format_branch {
my ($prefix, $header, $branch, $list) = @_;
my $O = '';
my $dir;
foreach $dir (sort(keys(%{$list}))) {
$O .= &format_dir($prefix, $header, $branch, $dir, $list->{$dir});
}
return $O;
}
sub format_dir {
my ($prefix, $header, $branch, $dir, $list) = @_;
my $O = '';
my $file;
my $first = 1;
my $col = 0;
foreach $file (sort(@{$list})) {
if (($col + 1 + length($file)) > 78) {
$O .= "\n";
$col = 0;
}
if ($col == 0) {
if ($first) {
if ((2+length($dir)) > 25) {
$O .= sprintf("%s%s\n", $prefix, " " . $dir);
$O .= sprintf("%s%-25s", $prefix, "");
}
else {
$O .= sprintf("%s%-25s", $prefix, " " . $dir);
}
$first = 0;
}
else {
$O .= sprintf("%s%-25s", $prefix, "");
}
$col += length($prefix) + 25;
}
$O .= " " . $file;
$col += 1 + length($file);
}
$O .= "\n" if ($O !~ m|\n$|s);
return $O;
}
}
# the log message
elsif ($content eq 'log') {
$O .= "\n";
$O .= $prefix."Log:\n";
my $log = $IN->{log};
if ($log !~ m|\n.+|s and length($log) > 70) {
$log = &wrap_message(70, $log);
}
$log =~ s|^|${prefix} |mg;
$O .= $log;
}
# the change summary
elsif ($content eq 'summary') {
$O .= "\n";
$O .= $prefix."Summary:\n";
$O .= $prefix." Revision Changes Path\n";
foreach $file (sort(keys(%{$IN->{file}}))) {
my ($op, $rev, $delta) = ($IN->{file}->{$file}->{op},
$IN->{file}->{$file}->{newrev},
$IN->{file}->{$file}->{delta});
next if ($op eq 'T');
if ($delta =~ m|^(.+)/(.+)$|) {
$delta = sprintf("%-3s %-3s", $1, $2);
}
$O .= $prefix . sprintf(" %-12s%-12s%s\n", $rev, $delta, $file);
}
}
# the change details
elsif ($content eq 'details') {
$O .= "\n";
if ($style =~ m|^url:(.+)|) {
$O .= "Change details:\n";
my $urlspec = $1;
foreach $file (sort(keys(%{$IN->{file}}))) {
next if ($IN->{file}->{$file}->{op} eq 'T');
my $url = $urlspec;
$url =~ s|%([sVv])|
if ($1 eq 's') { $file; }
elsif ($1 eq 'V') { $IN->{file}->{$file}->{oldrev}; }
elsif ($1 eq 'v') { $IN->{file}->{$file}->{newrev}; }
|gse;
$O .= " $prefix$url\n";
}
}
elsif ($style eq 'rdiff') {
$O .= "Change details:\n";
foreach $file (sort(keys(%{$IN->{file}}))) {
next if ($IN->{file}->{$file}->{op} eq 'T');
if ($IN->{file}->{$file}->{op} eq 'A') {
$O .= " \$ cvs rdiff -u" .
" -r0 -r" . $IN->{file}->{$file}->{newrev} .
" " . $file .
"\n";
}
else {
$O .= " \$ cvs rdiff -u" .
" -r" . $IN->{file}->{$file}->{oldrev} .
" -r" . $IN->{file}->{$file}->{newrev} .
" " . $file .
"\n";
}
}
}
elsif ($style eq 'patch:plain') {
foreach $file (sort(keys(%{$IN->{file}}))) {
next if ($IN->{file}->{$file}->{op} eq 'T');
my $diff = $IN->{file}->{$file}->{diff};
$diff =~ s|^|$prefix|mg;
$O .= $diff;
}
}
elsif ($style eq 'patch:mime') {
foreach $file (sort(keys(%{$IN->{file}}))) {
next if ($IN->{file}->{$file}->{op} eq 'T');
my $diff = $IN->{file}->{$file}->{diff};
$diff =~ s|\n$||s;
$diff .= "\n\n";
$O .= "--".$RT->{mimeboundary}."\n";
$O .= "Content-Type: text/plain; charset=iso-8859-1\n";
$O .= "Content-Transfer-Encoding: 8bit\n";
$O .= "Content-Description: changes to $file\n";
$O .= "Content-Disposition: attachment\n";
$O .= "\n";
$O .= "$diff";
}
}
}
}
# post-processing of output
$O =~ s|^\n+||s;
$O =~ s|\n+$|\n|s;
# MIME post-processing
if ($style eq 'patch:mime') {
$O = "This is a multi-part message in MIME format.\n" .
"--".$RT->{mimeboundary}."\n" .
"Content-Type: text/plain; charset=iso-8859-1\n" .
"Content-Transfer-Encoding: 8bit\n" .
"Content-Description: change summary\n" .
"Content-Disposition: inline\n" .
"\n" .
$O .
"--".$RT->{mimeboundary}."--\n" .
"\n";
}
return $O;
}
