svn.pm #2

package VCP::Utils::svn ;

=head1 NAME

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

=head1 SYNOPSIS

   use VCP::Utils::svn ;

=head1 DESCRIPTION

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

=for test_scripts t/90revml2svn.t t/91svn2revml.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 shell_quote );
use VCP::Logger qw( BUG pr lg );
use File::Spec ;
use File::Temp qw( mktemp ) ;
use POSIX ":sys_wait_h" ;

=head1 METHODS

=over

=item svn

Calls the svn command with the appropriate svnroot option.

=cut

sub svn {
   my $self = shift ;

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


   my @args;

   my @in_args = @{shift()};

   my $is_not_interactive = 
       0+grep 0 <= index( "|add|help|--version|", "|$_|" ), @in_args;

   unless ( $is_not_interactive ) {
      push @args, "--non-interactive"
         unless $is_not_interactive;

      push @args, "--username", $self->repo_user
         unless empty $self->repo_user;

      push @args, "--password", $self->repo_password
         unless empty $self->repo_password;
   }

   return $self->run_safely( [ "svn", @args, @in_args ], @_ ) ;
}

=item svnadmin

Calls the svnadmin command with the appropriate svnroot option.

=cut

sub svnadmin {
   my $self = shift ;

   my @args = @{shift()} ;

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

=item parse_svn_repo_spec

This handles the SVN repo spec, which always has a second colon
after the URI scheme: svn:file:///foo/bar:/path/to/module

=cut

sub parse_svn_repo_spec {
   my $self = shift;

   my ( $spec ) = @_;

   my $uri_scheme;
   $uri_scheme = $2
      if $spec =~ s{\A(.*?:(?:[^:]*(?::[^:]*)?\@)?)((?:file|svn|http)[^:]*:)([^:]*):?}{$1$3:};
   $self->parse_repo_spec( $spec );

   $self->repo_server( $uri_scheme . $self->repo_server )
       if defined $uri_scheme;

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

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


=item create_svn_workspace

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

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

=cut

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

   ## establish_workspace in a directory named "co" for "checkout". This is
   ## so that VCP::Source::svn 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.
   my $module = $self->repo_filespec;
   die "vcp: empty svn module spec\n"
      if empty $module ;
   $module =~ s{[\\/]+[^\\/]*(?:\.\.\.|[*\\?[].*)}{};

   my @expect_cannot_find_module = (
      stderr_filter => qr/svn: URL .* doesn't exist.*\n/,
      ok_result_codes => [0,1],
   );

   my $source_uri = $self->repo_server . $module;

   ## TODO: use the oldest revision here?

   my $info = $self->get_svn_path_info( $source_uri, "HEAD" );
   $self->{SVN_URL_IS_FILE} = ( $info->{kind} || "" ) eq "file";

   $source_uri =~ s{[\\/][^\\/]*\z}{}g if $self->{SVN_URL_IS_FILE};

   my $dest_dir = $self->tmp_dir( "co" );

   pr "\$ svn ... checkout $source_uri $dest_dir # establish local svn workspace";
   $self->svn(
      [ "checkout", $source_uri, $dest_dir ],
      {
         $options{create_in_repository}
            ? @expect_cannot_find_module
            : ()
      }
   ) ;

   ## Create the directory and any intermediate directories.  First
   ## figure out which already exist, then create all the remaining
   ## ones in a single commit.

   if ( $self->command_result_code == 1 ) {
      pr "$source_uri not found.";
      my @dirs = File::Spec->splitdir( $module );
      shift @dirs while @dirs && !length $dirs[0];
      pop   @dirs while @dirs && !length $dirs[-1];
      my @paths_to_create;
      my $base_uri = $self->repo_server;
      while ( @dirs ) {
         my $dir = $dirs[0];
         my $abs_dir = "$base_uri/$dir";
         $self->svn( [ "ls", $abs_dir ], \undef, \my $stdout, \my $stderr, {
            ok_result_codes => [0,1],
         } );
         if ( $self->command_result_code != 0 ) {
            last;
         }
         shift @dirs;
      }

      BUG "No directories to create" unless @dirs;
      my $prev = $base_uri;
      $prev = $_ = "$prev/$_" for @dirs;

      pr "\$ svn ... mkdir $source_uri   # create dest dir in repository";
      $self->svn(
         [
            "mkdir",
            "-m",
            "VCP destination directory creation",
            @dirs
         ]
      );

      pr "\$ svn ... checkout $source_uri, $dest_dir # establish local svn workspace";
      $self->svn( [ "checkout", $source_uri, $dest_dir ] ) ;
   }

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


=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 svn'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];
}


=item get_svn_path_info

Runs svn info for a particular revision.

=cut

sub get_svn_path_info {
   my $self = shift ;
   my ( $url, $revision, $recursive ) = @_;

   local $self->{_SVN_INFO_RECURSIVE} = $recursive;

   my @cmd = ( "svn", "info",
      $recursive ? "-R" : (),
      "--xml",
      "$url\@$revision"
   );
   my $cmd = join " ", shell_quote @cmd;

   local $self->{_SNV_INFO};

   my $p = XML::Parser->new(
      Handlers => {
         Start => sub {
	    my $expat = shift ;
	    my $tag = shift ;

            my $meth = "start_info_$tag";
            $self->$meth( @_ ) if $self->can( $meth );
	 },

	 End => sub {
	    my $expat = shift ;
	    my $tag = shift ;

            $self->{SVN_INFO_TEXT} = undef;

            my $meth = "end_info_$tag";
            $self->$meth( @_ ) if $self->can( $meth );
	 },

	 Char => sub {
	    my $expat = shift ;
            ${$self->{SVN_INFO_TEXT}} .= shift if $self->{SVN_INFO_TEXT};
             
         }
      },
   ) ;
   lg "\$ $cmd";
   $p->parsefile( "$cmd |" );

   ## Get the hash out of _SVN_INFO do the local() above doesn't rewrite it
   ## upon return.
   my $s = $self->{_SVN_INFO};
   $self->{_SVN_INFO} = undef;
   return $s;
}


sub start_info_entry {
   my $self = shift;
   my %attrs = @_;
   $self->{SVN_INFO_ENTRY} = \%attrs;
}


sub end_info_entry {
   my $self = shift;
   my %attrs = @_;

   my $e = $self->{SVN_INFO_ENTRY};
   $self->{SVN_INFO_ENTRY} = undef;

   return unless $e->{kind} eq "file";

   $e->{path} =~ s{\\+}{/}g;
   $e->{path} =~ s{^/+}{};
   if ( $self->{_SVN_INFO_RECURSIVE} ) {
      $self->{_SVN_INFO}->{$e->{path}} = $e;
   }
   else {
      $self->{_SVN_INFO} = $e;
   }
}


=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 ;