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 =item find_exec
  96
  97 =back
  98
  99 =cut
 100
 101 @EXPORT_OK = qw( evcheck save_output restore_output );
 102
 103 # Utility -----------------------------
 104
 105 use Carp                          qw( carp croak );
 106 use Cwd                      2.01 qw( cwd );
 107 use Env                           qw( PATH );
 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 );
 117
 118 # ----------------------------------------------------------------------------
 119
 120 sub rel2abs {
 121   if ( File::Spec->file_name_is_absolute($_[0]) ) {
 122     return $_[0];
 123   } else {
 124     return File::Spec->catdir(cwd, $_[0]);
 125   }
 126 }
 127
 128 sub min {
 129   croak "Can't min over 0 args!\n"
 130     unless @_;
 131   my $min = $_[0];
 132   for (@_[1..$#_]) {
 133     $min = $_
 134       if $_ < $min;
 135   }
 136
 137   return $min;
 138 }
 139
 140 # -------------------------------------
 141 # PACKAGE CONSTANTS
 142 # -------------------------------------
 143
 144 use constant BUILD_SCRIPT_DIR => => File::Spec->catdir( $Bin, File::Spec->updir, qw( blib script ) );
 145
 146 sub find_exec {
 147   my ($exec) = @_;
 148
 149   for (split /:/, $PATH) {
 150     my $try = File::Spec->catfile($_, $exec);
 151     return rel2abs($try)
 152       if -x $try;
 153   }
 154   return;
 155 }
 156
 157 # -------------------------------------
 158 # PACKAGE ACTIONS
 159 # -------------------------------------
 160
 161 $PATH = join ':', BUILD_SCRIPT_DIR, split /:/, $PATH;
 162
 163 my $tmpdn = tempdir();
 164 $| = 1;
 165
 166 mkpath $tmpdn;
 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;
 169
 170 chdir $tmpdn;
 171
 172 # -------------------------------------
 173 # PACKAGE FUNCTIONS
 174 # -------------------------------------
 175
 176 =head2 evcheck
 177
 178 Eval code, return status
 179
 180 =over 4
 181
 182 =item ARGUMENTS
 183
 184 =over 4
 185
 186 =item code
 187
 188 Coderef to eval
 189
 190 =item name
 191
 192 Name to use in error messages
 193
 194 =back
 195
 196 =item RETURNS
 197
 198 =over 4
 199
 200 =item okay
 201
 202 1 if eval was okay, 0 if not.
 203
 204 =back
 205
 206 =back
 207
 208 =cut
 209
 210 sub evcheck {
 211   my ($code, $name) = @_;
 212
 213   my $ok = 0;
 214
 215   eval {
 216     &$code;
 217     $ok = 1;
 218   }; if ( $@ ) {
 219     carp "Code $name failed: $@\n"
 220       if $ENV{TEST_DEBUG};
 221     $ok = 0;
 222   }
 223
 224   return $ok;
 225 }
 226
 227 # -------------------------------------
 228
 229 =head2 save_output
 230
 231 Redirect a filehandle to temporary storage for later examination.
 232
 233 =over 4
 234
 235 =item ARGUMENTS
 236
 237 =over 4
 238
 239 =item name
 240
 241 Name to store as (used in L<restore_output>)
 242
 243 =item filehandle
 244
 245 The filehandle to save
 246
 247 =back
 248
 249 =cut
 250
 251 # Map from names to saved filehandles.
 252
 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
 256 # stack.
 257
 258 my %grabs;
 259
 260 sub save_output {
 261   croak sprintf("%s takes 2 arguments\n", (caller 0)[3])
 262     unless @_ == 2;
 263   my ($name, $filehandle) = @_;
 264
 265   my $tmpfh  = do { local *F; *F; };
 266   my $savefh = do { local *F; *F; };
 267
 268   (undef, $tmpfh) = test::tmpnam();
 269   select((select($tmpfh), $| = 1)[0]);
 270
 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: $!";
 275
 276   push @{$grabs{$name}}, $savefh, $tmpfh, $filehandle;
 277 }
 278
 279 # -------------------------------------
 280
 281 =head2 restore_output
 282
 283 Restore a saved filehandle to its original state, return the saved output.
 284
 285 =over 4
 286
 287 =item ARGUMENTS
 288
 289 =over 4
 290
 291 =item name
 292
 293 Name of the filehandle to restore (as passed to L<save_output>).
 294
 295 =back
 296
 297 =item RETURNS
 298
 299 =over 4
 300
 301 =item saved_string
 302
 303 A single string being the output saved.
 304
 305 =back
 306
 307 =cut
 308
 309 sub restore_output {
 310   my ($name) = @_;
 311
 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;
 317
 318   close $origfh
 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]);
 323
 324   seek $tmpfh, 0, 0;
 325   local $/ = undef;
 326   my $string = <$tmpfh>;
 327   close $tmpfh;
 328
 329   return $string;
 330 }
 331
 332 sub _test_save_restore_output {
 333   warn "to stderr 1\n";
 334   save_output("stderr", *STDERR{IO});
 335   warn "Hello, Mum!";
 336   print 'SAVED:->:', restore_output("stderr"), ":<-\n";
 337   warn "to stderr 2\n";
 338 }
 339
 340 # -------------------------------------
 341
 342 =head2 tmpnam
 343
 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.
 346
 347 =over 4
 348
 349 =item ARGUMENTS
 350
 351 =over 4
 352
 353 =item name
 354
 355 I<Optional>.  If defined, a name by which to refer to the tmpfile in user
 356 messages.
 357
 358 =back
 359
 360 =item RETURNS
 361
 362 =over 4
 363
 364 =item filename
 365
 366 Name of temporary file.
 367
 368 =item fh
 369
 370 Open filehandle to temp file, in r/w mode.  Only created & returned in list
 371 context.
 372
 373 =back
 374
 375 =back
 376
 377 =cut
 378
 379 my @tmpfns;
 380
 381 BEGIN {
 382   my $savewarn = $SIG{__WARN__};
 383   # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03
 384   local $SIG{__WARN__} =
 385     sub {
 386       $savewarn->(@_)
 387         if defined $savewarn                        and
 388            UNIVERSAL::isa($savewarn,'CODE')         and
 389            $_[0] !~ /^Subroutine tmpnam redefined/;
 390     };
 391
 392   *tmpnam = sub {
 393     my $tmpnam = POSIX::tmpnam;
 394
 395     if (@_) {
 396       push @tmpfns, [ $tmpnam, $_[0] ];
 397     } else {
 398       push @tmpfns, $tmpnam;
 399     }
 400
 401     if (wantarray) {
 402       sysopen my $tmpfh, $tmpnam, O_RDWR | O_CREAT | O_EXCL;
 403       return $tmpnam, $tmpfh;
 404     } else {
 405       return $tmpnam;
 406     }
 407   }
 408 }
 409
 410 END {
 411   if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 412     for (@tmpfns) {
 413       if ( ref $_ ) {
 414         printf "Used temp file: %s (%s)\n", @$_;
 415       } else {
 416         print "Used temp file: $_\n";
 417       }
 418     }
 419   } else {
 420     unlink map((ref $_ ? $_->[0] : $_), @tmpfns)
 421       if @tmpfns;
 422   }
 423 }
 424
 425 # -------------------------------------
 426
 427 =head2 tempdir
 428
 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).
 431
 432 =over 4
 433
 434 =item ARGUMENTS
 435
 436 I<None>
 437
 438 =item RETURNS
 439
 440 =over 4
 441
 442 =item name
 443
 444 Name of temporary dir.
 445
 446 =back
 447
 448 =back
 449
 450 =cut
 451
 452 my @tmpdirs;
 453 sub tempdir {
 454   my $tempdir = POSIX::tmpnam;
 455   mkdir $tempdir, 0700
 456     or die "Failed to create temporary directory $tempdir: $!\n";
 457
 458   if (@_) {
 459     push @tmpdirs, [ $tempdir, $_[0] ];
 460   } else {
 461     push @tmpdirs, $tempdir;
 462   }
 463
 464   return $tempdir;
 465 }
 466
 467 END {
 468   for (@tmpdirs) {
 469     if ( ref $_ ) {
 470       if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 471         printf "Used temp dir: %s (%s)\n", @$_;
 472       } else {
 473         # Solaris gets narky about removing the pwd.
 474         chdir File::Spec->rootdir;
 475         rmtree $_->[0];
 476       }
 477     } else {
 478       if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 479         print "Used temp dir: $_\n";
 480       } else {
 481         # Solaris gets narky about removing the pwd.
 482         chdir File::Spec->rootdir;
 483         rmtree $_;
 484       }
 485     }
 486   }
 487 }
 488
 489 # -------------------------------------
 490
 491 =head2 find_exec
 492
 493 =over 4
 494
 495 =item ARGUMENTS
 496
 497 =over 4
 498
 499 =item proggie
 500
 501 The name of the program
 502
 503 =back
 504
 505 =item RETURNS
 506
 507 =over 4
 508
 509 =item path
 510
 511 The path to the first executable file with the given name on C<$PATH>.  Or
 512 nothing, if no such file exists.
 513
 514 =back
 515
 516 =back
 517
 518 =cut
 519
 520 # defined further up to use in constants
 521
 522 # ----------------------------------------------------------------------------
 523
 524 =head1 EXAMPLES
 525
 526 Z<>
 527
 528 =head1 BUGS
 529
 530 Z<>
 531
 532 =head1 REPORTING BUGS
 533
 534 Email the author.
 535
 536 =head1 AUTHOR
 537
 538 Martyn J. Pearce C<fluffy@cpan.org>
 539
 540 =head1 COPYRIGHT
 541
 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
 544 Perl itself.
 545
 546 =head1 SEE ALSO
 547
 548 Z<>
 549
 550 =cut
 551
 552 1; # keep require happy.
 553
 554 __END__