*** /dev/null Sat Nov 23 01:41:14 2024
--- - Sat Nov 23 01:41:18 2024
***************
*** 0 ****
--- 1,2338 ----
+ #!@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 $v = `$RT->{cvs} --version 2>/dev/null`;
+ $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}, "$program -f -Q -n server")
+ 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;
+ open($sm->{fd}, "|$RT->{sendmail} -oi -oem $toaddr");
+ print "sendmail: spawned \"$RT->{sendmail} -oi -oem $toaddr\"\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;
+ }
+ }
+
+ ## _________________________________________________________________
+ ##
+ ## 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 "$RT->{cvs} -f -Q -n status ".join(' ', @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 "$RT->{cvs} -f -Q -n log -r$It '$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 "$RT->{cvs} -f -Q -n log '$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 "$RT->{cvs} -f -Q -n log -r$Iv '$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 "$RT->{cvs} -f -Q -n update -p -r$Iv '$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("$RT->{xdelta} delta $RT->{tmpfile}.null " .
+ "$RT->{tmpfile}.all $RT->{tmpfile}.xdelta >/dev/null 2>&1");
+ $io = new IO::File "$RT->{uuencode} $RT->{tmpfile}.xdelta $Is.xdelta |"
+ 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 "$RT->{diff} -u /dev/null $RT->{tmpfile}.all|"
+ 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 "$RT->{cvs} -f -Q -n update -p -r$IV '$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 "$RT->{cvs} -f -Q -n update -p -r$Iv '$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("$RT->{xdelta} delta $RT->{tmpfile}.old " .
+ "$RT->{tmpfile}.new $RT->{tmpfile}.xdelta >/dev/null 2>&1");
+ $io = new IO::File "$RT->{uuencode} $RT->{tmpfile}.xdelta $Is.xdelta |"
+ 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 "$RT->{cvs} -f -Q -n diff -u -r$IV -r$Iv '$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;
+ }
+
|
