481 lines
13 KiB
Perl
Executable File
481 lines
13 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
#
|
|
|
|
package MultiCVS;
|
|
use strict;
|
|
|
|
BEGIN {
|
|
use Carp qw{confess croak};
|
|
use IO::File qw{};
|
|
use File::Find qw{find};
|
|
use Fcntl qw{O_RDONLY};
|
|
|
|
use constant TRUE => 1;
|
|
use constant FALSE => ();
|
|
}
|
|
|
|
|
|
### (CONSTRUCTOR) METHOD: new( $mainconfig )
|
|
### Create a new MultiCVS object.
|
|
sub new {
|
|
my $proto = shift;
|
|
my $class = ref $proto || $proto;
|
|
my $mainconfig = shift;
|
|
|
|
my $self = bless {
|
|
dir_live => '',
|
|
dir_cvs => '',
|
|
|
|
directories => undef,
|
|
filemap => undef,
|
|
|
|
_debug => undef,
|
|
}, $class;
|
|
|
|
# Read the first argument as the main config file, and try to find and read
|
|
# any local variant after that.
|
|
if ( $mainconfig ) {
|
|
$self->read_config( $mainconfig, 1 );
|
|
|
|
if ( $mainconfig =~ m{^(.+)multicvs.conf$} ) {
|
|
my $localconf = "$1multicvs-local.conf";
|
|
$self->read_config( $localconf );
|
|
}
|
|
}
|
|
|
|
return $self;
|
|
}
|
|
|
|
|
|
sub debugmsg {
|
|
my $self = shift or confess "Cannot be used as a function";
|
|
return unless $self->{_debug};
|
|
my ( $fmt, @args ) = @_;
|
|
|
|
printf STDERR $fmt, @args;
|
|
}
|
|
|
|
|
|
### METHOD: read_config( $file[, $ismain] )
|
|
### Read the object's configuration from the given I<file>.
|
|
sub read_config {
|
|
my ( $self, $file, $ismain ) = @_;
|
|
|
|
my (
|
|
$ifh,
|
|
$line,
|
|
);
|
|
|
|
open $ifh, "<$file" or die "open: $file: $!";
|
|
|
|
while ( <$ifh> ) {
|
|
$line = $_;
|
|
chomp $line;
|
|
|
|
# Strip leading, trailing space and comments
|
|
$line =~ s{(^\s+|#.*|\s+$)}{}g;
|
|
next unless $line =~ /\S/;
|
|
|
|
# Expand environment variables
|
|
$line =~ s/\$(\w+)/$ENV{$1} or die "Environment variable \$$1 not set.\n"/ge;
|
|
|
|
# Set key/value pair variables if this is the main config
|
|
if ( $line =~ /(\w+)\s*=\s*(.+)/ ) {
|
|
my ($k, $v) = ($1, $2);
|
|
die "Included config files can't set variables such as $k.\n" unless $ismain;
|
|
|
|
if ( $k eq "LIVEDIR" ) { $self->{dir_live} = $v }
|
|
elsif ( $k eq "CVSDIR" ) { $self->{dir_cvs} = $v }
|
|
else { die "Unknown option $k = $v\n"; }
|
|
}
|
|
|
|
# Set name<space>value pairs
|
|
elsif (/(\S+)\s+(.+)/) {
|
|
my ($from, $to) = ($1, $2);
|
|
my $optional = 0;
|
|
|
|
if ($from =~ s/\?$//) { $optional = 1; }
|
|
|
|
push @{$self->{paths}}, {
|
|
'from' => $from,
|
|
'to' => $to,
|
|
'optional' => $optional,
|
|
};
|
|
} else {
|
|
die "Bogus config line in '$file': $line\n";
|
|
}
|
|
}
|
|
close $ifh;
|
|
|
|
# Clear any old entries
|
|
$self->{directories} = $self->{files} = undef;
|
|
|
|
return TRUE;
|
|
}
|
|
|
|
|
|
### METHOD: cvs_update( [$quiet] )
|
|
### Update the modules under multicvs's control, optionally with the quiet flag
|
|
### turned on.
|
|
sub cvs_update {
|
|
my $self = shift or confess "can't be called as a function";
|
|
my $quiet = shift || 0;
|
|
|
|
my (
|
|
$dir,
|
|
$count,
|
|
);
|
|
|
|
$count = 0;
|
|
|
|
# Do a 'cvs update' in directories that haven't been updated yet.
|
|
foreach my $dir ( $self->directories ) {
|
|
chdir $dir or die "chdir: $dir: $!\n";
|
|
$self->debugmsg( "Updating CVS dir '$dir' ...\n" );
|
|
system( "cvs", "update", "-dP" );
|
|
|
|
$count++;
|
|
}
|
|
|
|
return $count;
|
|
}
|
|
|
|
|
|
|
|
### METHOD: directories()
|
|
### Returns a list of the top-level directories which should be checked for
|
|
### updates.
|
|
sub directories {
|
|
my $self = shift or confess "cannot be used as a function";
|
|
|
|
my (
|
|
$root,
|
|
$dir,
|
|
);
|
|
|
|
unless ( $self->{directories} ) {
|
|
my %map = ();
|
|
|
|
foreach my $path ( @{$self->{paths}} ) {
|
|
|
|
# Get the root module which contains the file, fully-qualify it,
|
|
# then add it to the map
|
|
( $root = $path->{from} ) =~ s!/.*!!;
|
|
$dir = "$self->{dir_cvs}/$root";
|
|
$map{ $dir } = 1 if -d $dir;
|
|
}
|
|
|
|
$self->{directories} = [ keys %map ];
|
|
}
|
|
|
|
return wantarray ? @{$self->{directories}} : $self->{directories};
|
|
}
|
|
|
|
|
|
### METHOD: filemap()
|
|
### Make a map of file paths to equivalent cvs path out of the multicvs
|
|
### configuration. Returns either a hash in list context or a hashref in scalar
|
|
### context.
|
|
sub filemap {
|
|
my $self = shift or confess "can't be used as a function";
|
|
|
|
unless ( $self->{filemap} ) {
|
|
my (
|
|
$from,
|
|
$to,
|
|
$cvsfile,
|
|
$livefile,
|
|
$selector,
|
|
%files,
|
|
);
|
|
|
|
# Process each path from the config
|
|
foreach my $path ( @{$self->{paths}} ) {
|
|
|
|
$self->debugmsg( ">>> Mapping files under $path->{from}...\n" );
|
|
|
|
# Calculate the fully-qualified source and destination paths
|
|
$from = "$self->{dir_cvs}/$path->{from}";
|
|
$to = "$self->{dir_live}/$path->{to}";
|
|
|
|
# Trim leading dot from destination
|
|
$to =~ s{/\.?/?$}{};
|
|
$from =~ s{/\.?/?$}{};
|
|
|
|
# Search the current directories for files.
|
|
if ( -d $from ) {
|
|
$self->debugmsg( "Adding files to the map from directory ${from} under ${to}\n" );
|
|
|
|
# Selector proc -- discards backups, saves good files.
|
|
$selector = sub {
|
|
my $name = $_;
|
|
$self->debugmsg( " Examining '$name' in '${File::Find::dir}'...\n" );
|
|
|
|
# Skip all but the first dot-dir
|
|
if ( $name ne '.' || $File::Find::dir ne $from ) {
|
|
|
|
# Prune garbage
|
|
if ( $name eq '..'|| $name =~ m{^\.\#|\bCVS\b|~$} ) {
|
|
$File::Find::prune = 1;
|
|
}
|
|
|
|
# Add the file to the map after fully-qualifying the
|
|
# paths.
|
|
else {
|
|
$cvsfile = "${File::Find::dir}/${name}";
|
|
( $livefile = $cvsfile ) =~ s{^$from}{$to}e;
|
|
$self->debugmsg( " Adding file from %s to map as %s\n",
|
|
$cvsfile, $livefile );
|
|
|
|
$files{ $livefile } = $cvsfile if -f $cvsfile;
|
|
}
|
|
}
|
|
};
|
|
|
|
# Now actually do the find
|
|
File::Find::find( {wanted => $selector, follow => 1}, $from );
|
|
}
|
|
|
|
# Plain file -- just look to see if it exists in the cvs dir, adding
|
|
# it if so, warning about it if not
|
|
else {
|
|
if ( -e $from ) {
|
|
$self->debugmsg( "Adding file ${from} to map as ${to}\n" );
|
|
$files{ $to } = $from;
|
|
} else {
|
|
warn "WARNING: $from doesn't exist under $self->{dir_cvs}\n"
|
|
unless $path->{optional};
|
|
}
|
|
}
|
|
}
|
|
|
|
# Cache the results
|
|
$self->{filemap} = \%files;
|
|
}
|
|
|
|
return wantarray ? %{$self->{filemap}} : $self->{filemap};
|
|
}
|
|
|
|
|
|
|
|
### METHOD: find_changed_files( [@files] )
|
|
### Returns a hash (or hashref in scalar context) of tuples describing changes
|
|
### which must be made to bring the cvs and live dirs into sync for the given
|
|
### I<files>, or for all files if no I<files> are given. Each entry in the hash
|
|
### is keyed by relative filename, and each value is a tuple (an arrayref) of
|
|
### the following form:
|
|
###
|
|
### { from => $from_path, type => $direction, to => $to_path }
|
|
###
|
|
### where I<from_path> is the path to the newer file, I<direction> is either
|
|
### C<c> for a file which is newer in CVS or C<l> for a file which is newer in
|
|
### the live tree, and I<to_path> is the path to the older file that should be
|
|
### replaced.
|
|
sub find_changed_files {
|
|
my $self = shift or confess "Cannot be called as a function";
|
|
|
|
my $filemap = $self->filemap;
|
|
my %tuples = ();
|
|
|
|
my (
|
|
$module,
|
|
$relfile,
|
|
$lfile,
|
|
$cfile,
|
|
$live_time,
|
|
$cvs_time,
|
|
);
|
|
|
|
# Iterate over the list of relative files, fully-qualifying them and then
|
|
# checking for up-to-dateness.
|
|
while ( ($lfile, $cfile) = each %$filemap ) {
|
|
|
|
# Get the name of the cvs module for this entry, as well as the relative
|
|
# path in the live site.
|
|
( $module = $cfile ) =~ s{(^$self->{dir_cvs}/|/.*)}{}g;
|
|
( $relfile = $lfile ) =~ s{^$self->{dir_live}/}{};
|
|
|
|
# Fetch timestamps
|
|
$live_time = -e $lfile ? (stat _)[9] : 0;
|
|
$cvs_time = -e $cfile ? (stat _)[9] : 0;
|
|
|
|
$self->debugmsg( "Comparing: %s -> %s (%s): %d -> %d\n",
|
|
$lfile, $cfile, $relfile, $live_time, $cvs_time );
|
|
|
|
# If either of them is newer, add an entry for it
|
|
if ( $live_time > $cvs_time ) {
|
|
$self->debugmsg( " Live was newer: adding " );
|
|
$tuples{ $relfile } = {
|
|
from => $lfile,
|
|
type => 'l',
|
|
module => $module,
|
|
to => $cfile,
|
|
live_time => $live_time,
|
|
cvs_time => $cvs_time,
|
|
diff => undef,
|
|
};
|
|
} elsif ( $cvs_time > $live_time ) {
|
|
$tuples{ $relfile } = {
|
|
from => $cfile,
|
|
type => 'c',
|
|
module => $module,
|
|
to => $lfile,
|
|
live_time => $live_time,
|
|
cvs_time => $cvs_time,
|
|
diff => undef,
|
|
};
|
|
}
|
|
}
|
|
|
|
return wantarray ? %tuples : \%tuples;
|
|
}
|
|
|
|
|
|
### METHOD: find_init_files( [@files] )
|
|
### Like find_changed_files(), but assumes that none of the given I<files> are
|
|
### extant on the live side (for --init).
|
|
sub find_init_files {
|
|
my $self = shift or confess "Cannot be called as a function";
|
|
|
|
my $filemap = $self->filemap;
|
|
my %tuples = ();
|
|
|
|
my (
|
|
$module,
|
|
$relfile,
|
|
$lfile,
|
|
$cfile,
|
|
$cvs_time,
|
|
);
|
|
|
|
while ( ($lfile, $cfile) = each %$filemap ) {
|
|
( $relfile = $cfile ) =~ s{^$self->{dir_cvs}/}{};
|
|
( $module = $relfile ) =~ s{/.*}{};
|
|
|
|
# Fetch the mtime of the cvs file
|
|
$cvs_time = -e $cfile ? (stat _)[9] : 0;
|
|
|
|
# Add an entry for every file
|
|
$tuples{ $lfile } = {
|
|
from => $cfile,
|
|
type => 'c',
|
|
module => $module,
|
|
to => $lfile,
|
|
live_time => 0,
|
|
cvs_time => $cvs_time,
|
|
};
|
|
}
|
|
|
|
return wantarray ? %tuples : \%tuples;
|
|
}
|
|
|
|
|
|
# :TODO: This should really use Text::Diff or something instead of doing a bunch
|
|
# of forked reads...
|
|
|
|
### METHOD: get_diffs( \@options, @files )
|
|
### Given one or more tuples like those returned from find_changed_files(),
|
|
### return a list of diffs the diffs for each one.
|
|
sub get_diffs {
|
|
my $self = shift or confess "Cannot be called as a function";
|
|
my $options = ref $_[0] eq 'ARRAY' ? shift : [];
|
|
|
|
my @files = @_;
|
|
my @diffs = ();
|
|
my $diff = undef;
|
|
|
|
$self->debugmsg( "In get_diffs" );
|
|
|
|
foreach my $tuple ( @files ) {
|
|
|
|
# Reuse cached diffs
|
|
if ( $tuple->{diff} ) {
|
|
push @diffs, $tuple->{diff};
|
|
}
|
|
|
|
# Regular diff
|
|
elsif ( -e $tuple->{from} && -e $tuple->{to} ) {
|
|
$self->debugmsg( "Forking for real diff on $tuple->{from} -> $tuple->{to}" );
|
|
$diff = $self->forkread( 'diff', @$options,
|
|
$tuple->{to}, $tuple->{from} );
|
|
$self->debugmsg( "Read diff: '", $diff, "'" );
|
|
$tuple->{diff} = $diff;
|
|
push @diffs, $diff;
|
|
}
|
|
|
|
# Simulate a diff for a new file
|
|
else {
|
|
$self->debugmsg( "Diff for new file $tuple->{from}" );
|
|
$diff = sprintf " >>> New File <<<\n%s\n\n", $self->readfile( $tuple->{from} );
|
|
$self->debugmsg( "Read diff: '", $diff, "'" );
|
|
$tuple->{diff} = $diff;
|
|
push @diffs, $diff;
|
|
}
|
|
}
|
|
|
|
return @diffs;
|
|
}
|
|
|
|
|
|
### METHOD: readfile( $file )
|
|
### Return the specified file in and return it as a scalar.
|
|
sub readfile {
|
|
my $self = shift or confess "cannot be used as a function";
|
|
my $filename = shift;
|
|
|
|
local $/ = undef;
|
|
open( my $ifh, $filename, O_RDONLY ) or
|
|
croak "open: $filename: $!";
|
|
my $content = <$ifh>;
|
|
|
|
return $content;
|
|
}
|
|
|
|
|
|
### METHOD: forkread( $cmd, @args )
|
|
### Fork and exec the specified I<cmd>, giving it the specified I<args>, and
|
|
### return the output of the command as a list of lines.
|
|
sub forkread {
|
|
my $self = shift or confess "Cannot be used as a function";
|
|
my ( $cmd, @args ) = @_;
|
|
|
|
my (
|
|
$fh,
|
|
@lines,
|
|
$pid,
|
|
);
|
|
|
|
# Fork-open and read the child's output as the parent
|
|
if (( $pid = open($fh, "-|") )) {
|
|
@lines = <$fh>;
|
|
$fh->close;
|
|
}
|
|
|
|
# Child - capture output for diagnostics and progress display stuff.
|
|
else {
|
|
die "Couldn't fork: $!" unless defined $pid;
|
|
|
|
open STDERR, ">&STDOUT" or die "Can't dup stdout: $!";
|
|
{ exec $cmd, @args };
|
|
|
|
# Only reached if the exec() fails.
|
|
close STDERR;
|
|
close STDOUT;
|
|
exit 1;
|
|
}
|
|
|
|
return wantarray ? @lines : join( '', @lines );
|
|
}
|
|
|
|
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
# Local Variables:
|
|
# mode: perl
|
|
# c-basic-indent: 4
|
|
# indent-tabs-mode: nil
|
|
# End:
|