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