| #! /usr/bin/perl |
| # |
| # testsvncopy.pl -- test script for svncopy.pl. |
| # |
| # This program is free software; you can redistribute it and/or modify it |
| # under the terms of the GNU General Public License as published by the |
| # Free Software Foundation; either version 2 of the License, or (at your |
| # option) any later version. |
| # |
| # THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED |
| # WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF |
| # MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN |
| # NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, |
| # INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT |
| # NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF |
| # USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON |
| # ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT |
| # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF |
| # THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. |
| # |
| # You should have received a copy of the GNU General Public License along |
| # with this program; if not, write to the Free Software Foundation, Inc., |
| # 59 Temple Place - Suite 330, Boston MA 02111-1307 USA. |
| # |
| # This product makes use of software developed by |
| # CollabNet (http://www.Collab.Net/), see http://subversion.tigris.org/. |
| # |
| # This software consists of voluntary contributions made by many |
| # individuals. For exact contribution history, see the revision |
| # history and logs, available at http://subversion.tigris.org/. |
| #------------------------------------------------------------------------------ |
| |
| #------------------------------------------------------------------------------ |
| # |
| # This script tests the operation of svncopy.pl. |
| # |
| # For more information see the pod documentation at the foot of the file, |
| # or run testsvncopy.pl -?. |
| # |
| #------------------------------------------------------------------------------ |
| |
| # |
| # Include files |
| # |
| use Cwd; |
| use File::Temp 0.12 qw(tempdir tempfile); |
| use Getopt::Long 2.25; |
| use Pod::Usage; |
| use URI 1.17; |
| |
| # |
| # Global definitions |
| # |
| |
| # Specify the location of the svn command. |
| my $svn = '@SVN_BINDIR@/svn'; |
| |
| # The scratch repository location for the tests |
| my $testroot = '@SVN_TEST_REPOSITORY@'; |
| |
| # Input parameters |
| my $verbose = 0; |
| my @svn_options = (); |
| |
| # Internal information |
| my %externals_hash; |
| my $temp_dir; |
| |
| # Error handling |
| my @errors = (); |
| my @warnings = (); |
| |
| # Testing-specific variables |
| my $hideerrors = 0; |
| |
| |
| #------------------------------------------------------------------------------ |
| # Main execution block |
| # |
| |
| # |
| # Process arguments |
| # |
| GetOptions( "verbose!" => sub { $verbose = 1; push( @svn_options, "--verbose" ) }, |
| "quiet|q" => sub { $verbose = 0; push( @svn_options, "--quiet" ) }, |
| "username=s" => sub { push( @svn_options, "--username", $_[1] ) }, |
| "password=s" => sub { push( @svn_options, "--password", $_[1] ) }, |
| "no_auth_cache" => sub { push( @svn_options, "--no-auth-cache" ) }, |
| "force-log" => sub { push( @svn_options, "--force-log" ) }, |
| "encoding=s" => sub { push( @svn_options, "--encoding", $_[1] ) }, |
| "config-dir=s" => sub { push( @svn_options, "--config-dir", $_[1] ) }, |
| "test-repository|t=s" => \$testroot, |
| "help|?" => sub{ Usage() }, |
| ) or Usage(); |
| |
| # Put in a signal handler to clean up any temporary directories. |
| sub catch_signal { |
| my $signal = shift; |
| warn "$0: caught signal $signal. Quitting now.\n"; |
| exit 1; |
| } |
| |
| $SIG{HUP} = \&catch_signal; |
| $SIG{INT} = \&catch_signal; |
| $SIG{TERM} = \&catch_signal; |
| $SIG{PIPE} = \&catch_signal; |
| |
| # Make sure we're in the correct directory, saving current before we move |
| my $startDir = cwd; |
| if ( $0 =~ m"(.*[\\/])[^\\/]+$" ) |
| { |
| my $programDir = $1; |
| chdir( $programDir ); |
| } |
| |
| # Run the tests |
| testUpdateExternals(); |
| |
| # Check whether they passed |
| if ( 0 != scalar( @errors ) ) |
| { |
| print "\n*****************************************************************\n"; |
| print "Errors:\n"; |
| print @errors; |
| } |
| else |
| { |
| print "*** Script passed tests ***\n"; |
| } |
| |
| # Return to the original directory |
| chdir( $startDir ); |
| |
| exit( scalar( @errors ) ); |
| |
| |
| #------------------------------------------------------------------------------ |
| # Function: testUpdateExternals |
| # |
| # Tests the script, pushing any errors onto @errors. |
| # |
| # Parameters: |
| # none |
| # |
| # Returns: none |
| #------------------------------------------------------------------------------ |
| sub testUpdateExternals |
| { |
| my $failed = 0; |
| my $retval; |
| my $testsubdir = "svncopy-update"; |
| my $testURL = "$testroot/$testsubdir"; |
| my @testdirs = ( |
| "source/dirA/dir1", |
| "source/dirA/dir2", |
| "source/dirB/dir3", |
| "wibble/dirA/dir2", |
| ); |
| my $dirWithExternals = $testdirs[0]; |
| my $pinnedDir = $testdirs[1]; |
| my $dest = "$testURL/dest"; |
| my $old_verbose = $verbose; |
| my %revisions = {}; |
| my $testRev; |
| |
| my $test_externals = |
| "DIR2 $testURL/source/dirA/dir2\n". # 1 space |
| "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2\n". |
| "DIR3 $testURL/source/dirB/dir3\n". # 5 spaces |
| "DIR4 $testURL/wibble/dirA/dir2"; # 2 tabs |
| |
| my @tests = ( |
| # Updating with nothing to update |
| { sources => [ "$testURL/source/dirA/dir1", ], |
| pin => 0, |
| update => 1, |
| ext_dir => "dir1", |
| expected_externals => [ |
| "DIR2 $testURL/source/dirA/dir2", |
| "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2", |
| "DIR3 $testURL/source/dirB/dir3", |
| "DIR4 $testURL/wibble/dirA/dir2" |
| ], |
| expected_tree => [ |
| "dir1/", |
| ], |
| }, |
| # Updating a tree - enclosed should change, unless pinned |
| { sources => [ "$testURL/source/dirA", ], |
| pin => 0, |
| update => 1, |
| ext_dir => "dirA/dir1", |
| expected_externals => [ |
| "DIR2 $testURL/dest/dirA/dir2", |
| "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2", |
| "DIR3 $testURL/source/dirB/dir3", |
| "DIR4 $testURL/wibble/dirA/dir2" |
| ], |
| expected_tree => [ |
| "dirA/", |
| "dirA/dir1/", |
| "dirA/dir2/", |
| ], |
| }, |
| # Updating with no update - no change |
| { sources => [ "$testURL/source/dirA", ], |
| pin => 0, |
| update => 0, |
| ext_dir => "dirA/dir1", |
| expected_externals => [ |
| "DIR2 $testURL/source/dirA/dir2", |
| "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2", |
| "DIR3 $testURL/source/dirB/dir3", |
| "DIR4 $testURL/wibble/dirA/dir2" |
| ], |
| expected_tree => [ |
| "dirA/", |
| "dirA/dir1/", |
| "dirA/dir2/", |
| ], |
| }, |
| # Updating with two sources |
| { sources => [ "$testURL/source/dirA/dir1", |
| "$testURL/source/dirB/dir3" ], |
| pin => 0, |
| update => 1, |
| ext_dir => "dir1", |
| expected_externals => [ |
| "DIR2 $testURL/source/dirA/dir2", |
| "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2", |
| "DIR3 $testURL/dest/dir3", |
| "DIR4 $testURL/wibble/dirA/dir2" |
| ], |
| expected_tree => [ |
| "dir1/", |
| "dir3/", |
| ], |
| }, |
| # Pinning |
| { sources => [ "$testURL/source/dirA/dir1", ], |
| pin => 1, |
| update => 0, |
| ext_dir => "dir1", |
| expected_externals => [ |
| "DIR2 -r __REV__ $testURL/source/dirA/dir2", |
| "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2", |
| "DIR3 -r __REV__ $testURL/source/dirB/dir3", |
| "DIR4 -r __REV__ $testURL/wibble/dirA/dir2", |
| ], |
| expected_tree => [ |
| "dir1/", |
| ], |
| }, |
| # Pinning a tree |
| { sources => [ "$testURL/source/dirA", ], |
| pin => 1, |
| update => 0, |
| ext_dir => "dirA/dir1", |
| expected_externals => [ |
| "DIR2 -r __REV__ $testURL/source/dirA/dir2", |
| "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2", |
| "DIR3 -r __REV__ $testURL/source/dirB/dir3", |
| "DIR4 -r __REV__ $testURL/wibble/dirA/dir2", |
| ], |
| expected_tree => [ |
| "dirA/", |
| "dirA/dir1/", |
| "dirA/dir2/", |
| ], |
| }, |
| # Pinning with two sources |
| { sources => [ "$testURL/source/dirA/dir1", |
| "$testURL/source/dirB/dir3" ], |
| pin => 1, |
| update => 0, |
| ext_dir => "dir1", |
| expected_externals => [ |
| "DIR2 -r __REV__ $testURL/source/dirA/dir2", |
| "DIR2Pin -r __PINREV__ $testURL/source/dirA/dir2", |
| "DIR3 -r __REV__ $testURL/source/dirB/dir3", |
| "DIR4 -r __REV__ $testURL/wibble/dirA/dir2", |
| ], |
| expected_tree => [ |
| "dir1/", |
| "dir3/", |
| ], |
| }, |
| ); |
| |
| my $auto_temp_dir = Temp::Delete->new(); |
| my $test_temp_dir = $auto_temp_dir->temp_dir(); |
| $temp_dir = $test_temp_dir; |
| print "\n################################################################\n"; |
| print( "Testing svncopy.pl\n" ); |
| info( "Using temporary directory $test_temp_dir\n" ); |
| print( "Preparing source directory structure...\n" ); |
| |
| # |
| # Set up the source directory to copy |
| # |
| |
| # Kill the directory if it's there |
| info( " - Deleting '$testURL'\n" ); |
| SVNCall( 'delete', '-m', '"Preparing to test svncopy --update-externals"', $testURL ); |
| |
| # Now create the source directories |
| foreach my $dir ( @testdirs ) |
| { |
| if ( !CreateTestDirectory( "$testURL/$dir" ) ) |
| { |
| $failed = 1; |
| return; |
| } |
| } |
| |
| # Check out the test root |
| if ( 0 != SVNCall( "co", $testURL, "$test_temp_dir/$testsubdir" ) ) |
| { |
| error( "Preparatory checkout failed" ); |
| $failed = 1; |
| return; |
| } |
| |
| # Set an svn:externals on it |
| # - work our what externals we need to set (get the revision for the |
| # pinned directory) |
| my $pinnedRev = CurrentRevision( "$testURL/$pinnedDir" ); |
| $test_externals =~ s|__PINREV__|$pinnedRev|gi; |
| |
| # Now write the externals to a temporary file and set them on the dir. |
| my ($handle, $tmpfile) = tempfile( DIR => $test_temp_dir ); |
| print $handle $test_externals; |
| close($handle); |
| if ( 0 != SVNCall( "propset", "svn:externals", |
| "--file", $tmpfile, |
| "$test_temp_dir/$testsubdir/$dirWithExternals" ) ) |
| { |
| error( "svn propset of svn:externals failed" ); |
| $failed = 1; |
| return; |
| } |
| |
| # And commit them |
| if ( 0 != SVNCall( "commit", "-m", |
| "\"Testing svncopy --update_externals - adding svn:externals\"", |
| "$test_temp_dir/$testsubdir/$dirWithExternals" ) ) |
| { |
| error( "svn commit failed" ); |
| $failed = 1; |
| return; |
| } |
| |
| # |
| # Also set a property on the pinned directory to make sure the pinned |
| # revision isn't the last one. |
| # |
| if ( 0 != SVNCall( "propset", |
| "svncopyTest", |
| "wibble", |
| "$test_temp_dir/$testsubdir/$pinnedDir" ) ) |
| { |
| error( "svn propset of svncopyTest failed" ); |
| $failed = 1; |
| return; |
| } |
| # And commit |
| if ( 0 != SVNCall( "commit", "-m", |
| "\"Testing svncopy --update_externals - adding svncopyTest property\"", |
| "$test_temp_dir/$testsubdir/$pinnedDir" ) ) |
| { |
| error( "svn commit failed" ); |
| $failed = 1; |
| return; |
| } |
| |
| # Having done all the set-up, get our revision numbers. |
| foreach my $dir ( @testdirs ) |
| { |
| $revisions{ "$testURL/$dir" } = CurrentRevision( "$testURL/$dir" ); |
| } |
| |
| print( "...Source directory structure complete\n" ); |
| |
| # Script parameters |
| my $message = "\"Testing svncopy.pl\""; |
| |
| TEST: foreach my $testtype ( "HEAD", "-r" ) |
| { |
| my @copy_options = @svn_options; |
| my $testno = 1; |
| |
| # Do extra setup for -r |
| if ( "-r" eq $testtype ) |
| { |
| $testRev = $revisions{ "$testURL/$pinnedDir" }; |
| print "Updating repository to run --revision tests against revision ". |
| "$testRev...\n"; |
| |
| # |
| # Copy the same revision we did before |
| # The last thing we changed was the pinned directory, so |
| # take its revision as the one we want to copy. |
| # |
| push( @copy_options, "--revision", "$testRev" ); |
| |
| # |
| # Now add a file to each directory. |
| # |
| foreach my $dir ( @testdirs ) |
| { |
| if ( !UpdateTestDirectory( "$test_temp_dir/$testsubdir/$dir" ) ) |
| { |
| $failed = 1; |
| return; |
| } |
| } |
| |
| # And commit |
| if ( 0 != SVNCall( "commit", "-m", |
| "\"Testing svncopy --update_externals". |
| " - updating directories for '--revision' test\"", |
| "$test_temp_dir/$testsubdir" ) ) |
| { |
| error( "svn commit of updated directories failed" ); |
| $failed = 1; |
| return; |
| } |
| |
| print "...update done. Now re-running tests against new repository\n"; |
| } |
| |
| foreach my $test ( @tests ) |
| { |
| my @cmd_options = @copy_options; |
| |
| print "\n################################################################\n"; |
| print "### test number $testno\n"; |
| |
| # Kill the destination directory if it's there |
| $verbose = 0; |
| SVNCall( 'delete', '-m', '"Preparing to test svncopy --update-externals"', $dest ); |
| $verbose = $old_verbose; |
| |
| my @sources = @{$test->{sources}}; |
| my @expected_externals = @{$test->{expected_externals}}; |
| my @expected_tree = @{$test->{expected_tree}}; |
| |
| # Update global parameters |
| push( @cmd_options, "--message", "$message" ); |
| push( @cmd_options, "--tag" ) if ( $test->{pin} ); |
| push( @cmd_options, "--branch" ) if ( $test->{update} ); |
| |
| # Now do the copy |
| my @cmdline = ( "perl", "svncopy.pl", @cmd_options, @sources, $dest ); |
| info( "\n=> Calling ", join( " ", @cmdline ), "\n\n" ); |
| if ( system( @cmdline ) ) |
| { |
| error( "Copy failed" ); |
| $failed = 1; |
| } |
| |
| # Check that the generated tree is as expected. |
| if ( !CheckTree( $dest, @expected_tree ) ) |
| { |
| # CheckTree outputs an error message if it fails |
| $failed = 1; |
| } |
| |
| # And check the externals |
| my $ext_dir = "$dest/$test->{ext_dir}"; |
| if ( !CheckExternals( $ext_dir, \%revisions, $pinnedRev, @expected_externals ) ) |
| { |
| # CheckExternals outputs an error message if it fails |
| $failed = 1; |
| } |
| |
| # Bomb out if we had an error |
| if ( $failed ) |
| { |
| print "\n*** '$testtype' test $testno failed ***\n"; |
| print "****************************************************************\n"; |
| last TEST; |
| } |
| |
| print "\n### '$testtype' test $testno passed\n"; |
| print "################################################################\n"; |
| $testno++; |
| } |
| } |
| |
| if ( $failed ) { error( "*** svncopy tests failed\n" ); } |
| else { print "... svncopy tests passed\n"; } |
| } |
| |
| |
| #------------------------------------------------------------------------------ |
| # Function: CreateTestDirectory |
| # |
| # Creates a directory in svn. |
| # |
| # Parameters: |
| # svnpath directory to create |
| # |
| # Returns: non-zero on success |
| #------------------------------------------------------------------------------ |
| sub CreateTestDirectory |
| { |
| my $svnpath = $_[0]; |
| |
| my $test_uri = URI->new( "$svnpath" ); |
| info( "Creating '$test_uri'\n" ); |
| if ( !CreateSVNDirectories( $test_uri, "Testing svncopy --update_externals" ) ) |
| { |
| error( "CreateSVNDirectories on '$test_uri' failed" ); |
| return 0; |
| } |
| |
| return 1; |
| } |
| |
| |
| #------------------------------------------------------------------------------ |
| # Function: UpdateTestDirectory |
| # |
| # Modifies the directory in the working copy so that we can check the version |
| # copied is correct. |
| # |
| # Parameters: |
| # dir directory to modify (on file system) |
| # |
| # Returns: non-zero on success |
| #------------------------------------------------------------------------------ |
| sub UpdateTestDirectory |
| { |
| my $dir = $_[0]; |
| my $testfile = "$dir/test.txt"; |
| |
| # Create a file in the directory |
| if ( !open FILE, ">$testfile" ) |
| { |
| error( "Couldn't create test file '$testfile'" ); |
| return 0; |
| } |
| print FILE "Test file in '$dir'\n"; |
| close FILE; |
| |
| # Now add it to Subversion |
| if ( 0 != SVNCall( "add", $testfile ) ) |
| { |
| error( "svn add '$testfile' failed" ); |
| return 0; |
| } |
| |
| # We're done |
| return 1; |
| } |
| |
| |
| #------------------------------------------------------------------------------ |
| # Function: CheckTree |
| # |
| # Checks that directory structure in the subversion location matches |
| # the given tree. |
| # |
| # Parameters: |
| # svnpath Subversion location to check. |
| # expected Expected response - list of files and dirs as returned |
| # by svn list. |
| # |
| # Returns: non-zero on success |
| #------------------------------------------------------------------------------ |
| sub CheckTree |
| { |
| my ( $svnpath, @expected ) = @_; |
| |
| my ( $retval, @output ) = SVNCall( "list", "--recursive", $svnpath ); |
| if ( 0 != $retval ) |
| { |
| error( "svn list on '$svnpath' failed" ); |
| return 0; |
| } |
| |
| # Remove any blank lines and carriage returns |
| @output = grep( { chomp($_); $_ !~ m"^\s*$"} @output ); |
| |
| # Now compare with expected |
| my $compare_ctx = { list1 => [@expected], list2 => [@output] }; |
| |
| if ( 0 != CompareLists( $compare_ctx ) ) |
| { |
| my $addedtext; |
| my $removedtext; |
| |
| if ( @{$compare_ctx->{added}} ) |
| { |
| $addedtext = "\n +".join( "\n +", @{$compare_ctx->{added}} ); |
| } |
| if ( @{$compare_ctx->{removed}} ) |
| { |
| $removedtext = "\n -".join( "\n -", @{$compare_ctx->{removed}} ); |
| } |
| error( "'$svnpath' doesn't match expected$addedtext$removedtext\n" ); |
| |
| return 0; |
| } |
| |
| return 1; |
| } |
| |
| |
| #------------------------------------------------------------------------------ |
| # Function: CheckExternals |
| # |
| # Checks that the subversion location matches the given tree. |
| # |
| # Parameters: |
| # svnpath Subversion location to check. |
| # revisions Hash containing the revisions for externals. |
| # pinnedRev Revision of pinned directory. |
| # expected Expected response - list of externals as returned |
| # by svn propget svn:externals. |
| # |
| # Returns: non-zero on success |
| #------------------------------------------------------------------------------ |
| sub CheckExternals |
| { |
| my ( $svnpath, $revisions, $pinnedRev, @expected ) = @_; |
| my @new_externals; |
| |
| ( $retval, @new_externals ) = SVNCall( "propget", "svn:externals", $svnpath ); |
| if ( 0 != $retval ) |
| { |
| error( "svn propget on '$svnpath' failed" ); |
| return 0; |
| } |
| |
| # Update @expected with revisions |
| @expected = grep |
| { |
| $_ =~ s|__PINREV__|$pinnedRev|g; |
| if ( $_ =~ m"(.*)\s+-r __REV__\s+(.*)" ) |
| { |
| my $path = $1; |
| my $svnpath = $2; |
| my $rev = $revisions->{$svnpath}; |
| $_ =~ s|__REV__|$rev|g; |
| } |
| 1; |
| } @expected; |
| |
| # Remove any blank lines and carriage returns from the output |
| @new_externals = grep( { chomp($_); $_ !~ m"^\s*$"} @new_externals ); |
| |
| # Now compare with expected |
| my $compare_ctx = { list1 => [@expected], list2 => [@new_externals] }; |
| |
| if ( 0 != CompareLists( $compare_ctx ) ) |
| { |
| error( "Externals on '$svnpath' don't match expected\n". |
| " - expected:\n ". |
| join( "\n ", @expected ) . |
| "\n - actual:\n ". |
| join( "\n ", @new_externals ) |
| ); |
| |
| return 0; |
| } |
| |
| return 1; |
| } |
| |
| |
| #------------------------------------------------------------------------------ |
| # Function: CurrentRevision |
| # |
| # Returns the repository revision of the last change to the given object. |
| # |
| # Parameters: |
| # source The URL to check |
| # |
| # Returns: The relevant revision number |
| #------------------------------------------------------------------------------ |
| sub CurrentRevision |
| { |
| my $source = shift; |
| |
| my $old_verbose = $verbose; |
| $verbose = 0; |
| my ( $retval, @output ) = SVNCall( "log -q", $source ); |
| $verbose = $old_verbose; |
| |
| if ( 0 != $retval ) |
| { |
| error( "CurrentRevision: 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( "CurrentRevision: log output not formatted as expected\n" ); |
| |
| return -1; |
| } |
| |
| |
| #------------------------------------------------------------------------------ |
| # 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, @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: CreateSVNDirectories |
| # |
| # Creates a directory in Subversion, including all intermediate directories. |
| # |
| # Parameters: |
| # URI directory path to create. |
| # message commit message (optional). |
| # |
| # Returns: 1 on success, 0 on error |
| #------------------------------------------------------------------------------ |
| sub CreateSVNDirectories |
| { |
| my ( $URI, $message ) = @_; |
| my $r = $URI->clone; |
| my @path_segments = grep { length($_) } $r->path_segments; |
| my @r_path_segments; |
| unshift(@path_segments, ''); |
| $r->path(''); |
| |
| my $found_root = 0; |
| my $found_tail = 0; |
| |
| # Prepare a file containing the message |
| my ($handle, $messagefile) = tempfile( DIR => $temp_dir ); |
| print $handle $message; |
| close($handle); |
| my @msgcmd = ( "--file", $messagefile ); |
| |
| # We're going to get errors while we do this. Don't show the user. |
| my $old_verbose = $verbose; |
| $verbose = 0; |
| # Find the repository root |
| while (@path_segments) |
| { |
| my $segment = shift @path_segments; |
| push( @r_path_segments, $segment ); |
| $r->path_segments( @r_path_segments ); |
| if ( !$found_root ) |
| { |
| if ( SVNCall( 'log', '-r', 'HEAD', $r ) == 0 ) |
| { |
| # We've found the root of the repository. |
| $found_root = 1; |
| } |
| } |
| elsif ( !$found_tail ) |
| { |
| if ( SVNCall( 'log', '-r', 'HEAD', $r ) != 0 ) |
| { |
| # We've found the first directory which doesn't exist. |
| $found_tail = 1; |
| } |
| } |
| |
| if ( $found_tail ) |
| { |
| # We're creating directories |
| $verbose = $old_verbose; |
| if ( 0 != SVNCall( 'mkdir', @msgcmd, $r ) ) |
| { |
| error( "Couldn't create directory '$r'" ); |
| return 0; |
| } |
| } |
| } |
| $verbose = $old_verbose; |
| |
| return 1; |
| } |
| |
| |
| #------------------------------------------------------------------------------ |
| # Function: CompareLists |
| # |
| # Compares two lists. |
| # |
| # Parameters: |
| # context Structure containing the current state of the comparison: |
| # list1 [in] first list |
| # list2 [in] second list |
| # diffs [out] The number of differences |
| # added [out] The entries in list2 not in list1 |
| # removed [out] The entries in list1 not in list2 |
| # common [out] The entries in both lists |
| # |
| # Returns: The number of differences |
| #------------------------------------------------------------------------------ |
| sub CompareLists |
| { |
| my $context = $_[0]; |
| my %count = (); |
| |
| # Make sure everything's clean |
| @{$context->{added}} = (); |
| @{$context->{removed}} = (); |
| @{$context->{common}} = (); |
| |
| # Add the elements from list 1 into the hash |
| foreach $element( @{$context->{list1}} ) |
| { |
| $count{$element}++; |
| } |
| # Add the elements from list 2 into the hash (negative) |
| foreach $element( @{$context->{list2}} ) |
| { |
| $count{$element}--; |
| } |
| |
| # Now elements in list1 only have a count of 1, in list2 only have a |
| # count of -1, and in both have a count of 0 |
| foreach $element ( keys %count ) |
| { |
| if ( 1 == $count{$element} ) { push( @{$context->{removed}}, $element ); } |
| elsif ( 0 == $count{$element} ) { push( @{$context->{common}}, $element ); } |
| else { push( @{$context->{added}}, $element ); } |
| } |
| |
| $context->{diffs} = scalar( @{$context->{added}} ) + |
| scalar( @{$context->{removed}} ); |
| |
| return $context->{diffs}; |
| } |
| |
| |
| #------------------------------------------------------------------------------ |
| # Function: info |
| # |
| # Prints out an informational message in verbose mode |
| # |
| # Parameters: |
| # @_ The message(s) to print |
| # |
| # Returns: none |
| #------------------------------------------------------------------------------ |
| sub info |
| { |
| if ( $verbose ) |
| { |
| print @_; |
| } |
| } |
| |
| |
| #------------------------------------------------------------------------------ |
| # Function: error |
| # |
| # Prints out and logs an error message |
| # |
| # Parameters: |
| # @_ The error messages |
| # |
| # Returns: none |
| #------------------------------------------------------------------------------ |
| sub error |
| { |
| my $error; |
| |
| # This is used during testing |
| if ( $hideerrors ) |
| { |
| return; |
| } |
| |
| # Now print out each error message and add it to the list. |
| foreach $error ( @_ ) |
| { |
| my $text = "svncopy.pl: $error\n"; |
| push( @errors, $text ); |
| if ( $verbose ) |
| { |
| print $text; |
| } |
| } |
| } |
| |
| |
| #------------------------------------------------------------------------------ |
| # Function: Usage |
| # |
| # Prints out usage information. |
| # |
| # Parameters: |
| # optional error message |
| # |
| # Returns: none |
| #------------------------------------------------------------------------------ |
| sub Usage |
| { |
| my $msg; |
| $msg = "\n*** $_[0] ***\n" if $_[0]; |
| |
| pod2usage( { -message => $msg, |
| -verbose => 0 } ); |
| } |
| |
| |
| #------------------------------------------------------------------------------ |
| # This package exists just to delete the temporary directory. |
| #------------------------------------------------------------------------------ |
| package Temp::Delete; |
| |
| use File::Temp 0.12 qw(tempdir); |
| |
| sub new |
| { |
| my $this = shift; |
| my $class = ref($this) || $this; |
| my $self = {}; |
| bless $self, $class; |
| |
| my $temp_dir = tempdir("testsvncopy_XXXXXXXXXX", TMPDIR => 1); |
| |
| $self->{tempdir} = $temp_dir; |
| |
| return $self; |
| } |
| |
| sub temp_dir |
| { |
| my $self = shift; |
| return $self->{tempdir}; |
| } |
| |
| sub DESTROY |
| { |
| my $self = shift; |
| my $temp_dir = $self->{tempdir}; |
| if ( scalar( @errors ) ) |
| { |
| print "Leaving $temp_dir for inspection\n"; |
| } |
| else |
| { |
| info( "Cleaning up $temp_dir\n" ); |
| File::Path::rmtree([$temp_dir], 0, 0); |
| } |
| |
| # Return to the original directory |
| chdir( $startDir ); |
| } |
| |
| |
| #------------------------------------------------------------------------------ |
| # Documentation follows, in pod format. |
| #------------------------------------------------------------------------------ |
| __END__ |
| |
| =head1 NAME |
| |
| B<testsvncopy> - tests for B<svncopy> script |
| |
| =head1 SYNOPSIS |
| |
| B<testsvncopy.pl> [option ...] |
| |
| B<testsvncopy.pl> tests the operation of the B<svncopy.pl> script. |
| |
| Options: |
| -t [--test-repository] : URL to repository for root of tests |
| -q [--quiet] : print as little as possible |
| --username arg : specify a username ARG |
| --password arg : specify a password ARG |
| --no-auth-cache : do not cache authentication tokens |
| --force-log : force validity of log message source |
| --encoding arg : treat value as being in charset encoding ARG |
| --config-dir arg : read user configuration files from directory ARG |
| --[no]verbose : set the script to give lots of output |
| |
| =head1 OPTIONS |
| |
| =over 8 |
| |
| =item B<-t [--test-repository]> |
| |
| Specify a URL to a scratch area of repository which the tests can use. |
| This can be any valid repository URL. |
| |
| =item B<-q [--quiet]> |
| |
| Print as little as possible |
| |
| =item B<--username arg> |
| |
| Specify a username ARG |
| |
| =item B<--password arg> |
| |
| Specify a password ARG |
| |
| =item B<--no-auth-cache> |
| |
| Do not cache authentication tokens |
| |
| =item B<--force-log> |
| |
| Force validity of log message source |
| |
| =item B<--encoding arg> |
| |
| Treat value as being in charset encoding ARG |
| |
| =item B<--config-dir arg> |
| |
| Read user configuration files from directory ARG |
| |
| =item B<--[no]verbose> |
| |
| Set the script to give lots of output when it runs |
| |
| =item B<--help> |
| |
| Print a brief help message and exits |
| |
| =back |
| |
| =head1 DESCRIPTION |
| |
| B<svncopy.pl> is a utility script which performs an B<svn copy> command. |
| It allows extra processing to get around some limitations of the B<svn copy> |
| command (in particular related to branching and tagging). |
| |
| B<testsvncopy.pl> tests the operation of this script. |
| |
| =cut |
| |
| #------------------------------- END OF FILE ---------------------------------- |
