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:
99 @EXPORT_OK = qw( evcheck save_output restore_output );
101 # Utility -----------------------------
103 use Carp qw( carp croak );
104 use Cwd 2.01 qw( cwd );
106 use Fatal 1.02 qw( close open seek sysopen unlink );
107 use Fcntl 1.03 qw( :DEFAULT );
108 use File::Basename qw( basename );
109 use File::Path 1.0401 qw( mkpath rmtree );
110 use File::Spec 0.6 qw( );
111 use FindBin 1.42 qw( $Bin );
112 use POSIX 1.02 qw( );
113 use Test 1.122 qw( ok skip );
115 # ----------------------------------------------------------------------------
118 if ( File::Spec->file_name_is_absolute($_[0]) ) {
121 return File::Spec->catdir(cwd, $_[0]);
125 # -------------------------------------
127 # -------------------------------------
129 use constant BUILD_SCRIPT_DIR => => File::Spec->catdir( $Bin, File::Spec->updir, qw( blib script ) );
131 # -------------------------------------
133 # -------------------------------------
135 $PATH = join ':', BUILD_SCRIPT_DIR, split /:/, $PATH;
137 my $tmpdn = tempdir();
141 die "Couldn't create temp dir: $tmpdn: $!\n"
142 unless -r $tmpdn and -w $tmpdn and -x $tmpdn and -o $tmpdn and -d $tmpdn;
146 # -------------------------------------
148 # -------------------------------------
152 Eval code, return status
166 Name to use in error messages
176 1 if eval was okay, 0 if not.
185 my ($code, $name) = @_;
193 carp "Code $name failed: $@\n"
201 # -------------------------------------
205 Redirect a filehandle to temporary storage for later examination.
215 Name to store as (used in L<restore_output>)
219 The filehandle to save
225 # Map from names to saved filehandles.
227 # Values are arrayrefs, being filehandle that was saved (to restore), the
228 # filehandle being printed to in the meantime, and the original filehandle.
229 # This may be treated as a stack; to allow multiple saves... push & pop this
235 croak sprintf("%s takes 2 arguments\n", (caller 0)[3])
237 my ($name, $filehandle) = @_;
239 my $tmpfh = do { local *F; *F; };
240 my $savefh = do { local *F; *F; };
242 (undef, $tmpfh) = test::tmpnam();
243 select((select($tmpfh), $| = 1)[0]);
245 open $savefh, '>&' . fileno $filehandle
246 or die "can't dup $name: $!";
247 open $filehandle, '>&' . fileno $tmpfh
248 or die "can't open $name to tempfile: $!";
250 push @{$grabs{$name}}, $savefh, $tmpfh, $filehandle;
253 # -------------------------------------
255 =head2 restore_output
257 Restore a saved filehandle to its original state, return the saved output.
267 Name of the filehandle to restore (as passed to L<save_output>).
277 A single string being the output saved.
286 croak "$name has not been saved\n"
287 unless exists $grabs{$name};
288 croak "All saved instances of $name have been restored\n"
289 unless @{$grabs{$name}};
290 my ($savefh, $tmpfh, $origfh) = splice @{$grabs{$name}}, -3;
293 or die "cannot close $name opened to tempfile: $!";
294 open $origfh, '>&' . fileno $savefh
295 or die "cannot dup $name back again: $!";
296 select((select($origfh), $| = 1)[0]);
300 my $string = <$tmpfh>;
306 sub _test_save_restore_output {
307 warn "to stderr 1\n";
308 save_output("stderr", *STDERR{IO});
310 print 'SAVED:->:', restore_output("stderr"), ":<-\n";
311 warn "to stderr 2\n";
314 # -------------------------------------
318 Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
319 if TEST_DEBUG has SAVE in the value.
329 I<Optional>. If defined, a name by which to refer to the tmpfile in user
340 Name of temporary file.
344 Open filehandle to temp file, in r/w mode. Only created & returned in list
356 my $savewarn = $SIG{__WARN__};
357 # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03
358 local $SIG{__WARN__} =
361 if defined $savewarn and
362 UNIVERSAL::isa($savewarn,'CODE') and
363 $_[0] !~ /^Subroutine tmpnam redefined/;
367 my $tmpnam = POSIX::tmpnam;
370 push @tmpfns, [ $tmpnam, $_[0] ];
372 push @tmpfns, $tmpnam;
376 sysopen my $tmpfh, $tmpnam, O_RDWR | O_CREAT | O_EXCL;
377 return $tmpnam, $tmpfh;
385 if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
388 printf "Used temp file: %s (%s)\n", @$_;
390 print "Used temp file: $_\n";
394 unlink map((ref $_ ? $_->[0] : $_), @tmpfns)
399 # -------------------------------------
403 Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
404 if TEST_DEBUG has SAVE in the value (does get deleted otherwise).
418 Name of temporary dir.
428 my $tempdir = POSIX::tmpnam;
430 or die "Failed to create temporary directory $tempdir: $!\n";
433 push @tmpdirs, [ $tempdir, $_[0] ];
435 push @tmpdirs, $tempdir;
444 if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
445 printf "Used temp dir: %s (%s)\n", @$_;
447 # Solaris gets narky about removing the pwd.
448 chdir File::Spec->rootdir;
452 if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
453 print "Used temp dir: $_\n";
455 # Solaris gets narky about removing the pwd.
456 chdir File::Spec->rootdir;
464 # defined further up to use in constants
466 # ----------------------------------------------------------------------------
476 =head1 REPORTING BUGS
482 Martyn J. Pearce C<fluffy@cpan.org>
486 Copyright (c) 2001, 2002, 2004 Martyn J. Pearce. This program is free
487 software; you can redistribute it and/or modify it under the same terms as
496 1; # keep require happy.