vcp #7

#!/usr/local/bin/perl -w

=head1 NAME

vcp - Copy versions of files between repositories and/or RevML

=head1 SYNOPSIS

   vcp [vcp_opts] src[:files] [src_opts] [dest:[<location>]] [dest_opts]

   vcp cvs:/mymodule/... -r 1.1: p4://depot/mymodule
   vcp p4://depot/mainbranch/...@100-105 revml:
   vcp help
   vcp revml: --dtd <foo.dtd> --save_dtd

=head1 STATUS

Alpha code.  Please report bugs to revml@perforce.com.

=head1 DESCRIPTION

vcp ('version copy') copies versions and version ranges of files from
one repository to another, translating as much as possible along the
way.

This allows you to copy and translate ranges of revisions of files
between different vendors' revision storage systems.

Inputs and output classes currently available are:

   Class    Source     Destination
   cvs        x            x
   p4         x            x
   revml      x            x

The general syntax of the vcp command line is:

   vcp [vcp_opts] <source> [src_opts] <dest> [dest_opts]

where C<E<lt>sourceE<gt>> and C<E<lt>destE<gt>> are composed of fields
separated by delimiters like so:

   scheme:user(view):password@server:filespec

where

   scheme is a repository type ('p4', 'cvs', 'revml'), or special
      command ('help', 'save_dtd').

   user, view, and password are optional values, one or more of
      which may be required for repository access.  CVS does not
      use (view).  For p4, (view) is the client setting
      (P4CLIENT or -c option).

   server is the repository spec, CVSROOT for CVS or P4PORT for p4.

   filespec is the file specification for the files to move.  As
      much as possible, this spec is similar to the native filespecs
      used by the repository indicated by the scheme.

Most C<E<lt>sourceE<gt>> and C<E<lt>destE<gt>> specs will omit one or more of
the fields.  For instance, Filespecs or passwords are often omitted from the
destination, in which case the leading colons for these fields are also
optional. If no user, view, or password is supplied, the "@" is optional.

That's a bit confusing, here are some examples of stripped-down specs:

   cvs:server:/foo
   p4:user@server://depot/foo/...
   p4:user:password@public.perforce.com:1666://depot/foo/...

Options and formats for of individual schemes can be found in the relevant
manpages:

L<VCP::Source::cvs>, L<VCP::Source::p4>, L<VCP::Source::revml>,
L<VCP::Dest::cvs>, L<VCP::Dest::p4>, L<VCP::Dest::revml>.

At some point, the help command will be extended to be able to display them.

=head2 OPTIONS

All general options to vcp must precede the first scheme.  Scheme-specific
options must come after the affected source or destination spec and before the
next one.

=over

=item --debug [spec], -d [spec]

Enables display of debugging information.  Default is to enable all debugging
if no spec is provided.  A debug spec is part or all of a module name like
C<source::revml> or a shell-like regular expression to be compared to a module
name.  All are compared case insensitively. The most general,
show-me-everything debug option is:

   -d "*"

The quotations are needed to slip the "*" past most command shells.

Any debug specs that don't match anything during a run are printed out
when vcp exits in order to help identify mispelled patterns.  vcp will also list
all of the internal names that didn't match during a run to
give clues as to what specs might be useful.

The special name 'what' is guaranteed to not match anything, so you can
do

   vcp -d what ...

to see the list of names that might be useful for the arguments '...' .

You may use multiple
C<-d> options or provide a comma separated list to enable debugging
within that module. Do not start a pattern with a "-".

Debugging messages are emitted to stderr. See L</VCPDEBUG> for how to specify
debug options in the environment.

=item --help, -h, -?

These are all equivalent to C<vcp help>.

=back

=head1 ARGUMENTS

There are two special schemes, "help" and "save_dtd".

=over

=item help

Displays the full help text.  This will be extended to allow the retrieval of
all of the manpages provided with VCP.

=item save_dtd [<how>]

This is primarily for vcp maintainers.

Outputs the DTD to stdout if <how> is C<->, or to a file named like
v1_000.pm if <how> looks like a version number, or in a module named
after <how> if <how> contains '::'.  This file is placed in
./lib/RevML/DTD or ./RevML/DTD or ./, whichever is found first.  No
directories will be created.

=back

=head1 ENVIRONMENT

The environment is often used to set context for the source and destination
by way of variables like P4USER, P4CLIENT, CVSROOT, etc.

There is also one environment variable that is used to enable
command line debugging.  The VCPDEBUG variable acts just like a leading
"-d=$VCPDEBUG" was present on the command line.

   VCPDEBUG=main,p4

