1# BEGIN BPS TAGGED BLOCK {{{ 2# COPYRIGHT: 3# 4# This software is Copyright (c) 2003-2008 Best Practical Solutions, LLC 5# <clkao@bestpractical.com> 6# 7# (Except where explicitly superseded by other copyright notices) 8# 9# 10# LICENSE: 11# 12# 13# This program is free software; you can redistribute it and/or 14# modify it under the terms of either: 15# 16# a) Version 2 of the GNU General Public License. You should have 17# received a copy of the GNU General Public License along with this 18# program. If not, write to the Free Software Foundation, Inc., 51 19# Franklin Street, Fifth Floor, Boston, MA 02110-1301 or visit 20# their web page on the internet at 21# http://www.gnu.org/copyleft/gpl.html. 22# 23# b) Version 1 of Perl's "Artistic License". You should have received 24# a copy of the Artistic License with this package, in the file 25# named "ARTISTIC". The license is also available at 26# http://opensource.org/licenses/artistic-license.php. 27# 28# This work is distributed in the hope that it will be useful, but 29# WITHOUT ANY WARRANTY; without even the implied warranty of 30# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU 31# General Public License for more details. 32# 33# CONTRIBUTION SUBMISSION POLICY: 34# 35# (The following paragraph is not intended to limit the rights granted 36# to you to modify and distribute this software under the terms of the 37# GNU General Public License and is only of importance to you if you 38# choose to contribute your changes and enhancements to the community 39# by submitting them to Best Practical Solutions, LLC.) 40# 41# By intentionally submitting any modifications, corrections or 42# derivatives to this work, or any other work intended for use with SVK, 43# to Best Practical Solutions, LLC, you confirm that you are the 44# copyright holder for those contributions and you grant Best Practical 45# Solutions, LLC a nonexclusive, worldwide, irrevocable, royalty-free, 46# perpetual, license to use, copy, create derivative works based on 47# those contributions, and sublicense and distribute those contributions 48# and any derivatives thereof. 49# 50# END BPS TAGGED BLOCK }}} 51package SVK::Test; 52use strict; 53 54# When running tests, don't let the user's .subversion/config 55# affect results. 56BEGIN { $ENV{SVKNOSVNCONFIG} = 1; } 57 58use SVK::Version; our $VERSION = $SVK::VERSION; 59use base 'Exporter'; 60 61use SVK::Logger; 62 63our @EXPORT = qw(plan_svm new_repos build_test build_floating_test 64 get_copath append_file overwrite_file 65 overwrite_file_raw is_file_content 66 is_file_content_raw _do_run is_output 67 is_sorted_output is_deeply_like is_output_like 68 is_output_unlike is_ancestor status_native status 69 get_editor create_basic_tree waste_rev 70 tree_from_fsroot tree_from_xdroot __ _x not_x _l 71 not_l uri set_editor replace_file glob_mime_samples 72 create_mime_samples chmod_probably_useless 73 add_prop_to_basic_tree 74 75 catdir HAS_SVN_MIRROR IS_WIN32 install_perl_hook 76 77 rmtree mkpath @TOCLEAN $output $answer $show_prompt); 78 79use Test::More; 80push @EXPORT, @Test::More::EXPORT; 81sub import { 82 my $class = shift; 83 84 my $caller = caller; 85 my $tb = Test::More->builder; 86 $tb->exported_to($caller); 87 88 $class->export_to_level(1, @_); 89} 90 91my $pid = $$; 92 93our @TOCLEAN; 94END { 95 return unless $$ == $pid; 96 rm_test($_) for @TOCLEAN; 97} 98 99use SVK; 100use File::Path; 101use File::Temp; 102use SVK::Util qw( dirname catdir tmpdir can_run abs_path $SEP $EOL IS_WIN32 HAS_SVN_MIRROR ); 103require Storable; 104use SVK::Path::Checkout; 105 106# Fake standard input 107our $answer = []; 108our $output; 109 110our $show_prompt = 0; 111 112BEGIN { 113 no warnings 'redefine'; 114 # override get_prompt in XD so devel::cover is happy for 115 # already-exported symbols being overridden 116 *SVK::Util::get_prompt = *SVK::XD::get_prompt = sub { 117 local $| = 1; 118 print "$_[0]\n" if $show_prompt; 119 $logger->debug("$_[0]"); 120 return $answer unless ref($answer); # compat 121 die "expecting input" unless @$answer; 122 my $ans = shift @$answer; 123 $logger->debug("-> ".($answer->[0]||'')); 124 return $ans unless ref($ans); 125 126 if (ref($ans->[0]) eq 'Regexp') { 127 Carp::cluck "prompt mismatch ($_[0]) vs ($ans->[0])" unless $_[0] =~ m/$ans->[0]/s; 128 } 129 else { 130 Carp::cluck "prompt mismatch ($_[0]) vs ($ans->[0])" if $_[0] ne $ans->[0]; 131 } 132 return $ans->[1]; 133 } unless $ENV{DEBUG_INTERACTIVE}; 134 135# chdir catdir(abs_path(dirname(__FILE__)), '..' ); 136} 137 138sub plan_svm { 139 unless (HAS_SVN_MIRROR) { 140 plan skip_all => "SVN::Mirror not installed"; 141 exit; 142 }; 143 plan @_; 144} 145 146use Carp; 147use SVK; 148use SVK::XD; 149 150END { 151 return unless $$ == $pid; 152 $SIG{__WARN__} = sub { 1 }; 153 cleanup_test($_) for @TOCLEAN; 154} 155 156for (qw/SVKRESOLVE SVKMERGE SVKDIFF SVKPGP SVKLOGOUTPUT LC_CTYPE LC_ALL LANG LC_MESSAGES/) { 157 $ENV{$_} = '' if $ENV{$_}; 158} 159$ENV{LANGUAGE} = $ENV{LANGUAGES} = 'i-default'; 160 161$ENV{SVKRESOLVE} = 's'; # default for test 162$ENV{HOME} ||= ( 163 $ENV{HOMEDRIVE} ? catdir(@ENV{qw( HOMEDRIVE HOMEPATH )}) : '' 164) || (getpwuid($<))[7]; 165$ENV{USER} ||= ( 166 (defined &Win32::LoginName) ? Win32::LoginName() : '' 167) || $ENV{USERNAME} || (getpwuid($<))[0]; 168 169# Make "prove -l" happy; abs_path() returns "undef" if the path 170# does not exist. This makes perl very unhappy. 171@INC = grep defined, map abs_path($_), @INC; 172 173if ($ENV{DEBUG}) { 174 { 175 package Tie::StdScalar::Tee; 176 require Tie::Scalar; 177 our @ISA = 'Tie::StdScalar'; 178 sub STORE { print STDOUT $_[1] ; ${$_[0]} = $_[1]; } 179 } 180 tie $output => 'Tie::StdScalar::Tee'; 181} 182 183my $pool = SVN::Pool->new_default; 184 185sub new_repos { 186 my $repospath = catdir(tmpdir(), "svk-$$"); 187 my $reposbase = $repospath; 188 my $repos; 189 my $i = 0; 190 while (-e $repospath) { 191 $repospath = $reposbase . '-'. (++$i); 192 } 193 my $pool = SVN::Pool->new_default; 194 $repos = SVN::Repos::create("$repospath", undef, undef, undef, 195 {'fs-type' => $ENV{SVNFSTYPE} || 'fsfs'}) 196 or die "failed to create repository at $repospath"; 197 return $repospath; 198} 199 200sub build_test { 201 my (@depot) = @_; 202 203 my $depotmap = {map {$_ => (new_repos())[0]} '',@depot}; 204 my $xd = SVK::XD->new (depotmap => $depotmap, 205 svkpath => $depotmap->{''}); 206 my $svk = SVK->new (xd => $xd, $ENV{DEBUG_INTERACTIVE} ? () : (output => \$output)); 207 push @TOCLEAN, [$xd, $svk]; 208 return ($xd, $svk); 209} 210 211sub build_floating_test { 212 my ($directory) = @_; 213 214 my $svkpath = File::Spec->catfile($directory, '.svk'); 215 my $xd = SVK::XD->new (statefile => File::Spec->catfile($svkpath, 'config'), 216 giantlock => File::Spec->catfile($svkpath, 'lock'), 217 svkpath => $svkpath, 218 floating => $directory); 219 $xd->load; 220 my $svk = SVK->new (xd => $xd, $ENV{DEBUG_INTERACTIVE} ? () : (output => \$output)); 221 push @TOCLEAN, [$xd, $svk]; 222 return ($xd, $svk); 223} 224 225sub get_copath { 226 my ($name) = @_; 227 unless ($name) { 228 $name = lc($0); 229 $name =~ s/\.t$//; 230 $name =~ s/(\W|[_-])+//g; 231 } 232 my $copath = SVK::Path::Checkout->copath ('t', "checkout/$name"); 233 mkpath [$copath] unless -d $copath; 234 rmtree [$copath] if -e $copath; 235 return ($copath, File::Spec->rel2abs($copath)); 236} 237 238sub rm_test { 239 my ($xd, $svk) = @{+shift}; 240 for my $depot (sort keys %{$xd->{depotmap}}) { 241 my $path = $xd->{depotmap}{$depot}; 242 die if $path eq '/'; 243 rmtree [$path]; 244 } 245} 246 247sub cleanup_test { 248 my ($xd, $svk) = @{+shift}; 249 for my $depotname (sort keys %{$xd->{depotmap}}) { 250 my $pool = SVN::Pool->new_default; 251 my $depot = eval { $xd->find_depot($depotname) } or next; 252 my @txns = @{ $depot->repos->fs->list_transactions }; 253 if (@txns) { 254 my $how_many = @txns; 255 diag "uncleaned txns ($how_many) on /$depotname/"; 256 if ( $ENV{SVKTESTUNCLEANTXN} ) { 257 for my $txn_name ( sort @txns ) { 258 my $txn = $depot->repos->fs->open_txn($txn_name); 259 my $log = $txn->prop('svn:log'); 260 diag "$txn_name: $log"; 261 } 262 } 263 } 264 } 265 return unless $ENV{TEST_VERBOSE}; 266 use YAML::Syck; 267 print Dump($xd); 268 for my $depotname (sort keys %{$xd->{depotmap}}) { 269 my $pool = SVN::Pool->new_default; 270 my $depot = eval { $xd->find_depot($depotname) } or next; 271 print "===> depot /$depotname/ (".$depot->repos->fs->get_uuid."):\n"; 272 $svk->log ('-v', "/$depotname/"); 273 # if DEBUG is set, the log command already printed the log to 274 # stdout; if it isn't, we have to do it ourself 275 print ${$svk->{output}} unless $ENV{DEBUG}; 276 } 277} 278 279sub append_file { 280 my ($file, $content) = @_; 281 open my ($fh), '>>', $file or die "can't append $file: $!"; 282 print $fh $content; 283 close $fh; 284} 285 286sub overwrite_file { 287 my ($file, $content) = @_; 288 open my ($fh), '>', $file or confess "Cannot overwrite $file: $!"; 289 print $fh $content; 290 close $fh; 291} 292 293sub overwrite_file_raw { 294 my ($file, $content) = @_; 295 open my ($fh), '>:raw', $file or confess "Cannot overwrite $file: $!"; 296 print $fh $content; 297 close $fh; 298} 299 300sub is_file_content { 301 my ($file, $content, $test) = @_; 302 unless (-e $file) { 303 @_ = (undef, $content, $test); 304 goto &is; 305 } 306 open my ($fh), '<', $file or confess "Cannot read from $file: $!"; 307 my $actual_content = do { local $/; <$fh> }; 308 309 @_ = ($actual_content, $content, $test); 310 goto &is; 311} 312 313sub is_file_content_raw { 314 my ($file, $content, $test) = @_; 315 open my ($fh), '<:raw', $file or confess "Cannot read from $file: $!"; 316 local $/; 317 @_ = (<$fh>, $content, $test); 318 goto &is; 319} 320 321sub _do_run { 322 my ($svk, $cmd, $arg) = @_; 323 my $unlock = SVK::XD->can('unlock'); 324 my $giant_unlock = SVK::XD->can('giant_unlock'); 325 no warnings 'redefine'; 326 my $origxd = Storable::dclone($svk->{xd}->{checkout}); 327 require SVK::Command::Checkout; 328 my $giant_locked = 1; 329 local *SVK::XD::giant_unlock = sub { 330 $giant_locked = 0; 331 goto $giant_unlock; 332 }; 333 local *SVK::XD::unlock = sub { 334 my $self = shift; 335 unless ($giant_locked) { 336 my $newxd = Storable::dclone($self->{checkout}); 337 my @paths = $self->{checkout}->find ('', {lock => $$}); 338 my %empty = (lock => undef, '.conflict' => undef, 339 '.deleted' => undef, 340 SVK::Command::Checkout::detach->_remove_entry, 341 SVK::Command->_schedule_empty); 342 for (@paths) { 343 $origxd->store($_, \%empty, {override_sticky_descendents => 1}); 344 $newxd-> store($_, \%empty, {override_sticky_descendents => 1}); 345 } 346 diag Carp::longmess.YAML::Syck::Dump({orig => $origxd, new => $newxd, paths => \@paths}) 347 unless eq_hash($origxd, $newxd); 348 } 349 $unlock->($self, @_); 350 }; 351 $svk->$cmd (@$arg); 352} 353 354sub is_output { 355 my ($svk, $cmd, $arg, $expected, $test) = @_; 356 _do_run($svk, $cmd, $arg); 357 my $cmp = (grep {ref ($_) eq 'Regexp'} @$expected) 358 ? \&is_deeply_like : \&is_deeply; 359 my $o = $output; 360 $o =~ s/\r?\n$//; 361 @_ = ([split (/\r?\n/, $o, -1)], $expected, $test || join(' ', map { / / ? qq("$_") : $_ } $cmd, @$arg)); 362 goto &$cmp; 363} 364 365sub is_sorted_output { 366 my ($svk, $cmd, $arg, $expected, $test) = @_; 367 _do_run($svk, $cmd, $arg); 368 my $cmp = (grep {ref ($_) eq 'Regexp'} @$expected) 369 ? \&is_deeply_like : \&is_deeply; 370 @_ = ([sort split (/\r?\n/, $output)], [sort @$expected], $test || join(' ', $cmd, @$arg)); 371 goto &$cmp; 372} 373 374sub is_deeply_like { 375 my ($got, $expected, $test) = @_; 376 for (0..$#{$expected}) { 377 if (ref ($expected->[$_]) eq 'SCALAR' ) { 378 @_ = ($#{$got}, $#{$got}, $test); 379 goto &is; 380 } 381 elsif (ref ($expected->[$_]) eq 'Regexp' ) { 382 unless ($got->[$_] =~ m/$expected->[$_]/) { 383 diag "Different at $_:\n$got->[$_]\n$expected->[$_]"; 384 @_ = (0, $test); 385 goto &ok; 386 } 387 } 388 else { 389 if ($got->[$_] ne $expected->[$_]) { 390 diag "Different at $_:\n$got->[$_]\n$expected->[$_]"; 391 @_ = (0, $test); 392 goto &ok; 393 } 394 } 395 } 396 @_ = ($#{$expected}, $#{$got}, $test); 397 goto &is; 398} 399 400sub is_output_like { 401 my ($svk, $cmd, $arg, $expected, $test) = @_; 402 _do_run($svk, $cmd, $arg); 403 @_ = ($output, $expected, $test || join(' ', $cmd, @$arg)); 404 goto &like; 405} 406 407sub is_output_unlike { 408 my ($svk, $cmd, $arg, $expected, $test) = @_; 409 _do_run($svk, $cmd, $arg); 410 @_ = ($output, $expected, $test || join(' ', $cmd, @$arg)); 411 goto &unlike; 412} 413 414sub is_ancestor { 415 my ($svk, $path, @expected) = @_; 416 $svk->info ($path); 417 my (@copied) = $output =~ m/Copied From: (.*?), Rev. (\d+)/mg; 418 @_ = (\@copied, \@expected); 419 goto &is_deeply; 420} 421 422sub status_native { 423 my $copath = shift; 424 my @ret; 425 while (my ($status, $path) = splice (@_, 0, 2)) { 426 push @ret, join (' ', $status, $copath ? SVK::Path::Checkout->copath($copath, $path) : 427 File::Spec->catfile (File::Spec::Unix->splitdir ($path))); 428 } 429 return @ret; 430} 431 432sub status { 433 my @ret; 434 while (my ($status, $path) = splice (@_, 0, 2)) { 435 push @ret, join (' ', $status, $path); 436 } 437 return @ret; 438} 439 440require SVN::Simple::Edit; 441 442sub get_editor { 443 my ($repospath, $path, $repos) = @_; 444 445 return SVN::Simple::Edit->new 446 (_editor => [SVN::Repos::get_commit_editor($repos, 447 "file://$repospath", 448 $path, 449 'svk', 'test init tree', 450 sub {})], 451 base_path => $path, 452 root => $repos->fs->revision_root ($repos->fs->youngest_rev), 453 missing_handler => SVN::Simple::Edit::check_missing ()); 454} 455 456sub create_basic_tree { 457 my ($xd, $depotpath) = @_; 458 my $pool = SVN::Pool->new_default; 459 my ($depot, $path) = $xd->find_depotpath($depotpath); 460 461 local $/ = $EOL; 462 my $edit = get_editor ($depot->repospath, $path, $depot->repos); 463 $edit->open_root (); 464 465 $edit->modify_file ($edit->add_file ('/me'), 466 "first line in me$/2nd line in me$/"); 467 $edit->modify_file ($edit->add_file ('/A/be'), 468 "\$Rev\$ \$Revision\$$/\$FileRev\$$/first line in be$/2nd line in be$/"); 469 $edit->change_file_prop ('/A/be', 'svn:keywords', 'Rev URL Revision FileRev'); 470 $edit->modify_file ($edit->add_file ('/A/P/pe'), 471 "first line in pe$/2nd line in pe$/"); 472 $edit->add_directory ('/B'); 473 $edit->add_directory ('/C'); 474 $edit->add_directory ('/A/Q'); 475 $edit->change_dir_prop ('/A/Q', 'foo', 'prop on A/Q'); 476 $edit->modify_file ($edit->add_file ('/A/Q/qu'), 477 "first line in qu$/2nd line in qu$/"); 478 $edit->modify_file ($edit->add_file ('/A/Q/qz'), 479 "first line in qz$/2nd line in qz$/"); 480 $edit->add_directory ('/C/R'); 481 $edit->close_edit (); 482 my $tree = { child => { me => {}, 483 A => { child => { be => {}, 484 P => { child => {pe => {}, 485 }}, 486 Q => { child => {qu => {}, 487 ez => {}, 488 }}, 489 }}, 490 B => {}, 491 C => { child => { R => { child => {}}}} 492 }}; 493 my $rev = $depot->repos->fs->youngest_rev; 494 $edit = get_editor ($depot->repospath, $path, $depot->repos); 495 $edit->open_root (); 496 $edit->modify_file ('/me', "first line in me$/2nd line in me - mod$/"); 497 $edit->modify_file ($edit->add_file ('/B/fe'), 498 "file fe added later$/"); 499 $edit->delete_entry ('/A/P'); 500 $edit->copy_directory('/B/S', "file://@{[$depot->repospath]}/${path}/A", $rev); 501 $edit->modify_file ($edit->add_file ('/D/de'), 502 "file de added later$/"); 503 $edit->close_edit (); 504 505 $tree->{child}{B}{child}{fe} = {}; 506 # XXX: have to clone this... 507 %{$tree->{child}{B}{child}{S}} = (child => {%{$tree->{child}{A}{child}}}, 508 history => '/A:1'); 509 delete $tree->{child}{A}{child}{P}; 510 $tree->{child}{D}{child}{de} = {}; 511 512 return $tree; 513} 514 515sub add_prop_to_basic_tree { 516 my ($xd, $depotpath, $props) = @_; 517 my $pool = SVN::Pool->new_default; 518 my ($depot, $path) = $xd->find_depotpath($depotpath); 519 520 local $/ = $EOL; 521 my $edit = get_editor ($depot->repospath, $path, $depot->repos); 522 $edit->open_root (); 523 524 my %prop = %{$props}; 525 for my $key (keys %prop) { 526 $edit->change_dir_prop ('/', $key, $prop{$key}); 527 } 528 $edit->close_edit (); 529} 530 531sub waste_rev { 532 my ($svk, $path) = @_; 533 $svk->mkdir('-m', 'create', $path); 534 $svk->rm('-m', 'create', $path); 535} 536 537sub tree_from_fsroot { 538 # generate a hash describing a given fs root 539} 540 541sub tree_from_xdroot { 542 # generate a hash describing the content in an xdroot 543} 544 545sub __ ($) { 546 my $path = shift; 547 $path =~ s{/}{$SEP}go; 548 return $path; 549} 550 551sub _x { IS_WIN32 ? 1 : -x $_[0] } 552sub not_x { IS_WIN32 ? 1 : not -x $_[0] } 553sub _l { IS_WIN32 ? 1 : -l $_[0] } 554sub not_l { IS_WIN32 ? 1 : not -l $_[0] } 555 556sub uri { 557 my $file = shift; 558 $file =~ s{^|\\}{/}g if IS_WIN32; 559 return "file://$file"; 560} 561 562my @unlink; 563sub set_editor { 564 my $tmp = File::Temp->new( SUFFIX => '.pl', UNLINK => 0 ); 565 print $tmp $_[0]; 566 $tmp->close; 567 568 my $perl = can_run($^X); 569 my $tmpfile = $tmp->filename; 570 571 if (defined &Win32::GetShortPathName) { 572 $perl = Win32::GetShortPathName($perl); 573 $tmpfile = Win32::GetShortPathName($tmpfile); 574 } 575 576 chmod 0755, $tmpfile; 577 push @unlink, $tmpfile; 578 579 $ENV{SVN_EDITOR} = "$perl $tmpfile"; 580} 581 582sub replace_file { 583 my ($file, $from, $to) = @_; 584 my @content; 585 586 open my $fh, '<', $file or croak "Cannot open $file: $!"; 587 while (<$fh>) { 588 s/$from/$to/g; 589 push @content, $_; 590 } 591 close $fh; 592 593 open $fh, '>', $file or croak "Cannot open $file: $!"; 594 print $fh @content; 595 close $fh; 596} 597 598# Samples of files with various MIME types 599{ 600my %samples = ( 601 'empty.txt' => q{}, 602 'false.bin' => 'LZ Not application/octet-stream', 603 'foo.pl' => "#!/usr/bin/perl\n", 604 'foo.jpg' => "\xff\xd8\xff\xe0\x00this is jpeg", 605 'foo.bin' => "\x1f\xf0\xff\x01\x00\xffthis is binary", 606 'foo.html' => "<html>", 607 'foo.txt' => "test....", 608 'foo.c' => "/*\tHello World\t*/", 609 'not-audio.txt' => "if\n", # reported: alley_cat 2006-06-02 610); 611 612# Return the names of mime sample files relative to a particular directory 613sub glob_mime_samples { 614 my ($directory) = @_; 615 my @names; 616 push @names, "$directory/$_" for sort keys %samples; 617 return @names; 618} 619 620# Create a directory and fill it with files of different MIME types. 621# The directory must be specified as the first argument. 622sub create_mime_samples { 623 my ($directory) = @_; 624 625 mkdir $directory; 626 overwrite_file ("mime/not-audio.txt", "if\n"); # reported: alley_cat 2006-06-02 627 while ( my ($basename, $content) = each %samples ) { 628 overwrite_file( "$directory/$basename", $content ); 629 } 630} 631} 632 633sub chmod_probably_useless { 634 return $^O eq 'MSWin32' || Cwd::cwd() =~ m!^/afs/!; 635} 636 637sub install_perl_hook { 638 my ($repospath, $hook, $content) = @_; 639 $hook = "$repospath/hooks/$hook".(IS_WIN32 ? '.bat' : ''); 640 open my $fh, '>', $hook or die $!; 641 if (IS_WIN32) { 642 print $fh "\@rem = '--*-Perl-*--\n"; 643 print $fh '@echo off'."\n\"$^X\"".' -x -S %0 %*'."\n"; 644 print $fh 'if errorlevel 1 goto script_failed_so_exit_with_non_zero_val 2>nul'."\n"; 645 print $fh "goto endofperl\n\@rem ';\n"; 646 } 647 print $fh "#!$^X\n" . $content; 648 print $fh "\n__END__\n:endofperl\n" if IS_WIN32; 649 chmod(0755, $hook); 650 return $hook; 651} 652 653END { 654 return unless $$ == $pid; 655 unlink $_ for @unlink; 656} 657 6581; 659