cvs.pm #1

package VCP::Utils::cvs ;

=head1 NAME

VCP::Utils::cvs - utilities for dealing with the cvs command

=head1 SYNOPSIS

   use VCP::Utils::cvs ;

=head1 DESCRIPTION

A mix-in class providing methods shared by VCP::Source::cvs and VCP::Dest::cvs,
mostly wrappers for calling the cvs command.

=for test_scripts t/90revml2cvs.t t/91cvs2revml.t

=cut

@EXPORT_OK = qw( RCS_check_tag RCS_underscorify_tag );
@ISA = qw( Exporter );
use Exporter;

use strict ;

use Carp ;
use VCP::Debug qw( :debug :profile ) ;
use VCP::Utils qw( empty start_dir_rel2abs is_win32 );
use VCP::Logger qw( pr );
use File::Spec ;
use File::Temp qw( mktemp ) ;
use POSIX ":sys_wait_h" ;

=head1 METHODS

=over

=item cvs

Calls the cvs command with the appropriate cvsroot option.

=cut

sub cvs {
   my $self = shift ;

   my $cvs_command = "";
   if ( profiling ) {
      profile_group ref( $self ) . " cvs ";
      for( @{$_[0]} ) {
         unless ( /^-/ ) {
            $cvs_command = $_;
            last;
         }
      }
   }
   local $VCP::Debug::profile_category = ref( $self ) . " cvs $cvs_command"
      if profiling;


   my @args = @{shift()} ;

   unshift @args, "-d" . $self->cvsroot
      if defined $self->repo_server;

   return $self->run_safely( [ qw( cvs -Q -z9 ), @args ], @_ ) ;
}

=item parse_cvs_repo_spec

This handles ":pserver:"-like type repository specs specially, defaulting to
normal processing if the scheme is not followed by something like "foo".  The
username and password are parsed out of the spec

If the first colon is followed by a colon, like

   cvs::pserver:user@server/foo:bar

, then the special processing kicks in and the spec is parsed accordingly.
Everything up to and including the first colon and starting with the last colon
are stripped, just like with L<normal specs|VCP::Plugin/parse_repo_spec>, and
the remainder becomes the CVSROOT.  This does have the side effect of
plaintexting the password in various CVS places (like the local CVS directories
and the command lines that VCP forks to launch CVS).  Let me know if you need
this changed.

=cut

sub parse_cvs_repo_spec {
   my $self = shift;

   my ( $spec ) = @_;

   unless ( $spec =~ /\A\w+::/ ) {
      $self->parse_repo_spec( @_ );
   }
   else {
      my ( $scheme, $cvs_root, $filespec ) = ( $spec =~ /\A([^:]*):(.*):([^:]*)\z/ )
         or die "Can't parse CVS remote file spec '$spec'\n";


      $self->repo_scheme( $scheme );
      $self->repo_server( $cvs_root );
      $self->repo_filespec( $filespec );
   }

   my $filespec = $self->repo_filespec;
   $filespec =~ s(/{2,})(/)g;
   $filespec =~ s(\\{2,})(\\)g;
   $self->repo_filespec( $filespec );

  debug "parsed '$spec' as",
      " scheme=", $self->repo_scheme,
      " server=", $self->repo_server,
      " filespec=", $self->repo_filespec
      if debugging;

   die "parse_cvs_repo_spec does not return a result" if defined wantarray;
}

=item cvsroot

Returns the specced cvsroot if set, or $ENV{CVSROOT} if not.

While $ENV{CVSROOT} must be an absolute path if it's local (to be
completely consistent with the cvs command), the path repo_server value,
if set, may be relative (unless it begins with a ':', which indicates a
non-local path).

=cut

sub cvsroot {
   my $self = shift;
   my $root = $self->repo_server;

   ( ! empty $root )
      ? substr( $root, 0, 1 ) eq ":"
         ? $root                         ## Remote repo
         : do {       ## local repo.
            $root = start_dir_rel2abs $root;

            ## The slashes need to be left-leaning or CVS misinterprets
            ## "-d C:/foo/bar" as an rsh CVSROOT spec
            $root =~ s{/}{\\}g if is_win32;
            $root;
         }
      : $ENV{CVSROOT};
}