(see L</--debug, -d> for more info).  This is useful when VCP is embedded in
another application, like a makefile or a test suite.

=cut

use strict ;

use Getopt::Long ;
use File::Basename ;
use File::Spec ;
use VCP ;
use VCP::Debug qw( :debug ) ;
use XML::Doctype ;


{
   my $pname = basename( $0 ) ;
   my $dtd_spec ;
   my $arg = 'help' ;

   usage_and_exit() unless @ARGV ;

   enable_debug( split /,/, $ENV{VCPDEBUG} ) if defined $ENV{VCPDEBUG} ;

   ## Parse up to the first non-option, then let sources & dests parse
   ## from there.
   Getopt::Long::Configure( qw( no_auto_abbrev no_bundling no_permute ) ) ;
   GetOptions(
      'debug|d=s'   => sub {
         enable_debug( length $_[1] ? split /,/, $_[1] : () )
      },
      'help|h|?'    => \&help_and_exit,
      'versions'    => \&versions_and_exit,
   ) or options_and_exit() ;

   usage_and_exit() unless @ARGV ;

   $arg = shift ;

   help_and_exit() if $arg eq 'help' ;

   my @errors ;

   ## We pass \@ARGV to the constructors for source and dest so that
   ## they may parse some of @ARGV and leave the rest.  Actually, that's
   ## only important for sources, since the dests should consume it all
   ## anyway.  But, for consistency's sake, I do the same to both.

   my $source ;
   if ( defined $arg ) {
      my ( $scheme, $spec ) = $arg =~ /^(.*?)(?::(.*))?$/ ;
      if ( defined $spec && ! length $spec
         && @ARGV
	 && ( $ARGV[0] eq '-' || substr( $ARGV[0], 0, 1 ) ne '-' )
	 && index( $ARGV[0], ':' ) < 0
      ) {
         $spec = shift ;
      }

      $spec = defined $spec ? "$scheme:$spec" : $scheme ;
      eval {
	 $source = load_module( "VCP::Source::$scheme", $spec, \@ARGV );
	 die "unknown source scheme '$scheme', try ",
	    list_modules( "VCP::Source" ), "\n"
	    unless defined $source ;
      } ;

      push @errors, $@ if $@ ;
   }

   my $dest ;
   if ( defined $source ? $source->dest_expected : @ARGV ) {
      my $scheme ;
      my $spec = '' ;
      if ( @ARGV ) {
	 ( $scheme, $spec ) = shift =~ /^(.*?)(?::(.*))?$/ ;
	 if ( defined $spec && ! length $spec
	    && @ARGV
	    && ( $ARGV[0] eq '-' || substr( $ARGV[0], 0, 1 ) ne '-' )
	    && index( $ARGV[0], ':' ) < 0
	 ) {
	    $spec = shift ;
	 }
      }
      else {
	 $scheme = 'revml' ;
      }

      $spec = defined $spec ? "$scheme:$spec" : $scheme ;
      eval {
	 $dest = load_module("VCP::Dest::$scheme", $spec, \@ARGV );
	 die "unknown destination scheme '$scheme', try ",
	    list_modules( "VCP::Dest" ), "\n"
	    unless defined $dest ;
      } ;
      push @errors, $@ if $@ ;
      @ARGV = () ;
   }
   elsif ( @ARGV ) {
      push @errors, "extra parameters: " . join( ' ', @ARGV ) . "\n" ;
   }

   if ( debugging ) {
      debug 'vcp: no dest expected' unless ! $source || $source->dest_expected ;
      debug 'vcp: $source is ', $source ;
      debug 'vcp: $dest   is ',   $dest ;
   }

   unless ( @errors ) {
      my $cp = VCP->new( $source, $dest ) ;
      my $header = {} ;
      my $footer = {} ;
      $cp->copy_all( $header, $footer ) ;
   }

   if ( @errors ) {
      my $errors = join( '', @errors ) ;
      $errors =~ s/^/$pname: /mg ;
      die $errors ;
   }

}

###############################################################################
###############################################################################

sub load_module {
   my ( $name, @args ) = @_ ;

   my $filename = $name ;
   $filename =~ s{::}{/}g ;

   my $x ;
   {
      local $@ ;
      my $v = eval "require '$filename.pm'; 1" ;
      return undef if $@ && $@ =~ /^Can't locate $filename.pm/ ;
      $x = $@ ;
   }
   die $x if $x ;

   debug "vcp: loaded '$name' from '", $INC{"$filename.pm"}, "'"
      if debugging 'main', $name ;
   return $name->new( @args ) ;#if $v == 1 ;
}


