svncopy.pl.in

subversion-1.4.3-1.tar.gz 配置svn的源码

    }
  return "$destination/$subdir";
}


#------------------------------------------------------------------------------
# Function:    UpdateExternals
#
# Updates the svn:externals in the tree according to the --pin-externals or
# --update_externals options.
#
# Parameters:
#       sourceref   Ref to the URLs to copy from
#       destination The URL being copied to
#       work_dir    The working directory
#       msgref      Ref to message string to update with changes
#
# Returns:     1 on success
#------------------------------------------------------------------------------
sub UpdateExternals
{
  my ( $sourceref, $destination, $work_dir, $msgref ) = @_;
  my @commandline = ();
  my $msg;
  my @dirfiles;
  my %extlist;

  # Check the externals on this directory and subdirectories
  info( "Checking '$work_dir'\n" );
  %extlist = GetRecursiveExternals( $work_dir );
    
  # And do the update
  while ( my ( $subdir, $exts ) = each ( %extlist ) )
    {
      my @externals = @$exts;
      if ( scalar( @externals ) )
        {
          UpdateExternalsOnDir( $sourceref, $destination, $subdir, $msgref, \@externals );
        }
    }
  
  return 1;
}


#------------------------------------------------------------------------------
# Function:    UpdateExternalsOnDir
#
# Updates the svn:externals in the tree according to the --pin-externals or
# --update_externals options.
#
# Parameters:
#       sourceref   Ref to the URLs to copy from
#       destination The URL being copied to
#       work_dir    The working directory
#       externals   Ref to the externals on the directory
#       msgref      Ref to message string to update with changes
#
# Returns:     1 on success
#------------------------------------------------------------------------------
sub UpdateExternalsOnDir
{
  my ( $sourceref, $destination, $work_dir, $msgref, $externalsref ) = @_;
  my @sources = @$sourceref;
  my @externals = @$externalsref;
  my @new_externals;
  my %changed;
    
  # Do any updating required
  foreach my $external ( @externals )
    {
      chomp( $external );
      next unless ( $external =~ m"^(\S+)(\s+)(?:-r\s*(\d+)\s+)?(.*)" );
      my ( $ext_dir, $spacing, $ext_rev, $ext_val ) = ( $1, $2, $3, $4 );
            
      info( " - Found $ext_dir => '$ext_val'" );
      info( " ($ext_rev)" ) if $ext_rev;
      info( "\n" );
        
      $externals_hash{ "$ext_val" } = $ext_rev;
        
      # Only update if it's not pinned to a version
      if ( !$ext_rev )
        {
          if ( $update_externals )
            {
              my $old_external = $external;
              foreach my $source ( @sources )
                {
                  my $dest_dir = DestinationSubdir( $source, $destination );
                  #info( "Checking against '$source'\n" );
                  if ( $ext_val =~ s|^$source|$dest_dir| )
                    {
                      $external = "$ext_dir$spacing$ext_val";
                      info( " - updated '$old_external' to '$external'\n" );
                      $changed{$old_external} = $external;
                    }
                }
            }
          elsif ( $pin_externals )
            {
              # Find the last revision of the destination and pin to that.
              my $old_external = $external;
              my $rev = LatestRevision( $ext_val, $revision );
              #info( "Pinning '$ext_val' to '$rev'\n" );
              $external = "$ext_dir -r $rev$spacing$ext_val";
              info( " - updated '$old_external' to '$external'\n" );
              $changed{$old_external} = $external;
            }
        }
      push( @new_externals, $external );
    }

  # And write the changes back
  if ( scalar( %changed ) )
    {
      # Update the commit log message
      my %info = SVNInfo( $work_dir );
      $$msgref .= "\n * $info{URL}: update svn:externals\n";
      while ( my ( $old, $new ) = each( %changed ) )
        {
          $$msgref .= "   from '$old' to '$new'\n";
          info( "   '$old' => '$new'\n" );
        }

      # And set the new externals
      my ($handle, $tmpfile) = tempfile( DIR => $temp_dir );
      print $handle join( "\n", @new_externals );
      close($handle);
      SVNCall( "propset", "--file", $tmpfile, "svn:externals", $work_dir );
    }
}


#------------------------------------------------------------------------------
# Function:    GetRecursiveExternals
#
# This function retrieves the svn:externals value from the
# specified URL or location and subdirectories.
#
# Parameters:
#       location      location of SVN object - file/dir or URL.
#
# Returns:     hash
#------------------------------------------------------------------------------
sub GetRecursiveExternals
{
  my ( $location ) = @_;
  my %retval;
  my $externals;
  my $subdir = ".";
    
  my ( $status, @externals ) = SVNCall( "propget", "-R", "svn:externals", $location );
    
  foreach my $external ( @externals )
    {
      chomp( $external );

      if ( $external =~ m"(.*) - (.*\s.*)" )
        {
          $subdir = $1;
          $external = $2;
        }

      push( @{$retval{$subdir}}, $external ) unless $external =~ m"^\s*$";
    }

  return %retval;
}