=item create_cvs_workspace

    $self->create_cvs_workspace;
    $self->create_cvs_workspace( create_in_repository => 1 );

Creates a temp dir named "co" for C<cvs> to work in, checks out the module
there, and sets the work root and cvs working dir to that directory.

=cut

sub create_cvs_workspace {
   my $self = shift ;
   my %options = @_;

   ## establish_workspace in a directory named "co" for "checkout". This is
   ## so that VCP::Source::cvs can use a different directory to contain
   ## the revs, since all the revs need to be kept around until the VCP::Dest
   ## is through with them.
   $self->command_chdir( $self->tmp_dir( "co" ) ) ;
   my $module = $self->repo_filespec;
   die "vcp: empty cvs module spec\n"
      if empty $module ;
   $module =~ s{[\\/]+[^\\/]*(?:\.\.\.|[*\\?[].*)}{};

   ## cvs login if needed
   if ( ( $self->repo_server || "" ) =~ /^:([^:]+):([^:]*)(?::([^:]*))?\@/ ) {
      my ( $protocol, $username, $password ) = ( $1, $2, $3 );

      ## Only do a cvs login if the password is not present; "" is
      ## ok (think anonymous access)
      if ( $protocol eq "pserver" && !defined $password ) {
         pr "\$ cvs login   # for '$username'";
         $self->cvs( ["login"], undef, undef, \*STDERR );
      }
   }

   my @expect_cannot_find_module = (
      stderr_filter => qr/cvs checkout: cannot find module .*\n/,
      ok_result_codes => [0,1],
   );

   pr "\$ cvs ... checkout $module   # establish local CVS workspace";

   $self->cvs(
      [ "checkout", $module ],
      {
         $options{create_in_repository}
            ? @expect_cannot_find_module
            : ()
      }
   ) ;

   if ( $self->command_result_code == 1 ) {
      pr "cvs checkout failed.  Missing module?";
      pr "\$ cvs import ... $module   # create module in repository";

      my $empty_dir = $self->tmp_dir( "empty_dir" );
      $self->mkdir( $empty_dir );
      $self->cvs(
         [
            "import",
            "-m",
            "VCP destination module creation",
            $module,
            "vcp",
            "start"
         ]
      );

      pr "\$ cvs ... checkout $module   # establish local CVS workspace";
      $self->cvs( [ "checkout", $module ] ) ;
   }

   $self->work_root( $self->tmp_dir( "co" ) ) ;
}


=item RCS_check_tag

    RCS_check_tag $tag1, ...;

Checks a list of tags for legality, die()s if it's not legal.  Named after the
corresponding routine in CVS's rcs.c source file.

No clue how this interacts with your locale.

=cut

sub RCS_check_tag {
   my @errors;
   for ( @_ ) {
      if ( /\A[^a-zA-Z]/ ) {
         push @errors, "RCS tag '$_' must start with a letter\n";
      }
      elsif ( /([[:^graph:]])/ ) {
         push @errors,
            sprintf "RCS tag '%s' must not contain \\0x%02x\n", $_, ord $1;
      }
      elsif ( /(["\$,.:;\@])/ ) {
         push @errors, "RCS tag '$_' must not contain '$1'\n"
      }
   }

   die @errors if @errors;
}


=item RCS_underscorify_tag

    @tags = RCS_check_tag $tag1, ...;

Modifies a list of tags, replacing illegal characters with
underscores.  This may lead to tag collisions, but it should be ok
for most uses.

Converts something like "a@" to "a_AF_".  Not a guaranteed solution,
but good enough for now.

=cut

sub RCS_underscorify_tag {
   my @out = @_;
   for ( @out ) {
      s/(["\$,.:;\@[:^graph:]])/sprintf( "_%02x_", ord $1 )/ge;
      s/\A([^a-zA-Z])/tag_$1/;
   }

   wantarray ? @out : @out > 1 ? Carp::confess "Returning multiple tags in scalar context" : $out[0];
}


=back

=head1 COPYRIGHT

Copyright 2000, Perforce Software, Inc.  All Rights Reserved.

This module and the VCP package are licensed according to the terms given in
the file LICENSE accompanying this distribution, a copy of which is included in
L<vcp>.

=cut

1 ;