cpan/Test-Harness/t/spool.t

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