t/test.pm

   1 # (X)Emacs mode: -*- cperl -*-
   2
   3 package test;
   4
   5 =head1 NAME
   6
   7 test - tools for helping in test suites (not including running externalprograms).
   8
   9 =head1 SYNOPSIS
  10
  11   use FindBin               1.42 qw( $Bin );
  12   use Test                  1.13 qw( ok plan );
  13
  14   BEGIN { unshift @INC, $Bin };
  15
  16   use test                  qw(   evcheck runcheck );
  17
  18   BEGIN {
  19     plan tests  => 3,
  20          todo   => [],
  21          ;
  22   }
  23
  24   ok evcheck(sub {
  25                open my $fh, '>', 'foo';
  26                print $fh "$_\n"
  27                  for 'Bulgaria', 'Cholet';
  28                close $fh;
  29              }, 'write foo'), 1, 'write foo';
  30
  31   save_output('stderr', *STDERR{IO});
  32   warn 'Hello, Mum!';
  33   print restore_output('stderr');
  34
  35 =head1 DESCRIPTION
  36
  37 This package provides some variables, and sets up an environment, for test
  38 scripts, such as those used in F<t/>.
  39
  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>.
  43
  44 Setting up the environment includes:
  45
  46 =over 4
  47
  48 =item Prepending F<blib/script> onto the path
  49
  50 =item Pushing the module F<lib/> dir onto the @INC var
  51
  52 For internal C<use> calls.
  53
  54 =item Changing directory to a temporary directory
  55
  56 To avoid cluttering the local dir, and/or allowing the local directory
  57 structure to affect matters.
  58
  59 =item Cleaning up the temporary directory afterwards
  60
  61 Unless TEST_DEBUG is set in the environment.
  62
  63 =back
  64
  65 =cut
  66
  67 # ----------------------------------------------------------------------------
  68
  69 # Pragmas -----------------------------
  70
  71 use 5.00503;
  72 use strict;
  73 use vars qw( @EXPORT_OK );
  74
  75 # Inheritance -------------------------
  76
  77 use base qw( Exporter );
  78
  79 =head2 EXPORTS
  80
  81 The following symbols are exported upon request:
  82
  83 =over 4
  84
  85 =item evcheck
  86
  87 =item save_output
  88
  89 =item restore_output
  90
  91 =item tmpnam
  92
  93 =item tempdir
  94
  95 =back
  96
  97 =cut
  98
  99 @EXPORT_OK = qw( evcheck save_output restore_output );
 100
 101 # Utility -----------------------------
 102
 103 use Carp                          qw( carp croak );
 104 use Cwd                      2.01 qw( cwd );
 105 use Env                           qw( PATH );
 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 );
 114
 115 # ----------------------------------------------------------------------------
 116
 117 sub rel2abs {
 118   if ( File::Spec->file_name_is_absolute($_[0]) ) {
 119     return $_[0];
 120   } else {
 121     return File::Spec->catdir(cwd, $_[0]);
 122   }
 123 }
 124
 125 # -------------------------------------
 126 # PACKAGE CONSTANTS
 127 # -------------------------------------
 128
 129 use constant BUILD_SCRIPT_DIR => => File::Spec->catdir( $Bin, File::Spec->updir, qw( blib script ) );
 130
 131 # -------------------------------------
 132 # PACKAGE ACTIONS
 133 # -------------------------------------
 134
 135 $PATH = join ':', BUILD_SCRIPT_DIR, split /:/, $PATH;
 136
 137 my $tmpdn = tempdir();
 138 $| = 1;
 139
 140 mkpath $tmpdn;
 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;
 143
 144 chdir $tmpdn;
 145
 146 # -------------------------------------
 147 # PACKAGE FUNCTIONS
 148 # -------------------------------------
 149
 150 =head2 evcheck
 151
 152 Eval code, return status
 153
 154 =over 4
 155
 156 =item ARGUMENTS
 157
 158 =over 4
 159
 160 =item code
 161
 162 Coderef to eval
 163
 164 =item name
 165
 166 Name to use in error messages
 167
 168 =back
 169
 170 =item RETURNS
 171
 172 =over 4
 173
 174 =item okay
 175
 176 1 if eval was okay, 0 if not.
 177
 178 =back
 179
 180 =back
 181
 182 =cut
 183
 184 sub evcheck {
 185   my ($code, $name) = @_;
 186
 187   my $ok = 0;
 188
 189   eval {
 190     &$code;
 191     $ok = 1;
 192   }; if ( $@ ) {
 193     carp "Code $name failed: $@\n"
 194       if $ENV{TEST_DEBUG};
 195     $ok = 0;
 196   }
 197
 198   return $ok;
 199 }
 200
 201 # -------------------------------------
 202
 203 =head2 save_output
 204
 205 Redirect a filehandle to temporary storage for later examination.
 206
 207 =over 4
 208
 209 =item ARGUMENTS
 210
 211 =over 4
 212
 213 =item name
 214
 215 Name to store as (used in L<restore_output>)
 216
 217 =item filehandle
 218
 219 The filehandle to save
 220
 221 =back
 222
 223 =cut
 224
 225 # Map from names to saved filehandles.
 226
 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
 230 # stack.
 231
 232 my %grabs;
 233
 234 sub save_output {
 235   croak sprintf("%s takes 2 arguments\n", (caller 0)[3])
 236     unless @_ == 2;
 237   my ($name, $filehandle) = @_;
 238
 239   my $tmpfh  = do { local *F; *F; };
 240   my $savefh = do { local *F; *F; };
 241
 242   (undef, $tmpfh) = test::tmpnam();
 243   select((select($tmpfh), $| = 1)[0]);
 244
 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: $!";
 249
 250   push @{$grabs{$name}}, $savefh, $tmpfh, $filehandle;
 251 }
 252
 253 # -------------------------------------
 254
 255 =head2 restore_output
 256
 257 Restore a saved filehandle to its original state, return the saved output.
 258
 259 =over 4
 260
 261 =item ARGUMENTS
 262
 263 =over 4
 264
 265 =item name
 266
 267 Name of the filehandle to restore (as passed to L<save_output>).
 268
 269 =back
 270
 271 =item RETURNS
 272
 273 =over 4
 274
 275 =item saved_string
 276
 277 A single string being the output saved.
 278
 279 =back
 280
 281 =cut
 282
 283 sub restore_output {
 284   my ($name) = @_;
 285
 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;
 291
 292   close $origfh
 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]);
 297
 298   seek $tmpfh, 0, 0;
 299   local $/ = undef;
 300   my $string = <$tmpfh>;
 301   close $tmpfh;
 302
 303   return $string;
 304 }
 305
 306 sub _test_save_restore_output {
 307   warn "to stderr 1\n";
 308   save_output("stderr", *STDERR{IO});
 309   warn "Hello, Mum!";
 310   print 'SAVED:->:', restore_output("stderr"), ":<-\n";
 311   warn "to stderr 2\n";
 312 }
 313
 314 # -------------------------------------
 315
 316 =head2 tmpnam
 317
 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.
 320
 321 =over 4
 322
 323 =item ARGUMENTS
 324
 325 =over 4
 326
 327 =item name
 328
 329 I<Optional>.  If defined, a name by which to refer to the tmpfile in user
 330 messages.
 331
 332 =back
 333
 334 =item RETURNS
 335
 336 =over 4
 337
 338 =item filename
 339
 340 Name of temporary file.
 341
 342 =item fh
 343
 344 Open filehandle to temp file, in r/w mode.  Only created & returned in list
 345 context.
 346
 347 =back
 348
 349 =back
 350
 351 =cut
 352
 353 my @tmpfns;
 354
 355 BEGIN {
 356   my $savewarn = $SIG{__WARN__};
 357   # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03
 358   local $SIG{__WARN__} =
 359     sub {
 360       $savewarn->(@_)
 361         if defined $savewarn                        and
 362            UNIVERSAL::isa($savewarn,'CODE')         and
 363            $_[0] !~ /^Subroutine tmpnam redefined/;
 364     };
 365
 366   *tmpnam = sub {
 367     my $tmpnam = POSIX::tmpnam;
 368
 369     if (@_) {
 370       push @tmpfns, [ $tmpnam, $_[0] ];
 371     } else {
 372       push @tmpfns, $tmpnam;
 373     }
 374
 375     if (wantarray) {
 376       sysopen my $tmpfh, $tmpnam, O_RDWR | O_CREAT | O_EXCL;
 377       return $tmpnam, $tmpfh;
 378     } else {
 379       return $tmpnam;
 380     }
 381   }
 382 }
 383
 384 END {
 385   if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 386     for (@tmpfns) {
 387       if ( ref $_ ) {
 388         printf "Used temp file: %s (%s)\n", @$_;
 389       } else {
 390         print "Used temp file: $_\n";
 391       }
 392     }
 393   } else {
 394     unlink map((ref $_ ? $_->[0] : $_), @tmpfns)
 395       if @tmpfns;
 396   }
 397 }
 398
 399 # -------------------------------------
 400
 401 =head2 tempdir
 402
 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).
 405
 406 =over 4
 407
 408 =item ARGUMENTS
 409
 410 I<None>
 411
 412 =item RETURNS
 413
 414 =over 4
 415
 416 =item name
 417
 418 Name of temporary dir.
 419
 420 =back
 421
 422 =back
 423
 424 =cut
 425
 426 my @tmpdirs;
 427 sub tempdir {
 428   my $tempdir = POSIX::tmpnam;
 429   mkdir $tempdir, 0700
 430     or die "Failed to create temporary directory $tempdir: $!\n";
 431
 432   if (@_) {
 433     push @tmpdirs, [ $tempdir, $_[0] ];
 434   } else {
 435     push @tmpdirs, $tempdir;
 436   }
 437
 438   return $tempdir;
 439 }
 440
 441 END {
 442   for (@tmpdirs) {
 443     if ( ref $_ ) {
 444       if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 445         printf "Used temp dir: %s (%s)\n", @$_;
 446       } else {
 447         # Solaris gets narky about removing the pwd.
 448         chdir File::Spec->rootdir;
 449         rmtree $_->[0];
 450       }
 451     } else {
 452       if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 453         print "Used temp dir: $_\n";
 454       } else {
 455         # Solaris gets narky about removing the pwd.
 456         chdir File::Spec->rootdir;
 457         rmtree $_;
 458       }
 459     }
 460   }
 461 }
 462
 463
 464 # defined further up to use in constants
 465
 466 # ----------------------------------------------------------------------------
 467
 468 =head1 EXAMPLES
 469
 470 Z<>
 471
 472 =head1 BUGS
 473
 474 Z<>
 475
 476 =head1 REPORTING BUGS
 477
 478 Email the author.
 479
 480 =head1 AUTHOR
 481
 482 Martyn J. Pearce C<fluffy@cpan.org>
 483
 484 =head1 COPYRIGHT
 485
 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
 488 Perl itself.
 489
 490 =head1 SEE ALSO
 491
 492 Z<>
 493
 494 =cut
 495
 496 1; # keep require happy.
 497
 498 __END__