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 # -------------------------------------
 118 # PACKAGE CONSTANTS
 119 # -------------------------------------
 120
 121 use constant BUILD_SCRIPT_DIR => => File::Spec->catdir( $Bin, File::Spec->updir, qw( blib script ) );
 122
 123 # -------------------------------------
 124 # PACKAGE ACTIONS
 125 # -------------------------------------
 126
 127 $PATH = join ':', BUILD_SCRIPT_DIR, split /:/, $PATH;
 128
 129 my $tmpdn = tempdir();
 130 $| = 1;
 131
 132 mkpath $tmpdn;
 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;
 135
 136 chdir $tmpdn;
 137
 138 # -------------------------------------
 139 # PACKAGE FUNCTIONS
 140 # -------------------------------------
 141
 142 =head2 evcheck
 143
 144 Eval code, return status
 145
 146 =over 4
 147
 148 =item ARGUMENTS
 149
 150 =over 4
 151
 152 =item code
 153
 154 Coderef to eval
 155
 156 =item name
 157
 158 Name to use in error messages
 159
 160 =back
 161
 162 =item RETURNS
 163
 164 =over 4
 165
 166 =item okay
 167
 168 1 if eval was okay, 0 if not.
 169
 170 =back
 171
 172 =back
 173
 174 =cut
 175
 176 sub evcheck {
 177   my ($code, $name) = @_;
 178
 179   my $ok = 0;
 180
 181   eval {
 182     &$code;
 183     $ok = 1;
 184   }; if ( $@ ) {
 185     carp "Code $name failed: $@\n"
 186       if $ENV{TEST_DEBUG};
 187     $ok = 0;
 188   }
 189
 190   return $ok;
 191 }
 192
 193 # -------------------------------------
 194
 195 =head2 save_output
 196
 197 Redirect a filehandle to temporary storage for later examination.
 198
 199 =over 4
 200
 201 =item ARGUMENTS
 202
 203 =over 4
 204
 205 =item name
 206
 207 Name to store as (used in L<restore_output>)
 208
 209 =item filehandle
 210
 211 The filehandle to save
 212
 213 =back
 214
 215 =cut
 216
 217 # Map from names to saved filehandles.
 218
 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
 222 # stack.
 223
 224 my %grabs;
 225
 226 sub save_output {
 227   croak sprintf("%s takes 2 arguments\n", (caller 0)[3])
 228     unless @_ == 2;
 229   my ($name, $filehandle) = @_;
 230
 231   my $tmpfh  = do { local *F; *F; };
 232   my $savefh = do { local *F; *F; };
 233
 234   (undef, $tmpfh) = test::tmpnam();
 235   select((select($tmpfh), $| = 1)[0]);
 236
 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: $!";
 241
 242   push @{$grabs{$name}}, $savefh, $tmpfh, $filehandle;
 243 }
 244
 245 # -------------------------------------
 246
 247 =head2 restore_output
 248
 249 Restore a saved filehandle to its original state, return the saved output.
 250
 251 =over 4
 252
 253 =item ARGUMENTS
 254
 255 =over 4
 256
 257 =item name
 258
 259 Name of the filehandle to restore (as passed to L<save_output>).
 260
 261 =back
 262
 263 =item RETURNS
 264
 265 =over 4
 266
 267 =item saved_string
 268
 269 A single string being the output saved.
 270
 271 =back
 272
 273 =cut
 274
 275 sub restore_output {
 276   my ($name) = @_;
 277
 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;
 283
 284   close $origfh
 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]);
 289
 290   seek $tmpfh, 0, 0;
 291   local $/ = undef;
 292   my $string = <$tmpfh>;
 293   close $tmpfh;
 294
 295   return $string;
 296 }
 297
 298 sub _test_save_restore_output {
 299   warn "to stderr 1\n";
 300   save_output("stderr", *STDERR{IO});
 301   warn "Hello, Mum!";
 302   print 'SAVED:->:', restore_output("stderr"), ":<-\n";
 303   warn "to stderr 2\n";
 304 }
 305
 306 # -------------------------------------
 307
 308 =head2 tmpnam
 309
 310 Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
 311 if TEST_DEBUG has SAVE in the value.
 312
 313 =over 4
 314
 315 =item ARGUMENTS
 316
 317 =over 4
 318
 319 =item name
 320
 321 I<Optional>.  If defined, a name by which to refer to the tmpfile in user
 322 messages.
 323
 324 =back
 325
 326 =item RETURNS
 327
 328 =over 4
 329
 330 =item filename
 331
 332 Name of temporary file.
 333
 334 =item fh
 335
 336 Open filehandle to temp file, in r/w mode.  Only created & returned in list
 337 context.
 338
 339 =back
 340
 341 =back
 342
 343 =cut
 344
 345 my @tmpfns;
 346
 347 BEGIN {
 348   my $savewarn = $SIG{__WARN__};
 349   # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03
 350   local $SIG{__WARN__} =
 351     sub {
 352       $savewarn->(@_)
 353         if defined $savewarn                        and
 354            UNIVERSAL::isa($savewarn,'CODE')         and
 355            $_[0] !~ /^Subroutine tmpnam redefined/;
 356     };
 357
 358   *tmpnam = sub {
 359     my $tmpnam = POSIX::tmpnam;
 360
 361     if (@_) {
 362       push @tmpfns, [ $tmpnam, $_[0] ];
 363     } else {
 364       push @tmpfns, $tmpnam;
 365     }
 366
 367     if (wantarray) {
 368       sysopen my $tmpfh, $tmpnam, O_RDWR | O_CREAT | O_EXCL;
 369       return $tmpnam, $tmpfh;
 370     } else {
 371       return $tmpnam;
 372     }
 373   }
 374 }
 375
 376 END {
 377   if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 378     for (@tmpfns) {
 379       if ( ref $_ ) {
 380         printf "Used temp file: %s (%s)\n", @$_;
 381       } else {
 382         print "Used temp file: $_\n";
 383       }
 384     }
 385   } else {
 386     unlink map((ref $_ ? $_->[0] : $_), @tmpfns)
 387       if @tmpfns;
 388   }
 389 }
 390
 391 # -------------------------------------
 392
 393 =head2 tempdir
 394
 395 Very much like the one in L<POSIX> or L<File::Temp>, but does not get deleted
 396 if TEST_DEBUG has SAVE in the value (does get deleted otherwise).
 397
 398 =over 4
 399
 400 =item ARGUMENTS
 401
 402 I<None>
 403
 404 =item RETURNS
 405
 406 =over 4
 407
 408 =item name
 409
 410 Name of temporary dir.
 411
 412 =back
 413
 414 =back
 415
 416 =cut
 417
 418 my @tmpdirs;
 419 sub tempdir {
 420   my $tempdir = POSIX::tmpnam;
 421   mkdir $tempdir, 0700
 422     or die "Failed to create temporary directory $tempdir: $!\n";
 423
 424   if (@_) {
 425     push @tmpdirs, [ $tempdir, $_[0] ];
 426   } else {
 427     push @tmpdirs, $tempdir;
 428   }
 429
 430   return $tempdir;
 431 }
 432
 433 END {
 434   for (@tmpdirs) {
 435     if ( ref $_ ) {
 436       if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 437         printf "Used temp dir: %s (%s)\n", @$_;
 438       } else {
 439         # Solaris gets narky about removing the pwd.
 440         chdir File::Spec->rootdir;
 441         rmtree $_->[0];
 442       }
 443     } else {
 444       if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 445         print "Used temp dir: $_\n";
 446       } else {
 447         # Solaris gets narky about removing the pwd.
 448         chdir File::Spec->rootdir;
 449         rmtree $_;
 450       }
 451     }
 452   }
 453 }
 454
 455
 456 # defined further up to use in constants
 457
 458 # ----------------------------------------------------------------------------
 459
 460 =head1 EXAMPLES
 461
 462 Z<>
 463
 464 =head1 BUGS
 465
 466 Z<>
 467
 468 =head1 REPORTING BUGS
 469
 470 Email the author.
 471
 472 =head1 AUTHOR
 473
 474 Martyn J. Pearce C<fluffy@cpan.org>
 475
 476 =head1 COPYRIGHT
 477
 478 Copyright (c) 2001, 2002, 2004 Martyn J. Pearce.  This program is free
 479 software; you can redistribute it and/or modify it under the same terms as
 480 Perl itself.
 481
 482 =head1 SEE ALSO
 483
 484 Z<>
 485
 486 =cut
 487
 488 1; # keep require happy.
 489
 490 __END__