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 # -------------------------------------
 299
 300 =head2 tmpnam
 301
 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.
 304
 305 =over 4
 306
 307 =item ARGUMENTS
 308
 309 =over 4
 310
 311 =item name
 312
 313 I<Optional>.  If defined, a name by which to refer to the tmpfile in user
 314 messages.
 315
 316 =back
 317
 318 =item RETURNS
 319
 320 =over 4
 321
 322 =item filename
 323
 324 Name of temporary file.
 325
 326 =item fh
 327
 328 Open filehandle to temp file, in r/w mode.  Only created & returned in list
 329 context.
 330
 331 =back
 332
 333 =back
 334
 335 =cut
 336
 337 my @tmpfns;
 338
 339 BEGIN {
 340   my $savewarn = $SIG{__WARN__};
 341   # Subvert bizarre (& incorrect) subroutine redefined errors in 5.005_03
 342   local $SIG{__WARN__} =
 343     sub {
 344       $savewarn->(@_)
 345         if defined $savewarn                        and
 346            UNIVERSAL::isa($savewarn,'CODE')         and
 347            $_[0] !~ /^Subroutine tmpnam redefined/;
 348     };
 349
 350   *tmpnam = sub {
 351     my $tmpnam = POSIX::tmpnam;
 352
 353     if (@_) {
 354       push @tmpfns, [ $tmpnam, $_[0] ];
 355     } else {
 356       push @tmpfns, $tmpnam;
 357     }
 358
 359     if (wantarray) {
 360       sysopen my $tmpfh, $tmpnam, O_RDWR | O_CREAT | O_EXCL;
 361       return $tmpnam, $tmpfh;
 362     } else {
 363       return $tmpnam;
 364     }
 365   }
 366 }
 367
 368 END {
 369   if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 370     for (@tmpfns) {
 371       if ( ref $_ ) {
 372         printf "Used temp file: %s (%s)\n", @$_;
 373       } else {
 374         print "Used temp file: $_\n";
 375       }
 376     }
 377   } else {
 378     unlink map((ref $_ ? $_->[0] : $_), @tmpfns)
 379       if @tmpfns;
 380   }
 381 }
 382
 383 # -------------------------------------
 384
 385 =head2 tempdir
 386
 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).
 389
 390 =over 4
 391
 392 =item ARGUMENTS
 393
 394 I<None>
 395
 396 =item RETURNS
 397
 398 =over 4
 399
 400 =item name
 401
 402 Name of temporary dir.
 403
 404 =back
 405
 406 =back
 407
 408 =cut
 409
 410 my @tmpdirs;
 411 sub tempdir {
 412   my $tempdir = POSIX::tmpnam;
 413   mkdir $tempdir, 0700
 414     or die "Failed to create temporary directory $tempdir: $!\n";
 415
 416   if (@_) {
 417     push @tmpdirs, [ $tempdir, $_[0] ];
 418   } else {
 419     push @tmpdirs, $tempdir;
 420   }
 421
 422   return $tempdir;
 423 }
 424
 425 END {
 426   for (@tmpdirs) {
 427     if ( ref $_ ) {
 428       if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 429         printf "Used temp dir: %s (%s)\n", @$_;
 430       } else {
 431         # Solaris gets narky about removing the pwd.
 432         chdir File::Spec->rootdir;
 433         rmtree $_->[0];
 434       }
 435     } else {
 436       if ( defined $ENV{TEST_DEBUG} and $ENV{TEST_DEBUG} =~ /\bSAVE\b/ ) {
 437         print "Used temp dir: $_\n";
 438       } else {
 439         # Solaris gets narky about removing the pwd.
 440         chdir File::Spec->rootdir;
 441         rmtree $_;
 442       }
 443     }
 444   }
 445 }
 446
 447
 448 # defined further up to use in constants
 449
 450 # ----------------------------------------------------------------------------
 451
 452 =head1 EXAMPLES
 453
 454 Z<>
 455
 456 =head1 BUGS
 457
 458 Z<>
 459
 460 =head1 REPORTING BUGS
 461
 462 Email the author.
 463
 464 =head1 AUTHOR
 465
 466 Martyn J. Pearce C<fluffy@cpan.org>
 467
 468 =head1 COPYRIGHT
 469
 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
 472 Perl itself.
 473
 474 =head1 SEE ALSO
 475
 476 Z<>
 477
 478 =cut
 479
 480 1; # keep require happy.
 481
 482 __END__