#------------------------------------------------------------------------------
# Function:    SVNInfo
#
# Gets the info about the given file.
#
# Parameters:
#       file    The SVN object to query
#
# Returns:     hash with the info
#------------------------------------------------------------------------------
sub SVNInfo
{
  my $file = shift;
  my $old_verbose = $verbose;
  $verbose = 0;
  my ( $retval, @output ) = SVNCall( "info", $file );
  $verbose = $old_verbose;
  my %info;
    
  return if ( 0 != $retval );
    
  foreach my $line ( @output )
    {
      if ( $line =~ "^(.*): (.*)" )
        {
          $info{ $1 } = $2;
        }
    }
    
  return %info;
}


#------------------------------------------------------------------------------
# Function:    LatestRevision
#
# Returns the repository revision of the last change to the given object not
# later than the given revision (i.e. it may return revision, but won't
# return revision+1).
#
# Parameters:
#       source      The URL to check
#       revision    The revision of the URL to check from (if not supplied
#                   defaults to last revision).
#
# Returns:     The relevant revision number
#------------------------------------------------------------------------------
sub LatestRevision
{
  my ( $source, $revision ) = @_;
  my $revtext = "";

  if ( $revision )
    {
      $revtext = "--revision $revision:0";
    }
        
  my $old_verbose = $verbose;
  $verbose = 0;
  my ( $retval, @output ) = SVNCall( "log -q", $revtext, $source );
  $verbose = $old_verbose;

  if ( 0 != $retval )
    {
      error( "LatestRevision: log -q on '$source' failed" );
      return -1;
    }
    
  #
  # The second line should give us the info we need: e.g.
  #
  # >svn log -q http://subversion/svn/scratch/ianb/svncopy-update/source/dirA
  # ------------------------------------------------------------------------
  # r1429 | ib | 2004-06-14 17:39:36 +0100 (Mon, 14 Jun 2004)
  # ------------------------------------------------------------------------
  # r1423 | ib | 2004-06-14 17:39:26 +0100 (Mon, 14 Jun 2004)
  # ------------------------------------------------------------------------
  # r1422 | ib | 2004-06-14 17:39:23 +0100 (Mon, 14 Jun 2004)
  # ------------------------------------------------------------------------
  # r1421 | ib | 2004-06-14 17:39:22 +0100 (Mon, 14 Jun 2004)
  # ------------------------------------------------------------------------
  #
  # The second line starts with the latest revision number.
  #
  if ( $output[1] =~ m"^r(\d+) \|" )
    {
      return $1;
    }
    
  error( "LatestRevision: log output not formatted as expected\n" );
    
  return -1;
}


#------------------------------------------------------------------------------
# Function:    DoCommit
#
# svn commits the temporary directory.
#
# Parameters:
#       work_dir    The working directory
#       message     Commit message
#
# Returns:     non-zero on success
#------------------------------------------------------------------------------
sub DoCommit
{
  my ( $work_dir, $message ) = @_;
  my @commandline = ();
    
  # Prepare a file containing the message
  my ($handle, $messagefile) = tempfile( DIR => $temp_dir );
  print $handle $message;
  close($handle);
  push( @commandline, "--file", $messagefile );
    
  push( @commandline, $work_dir );
        
  my ( $exit ) = SVNCall( "commit", @commandline );
    
  error( "$0: svn commit failed" ) if ( 0 != $exit );
    
  return ( 0 == $exit );
}


#------------------------------------------------------------------------------
# Function:    SVNCall
#
# Makes a call to subversion.
#
# Parameters:
#       command     Subversion command
#       options     Other options to pass to Subversion
#
# Returns:     exit status, output from command
#------------------------------------------------------------------------------
sub SVNCall
{
  my ( $command, @options ) = @_;

  my @commandline = ( $svn, $command, @svn_options, @options );

  info( " > ", join( " ", @commandline ), "\n" );
  
  my @output = qx( @commandline 2>&1 );
      
  my $result = $?;
  my $exit   = $result >> 8;
  my $signal = $result & 127;
  my $cd     = $result & 128 ? "with core dump" : "";
  if ($signal or $cd)
    {
      error( "$0: 'svn $command' failed $cd: exit=$exit signal=$signal\n" );
    }
  
  if ( $exit > 0 )
    {
      info( join( "\n", @output ) );
    }
  if ( wantarray )
    {
      return ( $exit, @output );
    }
    
  return $exit;
}


#------------------------------------------------------------------------------
# Function:    FindRepositoryRoot
#
# Returns the root of the repository for a given URL.  Do
# this with the svn log command.  Take the svn_url hostname and port
# as the initial url and append to it successive portions of the final
# path until svn log succeeds.
#
# Parameters:
#       URI    URI within repository
#
# Returns:     A URI for the root, or undefined on error
#------------------------------------------------------------------------------
sub FindRepositoryRoot
{
  my $URI = shift;
  my $repos_root_uri;
  my $repos_root_uri_path;
  my $old_verbose = $verbose;
  $verbose = 0;
  
  info( "Finding the root URL of '$URI'.\n" );
  
  my $r = $URI->clone;
  my @path_segments = grep { length($_) } $r->path_segments;
  unshift(@path_segments, '');
  $r->path('');
  my @r_path_segments;

  while (@path_segments)
    {
      $repos_root_uri_path = shift @path_segments;
      push(@r_path_segments, $repos_root_uri_path);
      $r->path_segments(@r_path_segments);