sub list_modules {
   my ( $prefix ) = @_ ;

   my $dirname = $prefix . '::' ;
   $dirname =~ s{(::)+}{/}g ;

   my %seen ;
   for ( @INC ) {
      my $dir = File::Spec->catdir( $_, $dirname ) ;
      opendir( D, $dir ) or next ;
      my @files = grep $_ !~ /^\.\.?$/ && s/\.pm$//, readdir D ;
      closedir D ;
      $seen{$_} = 1 for @files ;
   }

   my $list = join( ', ', map "$_:", sort keys %seen ) ;

   $list =~ s/,([^,]*)$/ or$1/ ;
   return $list ;
}


sub usage_and_exit {
   require Pod::Usage ;
   Pod::Usage::pod2usage( -message => shift, -verbose => 0, -exitval => 1 ) ;
}

sub options_and_exit {
   require Pod::Usage ;
   Pod::Usage::pod2usage( -verbose => 1, -exitval => 1 ) ;
}

sub help_and_exit {
   require Pod::Usage ;
   Pod::Usage::pod2usage( -verbose => 2, -exitval => 0 ) ;
}


sub versions_and_exit {
   require File::Find ;

   my $require_module = sub {
      return unless m/\.pm$/ ;
      ## Avoid "name used only once" warning
      my $fn = $File::Find::name ;
      $fn = $File::Find::name ;
      require $fn ;
   } ;

   File::Find::find(
      {
         no_chdir => 1,
	 wanted   => $require_module,
      },
      grep -d $_,
      map {
         ( File::Spec->catdir( $_, "lib", "VCP", "Source" ),
         File::Spec->catdir( $_, "lib", "VCP", "Dest" ),
	 ) ;
      } @INC
   ) ;

   my %vers ;
   my %no_vers ;

   my $recur ;
   $recur = sub {
      my ( $pkg_namespace ) = @_ ;

      no strict "refs" ;

      my $pkg_name = substr( $pkg_namespace, 0, -2 ) ;

      ## The grep means "only bother with namespaces that contain somthing
      ## other than child namespaces.
      if ( ! grep /::/, keys %{$pkg_namespace} ) {
         if ( exists ${$pkg_namespace}{VERSION} ) {
	    $vers{$pkg_name} = ${"${pkg_namespace}VERSION"}
	 }
	 else {
	    $no_vers{$pkg_name} = undef ;
	 }
      }

      my $prefix = $pkg_namespace eq "main::" ? "" : $pkg_namespace ;
      for ( keys %{$pkg_namespace} ) {
	 next unless /::$/ ;
	 next if /^main::/ ;
	 $recur->( "$prefix$_" ) ;
      }
   } ;

   $recur->( "main::" ) ;

   my $max_len = 0 ;
   $max_len = length > $max_len ? length : $max_len for keys %vers ;
      
   print "Package \$VERSIONs:\n" ;
   for ( sort keys %vers ) {
      printf(
         "   %-${max_len}s: %s\n",
	 $_,
	 defined $vers{$_} ? $vers{$_} : "undef"
      ) ;
   }

   print "No \$VERSION found for: ", join( ", ", sort keys %no_vers ), "\n" ;

   $max_len = 0 ;
   $max_len = length > $max_len ? length : $max_len for values %INC ;
   print "\nFile sizes:\n" ;
   for ( sort values %INC ) {
      printf( "   %-${max_len}s: %7d\n", $_, -s $_ ) ;
   }

   print "\nperl -V:\n" ;

   my $v = `$^X -V` ;
   $v =~ s/^/   /gm ;
   print $v ;

   exit ;
}

=head1 AUTHOR

Barrie Slaymaker <barries@slaysys.com>

=head1 COPYRIGHT

This program is licensed under the provisions of the BSD license:

      Copyright (c) 2000, 2001, Perforce Software, Inc.
      All rights reserved.

      Redistribution and use in source and binary forms, with or without
      modification, are permitted provided that the following conditions are
      met:

	   - Redistributions of source code must retain the above copyright
	     notice, this list of conditions and the following disclaimer. 
	   - Redistributions in binary form must reproduce the above copyright
	     notice, this list of conditions and the following disclaimer in
	     the documentation and/or other materials provided with the
	     distribution. 
	   - Neither the name of the Perforce Software, Inc.nor the names of
	     its contributors may be used to endorse or promote products
	     derived from this software without specific prior written
	     permission. 

      THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS
      AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED
      WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
      WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
      PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL
      THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT,
      INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
      CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
      PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF
      USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
      HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
      WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
      NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE
      USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY
      OF SUCH DAMAGE.

This notice is also included in the LICENSE file accompanying this
distribution, which also must be retained in redistributions.

=cut