cpan/Test-Harness/t/spool.t

   1 #!/usr/bin/perl -w
   2
   3 BEGIN {
   4     if ( $ENV{PERL_CORE} ) {
   5         chdir 't';
   6         @INC = ( '../lib', 'lib' );
   7     }
   8     else {
   9         unshift @INC, 't/lib';
  10     }
  11 }
  12
  13 # test T::H::_open_spool and _close_spool - these are good examples
  14 # of the 'Fragile Test' pattern - messing with I/O primitives breaks
  15 # nearly everything
  16
  17 use strict;
  18 use Test::More;
  19
  20 my $useOrigOpen;
  21 my $useOrigClose;
  22
  23 # setup replacements for core open and close - breaking these makes everything very fragile
  24 BEGIN {
  25     $useOrigOpen = $useOrigClose = 1;
  26
  27     # taken from http://www.perl.com/pub/a/2002/06/11/threads.html?page=2
  28
  29     *CORE::GLOBAL::open = \&my_open;
  30
  31     sub my_open (*@) {
  32         if ($useOrigOpen) {
  33             if ( defined( $_[0] ) ) {
  34                 use Symbol qw();
  35                 my $handle = Symbol::qualify( $_[0], (caller)[0] );
  36                 no strict 'refs';
  37                 if ( @_ == 1 ) {
  38                     return CORE::open($handle);
  39                 }
  40                 elsif ( @_ == 2 ) {
  41                     return CORE::open( $handle, $_[1] );
  42                 }
  43                 else {
  44                     die "Can't open with more than two args";
  45                 }
  46             }
  47         }
  48         else {
  49             return;
  50         }
  51     }
  52
  53     *CORE::GLOBAL::close = sub (*) {
  54         if   ($useOrigClose) { return CORE::close(shift) }
  55         else                 {return}
  56     };
  57
  58 }
  59
  60 use TAP::Harness;
  61 use TAP::Parser;
  62 use TAP::Parser::Iterator::Array;
  63
  64 plan tests => 4;
  65
  66 {
  67
  68     # coverage tests for the basically untested T::H::_open_spool
  69
  70     my @spool = ( $ENV{PERL_CORE} ? ('spool') : ( 't', 'spool' ) );
  71     $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool);
  72
  73 # now given that we're going to be writing stuff to the file system, make sure we have
  74 # a cleanup hook
  75
  76     END {
  77         use File::Path;
  78
  79         $useOrigOpen = $useOrigClose = 1;
  80
  81         # remove the tree if we made it this far
  82         rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} )
  83           if $ENV{PERL_TEST_HARNESS_DUMP_TAP};
  84     }
  85
  86     my @die;
  87
  88     eval {
  89         local $SIG{__DIE__} = sub { push @die, @_ };
  90
  91         # use the broken open
  92         $useOrigOpen = 0;
  93
  94         TAP::Harness->_open_spool(
  95             File::Spec->catfile(qw (source_tests harness )) );
  96
  97         # restore universal sanity
  98         $useOrigOpen = 1;
  99     };
 100
 101     is @die, 1, 'open failed, die as expected';
 102
 103     my $spoolDir = quotemeta(
 104         File::Spec->catfile( @spool, qw( source_tests harness ) ) );
 105
 106     like pop @die, qr/ Can't write $spoolDir \( /, '...with expected message';
 107
 108     # now make close fail
 109
 110     use Symbol;
 111
 112     my $spoolHandle = gensym;
 113
 114     my $tap = <<'END_TAP';
 115 1..1
 116 ok 1 - input file opened
 117
 118 END_TAP
 119
 120     my $parser = TAP::Parser->new(
 121         {   spool => $spoolHandle,
 122             iterator =>
 123               TAP::Parser::Iterator::Array->new( [ split /\n/ => $tap ] )
 124         }
 125     );
 126
 127     @die = ();
 128
 129     eval {
 130         local $SIG{__DIE__} = sub { push @die, @_ };
 131
 132         # use the broken CORE::close
 133         $useOrigClose = 0;
 134
 135         TAP::Harness->_close_spool($parser);
 136
 137         $useOrigClose = 1;
 138     };
 139
 140     unless ( is @die, 1, 'close failed, die as expected' ) {
 141         diag " >>> $_ <<<\n" for @die;
 142     }
 143
 144     like pop @die, qr/ Error closing TAP spool file[(] /,
 145       '...with expected message';
 146 }