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 # ----------------------------------------------------------------------------
117 # -------------------------------------
119 # -------------------------------------
121 use constant BUILD_SCRIPT_DIR => => File::Spec->catdir( $Bin, File::Spec->updir, qw( blib script ) );
123 # -------------------------------------
125 # -------------------------------------
127 $PATH = join ':', BUILD_SCRIPT_DIR, split /:/, $PATH;
129 my $tmpdn = tempdir();
133 die "Couldn't create temp dir: $tmpdn: $!\n"
134 unless -r $tmpdn and -w $tmpdn and -x $tmpdn and -o $tmpdn and -d $tmpdn;
138 # -------------------------------------
140 # -------------------------------------
144 Eval code, return status
158 Name to use in error messages
168 1 if eval was okay, 0 if not.
177 my ($code, $name) = @_;
185 carp "Code $name failed: $@\n"
193 # -------------------------------------
197 Redirect a filehandle to temporary storage for later examination.
207 Name to store as (used in L<restore_output>)
211 The filehandle to save
217 # Map from names to saved filehandles.
219 # Values are arrayrefs, being filehandle that was saved (to restore), the
220 # filehandle being printed to in the meantime, and the original filehandle.
221 # This may be treated as a stack; to allow multiple saves... push & pop this
227 croak sprintf("%s takes 2 arguments\n", (caller 0)[3])
229 my ($name, $filehandle) = @_;
231 my $tmpfh = do { local *F; *F; };
232 my $savefh = do { local *F; *F; };
234 (undef, $tmpfh) = test::tmpnam();
235 select((select($tmpfh), $| = 1)[0]);
237 open $savefh, '>&' . fileno $filehandle
238 or die "can't dup $name: $!";
239 open $filehandle, '>&' . fileno $tmpfh
240 or die "can't open $name to tempfile: $!";
242 push @{$grabs{$name}}, $savefh, $tmpfh, $filehandle;
245 # -------------------------------------
247 =head2 restore_output
249 Restore a saved filehandle to its original state, return the saved output.
259 Name of the filehandle to restore (as passed to L<save_output>).
269 A single string being the output saved.
278 croak "$name has not been saved\n"
279 unless exists $grabs{$name};
280 croak "All saved instances of $name have been restored\n"
281 unless @{$grabs{$name}};
282 my ($savefh, $tmpfh, $origfh) = splice @{$grabs{$name}}, -3;
285 or die "cannot close $name opened to tempfile: $!";
286 open $origfh, '>&' . fileno $savefh
287 or die "cannot dup $name back again: $!";
288 select((select($origfh), $| = 1)[0]);
292 my $string = <$tmpfh>;
298 # -------------------------------------
302 Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
303 if TEST_DEBUG has SAVE in the value.
313 I<Optional>. If defined, a name by which to refer to the tmpfile in user
324 Name of temporary file.
328 Open filehandle to temp file, in r/w mode. Only created & returned in list
340 my $savewarn = $SIG{__WARN__};
341 # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03
342 local $SIG{__WARN__} =
345 if defined $savewarn and
346 UNIVERSAL::isa($savewarn,'CODE') and
347 $_[0] !~ /^Subroutine tmpnam redefined/;
351 my $tmpnam = POSIX::tmpnam;
354 push @tmpfns, [ $tmpnam, $_[0] ];
356 push @tmpfns, $tmpnam;
360 sysopen my $tmpfh, $tmpnam, O_RDWR | O_CREAT | O_EXCL;
361 return $tmpnam, $tmpfh;
369 if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
372 printf "Used temp file: %s (%s)\n", @$_;
374 print "Used temp file: $_\n";
378 unlink map((ref $_ ? $_->[0] : $_), @tmpfns)
383 # -------------------------------------
387 Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
388 if TEST_DEBUG has SAVE in the value (does get deleted otherwise).
402 Name of temporary dir.
412 my $tempdir = POSIX::tmpnam;
414 or die "Failed to create temporary directory $tempdir: $!\n";
417 push @tmpdirs, [ $tempdir, $_[0] ];
419 push @tmpdirs, $tempdir;
428 if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
429 printf "Used temp dir: %s (%s)\n", @$_;
431 # Solaris gets narky about removing the pwd.
432 chdir File::Spec->rootdir;
436 if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
437 print "Used temp dir: $_\n";
439 # Solaris gets narky about removing the pwd.
440 chdir File::Spec->rootdir;
448 # defined further up to use in constants
450 # ----------------------------------------------------------------------------
460 =head1 REPORTING BUGS
466 Martyn J. Pearce C<fluffy@cpan.org>
470 Copyright (c) 2001, 2002, 2004 Martyn J. Pearce. This program is free
471 software; you can redistribute it and/or modify it under the same terms as
480 1; # keep require happy.