*** /dev/null Sat Nov 23 00:53:44 2024
--- - Sat Nov 23 00:53:49 2024
***************
*** 0 ****
--- 1,2067 ----
+ #!/v/ossp/sw/bin/perl -w
+ ##
+ ## Shiela - CVS Access Control and Logging Facility
+ ## Copyright (c) 2000 Ralf S. Engelschall <rse@engelschall.com>
+ ##
+ ## This file is part of Shiela, an access control and logging
+ ## facility for Concurrent Versions System (CVS) repositories
+ ## which can be found at http://www.ossp.org/pkg/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: Shiela control program (syntax: Perl)
+ ##
+
+ my $version = '1.0.0';
+
+ require 5.005;
+
+ use strict; # shipped with Perl since 5.000
+ use POSIX; # shipped with Perl since 5.000
+ 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
+
+ # 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};
+
+ # Generic program error handler
+ $SIG{__DIE__} = sub {
+ my ($text) = @_;
+ $text =~ s|\s+at\s+.*||s;
+ my $name = ($0 =~ m|^.*?([^/]+?)(?:\.[^/.]+)?$|)[0];
+ print STDERR $name.":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 hook (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} || die 'unknown CVS root (set $CVSROOT variable)';
+ $RT->{userid} = $ENV{LOGUSER} || $ENV{USER} || $ENV{LOGNAME} || 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 "unknown user `$RT->{userid}'";
+ $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);
+
+ # determine various program paths
+ sub find_program {
+ my ($name) = @_;
+ my ($prog) = '';
+ foreach my $dir (split(/:/, "$ENV{PATH}:/usr/local/lib:/usr/lib:/lib")) {
+ if (-x "$dir/$name") {
+ $prog = "$dir/$name";
+ last;
+ }
+ }
+ return $prog;
+ }
+ $RT->{sendmail} = &find_program("ssmtp") ||
+ &find_program("sendmail") ||
+ die "unable to find `sendmail' program";
+ $RT->{cvs} = &find_program("cvs") ||
+ die "unable to find `cvs' program";
+
+ # 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.]+)\s+|s);
+ $RT->{cvsossp} = 0;
+ $RT->{cvsossp} = 1 if ($v =~ m|OSSP|s);
+ die "$RT->{cvs} is not at least CVS 1.10" if ($RT->{cvsvers} !~ m|^1\.10|);
+ $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 Shiela configuration.
+ ##
+ ## We theoretically could directly operate on the syntax tree as
+ ## created by parse_config() above. But for convinience 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
+ open(CFG, "<$file") || die "unable to open configuration file `$file'";
+ my $t = '';
+ $t .= $_ while (<CFG>);
+ close(CFG);
+
+ # 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' => {}
+ }
+ };
+ 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];
+ }
+ }
+ }
+ 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 achored
+ $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 convinience
+ ## 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} || 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 -Q -l -n server")
+ || 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 MT");
+ $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;
+ }
+ }
+
+ # convinience 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;
+ }
+ }
+
+ # convinience wrapper: provide a file entry
+ sub entry {
+ my $cvs = shift;
+ my @files = @_;
+ foreach my $file (@files) {
+ $cvs->send("Entry /$file////");
+ $cvs->send("Unchanged $file");
+ }
+ }
+
+ # convinience wrapper: provide one or more global options
+ sub global_options {
+ my $cvs = shift;
+ my @opts = @_;
+ foreach my $opt (@opts) {
+ $cvs->send("Global_option $opt");
+ }
+ }
+
+ # convinience wrapper: provide one or more arguments
+ sub arguments {
+ my $cvs = shift;
+ my @args = @_;
+ foreach my $arg (@args) {
+ $cvs->send("Argument $arg");
+ }
+ }
+
+ # convinience 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: ".uc(substr($RT->{name}, 0, 1)).substr($RT->{name}, 1)."/$RT->{vers} " .
+ ($RT->{cvsossp} ? "OSSP-CVS" : "CVS")."/$RT->{cvsvers}\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 convinience 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') {
+ open(FP, ($op eq 'append' ? ">" : "").">$file") or
+ die "unable to open `$file' for $op";
+ foreach my $line (@lines) {
+ $line =~ s|\n+$||s;
+ print FP $prefix . $line . "\n";
+ }
+ close(FP);
+ }
+ # read a file line by line into an array
+ elsif ($op eq 'read') {
+ my @text = ();
+ open(FP, "<$file") or
+ die "unable to open `$file' for $op";
+ while (<FP>) {
+ s|\n$||s;
+ push(@text, $prefix . $_);
+ }
+ close(FP);
+ 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 = '';
+ my $file;
+ foreach $file (keys(%{$IN->{file}})) {
+ my $e = $IN->{file}->{$file};
+ $O .= $IN->{handle};
+ $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";
+ }
+ open(HDB, ">>".$RT->{historydb})
+ || die "cannot store information to history db `$file'";
+ print HDB $O;
+ close(HDB);
+ return;
+ }
+
+ sub history_load {
+ my ($PA, $RT, $CF, $handle) = @_;
+ # XXX STILL MISSING, BECAUSE NOT USED XXX
+ # XXX HAS TO RE-DETERMINE DIFF AND LOG INFORMATION XXX
+ 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|^([^/]+)/(.*):([^:]+)$|
+ || 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
+ $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;
+ }
+
+ ## _________________________________________________________________
+ ##
+ ## 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}};
+ $cvsdir =~ s|^$RT->{cvsroot}/?||;
+
+ # 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}) {
+ open(CVSS, "$RT->{cvs} -f -l -Q -n status ".join(' ', @cvsfiles)."|");
+ $cvsstat .= $_ while (<CVSS>);
+ close(CVSS);
+ }
+ else {
+ my $cvs = new CVS ($RT->{cvs}, $RT->{cvsroot});
+ $cvs->global_options("-l", "-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';
+ if ($cvsstat =~ m|===+\nFile:\s+$cvsfile.+?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 `commitinfo' 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 a standard
+ ## version, this check is advisory only. If CVS contains the OSSP
+ ## patches, the log message is changed and CVS 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;
+
+ # we require the OSSP patches for operation
+ return $rv if (not $RT->{cvsossp});
+
+ # suck in the log message
+ my $logfile = $PA->{ARG}->[0];
+ open(FP, "<$logfile") || die "cannot open message file `$logfile' for reading";
+ my $data = '';
+ $data .= $_ while (<FP>);
+ close(FP);
+
+ # filter the log message
+ $data = &compress_message($data);
+
+ # update the log message
+ # (OSSP CVS reads in this again, stock CVS ignores it)
+ open(FP, ">$logfile") || die "cannot open message file `$logfile' for writing";
+ print FP $data;
+ close(FP);
+
+ # 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, @cvsinfo) = split(/\s+/, $PA->{ARG}->[0]);
+
+ # 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 (join(' ', @cvsinfo) eq '- New directory') { # see CVS' src/add.c
+ # Hmmm... we always just deal with files in 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 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 (join(' ', @cvsinfo) 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 (OSSP 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 .= "[Release Tags: $IT]\n";
+ 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 $subdir = $Is;
+ $subdir =~ s|/?[^/]+$||;
+ $subdir =~ s|^$|.|;
+ 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: 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);
+ }
+ open(CVSS, "$RT->{cvs} -f -l -Q -n log -r$It $Is|");
+ $rcslog = $_ while (<CVSS>);
+ close(CVSS);
+ }
+ else {
+ my $cvs = new CVS ($RT->{cvs}, $RT->{cvsroot});
+ $cvs->directory($cvsdir);
+ $cvs->entry($Is);
+ $cvs->arguments("-r$It", $Is);
+ $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 OSSP CVS version would provide).
+ if (not $RT->{cvsossp} 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|^([^,]+),([^,]+),([^,]+)$|
+ || die "invalid loginfo argument `$info'";
+ 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|^([^,]+),([^,]+),([^,]+),([^,]*),([^,]*)$|
+ || die "invalid loginfo argument `$info'";
+ my ($Is, $IV, $Iv, $It, $Io) = ($1, $2, $3, $4, $5);
+
+ # fix branch/tag and accumulate information
+ $It = 'HEAD' if ($It eq '');
+
+ # read file log entry
+ my $rcslog = '';
+ if ($Io eq 'A' or $Io eq 'M') {
+ if (not $RT->{useserver}) {
+ open(CVSS, "$RT->{cvs} -f -l -Q -n log -r$Iv $Is|");
+ $rcslog .= $_ while (<CVSS>);
+ close(CVSS);
+ }
+ 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) {
+ 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' or $Io eq 'R') {
+ open(FP, "<$Is");
+ my $l = 0;
+ $l++ while (<FP>);
+ close(FP);
+ $Id = sprintf("+%d/-%d", ($Io eq 'A' ? $l : 0), ($Io eq 'A' ? 0 : $l));
+ }
+ elsif ($Io eq 'M') {
+ # if ($rcslog =~ m|\ndate:.*lines:\s*(.+?)\s*\n|s) {
+ if ($rcslog =~ m|\ndate:.*lines:\s*([\d \t-]+)|s) {
+ $Id = $1;
+ $Id =~ s|\s+|/|g;
+ }
+ }
+ }
+
+ # determine change diff
+ if ($Io eq 'A') {
+ # file was added, so we show the whole contents
+ if ($Ik eq 'b' or -B $Is) {
+ # file seems to be a binary file
+ $cvsdiff .=
+ "<Diff $cvsdir/$Is>\n" .
+ "Index: $cvsdir/$Is\n" .
+ "============================================================\n" .
+ "\$ cvs update -p -r$Iv $Is | uuencode $Is\n";
+ if (not $RT->{useserver}) {
+ open(CVSS, "$RT->{cvs} -f -l -Q -n update -p -r$Iv $Is | uuencode $Is |");
+ $cvsdiff .= $_ while (<CVSS>);
+ close(CVSS);
+ }
+ else {
+ my $cvs = new CVS ($RT->{cvs}, $RT->{cvsroot});
+ $cvs->directory($cvsdir);
+ $cvs->entry($Is);
+ $cvs->arguments("-p", "-r$Iv", $Is);
+ $cvs->send("update");
+ $cvsdiff .= scalar $cvs->result;
+ $cvs->close;
+ }
+ $cvsdiff .= "</Diff>\n";
+ }
+ else {
+ # file seems to be a regular text file
+ $cvsdiff .=
+ "<Diff $cvsdir/$Is>\n" .
+ "Index: $cvsdir/$Is\n" .
+ "============================================================\n" .
+ "\$ cvs update -p -r$Iv $Is\n";
+ if (not $RT->{useserver}) {
+ open(CVSS, "$RT->{cvs} -f -l -Q -n update -p -r$Iv $Is|");
+ $cvsdiff .= $_ while (<CVSS>);
+ close(CVSS);
+ }
+ else {
+ my $cvs = new CVS ($RT->{cvs}, $RT->{cvsroot});
+ $cvs->directory($cvsdir);
+ $cvs->entry($Is);
+ $cvs->arguments("-p", "-r$Iv", $Is);
+ $cvs->send("update");
+ $cvsdiff .= scalar $cvs->result;
+ $cvs->close;
+ }
+ $cvsdiff .= "</Diff>\n";
+ }
+ }
+ elsif ($Io eq 'M') {
+ if ($Ik eq 'b' or -B $Is) {
+ # file seems to be a binary file
+ $cvsdiff .=
+ "<Diff $cvsdir/$Is>\n" .
+ "Index: $cvsdir/$Is\n" .
+ "============================================================\n" .
+ "\$ cvs update -p -r$IV $Is >$Is.old\n" .
+ "\$ cvs update -p -r$Iv $Is >$Is.new\n" .
+ "\$ diff -u $Is.old $Is.new\n";
+ if (not $RT->{useserver}) {
+ system("$RT->{cvs} -f -l -Q -n update -p -r$IV $Is | uuencode $Is >$Is.old");
+ system("$RT->{cvs} -f -l -Q -n update -p -r$Iv $Is | uuencode $Is >$Is.new");
+ }
+ 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 $data = scalar $cvs->result;
+ open(FP, ">$Is.old") || die "cannot write to $Is.old";
+ print FP $data;
+ close(FP);
+ $cvs->arguments("-p", "-r$Iv", $Is);
+ $cvs->send("update");
+ $data = scalar $cvs->result;
+ open(FP, ">$Is.new") || die "cannot write to $Is.old";
+ print FP $data;
+ close(FP);
+ $cvs->close;
+ }
+ open(FP, "diff -u $Is.old $Is.new|");
+ $cvsdiff .= $_ while (<FP>);
+ close(FP);
+ $cvsdiff .= "</Diff>\n";
+ }
+ else {
+ # file was modified, so we show the changed contents only
+ my $d = '';
+ if (not $RT->{useserver}) {
+ open(FP, "$RT->{cvs} -f -l -Q -n diff -u -r$IV -r$Iv $Is|");
+ $d .= $_ while (<FP>);
+ close(FP);
+ }
+ 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;
+ }
+ $d =~ s|^Index:.+?\ndiff\s+.*?\n||s;
+ $d =~ s|^(---\s+)$Is(\s+)|$1$cvsdir/$Is$2|m;
+ $d =~ s|^(\+\+\+\s+)$Is(\s+)|$1$cvsdir/$Is$2|m;
+ $cvsdiff .=
+ "<Diff $cvsdir/$Is>\n" .
+ "Index: $cvsdir/$Is\n" .
+ "============================================================\n" .
+ "\$ cvs diff -u -r$IV -r$Iv $Is\n" .
+ $d .
+ "</Diff>\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 = undef;
+ my $handle_max = undef;
+ foreach my $cvsinfo (@cvsinfo) {
+ $cvsinfo =~ m|^([^,]+),([^,]+),([^,]+),([^,]+),([^,]+),([^,]+),([^,]+),([^,]+)$|
+ || die "invalid loginfo argument `$cvsinfo'";
+ 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} = '';
+ $cvsdiff =~ s|\n<Diff\s+$Is>\n(.+?\n)</Diff>|$e->{diff} = $1, ''|se;
+ $IN->{file}->{$Is} = $e;
+ $handle_min = $ID if ($ID ne '' and (not defined($handle_min) or $handle_min > $ID));
+ $handle_max = $ID if ($ID ne '' 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 = '';
+ foreach my $path (sort(keys(%{$IN->{file}}))) {
+ my ($dir, $file) = ($path =~ m|^(.+)/([^/]+)$|);
+ if ($dirlast ne $dir) {
+ $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 ($CF->{Logging}->{Report}->{$logtype}->{Details} eq 'diff: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";
+ open(LOG, ">>$logurl") || die "cannot append log message to `$logurl'";
+ print LOG $logmsg;
+ close(LOG);
+ }
+ }
+ }
+ }
+
+ # 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} || die "No report of type `$type' defined";
+ my $prefix = $RP->{Prefix} || '';
+ my $style = $RP->{Details} || 'diff: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 $date = sprintf("%02d-%s-%04d %02d:%02d:%02d",
+ $mday, $moy[$mon], 1900+$year, $hour, $min, $sec);
+ $O .= "\n" .
+ $prefix . sprintf("%-40s %s\n", "Server: ".$CF->{Repository}->{Host}, "Name: ".$RT->{username}) .
+ $prefix . sprintf("%-40s %s\n", "Root: ".$CF->{Repository}->{Path}, "Email: ".$RT->{usermail}) .
+ $prefix . sprintf("%-40s %s\n", "Module: ".$IN->{cvsmodule}, "Date: ".$date) .
+ $prefix . sprintf("%-40s %s\n", "Branch: ".$IN->{cvsbranch}, "Handle: ".$IN->{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 .= $prefix."$header:\n";
+ }
+ else {
+ $O .= $prefix.sprintf("%-25s %s\n", "$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+length($file)+1 > 78) {
+ $O .= "\n";
+ $col = 0;
+ }
+ if ($col == 0) {
+ if ($first) {
+ if (length($dir) > 25) {
+ $O .= $prefix.sprintf("%s\n$prefix%-25s", " $dir", "");
+ }
+ else {
+ $O .= $prefix.sprintf("%-25s", " $dir");
+ }
+ $first = 0;
+ }
+ else {
+ $O .= $prefix.sprintf("%-25s", "");
+ }
+ $col += length($prefix)+25;
+ }
+ $O .= " $file";
+ $col += length($file)+1;
+ }
+ $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};
+ $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');
+ $delta =~ s|/| |g;
+ $O .= $prefix.sprintf(" %-12s%-12s%s\n", $rev, $delta, $file);
+ }
+ }
+
+ # the change details
+ elsif ($content eq 'details') {
+ $O .= "\n";
+ if ($style =~ m|^url:(.+)|) {
+ 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 'diff: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 'diff: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 'diff: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: commit summary\n" .
+ "Content-Disposition: inline\n" .
+ "\n" .
+ $O .
+ "--".$RT->{mimeboundary}."--\n" .
+ "\n";
+ }
+
+ return $O;
+ }
+
+ ##EOF##
|
