#!/v/ossp/sw/bin/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;
}