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

   1 #! /usr/bin/perl
   2 #
   3 #  testsvncopy.pl  --  test script for svncopy.pl.
   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 tests the operation of svncopy.pl.
  36 #
  37 #  For more information see the pod documentation at the foot of the file,
  38 #  or run testsvncopy.pl -?.
  39 #
  40 #------------------------------------------------------------------------------
  41
  42 #
  43 # Include files
  44 #
  45 use Cwd;
  46 use File::Temp   0.12   qw(tempdir tempfile);
  47 use Getopt::Long 2.25;
  48 use Pod::Usage;
  49 use URI          1.17;
  50
  51 #
  52 # Global definitions
  53 #
  54
  55 # Specify the location of the svn command.
  56 my $svn = '@SVN_BINDIR@/svn';
  57
  58 # The scratch repository location for the tests
  59 my $testroot = '@SVN_TEST_REPOSITORY@';
  60
  61 # Input parameters
  62 my $verbose = 0;
  63 my @svn_options = ();
  64
  65 # Internal information
  66 my %externals_hash;
  67 my $temp_dir;
  68
  69 # Error handling
  70 my @errors = ();
  71 my @warnings = ();
  72
  73 # Testing-specific variables
  74 my $hideerrors = 0;
  75
  76
  77 #------------------------------------------------------------------------------
  78 # Main execution block
  79 #
  80
  81 #
  82 # Process arguments
  83 #
  84 GetOptions( "verbose!" => sub { $verbose = 1; push( @svn_options, "--verbose" ) },
  85             "quiet|q" => sub { $verbose = 0; push( @svn_options, "--quiet" ) },
  86             "username=s" => sub { push( @svn_options, "--username", $_[1] ) },
  87             "password=s" => sub { push( @svn_options, "--password", $_[1] ) },
  88             "no_auth_cache" => sub { push( @svn_options, "--no-auth-cache" ) },
  89             "force-log" => sub { push( @svn_options, "--force-log" ) },
  90             "encoding=s" => sub { push( @svn_options, "--encoding", $_[1] ) },
  91             "config-dir=s" => sub { push( @svn_options, "--config-dir", $_[1] ) },
  92             "test-repository|t=s" => \$testroot,
  93             "help|?" => sub{ Usage() },
  94             ) or Usage();
  95
  96 # Put in a signal handler to clean up any temporary directories.
  97 sub catch_signal {
  98   my $signal = shift;
  99   warn "$0: caught signal $signal.  Quitting now.\n";
 100   exit 1;
 101 }
 102
 103 $SIG{HUP}  = \&catch_signal;
 104 $SIG{INT}  = \&catch_signal;
 105 $SIG{TERM} = \&catch_signal;
 106 $SIG{PIPE} = \&catch_signal;
 107
 108 # Make sure we're in the correct directory, saving current before we move
 109 my $startDir = cwd;
 110 if ( $0 =~ m"(.*[\\/])[^\\/]+$" )
 111 {
 112     my $programDir = $1;
 113     chdir( $programDir );
 114 }
 115
 116 # Run the tests
 117 testUpdateExternals();
 118
 119 # Check whether they passed
 120 if ( 0 != scalar( @errors ) )
 121 {
 122   print "\n*****************************************************************\n";
 123   print "Errors:\n";
 124   print @errors;
 125 }
 126 else
 127 {
 128   print "*** Script passed tests ***\n";
 129 }
 130
 131 # Return to the original directory
 132 chdir( $startDir );
 133
 134 exit( scalar( @errors ) );
 135
 136 \f
 137 #------------------------------------------------------------------------------
 138 # Function:    testUpdateExternals
 139 #
 140 # Tests the script, pushing any errors onto @errors.
 141 #
 142 # Parameters:
 143 #       none
 144 #
 145 # Returns:     none
 146 #------------------------------------------------------------------------------
 147 sub testUpdateExternals
 148 {
 149   my $failed = 0;
 150   my $retval;
 151   my $testsubdir = "svncopy-update";
 152   my $testURL = "$testroot/$testsubdir";
 153   my @testdirs = (
 154       "source/dirA/dir1",
 155       "source/dirA/dir2",
 156       "source/dirB/dir3",
 157       "wibble/dirA/dir2",
 158   );
 159   my $dirWithExternals = $testdirs[0];
 160   my $pinnedDir = $testdirs[1];
 161   my $dest = "$testURL/dest";
 162   my $old_verbose = $verbose;
 163   my %revisions = {};
 164   my $testRev;
 165
 166   my $test_externals =
 167                   "DIR2 $testURL/source/dirA/dir2\n".     # 1 space
 168                   "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2\n".
 169                   "DIR3     $testURL/source/dirB/dir3\n". # 5 spaces
 170                   "DIR4         $testURL/wibble/dirA/dir2";   # 2 tabs
 171
 172   my @tests = (
 173         # Updating with nothing to update
 174         { sources => [ "$testURL/source/dirA/dir1", ],
 175           pin => 0,
 176           update => 1,
 177           ext_dir => "dir1",
 178           expected_externals => [
 179                     "DIR2 $testURL/source/dirA/dir2",
 180                     "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2",
 181                     "DIR3     $testURL/source/dirB/dir3",
 182                     "DIR4               $testURL/wibble/dirA/dir2"
 183                     ],
 184           expected_tree => [
 185                     "dir1/",
 186                     ],
 187         },
 188         # Updating a tree - enclosed should change, unless pinned
 189         { sources => [ "$testURL/source/dirA", ],
 190           pin => 0,
 191           update => 1,
 192           ext_dir => "dirA/dir1",
 193           expected_externals => [
 194                     "DIR2 $testURL/dest/dirA/dir2",
 195                     "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2",
 196                     "DIR3     $testURL/source/dirB/dir3",
 197                     "DIR4               $testURL/wibble/dirA/dir2"
 198                     ],
 199           expected_tree => [
 200                     "dirA/",
 201                     "dirA/dir1/",
 202                     "dirA/dir2/",
 203                     ],
 204         },
 205         # Updating with no update - no change
 206         { sources => [ "$testURL/source/dirA", ],
 207           pin => 0,
 208           update => 0,
 209           ext_dir => "dirA/dir1",
 210           expected_externals => [
 211                     "DIR2 $testURL/source/dirA/dir2",
 212                     "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2",
 213                     "DIR3     $testURL/source/dirB/dir3",
 214                     "DIR4               $testURL/wibble/dirA/dir2"
 215                     ],
 216           expected_tree => [
 217                     "dirA/",
 218                     "dirA/dir1/",
 219                     "dirA/dir2/",
 220                     ],
 221         },
 222         # Updating with two sources
 223         { sources => [ "$testURL/source/dirA/dir1",
 224                        "$testURL/source/dirB/dir3" ],
 225           pin => 0,
 226           update => 1,
 227           ext_dir => "dir1",
 228           expected_externals => [
 229                     "DIR2 $testURL/source/dirA/dir2",
 230                     "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2",
 231                     "DIR3     $testURL/dest/dir3",
 232                     "DIR4               $testURL/wibble/dirA/dir2"
 233                     ],
 234           expected_tree => [
 235                     "dir1/",
 236                     "dir3/",
 237                     ],
 238         },
 239         # Pinning
 240         { sources => [ "$testURL/source/dirA/dir1", ],
 241           pin => 1,
 242           update => 0,
 243           ext_dir => "dir1",
 244           expected_externals => [
 245                     "DIR2 -r __REV__ $testURL/source/dirA/dir2",
 246                     "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2",
 247                     "DIR3 -r __REV__     $testURL/source/dirB/dir3",
 248                     "DIR4 -r __REV__            $testURL/wibble/dirA/dir2",
 249                     ],
 250           expected_tree => [
 251                     "dir1/",
 252                     ],
 253         },
 254         # Pinning a tree
 255         { sources => [ "$testURL/source/dirA", ],
 256           pin => 1,
 257           update => 0,
 258           ext_dir => "dirA/dir1",
 259           expected_externals => [
 260                     "DIR2 -r __REV__ $testURL/source/dirA/dir2",
 261                     "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2",
 262                     "DIR3 -r __REV__     $testURL/source/dirB/dir3",
 263                     "DIR4 -r __REV__            $testURL/wibble/dirA/dir2",
 264                     ],
 265           expected_tree => [
 266                     "dirA/",
 267                     "dirA/dir1/",
 268                     "dirA/dir2/",
 269                     ],
 270         },
 271         # Pinning with two sources
 272         { sources => [ "$testURL/source/dirA/dir1",
 273                        "$testURL/source/dirB/dir3" ],
 274           pin => 1,
 275           update => 0,
 276           ext_dir => "dir1",
 277           expected_externals => [
 278                     "DIR2 -r __REV__ $testURL/source/dirA/dir2",
 279                     "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2",
 280                     "DIR3 -r __REV__     $testURL/source/dirB/dir3",
 281                     "DIR4 -r __REV__            $testURL/wibble/dirA/dir2",
 282                     ],
 283           expected_tree => [
 284                     "dir1/",
 285                     "dir3/",
 286                     ],
 287         },
 288     );
 289
 290   my $auto_temp_dir = Temp::Delete->new();
 291   my $test_temp_dir = $auto_temp_dir->temp_dir();
 292   $temp_dir = $test_temp_dir;
 293   print "\n################################################################\n";
 294   print( "Testing svncopy.pl\n" );
 295   info( "Using temporary directory $test_temp_dir\n" );
 296   print( "Preparing source directory structure...\n" );
 297
 298   #
 299   # Set up the source directory to copy
 300   #
 301
 302   # Kill the directory if it's there
 303   info( " - Deleting '$testURL'\n" );
 304   SVNCall( 'delete', '-m', '"Preparing to test svncopy --update-externals"', $testURL );
 305
 306   # Now create the source directories
 307   foreach my $dir ( @testdirs )
 308     {
 309       if ( !CreateTestDirectory( "$testURL/$dir" ) )
 310         {
 311           $failed = 1;
 312           return;
 313         }
 314     }
 315
 316   # Check out the test root
 317   if ( 0 != SVNCall( "co", $testURL, "$test_temp_dir/$testsubdir" ) )
 318     {
 319       error( "Preparatory checkout failed" );
 320       $failed = 1;
 321       return;
 322     }
 323
 324   # Set an svn:externals on it
 325   # - work our what externals we need to set (get the revision for the
 326   #   pinned directory)
 327   my $pinnedRev = CurrentRevision( "$testURL/$pinnedDir" );
 328   $test_externals =~ s|__PINREV__|$pinnedRev|gi;
 329
 330   # Now write the externals to a temporary file and set them on the dir.
 331   my ($handle, $tmpfile) = tempfile( DIR => $test_temp_dir );
 332   print $handle $test_externals;
 333   close($handle);
 334   if ( 0 != SVNCall( "propset", "svn:externals",
 335                      "--file", $tmpfile,
 336                      "$test_temp_dir/$testsubdir/$dirWithExternals" ) )
 337     {
 338       error( "svn propset of svn:externals failed" );
 339       $failed = 1;
 340       return;
 341     }
 342
 343   # And commit them
 344   if ( 0 != SVNCall( "commit", "-m",
 345                      "\"Testing svncopy --update_externals - adding svn:externals\"",
 346                      "$test_temp_dir/$testsubdir/$dirWithExternals" ) )
 347     {
 348       error( "svn commit failed" );
 349       $failed = 1;
 350       return;
 351     }
 352
 353   #
 354   # Also set a property on the pinned directory to make sure the pinned
 355   # revision isn't the last one.
 356   #
 357   if ( 0 != SVNCall( "propset",
 358                      "svncopyTest",
 359                      "wibble",
 360                      "$test_temp_dir/$testsubdir/$pinnedDir" ) )
 361     {
 362       error( "svn propset of svncopyTest failed" );
 363       $failed = 1;
 364       return;
 365     }
 366   # And commit
 367   if ( 0 != SVNCall( "commit", "-m",
 368                      "\"Testing svncopy --update_externals - adding svncopyTest property\"",
 369                      "$test_temp_dir/$testsubdir/$pinnedDir" ) )
 370     {
 371       error( "svn commit failed" );
 372       $failed = 1;
 373       return;
 374     }
 375
 376   # Having done all the set-up, get our revision numbers.
 377   foreach my $dir ( @testdirs )
 378     {
 379       $revisions{ "$testURL/$dir" } = CurrentRevision( "$testURL/$dir" );
 380     }
 381
 382   print( "...Source directory structure complete\n" );
 383
 384   # Script parameters
 385   my $message = "\"Testing svncopy.pl\"";
 386
 387   TEST: foreach my $testtype ( "HEAD", "-r" )
 388     {
 389       my @copy_options = @svn_options;
 390       my $testno = 1;
 391
 392       # Do extra setup for -r
 393       if ( "-r" eq $testtype )
 394         {
 395           $testRev = $revisions{ "$testURL/$pinnedDir" };
 396           print "Updating repository to run --revision tests against revision ".
 397                 "$testRev...\n";
 398
 399           #
 400           # Copy the same revision we did before
 401           # The last thing we changed was the pinned directory, so
 402           # take its revision as the one we want to copy.
 403           #
 404           push( @copy_options, "--revision", "$testRev" );
 405
 406           #
 407           # Now add a file to each directory.
 408           #
 409           foreach my $dir ( @testdirs )
 410             {
 411               if ( !UpdateTestDirectory( "$test_temp_dir/$testsubdir/$dir" ) )
 412                 {
 413                   $failed = 1;
 414                   return;
 415                 }
 416             }
 417
 418           # And commit
 419           if ( 0 != SVNCall( "commit", "-m",
 420                              "\"Testing svncopy --update_externals".
 421                              " - updating directories for '--revision' test\"",
 422                              "$test_temp_dir/$testsubdir" ) )
 423             {
 424               error( "svn commit of updated directories failed" );
 425               $failed = 1;
 426               return;
 427             }
 428
 429           print "...update done.  Now re-running tests against new repository\n";
 430         }
 431
 432       foreach my $test ( @tests )
 433         {
 434           my @cmd_options = @copy_options;
 435
 436           print "\n################################################################\n";
 437           print "### test number $testno\n";
 438
 439           # Kill the destination directory if it's there
 440           $verbose = 0;
 441           SVNCall( 'delete', '-m', '"Preparing to test svncopy --update-externals"', $dest );
 442           $verbose = $old_verbose;
 443
 444           my @sources = @{$test->{sources}};
 445           my @expected_externals = @{$test->{expected_externals}};
 446           my @expected_tree = @{$test->{expected_tree}};
 447
 448           # Update global parameters
 449           push( @cmd_options, "--message", "$message" );
 450           push( @cmd_options, "--tag" ) if ( $test->{pin} );
 451           push( @cmd_options, "--branch" ) if ( $test->{update} );
 452
 453           # Now do the copy
 454           my @cmdline = ( "perl", "svncopy.pl", @cmd_options, @sources, $dest );
 455           info( "\n=> Calling ", join( " ", @cmdline ), "\n\n" );
 456           if ( system( @cmdline ) )
 457             {
 458               error( "Copy failed" );
 459               $failed = 1;
 460             }
 461
 462           # Check that the generated tree is as expected.
 463           if ( !CheckTree( $dest, @expected_tree ) )
 464             {
 465               # CheckTree outputs an error message if it fails
 466               $failed = 1;
 467             }
 468
 469           # And check the externals
 470           my $ext_dir = "$dest/$test->{ext_dir}";
 471           if ( !CheckExternals( $ext_dir, \%revisions, $pinnedRev, @expected_externals ) )
 472             {
 473               # CheckExternals outputs an error message if it fails
 474               $failed = 1;
 475             }
 476
 477           # Bomb out if we had an error
 478           if ( $failed )
 479             {
 480               print "\n*** '$testtype' test $testno failed ***\n";
 481               print "****************************************************************\n";
 482               last TEST;
 483             }
 484
 485           print "\n### '$testtype' test $testno passed\n";
 486           print "################################################################\n";
 487           $testno++;
 488         }
 489     }
 490
 491   if ( $failed ) { error( "*** svncopy tests failed\n" ); }
 492   else { print "... svncopy tests passed\n"; }
 493 }
 494
 495 \f
 496 #------------------------------------------------------------------------------
 497 # Function:    CreateTestDirectory
 498 #
 499 # Creates a directory in svn.
 500 #
 501 # Parameters:
 502 #       svnpath    directory to create
 503 #
 504 # Returns:     non-zero on success
 505 #------------------------------------------------------------------------------
 506 sub CreateTestDirectory
 507 {
 508   my $svnpath = $_[0];
 509
 510   my $test_uri = URI->new( "$svnpath" );
 511   info( "Creating '$test_uri'\n" );
 512   if ( !CreateSVNDirectories( $test_uri, "Testing svncopy --update_externals" ) )
 513     {
 514       error( "CreateSVNDirectories on '$test_uri' failed" );
 515       return 0;
 516     }
 517
 518   return 1;
 519 }
 520
 521 \f
 522 #------------------------------------------------------------------------------
 523 # Function:    UpdateTestDirectory
 524 #
 525 # Modifies the directory in the working copy so that we can check the version
 526 # copied is correct.
 527 #
 528 # Parameters:
 529 #       dir        directory to modify (on file system)
 530 #
 531 # Returns:     non-zero on success
 532 #------------------------------------------------------------------------------
 533 sub UpdateTestDirectory
 534 {
 535   my $dir = $_[0];
 536   my $testfile = "$dir/test.txt";
 537
 538   # Create a file in the directory
 539   if ( !open FILE, ">$testfile" )
 540     {
 541       error( "Couldn't create test file '$testfile'" );
 542       return 0;
 543     }
 544   print FILE "Test file in '$dir'\n";
 545   close FILE;
 546
 547   # Now add it to Subversion
 548   if ( 0 != SVNCall( "add", $testfile ) )
 549     {
 550       error( "svn add '$testfile' failed" );
 551       return 0;
 552     }
 553
 554   # We're done
 555   return 1;
 556 }
 557
 558 \f
 559 #------------------------------------------------------------------------------
 560 # Function:    CheckTree
 561 #
 562 # Checks that directory structure in the subversion location matches
 563 # the given tree.
 564 #
 565 # Parameters:
 566 #       svnpath    Subversion location to check.
 567 #       expected   Expected response - list of files and dirs as returned
 568 #                  by svn list.
 569 #
 570 # Returns:     non-zero on success
 571 #------------------------------------------------------------------------------
 572 sub CheckTree
 573 {
 574   my ( $svnpath, @expected ) = @_;
 575
 576   my ( $retval, @output ) = SVNCall( "list", "--recursive", $svnpath );
 577   if ( 0 != $retval )
 578     {
 579       error( "svn list on '$svnpath' failed" );
 580       return 0;
 581     }
 582
 583   # Remove any blank lines and carriage returns
 584   @output = grep( { chomp($_); $_ !~ m"^\s*$"} @output );
 585
 586   # Now compare with expected
 587   my $compare_ctx = { list1 => [@expected], list2 => [@output] };
 588
 589   if ( 0 != CompareLists( $compare_ctx ) )
 590     {
 591       my $addedtext;
 592       my $removedtext;
 593
 594       if ( @{$compare_ctx->{added}} )
 595         {
 596           $addedtext = "\n   +".join( "\n   +", @{$compare_ctx->{added}} );
 597         }
 598       if ( @{$compare_ctx->{removed}} )
 599         {
 600           $removedtext = "\n   -".join( "\n   -", @{$compare_ctx->{removed}} );
 601         }
 602       error( "'$svnpath' doesn't match expected$addedtext$removedtext\n" );
 603
 604       return 0;
 605     }
 606
 607   return 1;
 608 }
 609
 610 \f
 611 #------------------------------------------------------------------------------
 612 # Function:    CheckExternals
 613 #
 614 # Checks that the subversion location matches the given tree.
 615 #
 616 # Parameters:
 617 #       svnpath    Subversion location to check.
 618 #       revisions  Hash containing the revisions for externals.
 619 #       pinnedRev  Revision of pinned directory.
 620 #       expected   Expected response - list of externals as returned
 621 #                  by svn propget svn:externals.
 622 #
 623 # Returns:     non-zero on success
 624 #------------------------------------------------------------------------------
 625 sub CheckExternals
 626 {
 627   my ( $svnpath, $revisions, $pinnedRev, @expected ) = @_;
 628   my @new_externals;
 629
 630   ( $retval, @new_externals ) =  SVNCall( "propget", "svn:externals", $svnpath );
 631   if ( 0 != $retval )
 632     {
 633       error( "svn propget on '$svnpath' failed" );
 634       return 0;
 635     }
 636
 637   # Update @expected with revisions
 638   @expected = grep
 639     {
 640       $_ =~ s|__PINREV__|$pinnedRev|g;
 641       if ( $_ =~ m"(.*)\s+-r __REV__\s+(.*)" )
 642         {
 643           my $path = $1;
 644           my $svnpath = $2;
 645           my $rev = $revisions->{$svnpath};
 646           $_ =~ s|__REV__|$rev|g;
 647         }
 648       1;
 649     } @expected;
 650
 651   # Remove any blank lines and carriage returns from the output
 652   @new_externals = grep( { chomp($_); $_ !~ m"^\s*$"} @new_externals );
 653
 654   # Now compare with expected
 655   my $compare_ctx = { list1 => [@expected], list2 => [@new_externals] };
 656
 657   if ( 0 != CompareLists( $compare_ctx ) )
 658     {
 659       error( "Externals on '$svnpath' don't match expected\n".
 660              " - expected:\n    ".
 661              join( "\n    ", @expected ) .
 662              "\n - actual:\n    ".
 663              join( "\n    ", @new_externals )
 664            );
 665
 666       return 0;
 667     }
 668
 669   return 1;
 670 }
 671
 672 \f
 673 #------------------------------------------------------------------------------
 674 # Function:    CurrentRevision
 675 #
 676 # Returns the repository revision of the last change to the given object.
 677 #
 678 # Parameters:
 679 #       source      The URL to check
 680 #
 681 # Returns:     The relevant revision number
 682 #------------------------------------------------------------------------------
 683 sub CurrentRevision
 684 {
 685   my $source = shift;
 686
 687   my $old_verbose = $verbose;
 688   $verbose = 0;
 689   my ( $retval, @output ) = SVNCall( "log -q", $source );
 690   $verbose = $old_verbose;
 691
 692   if ( 0 != $retval )
 693     {
 694       error( "CurrentRevision: log -q on '$source' failed" );
 695       return -1;
 696     }
 697
 698   #
 699   # The second line should give us the info we need: e.g.
 700   #
 701   # >svn log -q http://subversion/svn/scratch/ianb/svncopy-update/source/dirA
 702   # ------------------------------------------------------------------------
 703   # r1429 | ib | 2004-06-14 17:39:36 +0100 (Mon, 14 Jun 2004)
 704   # ------------------------------------------------------------------------
 705   # r1423 | ib | 2004-06-14 17:39:26 +0100 (Mon, 14 Jun 2004)
 706   # ------------------------------------------------------------------------
 707   # r1422 | ib | 2004-06-14 17:39:23 +0100 (Mon, 14 Jun 2004)
 708   # ------------------------------------------------------------------------
 709   # r1421 | ib | 2004-06-14 17:39:22 +0100 (Mon, 14 Jun 2004)
 710   # ------------------------------------------------------------------------
 711   #
 712   # The second line starts with the latest revision number.
 713   #
 714   if ( $output[1] =~ m"^r(\d+) \|" )
 715     {
 716       return $1;
 717     }
 718
 719   error( "CurrentRevision: log output not formatted as expected\n" );
 720
 721   return -1;
 722 }
 723
 724 \f
 725 #------------------------------------------------------------------------------
 726 # Function:    SVNCall
 727 #
 728 # Makes a call to subversion.
 729 #
 730 # Parameters:
 731 #       command     Subversion command
 732 #       options     Other options to pass to Subversion
 733 #
 734 # Returns:     exit status, output from command
 735 #------------------------------------------------------------------------------
 736 sub SVNCall
 737 {
 738   my ( $command, @options ) = @_;
 739
 740   my @commandline = ( $svn, $command, @options );
 741
 742   info( " > ", join( " ", @commandline ), "\n" );
 743
 744   my @output = qx( @commandline 2>&1 );
 745
 746   my $result = $?;
 747   my $exit   = $result >> 8;
 748   my $signal = $result & 127;
 749   my $cd     = $result & 128 ? "with core dump" : "";
 750   if ($signal or $cd)
 751     {
 752       error( "$0: 'svn $command' failed $cd: exit=$exit signal=$signal\n" );
 753     }
 754
 755   if ( $exit > 0 )
 756     {
 757       info( join( "\n", @output ) );
 758     }
 759   if ( wantarray )
 760     {
 761       return ( $exit, @output );
 762     }
 763
 764   return $exit;
 765 }
 766
 767 \f
 768 #------------------------------------------------------------------------------
 769 # Function:    CreateSVNDirectories
 770 #
 771 # Creates a directory in Subversion, including all intermediate directories.
 772 #
 773 # Parameters:
 774 #       URI         directory path to create.
 775 #       message     commit message (optional).
 776 #
 777 # Returns:     1 on success, 0 on error
 778 #------------------------------------------------------------------------------
 779 sub CreateSVNDirectories
 780 {
 781   my ( $URI, $message ) = @_;
 782   my $r = $URI->clone;
 783   my @path_segments = grep { length($_) } $r->path_segments;
 784   my @r_path_segments;
 785   unshift(@path_segments, '');
 786   $r->path('');
 787
 788   my $found_root = 0;
 789   my $found_tail = 0;
 790
 791   # Prepare a file containing the message
 792   my ($handle, $messagefile) = tempfile( DIR => $temp_dir );
 793   print $handle $message;
 794   close($handle);
 795   my @msgcmd = ( "--file", $messagefile );
 796
 797   # We're going to get errors while we do this.  Don't show the user.
 798   my $old_verbose = $verbose;
 799   $verbose = 0;
 800   # Find the repository root
 801   while (@path_segments)
 802     {
 803       my $segment = shift @path_segments;
 804       push( @r_path_segments, $segment );
 805       $r->path_segments( @r_path_segments );
 806       if ( !$found_root )
 807         {
 808           if ( SVNCall( 'log', '-r', 'HEAD', $r ) == 0 )
 809             {
 810               # We've found the root of the repository.
 811               $found_root = 1;
 812             }
 813         }
 814       elsif ( !$found_tail )
 815         {
 816           if ( SVNCall( 'log', '-r', 'HEAD', $r ) != 0 )
 817             {
 818               # We've found the first directory which doesn't exist.
 819               $found_tail = 1;
 820             }
 821         }
 822
 823       if ( $found_tail )
 824         {
 825           # We're creating directories
 826           $verbose = $old_verbose;
 827           if ( 0 != SVNCall( 'mkdir', @msgcmd, $r ) )
 828             {
 829               error( "Couldn't create directory '$r'" );
 830               return 0;
 831             }
 832         }
 833     }
 834   $verbose = $old_verbose;
 835
 836   return 1;
 837 }
 838
 839 \f
 840 #------------------------------------------------------------------------------
 841 # Function:    CompareLists
 842 #
 843 # Compares two lists.
 844 #
 845 # Parameters:
 846 #       context    Structure containing the current state of the comparison:
 847 #           list1      [in]  first list
 848 #           list2      [in]  second list
 849 #           diffs      [out] The number of differences
 850 #           added      [out] The entries in list2 not in list1
 851 #           removed    [out] The entries in list1 not in list2
 852 #           common     [out] The entries in both lists
 853 #
 854 # Returns:     The number of differences
 855 #------------------------------------------------------------------------------
 856 sub CompareLists
 857 {
 858   my $context = $_[0];
 859   my %count = ();
 860
 861   # Make sure everything's clean
 862   @{$context->{added}} = ();
 863   @{$context->{removed}} = ();
 864   @{$context->{common}} = ();
 865
 866   # Add the elements from list 1 into the hash
 867   foreach $element( @{$context->{list1}} )
 868     {
 869       $count{$element}++;
 870     }
 871   # Add the elements from list 2 into the hash (negative)
 872   foreach $element( @{$context->{list2}} )
 873     {
 874       $count{$element}--;
 875     }
 876
 877   # Now elements in list1 only have a count of 1, in list2 only have a
 878   # count of -1, and in both have a count of 0
 879   foreach $element ( keys %count )
 880     {
 881       if ( 1 == $count{$element} ) { push( @{$context->{removed}}, $element ); }
 882       elsif ( 0 == $count{$element} ) { push( @{$context->{common}}, $element ); }
 883       else { push( @{$context->{added}}, $element ); }
 884     }
 885
 886   $context->{diffs} = scalar( @{$context->{added}} ) +
 887                       scalar( @{$context->{removed}} );
 888
 889   return $context->{diffs};
 890 }
 891
 892 \f
 893 #------------------------------------------------------------------------------
 894 # Function:    info
 895 #
 896 # Prints out an informational message in verbose mode
 897 #
 898 # Parameters:
 899 #       @_     The message(s) to print
 900 #
 901 # Returns:     none
 902 #------------------------------------------------------------------------------
 903 sub info
 904 {
 905   if ( $verbose )
 906     {
 907       print @_;
 908     }
 909 }
 910
 911 \f
 912 #------------------------------------------------------------------------------
 913 # Function:    error
 914 #
 915 # Prints out and logs an error message
 916 #
 917 # Parameters:
 918 #       @_     The error messages
 919 #
 920 # Returns:     none
 921 #------------------------------------------------------------------------------
 922 sub error
 923 {
 924   my $error;
 925
 926   # This is used during testing
 927   if ( $hideerrors )
 928     {
 929       return;
 930     }
 931
 932   # Now print out each error message and add it to the list.
 933   foreach $error ( @_ )
 934     {
 935       my $text = "svncopy.pl: $error\n";
 936       push( @errors, $text );
 937       if ( $verbose )
 938         {
 939           print $text;
 940         }
 941     }
 942 }
 943
 944 \f
 945 #------------------------------------------------------------------------------
 946 # Function:    Usage
 947 #
 948 # Prints out usage information.
 949 #
 950 # Parameters:
 951 #       optional error message
 952 #
 953 # Returns:     none
 954 #------------------------------------------------------------------------------
 955 sub Usage
 956 {
 957   my $msg;
 958   $msg = "\n*** $_[0] ***\n" if $_[0];
 959
 960   pod2usage( { -message => $msg,
 961                -verbose => 0 } );
 962 }
 963
 964 \f
 965 #------------------------------------------------------------------------------
 966 # This package exists just to delete the temporary directory.
 967 #------------------------------------------------------------------------------
 968 package Temp::Delete;
 969
 970 use File::Temp   0.12   qw(tempdir);
 971
 972 sub new
 973 {
 974   my $this = shift;
 975   my $class = ref($this) || $this;
 976   my $self = {};
 977   bless $self, $class;
 978
 979   my $temp_dir = tempdir("testsvncopy_XXXXXXXXXX", TMPDIR => 1);
 980
 981   $self->{tempdir} = $temp_dir;
 982
 983   return $self;
 984 }
 985
 986 sub temp_dir
 987 {
 988   my $self = shift;
 989   return $self->{tempdir};
 990 }
 991
 992 sub DESTROY
 993 {
 994   my $self = shift;
 995   my $temp_dir = $self->{tempdir};
 996   if ( scalar( @errors ) )
 997   {
 998     print "Leaving $temp_dir for inspection\n";
 999   }
1000   else
1001   {
1002     info( "Cleaning up $temp_dir\n" );
1003     File::Path::rmtree([$temp_dir], 0, 0);
1004   }
1005
1006   # Return to the original directory
1007   chdir( $startDir );
1008 }
1009
1010 \f
1011 #------------------------------------------------------------------------------
1012 # Documentation follows, in pod format.
1013 #------------------------------------------------------------------------------
1014 __END__
1015
1016 =head1 NAME
1017
1018 B<testsvncopy> - tests for B<svncopy> script
1019
1020 =head1 SYNOPSIS
1021
1022 B<testsvncopy.pl> [option ...]
1023
1024 B<testsvncopy.pl> tests the operation of the B<svncopy.pl> script.
1025
1026  Options:
1027   -t [--test-repository] : URL to repository for root of tests
1028   -q [--quiet]           : print as little as possible
1029   --username arg         : specify a username ARG
1030   --password arg         : specify a password ARG
1031   --no-auth-cache        : do not cache authentication tokens
1032   --force-log            : force validity of log message source
1033   --encoding arg         : treat value as being in charset encoding ARG
1034   --config-dir arg       : read user configuration files from directory ARG
1035   --[no]verbose          : set the script to give lots of output
1036
1037 =head1 OPTIONS
1038
1039 =over 8
1040
1041 =item B<-t [--test-repository]>
1042
1043 Specify a URL to a scratch area of repository which the tests can use.
1044 This can be any valid repository URL.
1045
1046 =item B<-q [--quiet]>
1047
1048 Print as little as possible
1049
1050 =item B<--username arg>
1051
1052 Specify a username ARG
1053
1054 =item B<--password arg>
1055
1056 Specify a password ARG
1057
1058 =item B<--no-auth-cache>
1059
1060 Do not cache authentication tokens
1061
1062 =item B<--force-log>
1063
1064 Force validity of log message source
1065
1066 =item B<--encoding arg>
1067
1068 Treat value as being in charset encoding ARG
1069
1070 =item B<--config-dir arg>
1071
1072 Read user configuration files from directory ARG
1073
1074 =item B<--[no]verbose>
1075
1076 Set the script to give lots of output when it runs
1077
1078 =item B<--help>
1079
1080 Print a brief help message and exits
1081
1082 =back
1083
1084 =head1 DESCRIPTION
1085
1086 B<svncopy.pl> is a utility script which performs an B<svn copy> command.
1087 It allows extra processing to get around some limitations of the B<svn copy>
1088 command (in particular related to branching and tagging).
1089
1090 B<testsvncopy.pl> tests the operation of this script.
1091
1092 =cut
1093
1094 #------------------------------- END OF FILE ----------------------------------