contrib/client-side/svncopy/svncopy.pl.in

   1 #! /usr/bin/perl
   2 #
   3 #  svncopy.pl  --  Utility script for copying with branching/tagging.
   4 #
   5 #  This program is free software; you can redistribute  it and/or modify it
   6 #  under  the terms of  the GNU General  Public License as published by the
   7 #  Free Software Foundation;  either version 2 of the  License, or (at your
   8 #  option) any later version.
   9 #
  10 #  THIS  SOFTWARE  IS PROVIDED   ``AS  IS'' AND   ANY  EXPRESS  OR  IMPLIED
  11 #  WARRANTIES,   INCLUDING, BUT NOT  LIMITED  TO, THE IMPLIED WARRANTIES OF
  12 #  MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.  IN
  13 #  NO  EVENT  SHALL   THE AUTHOR  BE    LIABLE FOR ANY   DIRECT,  INDIRECT,
  14 #  INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
  15 #  NOT LIMITED   TO, PROCUREMENT OF  SUBSTITUTE GOODS  OR SERVICES; LOSS OF
  16 #  USE, DATA,  OR PROFITS; OR  BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
  17 #  ANY THEORY OF LIABILITY, WHETHER IN  CONTRACT, STRICT LIABILITY, OR TORT
  18 #  (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
  19 #  THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  20 #
  21 #  You should have received a copy of the  GNU General Public License along
  22 #  with this program; if not, write  to the Free Software Foundation, Inc.,
  23 #  59 Temple Place - Suite 330, Boston MA 02111-1307 USA.
  24 #
  25 #  This product makes use of software developed by
  26 #  CollabNet (http://www.Collab.Net/), see http://subversion.tigris.org/.
  27 #
  28 #  This software consists of voluntary contributions made by many
  29 #  individuals.  For exact contribution history, see the revision
  30 #  history and logs, available at http://subversion.tigris.org/.
  31 #------------------------------------------------------------------------------
  32
  33 #------------------------------------------------------------------------------
  34 #
  35 #  This script copies one Subversion location to another, in the same way as
  36 #  svn copy.  Using the script allows proper branching and tagging of URLs
  37 #  containing svn:externals definitions.
  38 #
  39 #  For more information see the pod documentation at the foot of the file,
  40 #  or run svncopy.pl -?.
  41 #
  42 #------------------------------------------------------------------------------
  43
  44 #
  45 # Include files
  46 #
  47 use Cwd;
  48 use File::Temp   0.12   qw(tempdir tempfile);
  49 use Getopt::Long 2.25;
  50 use Pod::Usage;
  51 use URI          1.17;
  52
  53 #
  54 # Global definitions
  55 #
  56
  57 # Specify the location of the svn command.
  58 my $svn = '@SVN_BINDIR@/svn';
  59
  60 # Input parameters
  61 my $testscript = 0;
  62 my $verbose = 0;
  63 my $pin_externals = 0;
  64 my $update_externals = 0;
  65 my @sources;
  66 my $destination;
  67 my $message;
  68 my @svn_options = ();
  69
  70 # Internal information
  71 my %externals_hash;
  72 my $temp_dir;
  73
  74 # Error handling
  75 my @errors = ();
  76 my @warnings = ();
  77
  78 # Testing-specific variables
  79 my $hideerrors = 0;
  80
  81 \f
  82 #------------------------------------------------------------------------------
  83 # Main execution block
  84 #
  85
  86 #
  87 # Process arguments
  88 #
  89 GetOptions( "pin-externals|tag|t" => \$pin_externals,
  90             "update-externals|branch|b" => \$update_externals,
  91             "message|m=s" => \$message,
  92             "revision|r=s" => \$revision,
  93             "verbose!" => \$verbose,
  94             "quiet|q" => sub { $verbose = 0; push( @svn_options, "--quiet" ) },
  95             "file|F=s" => sub { push( @svn_options, "--file", $_[1] ) },
  96             "username=s" => sub { push( @svn_options, "--username", $_[1] ) },
  97             "password=s" => sub { push( @svn_options, "--password", $_[1] ) },
  98             "no_auth_cache" => sub { push( @svn_options, "--no-auth-cache" ) },
  99             "force-log" => sub { push( @svn_options, "--force-log" ) },
 100             "encoding=s" => sub { push( @svn_options, "--encoding", $_[1] ) },
 101             "config-dir=s" => sub { push( @svn_options, "--config-dir", $_[1] ) },
 102             "help|?" => sub{ Usage() },
 103             ) or Usage();
 104
 105 # Put in a signal handler to clean up any temporary directories.
 106 sub catch_signal {
 107   my $signal = shift;
 108   warn "$0: caught signal $signal.  Quitting now.\n";
 109   exit 1;
 110 }
 111
 112 $SIG{HUP}  = \&catch_signal;
 113 $SIG{INT}  = \&catch_signal;
 114 $SIG{TERM} = \&catch_signal;
 115 $SIG{PIPE} = \&catch_signal;
 116
 117 #
 118 # Check our parameters
 119 #
 120 if ( @ARGV < 2 )
 121 {
 122   Usage( "Please specify source and destination" );
 123   exit 1;
 124 }
 125
 126 #
 127 # Get source(s) and destination.
 128 #
 129 push ( @sources, shift( @ARGV ) );
 130 $destination = shift( @ARGV );
 131 while ( scalar( @ARGV ) )
 132   {
 133     push( @sources, $destination );
 134     $destination = shift( @ARGV );
 135   }
 136
 137 #
 138 # Any validation errors?  If so, bomb out.
 139 #
 140 if ( scalar( @errors ) > 0 )
 141   {
 142     print "\n", @errors;
 143     Usage();
 144     exit scalar( @errors );
 145   }
 146
 147 #
 148 # Now do the main processing.
 149 # This will update @errors if anything goes wrong.
 150 #
 151 if ( !DoCopy( \@sources, $destination, $message ) )
 152   {
 153     print "\n*****************************************************************\n";
 154     print "Errors:\n";
 155     print @errors;
 156   }
 157
 158 exit scalar( @errors );
 159
 160 \f
 161 #------------------------------------------------------------------------------
 162 # Function:    DoCopy
 163 #
 164 # Does the work of the copy.
 165 #
 166 # Parameters:
 167 #       sources         Reference to array containing source URLs
 168 #       destination     Destination URL
 169 #       message         Commit message to use
 170 #
 171 # Returns:     0 on error
 172 #
 173 # Updates @errors.
 174 #------------------------------------------------------------------------------
 175 sub DoCopy
 176 {
 177   my ( $sourceref, $destination, $message ) = @_;
 178   my @sources = @$sourceref;
 179   my $revstr = "";
 180   my $src;
 181   my $startdir = cwd;
 182   my $starterrors = scalar( @errors );
 183
 184   print "\n=================================================================\n";
 185   $revstr = "\@$revision" if $revision;
 186   print "=== Copying from:\n";
 187   foreach $src ( @sources ) { print "===       $src$revstr\n"; }
 188   print "===\n";
 189   print "=== Copying to:\n";
 190   print "===       $destination\n";
 191   print "===\n";
 192   print "===  - branching (updating fully-contained svn:externals definitions)\n" if $update_externals;
 193   if ( $pin_externals )
 194     {
 195       my $revtext = $revision ? "revision $revision" : "current revision";
 196       print "===  - tagging (pinning all svn:externals definitions to $revtext)\n";
 197     }
 198   print "===\n" if ( $update_externals or $pin_externals );
 199
 200   # Convert destination to URI
 201   $destination =~ s|/*$||;
 202   my $destination_uri = URI->new($destination);
 203
 204   #
 205   # Generate a message if we don't have one.
 206   #
 207   unless ( $message )
 208     {
 209       $message = "svncopy.pl: Copied to '$destination'\n";
 210       foreach $src ( @sources )
 211         {
 212           $message .= "            Copied from '$src'\n";
 213         }
 214     }
 215
 216   #
 217   # Create a temporary directory to work in.
 218   #
 219   my ( $auto_temp_dir, $dest_dir ) =
 220     PrepareDirectory( $destination_uri, "svncopy.pl to '$destination'\n - creating intermediate directory" );
 221   $temp_dir = $auto_temp_dir->temp_dir();
 222   chdir( $temp_dir );
 223
 224   foreach $src ( @sources )
 225     {
 226       # Convert source to URI
 227       $src =~ s|/*$||;
 228       my $source_uri = URI->new($src);
 229
 230       #
 231       # Do the initial copy into our temporary.  Note this will create a
 232       # subdirectory with the same name as the last directory in $source.
 233       #
 234       if ( !CopyToWorkDir( $src, $dest_dir ) )
 235         {
 236           error( "Copy failed" );
 237           return 0;
 238         }
 239     }
 240
 241   #
 242   # Do any processing.
 243   #
 244   if ( $pin_externals or $update_externals )
 245     {
 246       if ( !UpdateExternals( $sourceref, $destination, $dest_dir, \$message ) )
 247         {
 248           error( "Couldn't update svn:externals" );
 249           return 0;
 250         }
 251     }
 252
 253   #
 254   # And check in the new.
 255   #
 256   DoCommit( $dest_dir, $message ) or die "Couldn't commit\n";
 257
 258   # Make sure we finish in the directory we started
 259   chdir( $startdir );
 260
 261   print "=== ... copy complete\n";
 262   print "=================================================================\n";
 263
 264   # Return whether there was an error.
 265   return ( scalar( @errors ) == $starterrors );
 266 }
 267
 268 \f
 269 #------------------------------------------------------------------------------
 270 # Function:    PrepareDirectory
 271 #
 272 # Prepares a temporary directory to work in.
 273 #
 274 # Parameters:
 275 #       destination    Destination URI
 276 #       message        Commit message
 277 #
 278 # Returns:     temporary directory and subdirectory to work in
 279 #------------------------------------------------------------------------------
 280 sub PrepareDirectory
 281 {
 282   my ( $destination, $message ) = @_;
 283
 284   my $auto_temp_dir = Temp::Delete->new();
 285   $temp_dir = $auto_temp_dir->temp_dir();
 286   info( "Using temporary directory $temp_dir\n" );
 287
 288   #
 289   # Our working destination directory has the same name as the last directory
 290   # in the destination URI.
 291   #
 292   my @path_segments = grep { length($_) } $destination->path_segments;
 293   my $new_dir = pop( @path_segments );
 294   my $dest_dir = "$temp_dir/$new_dir";
 295
 296   # Make sure the destination directory exists in Subversion.
 297   info( "Creating intermediate directories (if necessary)\n" );
 298   if ( !CreateSVNDirectories( $destination, $message ) )
 299     {
 300       error( "Couldn't create parent directories for '$destination'" );
 301       return;
 302     }
 303
 304   # Check out the destination.
 305   info( "Checking out destination directory '$destination'\n" );
 306   if ( 0 != SVNCall( 'co', $destination, $dest_dir ) )
 307     {
 308       error( "Couldn't check out '$destination' into work directory." );
 309       return;
 310     }
 311
 312   return ( $auto_temp_dir, $dest_dir );
 313 }
 314
 315 \f
 316 #------------------------------------------------------------------------------
 317 # Function:    CopyToWorkDir
 318 #
 319 # Does the svn copy into the temporary directory.
 320 #
 321 # Parameters:
 322 #       source      The URI to copy from
 323 #       work_dir    The working directory
 324 #
 325 # Returns:     1 on success
 326 #------------------------------------------------------------------------------
 327 sub CopyToWorkDir
 328 {
 329   my ( $source, $work_dir ) = @_;
 330   my $dest_dir = DestinationSubdir( $source, $work_dir );
 331   my @commandline = ();
 332
 333   push( @commandline, "--revision", $revision ) if ( $revision );
 334
 335   push( @commandline, $source, $work_dir );
 336
 337   my $exit = SVNCall( "copy", @commandline );
 338
 339   error( "$0: svn copy failed" ) if ( 0 != $exit );
 340
 341   return ( 0 == $exit );
 342 }
 343
 344 \f
 345 #------------------------------------------------------------------------------
 346 # Function:    DestinationSubdir
 347 #
 348 # Returns the destination directory for a given source and a destination root
 349 # directory.
 350 #
 351 # Parameters:
 352 #       source      The URL to copy from
 353 #       destination The working directory
 354 #
 355 # Returns:     The relevant directory
 356 #------------------------------------------------------------------------------
 357 sub DestinationSubdir
 358 {
 359   my ( $source, $destination ) = @_;
 360   my $subdir;
 361
 362   # Make sure source and destination are consistent about separator.
 363   # Note every function we call can handle Unix path format, so we
 364   # default to that.
 365   $source =~ s|\\|/|g;
 366   $destination =~ s|\\|/|g;
 367
 368   # Find the last directory - that's the subdir we'll use in $destination
 369   if ( $source =~ m"/([^/]+)/*$" )
 370     {
 371       $subdir = $1;
 372     }
 373     else
 374     {
 375       $subdir = $source;
 376     }
 377   return "$destination/$subdir";
 378 }
 379
 380 \f
 381 #------------------------------------------------------------------------------
 382 # Function:    UpdateExternals
 383 #
 384 # Updates the svn:externals in the tree according to the --pin-externals or
 385 # --update_externals options.
 386 #
 387 # Parameters:
 388 #       sourceref   Ref to the URLs to copy from
 389 #       destination The URL being copied to
 390 #       work_dir    The working directory
 391 #       msgref      Ref to message string to update with changes
 392 #
 393 # Returns:     1 on success
 394 #------------------------------------------------------------------------------
 395 sub UpdateExternals
 396 {
 397   my ( $sourceref, $destination, $work_dir, $msgref ) = @_;
 398   my @commandline = ();
 399   my $msg;
 400   my @dirfiles;
 401   my %extlist;
 402
 403   # Check the externals on this directory and subdirectories
 404   info( "Checking '$work_dir'\n" );
 405   %extlist = GetRecursiveExternals( $work_dir );
 406
 407   # And do the update
 408   while ( my ( $subdir, $exts ) = each ( %extlist ) )
 409     {
 410       my @externals = @$exts;
 411       if ( scalar( @externals ) )
 412         {
 413           UpdateExternalsOnDir( $sourceref, $destination, $subdir, $msgref, \@externals );
 414         }
 415     }
 416
 417   return 1;
 418 }
 419
 420 \f
 421 #------------------------------------------------------------------------------
 422 # Function:    UpdateExternalsOnDir
 423 #
 424 # Updates the svn:externals in the tree according to the --pin-externals or
 425 # --update_externals options.
 426 #
 427 # Parameters:
 428 #       sourceref   Ref to the URLs to copy from
 429 #       destination The URL being copied to
 430 #       work_dir    The working directory
 431 #       externals   Ref to the externals on the directory
 432 #       msgref      Ref to message string to update with changes
 433 #
 434 # Returns:     1 on success
 435 #------------------------------------------------------------------------------
 436 sub UpdateExternalsOnDir
 437 {
 438   my ( $sourceref, $destination, $work_dir, $msgref, $externalsref ) = @_;
 439   my @sources = @$sourceref;
 440   my @externals = @$externalsref;
 441   my @new_externals;
 442   my %changed;
 443
 444   # Do any updating required
 445   foreach my $external ( @externals )
 446     {
 447       chomp( $external );
 448       next unless ( $external =~ m"^(\S+)(\s+)(?:-r\s*(\d+)\s+)?(.*)" );
 449       my ( $ext_dir, $spacing, $ext_rev, $ext_val ) = ( $1, $2, $3, $4 );
 450
 451       info( " - Found $ext_dir => '$ext_val'" );
 452       info( " ($ext_rev)" ) if $ext_rev;
 453       info( "\n" );
 454
 455       $externals_hash{ "$ext_val" } = $ext_rev;
 456
 457       # Only update if it's not pinned to a version
 458       if ( !$ext_rev )
 459         {
 460           if ( $update_externals )
 461             {
 462               my $old_external = $external;
 463               foreach my $source ( @sources )
 464                 {
 465                   my $dest_dir = DestinationSubdir( $source, $destination );
 466                   #info( "Checking against '$source'\n" );
 467                   if ( $ext_val =~ s|^$source|$dest_dir| )
 468                     {
 469                       $external = "$ext_dir$spacing$ext_val";
 470                       info( " - updated '$old_external' to '$external'\n" );
 471                       $changed{$old_external} = $external;
 472                     }
 473                 }
 474             }
 475           elsif ( $pin_externals )
 476             {
 477               # Find the last revision of the destination and pin to that.
 478               my $old_external = $external;
 479               my $rev = LatestRevision( $ext_val, $revision );
 480               #info( "Pinning '$ext_val' to '$rev'\n" );
 481               $external = "$ext_dir -r $rev$spacing$ext_val";
 482               info( " - updated '$old_external' to '$external'\n" );
 483               $changed{$old_external} = $external;
 484             }
 485         }
 486       push( @new_externals, $external );
 487     }
 488
 489   # And write the changes back
 490   if ( scalar( %changed ) )
 491     {
 492       # Update the commit log message
 493       my %info = SVNInfo( $work_dir );
 494       $$msgref .= "\n * $info{URL}: update svn:externals\n";
 495       while ( my ( $old, $new ) = each( %changed ) )
 496         {
 497           $$msgref .= "   from '$old' to '$new'\n";
 498           info( "   '$old' => '$new'\n" );
 499         }
 500
 501       # And set the new externals
 502       my ($handle, $tmpfile) = tempfile( DIR => $temp_dir );
 503       print $handle join( "\n", @new_externals );
 504       close($handle);
 505       SVNCall( "propset", "--file", $tmpfile, "svn:externals", $work_dir );
 506     }
 507 }
 508
 509 \f
 510 #------------------------------------------------------------------------------
 511 # Function:    GetRecursiveExternals
 512 #
 513 # This function retrieves the svn:externals value from the
 514 # specified URL or location and subdirectories.
 515 #
 516 # Parameters:
 517 #       location      location of SVN object - file/dir or URL.
 518 #
 519 # Returns:     hash
 520 #------------------------------------------------------------------------------
 521 sub GetRecursiveExternals
 522 {
 523   my ( $location ) = @_;
 524   my %retval;
 525   my $externals;
 526   my $subdir = ".";
 527
 528   my ( $status, @externals ) = SVNCall( "propget", "-R", "svn:externals", $location );
 529
 530   foreach my $external ( @externals )
 531     {
 532       chomp( $external );
 533
 534       if ( $external =~ m"(.*) - (.*\s.*)" )
 535         {
 536           $subdir = $1;
 537           $external = $2;
 538         }
 539
 540       push( @{$retval{$subdir}}, $external ) unless $external =~ m"^\s*$";
 541     }
 542
 543   return %retval;
 544 }
 545
 546 \f
 547 #------------------------------------------------------------------------------
 548 # Function:    SVNInfo
 549 #
 550 # Gets the info about the given file.
 551 #
 552 # Parameters:
 553 #       file    The SVN object to query
 554 #
 555 # Returns:     hash with the info
 556 #------------------------------------------------------------------------------
 557 sub SVNInfo
 558 {
 559   my $file = shift;
 560   my $old_verbose = $verbose;
 561   $verbose = 0;
 562   my ( $retval, @output ) = SVNCall( "info", $file );
 563   $verbose = $old_verbose;
 564   my %info;
 565
 566   return if ( 0 != $retval );
 567
 568   foreach my $line ( @output )
 569     {
 570       if ( $line =~ "^(.*): (.*)" )
 571         {
 572           $info{ $1 } = $2;
 573         }
 574     }
 575
 576   return %info;
 577 }
 578
 579 \f
 580 #------------------------------------------------------------------------------
 581 # Function:    LatestRevision
 582 #
 583 # Returns the repository revision of the last change to the given object not
 584 # later than the given revision (i.e. it may return revision, but won't
 585 # return revision+1).
 586 #
 587 # Parameters:
 588 #       source      The URL to check
 589 #       revision    The revision of the URL to check from (if not supplied
 590 #                   defaults to last revision).
 591 #
 592 # Returns:     The relevant revision number
 593 #------------------------------------------------------------------------------
 594 sub LatestRevision
 595 {
 596   my ( $source, $revision ) = @_;
 597   my $revtext = "";
 598
 599   if ( $revision )
 600     {
 601       $revtext = "--revision $revision:0";
 602     }
 603
 604   my $old_verbose = $verbose;
 605   $verbose = 0;
 606   my ( $retval, @output ) = SVNCall( "log -q", $revtext, $source );
 607   $verbose = $old_verbose;
 608
 609   if ( 0 != $retval )
 610     {
 611       error( "LatestRevision: log -q on '$source' failed" );
 612       return -1;
 613     }
 614
 615   #
 616   # The second line should give us the info we need: e.g.
 617   #
 618   # >svn log -q http://subversion/svn/scratch/ianb/svncopy-update/source/dirA
 619   # ------------------------------------------------------------------------
 620   # r1429 | ib | 2004-06-14 17:39:36 +0100 (Mon, 14 Jun 2004)
 621   # ------------------------------------------------------------------------
 622   # r1423 | ib | 2004-06-14 17:39:26 +0100 (Mon, 14 Jun 2004)
 623   # ------------------------------------------------------------------------
 624   # r1422 | ib | 2004-06-14 17:39:23 +0100 (Mon, 14 Jun 2004)
 625   # ------------------------------------------------------------------------
 626   # r1421 | ib | 2004-06-14 17:39:22 +0100 (Mon, 14 Jun 2004)
 627   # ------------------------------------------------------------------------
 628   #
 629   # The second line starts with the latest revision number.
 630   #
 631   if ( $output[1] =~ m"^r(\d+) \|" )
 632     {
 633       return $1;
 634     }
 635
 636   error( "LatestRevision: log output not formatted as expected\n" );
 637
 638   return -1;
 639 }
 640
 641 \f
 642 #------------------------------------------------------------------------------
 643 # Function:    DoCommit
 644 #
 645 # svn commits the temporary directory.
 646 #
 647 # Parameters:
 648 #       work_dir    The working directory
 649 #       message     Commit message
 650 #
 651 # Returns:     non-zero on success
 652 #------------------------------------------------------------------------------
 653 sub DoCommit
 654 {
 655   my ( $work_dir, $message ) = @_;
 656   my @commandline = ();
 657
 658   # Prepare a file containing the message
 659   my ($handle, $messagefile) = tempfile( DIR => $temp_dir );
 660   print $handle $message;
 661   close($handle);
 662   push( @commandline, "--file", $messagefile );
 663
 664   push( @commandline, $work_dir );
 665
 666   my ( $exit ) = SVNCall( "commit", @commandline );
 667
 668   error( "$0: svn commit failed" ) if ( 0 != $exit );
 669
 670   return ( 0 == $exit );
 671 }
 672
 673 \f
 674 #------------------------------------------------------------------------------
 675 # Function:    SVNCall
 676 #
 677 # Makes a call to subversion.
 678 #
 679 # Parameters:
 680 #       command     Subversion command
 681 #       options     Other options to pass to Subversion
 682 #
 683 # Returns:     exit status, output from command
 684 #------------------------------------------------------------------------------
 685 sub SVNCall
 686 {
 687   my ( $command, @options ) = @_;
 688
 689   my @commandline = ( $svn, $command, @svn_options, @options );
 690
 691   info( " > ", join( " ", @commandline ), "\n" );
 692
 693   my @output = qx( @commandline 2>&1 );
 694
 695   my $result = $?;
 696   my $exit   = $result >> 8;
 697   my $signal = $result & 127;
 698   my $cd     = $result & 128 ? "with core dump" : "";
 699   if ($signal or $cd)
 700     {
 701       error( "$0: 'svn $command' failed $cd: exit=$exit signal=$signal\n" );
 702     }
 703
 704   if ( $exit > 0 )
 705     {
 706       info( join( "\n", @output ) );
 707     }
 708   if ( wantarray )
 709     {
 710       return ( $exit, @output );
 711     }
 712
 713   return $exit;
 714 }
 715
 716 \f
 717 #------------------------------------------------------------------------------
 718 # Function:    FindRepositoryRoot
 719 #
 720 # Returns the root of the repository for a given URL.  Do
 721 # this with the svn log command.  Take the svn_url hostname and port
 722 # as the initial url and append to it successive portions of the final
 723 # path until svn log succeeds.
 724 #
 725 # Parameters:
 726 #       URI    URI within repository
 727 #
 728 # Returns:     A URI for the root, or undefined on error
 729 #------------------------------------------------------------------------------
 730 sub FindRepositoryRoot
 731 {
 732   my $URI = shift;
 733   my $repos_root_uri;
 734   my $repos_root_uri_path;
 735   my $old_verbose = $verbose;
 736   $verbose = 0;
 737
 738   info( "Finding the root URL of '$URI'.\n" );
 739
 740   my $r = $URI->clone;
 741   my @path_segments = grep { length($_) } $r->path_segments;
 742   unshift(@path_segments, '');
 743   $r->path('');
 744   my @r_path_segments;
 745
 746   while (@path_segments)
 747     {
 748       $repos_root_uri_path = shift @path_segments;
 749       push(@r_path_segments, $repos_root_uri_path);
 750       $r->path_segments(@r_path_segments);
 751       if ( SVNCall( 'log', '-r', 'HEAD', $r ) == 0 )
 752         {
 753           $repos_root_uri = $r;
 754           last;
 755         }
 756     }
 757
 758   $verbose = $old_verbose;
 759
 760   if ($repos_root_uri)
 761     {
 762       info( "Determined that the svn root URL is $repos_root_uri.\n\n" );
 763       return $repos_root_uri;
 764     }
 765   else
 766     {
 767       error( "$0: cannot determine root svn URL for '$URI'.\n" );
 768       return;
 769     }
 770 }
 771
 772 \f
 773 #------------------------------------------------------------------------------
 774 # Function:    CreateSVNDirectories
 775 #
 776 # Creates a directory in Subversion, including all intermediate directories.
 777 #
 778 # Parameters:
 779 #       URI         directory path to create.
 780 #       message     commit message (optional).
 781 #
 782 # Returns:     1 on success, 0 on error
 783 #------------------------------------------------------------------------------
 784 sub CreateSVNDirectories
 785 {
 786   my ( $URI, $message ) = @_;
 787   my $r = $URI->clone;
 788   my @path_segments = grep { length($_) } $r->path_segments;
 789   my @r_path_segments;
 790   unshift(@path_segments, '');
 791   $r->path('');
 792
 793   my $found_root = 0;
 794   my $found_tail = 0;
 795
 796   # Prepare a file containing the message
 797   my ($handle, $messagefile) = tempfile( DIR => $temp_dir );
 798   print $handle $message;
 799   close($handle);
 800   my @msgcmd = ( "--file", $messagefile );
 801
 802   # We're going to get errors while we do this.  Don't show the user.
 803   my $old_verbose = $verbose;
 804   $verbose = 0;
 805   # Find the repository root
 806   while (@path_segments)
 807     {
 808       my $segment = shift @path_segments;
 809       push( @r_path_segments, $segment );
 810       $r->path_segments( @r_path_segments );
 811       if ( !$found_root )
 812         {
 813           if ( SVNCall( 'log', '-r', 'HEAD', $r ) == 0 )
 814             {
 815               # We've found the root of the repository.
 816               $found_root = 1;
 817             }
 818         }
 819       elsif ( !$found_tail )
 820         {
 821           if ( SVNCall( 'log', '-r', 'HEAD', $r ) != 0 )
 822             {
 823               # We've found the first directory which doesn't exist.
 824               $found_tail = 1;
 825             }
 826         }
 827
 828       if ( $found_tail )
 829         {
 830           # We're creating directories
 831           $verbose = $old_verbose;
 832           if ( 0 != SVNCall( 'mkdir', @msgcmd, $r ) )
 833             {
 834               error( "Couldn't create directory '$r'" );
 835               return 0;
 836             }
 837         }
 838     }
 839   $verbose = $old_verbose;
 840
 841   return 1;
 842 }
 843
 844 \f
 845 #------------------------------------------------------------------------------
 846 # Function:    info
 847 #
 848 # Prints out an informational message in verbose mode
 849 #
 850 # Parameters:
 851 #       @_     The message(s) to print
 852 #
 853 # Returns:     none
 854 #------------------------------------------------------------------------------
 855 sub info
 856 {
 857   if ( $verbose )
 858     {
 859       print @_;
 860     }
 861 }
 862
 863 \f
 864 #------------------------------------------------------------------------------
 865 # Function:    error
 866 #
 867 # Prints out and logs an error message
 868 #
 869 # Parameters:
 870 #       @_     The error messages
 871 #
 872 # Returns:     none
 873 #------------------------------------------------------------------------------
 874 sub error
 875 {
 876   my $error;
 877
 878   # This is used during testing
 879   if ( $hideerrors )
 880     {
 881       return;
 882     }
 883
 884   # Now print out each error message and add it to the list.
 885   foreach $error ( @_ )
 886     {
 887       my $text = "svncopy.pl: $error\n";
 888       push( @errors, $text );
 889       if ( $verbose )
 890         {
 891           print $text;
 892         }
 893     }
 894 }
 895
 896 \f
 897 #------------------------------------------------------------------------------
 898 # Function:    Usage
 899 #
 900 # Prints out usage information.
 901 #
 902 # Parameters:
 903 #       optional error message
 904 #
 905 # Returns:     none
 906 #------------------------------------------------------------------------------
 907 sub Usage
 908 {
 909   my $msg;
 910   $msg = "\n*** $_[0] ***\n" if $_[0];
 911
 912   pod2usage( { -message => $msg,
 913                -verbose => 0 } );
 914 }
 915
 916 \f
 917 #------------------------------------------------------------------------------
 918 # This package exists just to delete the temporary directory.
 919 #------------------------------------------------------------------------------
 920 package Temp::Delete;
 921
 922 use File::Temp   0.12   qw(tempdir);
 923
 924 sub new
 925 {
 926   my $this = shift;
 927   my $class = ref($this) || $this;
 928   my $self = {};
 929   bless $self, $class;
 930
 931   my $temp_dir = tempdir("svncopy_XXXXXXXXXX", TMPDIR => 1);
 932
 933   $self->{tempdir} = $temp_dir;
 934
 935   return $self;
 936 }
 937
 938 sub temp_dir
 939 {
 940   my $self = shift;
 941   return $self->{tempdir};
 942 }
 943
 944 sub DESTROY
 945 {
 946   my $self = shift;
 947   my $temp_dir = $self->{tempdir};
 948   if ( scalar( @errors ) )
 949   {
 950     print "Leaving $temp_dir for inspection\n";
 951   }
 952   else
 953   {
 954     info( "Cleaning up $temp_dir\n" );
 955     File::Path::rmtree([$temp_dir], 0, 0);
 956   }
 957 }
 958
 959 \f
 960 #------------------------------------------------------------------------------
 961 # Documentation follows, in pod format.
 962 #------------------------------------------------------------------------------
 963 __END__
 964
 965 =head1 NAME
 966
 967 B<svncopy> - extended form of B<svn copy>
 968
 969 =head1 SYNOPSIS
 970
 971 B<svncopy.pl> [option ...] source [source ...] destination
 972
 973 This script copies one Subversion location or set of locations to another,
 974 in the same way as B<svn copy>.  Using the script allows more advanced operations,
 975 in particular allowing svn:externals to be dealt with properly for branching
 976 or tagging.
 977
 978  Parameters:
 979   source         Subversion item to copy from.
 980                  Multiple sources can be given.
 981   destination    Destination to copy to.
 982
 983  Options:
 984   -t [--tag]             : set svn:externals to current version
 985      [--pin-externals ]
 986   -b [--branch]          : update fully contained svn:externals
 987      [--update-externals]
 988   -m [--message] arg     : specify commit message ARG
 989   -F [--file] arg        : read data from file ARG
 990   -r [--revision] arg    : ARG (some commands also take ARG1:ARG2 range)
 991                            A revision argument can be one of:
 992                              NUMBER       revision number
 993                              "{" DATE "}" revision at start of the date
 994                              "HEAD"       latest in repository
 995                              "BASE"       base rev of item's working copy
 996                              "COMMITTED"  last commit at or before BASE
 997                              "PREV"       revision just before COMMITTED
 998   -q [--quiet]           : print as little as possible
 999   --username arg         : specify a username ARG
1000   --password arg         : specify a password ARG
1001   --no-auth-cache        : do not cache authentication tokens
1002   --force-log            : force validity of log message source
1003   --encoding arg         : treat value as being in charset encoding ARG
1004   --config-dir arg       : read user config files from directory ARG
1005   --[no]verbose          : sets the script to give lots of output
1006
1007 =head1 PARAMETERS
1008
1009 =over
1010
1011 =item B<source>
1012
1013 The subversion item or items to copy from.
1014
1015 =item B<destination>
1016
1017 The destination URL to copy to.
1018
1019 =back
1020
1021 =head1 OPTIONS
1022
1023 =over
1024
1025 =item B<-t [--pin-externals or --tag]>
1026
1027 Update any svn:externals to ensure they have a version number,
1028 using the current destination version if none is already specified.
1029 Useful for tagging operations.
1030
1031 =item B<-b [--update-externals or --branch]>
1032
1033 Update any unversioned svn:externals which point to a location
1034 within one of the sources so that they point to the corresponding
1035 location within the destination.
1036
1037 Note: --pin-externals and --update-externals are mutually exclusive.
1038
1039 =item B<-m [--message] arg>
1040
1041 Specify commit message ARG
1042
1043 =item B<-F [--file] arg>
1044
1045 Read data from file ARG
1046
1047 =item B<-r [--revision] arg>
1048
1049 ARG (some commands also take ARG1:ARG2 range)
1050 A revision argument can be one of:
1051
1052     NUMBER       revision number
1053     "{" DATE "}" revision at start of the date
1054     "HEAD"       latest in repository
1055     "BASE"       base rev of item's working copy
1056     "COMMITTED"  last commit at or before BASE
1057     "PREV"       revision just before COMMITTED
1058
1059 =item B<-q [--quiet]>
1060
1061 Print as little as possible
1062
1063 =item B<--username arg>
1064
1065 Specify a username ARG
1066
1067 =item B<--password arg>
1068
1069 Specify a password ARG
1070
1071 =item B<--no-auth-cache>
1072
1073 Do not cache authentication tokens
1074
1075 =item B<--force-log>
1076
1077 Force validity of log message source
1078
1079 =item B<--encoding arg>
1080
1081 Treat value as being in charset encoding ARG
1082
1083 =item B<--config-dir arg>
1084
1085 Read user configuration files from directory ARG
1086
1087 =item B<--[no]verbose>
1088
1089 Sets the script to give lots of output when it runs.
1090
1091 =item B<--help>
1092
1093 Print a brief help message and exits.
1094
1095 =back
1096
1097 =head1 DESCRIPTION
1098
1099 This script performs an B<svn copy> command.  It allows extra processing to get
1100 around the following limitations of B<svn copy>:
1101
1102 svn:externals definitions are (in Subversion 1.0 and 1.1 at least) absolute paths.
1103 This means that an B<svn copy> used as a branch or tag operation on a tree with
1104 embedded svn:externals will not do what is expected.  The svn:externals
1105 will still point at the original location and will not be pinned down.
1106
1107 B<svncopy --update-externals> (or B<svncopy --branch>) will update any
1108 unversioned svn:externals in the destination tree which point at locations
1109 within one of the source trees so that they point to the corresponding locations
1110 within the destination tree instead.  This effectively updates the reference to
1111 point to the destination tree, and is the behaviour you want for branching.
1112
1113 B<svncopy --pin-externals> (or B<svncopy --tag>) will update any unversioned
1114 svn:externals in the destination tree to contain the current version of the
1115 directory listed in the svn:externals definition.  This effectively pins
1116 the reference to the current version, and is the behaviour you want for tagging.
1117
1118 Note: both forms of the command leave unchanged any svn:externals which
1119 already contain a version number.
1120
1121 =cut
1122
1123 #------------------------------- END OF FILE ----------------------------------