1 # (X)Emacs mode: -*- cperl -*-
7 test - tools for helping in test suites (not including running externalprograms).
11 use FindBin 1.42 qw( $Bin );
12 use Test 1.13 qw( ok plan );
14 BEGIN { unshift @INC, $Bin };
16 use test qw( evcheck runcheck );
25 open my $fh, '>', 'foo';
27 for 'Bulgaria', 'Cholet';
29 }, 'write foo'), 1, 'write foo';
31 save_output('stderr', *STDERR{IO});
33 print restore_output('stderr');
37 This package provides some variables, and sets up an environment, for test
38 scripts, such as those used in F<t/>.
40 This package does not including running external programs; that is provided by
41 C<test2.pm>. This is so that suites not needing that can include only
42 test.pm, and so not require the presence of C<IPC::Run>.
44 Setting up the environment includes:
48 =item Prepending F<blib/script> onto the path
50 =item Pushing the module F<lib/> dir onto the @INC var
52 For internal C<use> calls.
54 =item Changing directory to a temporary directory
56 To avoid cluttering the local dir, and/or allowing the local directory
57 structure to affect matters.
59 =item Cleaning up the temporary directory afterwards
61 Unless TEST_DEBUG is set in the environment.
67 # ----------------------------------------------------------------------------
69 # Pragmas -----------------------------
73 use vars qw( @EXPORT_OK );
75 # Inheritance -------------------------
77 use base qw( Exporter );
81 The following symbols are exported upon request:
103 @EXPORT_OK = qw( compare evcheck
104 save_output restore_output tempdir tmpnam );
106 # Utility -----------------------------
108 use Carp qw( carp croak );
109 use Cwd 2.01 qw( cwd );
111 use Fatal 1.02 qw( close open seek sysopen unlink );
112 use Fcntl 1.03 qw( :DEFAULT );
113 use File::Basename qw( basename );
114 use File::Compare 1.1002 qw( );
115 use File::Path 1.0401 qw( mkpath rmtree );
116 use File::Spec 0.6 qw( );
117 use FindBin 1.42 qw( $Bin );
118 use POSIX 1.02 qw( );
119 use Test 1.122 qw( ok skip );
121 # ----------------------------------------------------------------------------
124 if ( File::Spec->file_name_is_absolute($_[0]) ) {
127 return File::Spec->catdir(cwd, $_[0]);
132 croak "Can't min over 0 args!\n"
143 # -------------------------------------
145 # -------------------------------------
147 use constant BUILD_SCRIPT_DIR => => File::Spec->catdir( $Bin, File::Spec->updir, qw( blib script ) );
152 for (split /:/, $PATH) {
153 my $try = File::Spec->catfile($_, $exec);
160 # -------------------------------------
162 # -------------------------------------
164 $PATH = join ':', BUILD_SCRIPT_DIR, split /:/, $PATH;
169 my $tmpdn = tempdir();
173 die "Couldn't create temp dir: $tmpdn: $!\n"
174 unless -r $tmpdn and -w $tmpdn and -x $tmpdn and -o $tmpdn and -d $tmpdn;
176 #@INC = map rel2abs($_), @INC;
179 # -------------------------------------
181 # -------------------------------------
185 Eval code, return status
199 Name to use in error messages
209 1 if eval was okay, 0 if not.
218 my ($code, $name) = @_;
226 carp "Code $name failed: $@\n"
234 # -------------------------------------
238 Redirect a filehandle to temporary storage for later examination.
248 Name to store as (used in L<restore_output>)
252 The filehandle to save
258 # Map from names to saved filehandles.
260 # Values are arrayrefs, being filehandle that was saved (to restore), the
261 # filehandle being printed to in the meantime, and the original filehandle.
262 # This may be treated as a stack; to allow multiple saves... push & pop this
268 croak sprintf("%s takes 2 arguments\n", (caller 0)[3])
270 my ($name, $filehandle) = @_;
272 my $tmpfh = do { local *F; *F; };
273 my $savefh = do { local *F; *F; };
275 (undef, $tmpfh) = test::tmpnam();
276 select((select($tmpfh), $| = 1)[0]);
278 open $savefh, '>&' . fileno $filehandle
279 or die "can't dup $name: $!";
280 open $filehandle, '>&' . fileno $tmpfh
281 or die "can't open $name to tempfile: $!";
283 push @{$grabs{$name}}, $savefh, $tmpfh, $filehandle;
286 # -------------------------------------
288 =head2 restore_output
290 Restore a saved filehandle to its original state, return the saved output.
300 Name of the filehandle to restore (as passed to L<save_output>).
310 A single string being the output saved.
319 croak "$name has not been saved\n"
320 unless exists $grabs{$name};
321 croak "All saved instances of $name have been restored\n"
322 unless @{$grabs{$name}};
323 my ($savefh, $tmpfh, $origfh) = splice @{$grabs{$name}}, -3;
326 or die "cannot close $name opened to tempfile: $!";
327 open $origfh, '>&' . fileno $savefh
328 or die "cannot dup $name back again: $!";
329 select((select($origfh), $| = 1)[0]);
333 my $string = <$tmpfh>;
339 sub _test_save_restore_output {
340 warn "to stderr 1\n";
341 save_output("stderr", *STDERR{IO});
343 print 'SAVED:->:', restore_output("stderr"), ":<-\n";
344 warn "to stderr 2\n";
347 # -------------------------------------
351 Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
352 if TEST_DEBUG has SAVE in the value.
362 I<Optional>. If defined, a name by which to refer to the tmpfile in user
373 Name of temporary file.
377 Open filehandle to temp file, in r/w mode. Only created & returned in list
389 my $savewarn = $SIG{__WARN__};
390 # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03
391 local $SIG{__WARN__} =
394 if defined $savewarn and
395 UNIVERSAL::isa($savewarn,'CODE') and
396 $_[0] !~ /^Subroutine tmpnam redefined/;
400 my $tmpnam = POSIX::tmpnam;
403 push @tmpfns, [ $tmpnam, $_[0] ];
405 push @tmpfns, $tmpnam;
409 sysopen my $tmpfh, $tmpnam, O_RDWR | O_CREAT | O_EXCL;
410 return $tmpnam, $tmpfh;
418 if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
421 printf "Used temp file: %s (%s)\n", @$_;
423 print "Used temp file: $_\n";
427 unlink map((ref $_ ? $_->[0] : $_), @tmpfns)
432 # -------------------------------------
436 Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
437 if TEST_DEBUG has SAVE in the value (does get deleted otherwise).
451 Name of temporary dir.
461 my $tempdir = POSIX::tmpnam;
463 or die "Failed to create temporary directory $tempdir: $!\n";
466 push @tmpdirs, [ $tempdir, $_[0] ];
468 push @tmpdirs, $tempdir;
477 if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
478 printf "Used temp dir: %s (%s)\n", @$_;
480 # Solaris gets narky about removing the pwd.
481 chdir File::Spec->rootdir;
485 if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
486 print "Used temp dir: $_\n";
488 # Solaris gets narky about removing the pwd.
489 chdir File::Spec->rootdir;
496 # -------------------------------------
500 compare(+{ fn1 => $fn1, fn2 => $fn2, gzip => 1 });
502 This performs one test.
508 A single argument is taken, considered as a hash ref, with the following keys:
510 In TEST_DEBUG mode, if the files do not compare equal, outputs file info on
517 B<Mandatory> File to compare
521 B<Mandatory> File to compare
525 B<Mandatory> Test name
529 B<Optional> sort files prior to comparison. Requires the C<sort> command to
530 be on C<$PATH> (else skips).
534 B<Optional> gunzip files prior to comparison. Requires the C<gzip> command to
535 be on C<$PATH> (else skips). gzip occurs prior to any sort.
539 B<Optional> untar files prior to comparison. Requires the C<tar> command to
540 be on C<$PATH> (else skips). any gzip occurs prior to any tar. Tar files are
541 considered equal if they each contain the same filenames & each file contained
542 is equal. If the sort flag is present, each file is sorted prior to comparison.
550 # return codes and old-style call semantics left for backwards compatibility
552 my $savewarn = $SIG{__WARN__};
553 # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03
554 local $SIG{__WARN__} =
557 if defined $savewarn and
558 UNIVERSAL::isa($savewarn,'CODE') and
559 $_[0] !~ /^Subroutine compare redefined/;
563 my ($fn1, $fn2, $sort) = @_;
564 my ($gzip, $tar, $name);
567 if ( @_ == 1 and UNIVERSAL::isa($_[0], 'HASH') ) {
568 ($fn1, $fn2, $name, $sort, $gzip, $tar, $notest) =
569 @{$_[0]}{qw( fn1 fn2 name sort gunzip untar notest )};
570 my @missing = grep ! defined $_[0]->{$_}, qw( fn1 fn2 name );
571 carp "Missing mandatory key(s): " . join(', ', @missing) . "\n"
575 my ($name1, $name2) = ($fn1, $fn2);
577 for ( grep ! defined, $fn1, $fn2 ) {
578 carp 'Usage: compare({fn1 => $fn1, fn2 => $fn2, name => "some name"})' ."\n"
589 my $fn = ($name1, $name2)[$_];
591 carp "Does not exist: $fn\n"
594 } elsif ( ! -r $fn ) {
595 carp "Cannot read: $fn\n"
609 unless ( find_exec('gzip') ) {
610 print "ok # Skip gzip not found in path\n";
616 system "gzip $fn1 -cd > $tmp1"
617 and croak "gzip $fn1 failed: $?\n";
618 system "gzip $fn2 -cd > $tmp2"
619 and croak "gzip $fn2 failed: $?\n";
620 ($fn1, $fn2) = ($tmp1, $tmp2);
624 unless ( find_exec('tar') ) {
625 print "ok # Skip tar not found in path\n";
630 chomp (my @list1 = sort qx( tar tf $fn1 ));
631 croak "tar tf $fn1 failed with wait status: $?\n"
633 chomp(my @list2 = sort qx( tar tf $fn2 ));
634 croak "tar tf $fn2 failed with wait status: $?\n"
637 if ( @list2 > @list1 ) {
639 sprintf("More files (%d) in $name2 than $name1 (%d)\n",
640 scalar @list2, scalar @list1)
642 ok @list1, @list2, $name
645 } elsif ( @list1 > @list2 ) {
647 sprintf("More files (%d) in $name1 than $name2 (%d)\n",
648 scalar @list1, scalar @list2)
650 ok @list1, @list2, $name
655 for (my $i = 0; $i < @list1; $i++) {
656 if ( $list1[$i] lt $list2[$i] ) {
657 carp "File $list1[$i] is present in $name1 but not $name2\n"
659 ok $list1[$i], $list2[$i], $name
662 } elsif ( $list1[$i] gt $list2[$i] ) {
663 carp "File $list2[$i] is present in $name2 but not $name1\n"
665 ok $list2[$i], $list1[$i], $name
671 for my $fn (@list1) {
674 system "tar -xf $fn1 -O $fn > $tmp1"
675 and croak "tar -xf $fn1 -O $fn failed: $?\n";
676 system "tar -xf $fn2 -O $fn > $tmp2"
677 and croak "tar -xf $fn2 -O $fn failed: $?\n";
678 my $ok = compare({ fn1 => $tmp1,
683 qq'Subcheck file "$fn" for compare $name1, $name2',
685 unless ( $ok >= 1 ) {
686 carp qq'Difference found testing file "$fn" in tars $name1 ($tmp1), $name2 ($tmp2)\n'
700 unless ( find_exec('sort') ) {
701 print "ok # Skip sort not found in path\n";
707 system sort => $fn1, -o => $tmp1
708 and croak "Sort $fn1 failed: $?\n";
709 system sort => $fn2, -o => $tmp2
710 and croak "Sort $fn2 failed: $?\n";
711 ($fn1, $fn2) = ($tmp1, $tmp2);
714 unless ( File::Compare::compare($fn1, $fn2) ) {
720 if ( $ENV{TEST_DEBUG} ) {
722 die "Fork failed: $!\n"
725 if ( $pid ) { # Parent
726 my $waitpid = waitpid($pid, 0);
727 die "Waitpid got: $waitpid (expected $pid)\n"
728 unless $waitpid == $pid;
730 open *STDOUT{IO}, ">&" . fileno STDERR;
731 # Uniquify file names
732 my @args = keys %{+{ map {;$_=>1} $name1, $name2, $fn1, $fn2 }};
733 exec qw(ls -l), @args;
736 my $fh1 = IO::File->new($fn1, O_RDONLY)
737 or die "Couldn't open $fn1: $!\n";
738 my $fh2 = IO::File->new($fn2, O_RDONLY)
739 or die "Couldn't open $fn2: $!\n";
744 while ( ! $found and my $line1 = <$fh1> ) {
746 if ( ! defined $line2 ) {
747 print STDERR "$fn2 ended at line: $.\n";
749 } elsif ( $line2 ne $line1 ) {
750 my $maxlength = max(map length($_), $line1, $line2);
751 my $minlength = min(map length($_), $line1, $line2);
753 my @diffchars = grep(substr($line1, $_, 1) ne substr($line2, $_, 1),
755 my $diff = ' ' x $minlength;
756 substr($diff, $_, 1) = '|'
759 my @extrachars, map((length($line1) > length($line2) ? '^' : 'v'),
760 $minlength..$maxlength-1);
762 $diff = join '', $diff, @extrachars;
764 my $diff_count = @diffchars;
765 my $extra_count = @extrachars;
767 print STDERR <<"END";
768 Difference at line $. ($diff_count characters differ) (top line is $extra_count chars longer):
774 Differing characters at positions @{[join ',',@diffchars]} (zero-based)
782 if ( defined $line2 ) {
783 print STDERR "$name1 ended before line: $.\n";
785 print STDERR "Difference between $name1, $name2 not found!\n";
799 # -------------------------------------
811 The name of the program
821 The path to the first executable file with the given name on C<$PATH>. Or
822 nothing, if no such file exists.
830 # defined further up to use in constants
832 # ----------------------------------------------------------------------------
842 =head1 REPORTING BUGS
848 Martyn J. Pearce C<fluffy@cpan.org>
852 Copyright (c) 2001, 2002, 2004 Martyn J. Pearce. This program is free
853 software; you can redistribute it and/or modify it under the same terms as
862 1; # keep require happy.