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:
101 @EXPORT_OK = qw( evcheck save_output restore_output );
103 # Utility -----------------------------
105 use Carp qw( carp croak );
106 use Cwd 2.01 qw( cwd );
108 use Fatal 1.02 qw( close open seek sysopen unlink );
109 use Fcntl 1.03 qw( :DEFAULT );
110 use File::Basename qw( basename );
111 use File::Compare 1.1002 qw( );
112 use File::Path 1.0401 qw( mkpath rmtree );
113 use File::Spec 0.6 qw( );
114 use FindBin 1.42 qw( $Bin );
115 use POSIX 1.02 qw( );
116 use Test 1.122 qw( ok skip );
118 # ----------------------------------------------------------------------------
121 if ( File::Spec->file_name_is_absolute($_[0]) ) {
124 return File::Spec->catdir(cwd, $_[0]);
129 croak "Can't min over 0 args!\n"
140 # -------------------------------------
142 # -------------------------------------
144 use constant BUILD_SCRIPT_DIR => => File::Spec->catdir( $Bin, File::Spec->updir, qw( blib script ) );
149 for (split /:/, $PATH) {
150 my $try = File::Spec->catfile($_, $exec);
157 # -------------------------------------
159 # -------------------------------------
161 $PATH = join ':', BUILD_SCRIPT_DIR, split /:/, $PATH;
163 my $tmpdn = tempdir();
167 die "Couldn't create temp dir: $tmpdn: $!\n"
168 unless -r $tmpdn and -w $tmpdn and -x $tmpdn and -o $tmpdn and -d $tmpdn;
172 # -------------------------------------
174 # -------------------------------------
178 Eval code, return status
192 Name to use in error messages
202 1 if eval was okay, 0 if not.
211 my ($code, $name) = @_;
219 carp "Code $name failed: $@\n"
227 # -------------------------------------
231 Redirect a filehandle to temporary storage for later examination.
241 Name to store as (used in L<restore_output>)
245 The filehandle to save
251 # Map from names to saved filehandles.
253 # Values are arrayrefs, being filehandle that was saved (to restore), the
254 # filehandle being printed to in the meantime, and the original filehandle.
255 # This may be treated as a stack; to allow multiple saves... push & pop this
261 croak sprintf("%s takes 2 arguments\n", (caller 0)[3])
263 my ($name, $filehandle) = @_;
265 my $tmpfh = do { local *F; *F; };
266 my $savefh = do { local *F; *F; };
268 (undef, $tmpfh) = test::tmpnam();
269 select((select($tmpfh), $| = 1)[0]);
271 open $savefh, '>&' . fileno $filehandle
272 or die "can't dup $name: $!";
273 open $filehandle, '>&' . fileno $tmpfh
274 or die "can't open $name to tempfile: $!";
276 push @{$grabs{$name}}, $savefh, $tmpfh, $filehandle;
279 # -------------------------------------
281 =head2 restore_output
283 Restore a saved filehandle to its original state, return the saved output.
293 Name of the filehandle to restore (as passed to L<save_output>).
303 A single string being the output saved.
312 croak "$name has not been saved\n"
313 unless exists $grabs{$name};
314 croak "All saved instances of $name have been restored\n"
315 unless @{$grabs{$name}};
316 my ($savefh, $tmpfh, $origfh) = splice @{$grabs{$name}}, -3;
319 or die "cannot close $name opened to tempfile: $!";
320 open $origfh, '>&' . fileno $savefh
321 or die "cannot dup $name back again: $!";
322 select((select($origfh), $| = 1)[0]);
326 my $string = <$tmpfh>;
332 sub _test_save_restore_output {
333 warn "to stderr 1\n";
334 save_output("stderr", *STDERR{IO});
336 print 'SAVED:->:', restore_output("stderr"), ":<-\n";
337 warn "to stderr 2\n";
340 # -------------------------------------
344 Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
345 if TEST_DEBUG has SAVE in the value.
355 I<Optional>. If defined, a name by which to refer to the tmpfile in user
366 Name of temporary file.
370 Open filehandle to temp file, in r/w mode. Only created & returned in list
382 my $savewarn = $SIG{__WARN__};
383 # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03
384 local $SIG{__WARN__} =
387 if defined $savewarn and
388 UNIVERSAL::isa($savewarn,'CODE') and
389 $_[0] !~ /^Subroutine tmpnam redefined/;
393 my $tmpnam = POSIX::tmpnam;
396 push @tmpfns, [ $tmpnam, $_[0] ];
398 push @tmpfns, $tmpnam;
402 sysopen my $tmpfh, $tmpnam, O_RDWR | O_CREAT | O_EXCL;
403 return $tmpnam, $tmpfh;
411 if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
414 printf "Used temp file: %s (%s)\n", @$_;
416 print "Used temp file: $_\n";
420 unlink map((ref $_ ? $_->[0] : $_), @tmpfns)
425 # -------------------------------------
429 Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
430 if TEST_DEBUG has SAVE in the value (does get deleted otherwise).
444 Name of temporary dir.
454 my $tempdir = POSIX::tmpnam;
456 or die "Failed to create temporary directory $tempdir: $!\n";
459 push @tmpdirs, [ $tempdir, $_[0] ];
461 push @tmpdirs, $tempdir;
470 if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
471 printf "Used temp dir: %s (%s)\n", @$_;
473 # Solaris gets narky about removing the pwd.
474 chdir File::Spec->rootdir;
478 if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
479 print "Used temp dir: $_\n";
481 # Solaris gets narky about removing the pwd.
482 chdir File::Spec->rootdir;
489 # -------------------------------------
501 The name of the program
511 The path to the first executable file with the given name on C<$PATH>. Or
512 nothing, if no such file exists.
520 # defined further up to use in constants
522 # ----------------------------------------------------------------------------
532 =head1 REPORTING BUGS
538 Martyn J. Pearce C<fluffy@cpan.org>
542 Copyright (c) 2001, 2002, 2004 Martyn J. Pearce. This program is free
543 software; you can redistribute it and/or modify it under the same terms as
552 1; # keep require happy.