vcs.maemo.org Git - dh-make-perl/blob - dev/i386/libtest-harness-perl/libtest-harness-perl-3.12/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
  63 plan tests => 4;
  64
  65 {
  66
  67     # coverage tests for the basically untested T::H::_open_spool
  68
  69     my @spool = ( $ENV{PERL_CORE} ? ('spool') : ( 't', 'spool' ) );
  70     $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool);
  71
  72 # now given that we're going to be writing stuff to the file system, make sure we have
  73 # a cleanup hook
  74
  75     END {
  76         use File::Path;
  77
  78         $useOrigOpen = $useOrigClose = 1;
  79
  80         # remove the tree if we made it this far
  81         rmtree( $ENV{PERL_TEST_HARNESS_DUMP_TAP} )
  82           if $ENV{PERL_TEST_HARNESS_DUMP_TAP};
  83     }
  84
  85     my @die;
  86
  87     eval {
  88         local $SIG{__DIE__} = sub { push @die, @_ };
  89
  90         # use the broken open
  91         $useOrigOpen = 0;
  92
  93         TAP::Harness->_open_spool(
  94             File::Spec->catfile(qw (source_tests harness )) );
  95
  96         # restore universal sanity
  97         $useOrigOpen = 1;
  98     };
  99
 100     is @die, 1, 'open failed, die as expected';
 101
 102     my $spoolDir = quotemeta(
 103         File::Spec->catfile( @spool, qw( source_tests harness ) ) );
 104
 105     like pop @die, qr/ Can't write $spoolDir \( /, '...with expected message';
 106
 107     # now make close fail
 108
 109     use Symbol;
 110
 111     my $spoolHandle = gensym;
 112
 113     my $tap = <<'END_TAP';
 114 1..1
 115 ok 1 - input file opened
 116
 117 END_TAP
 118
 119     my $parser = TAP::Parser->new(
 120         {   spool => $spoolHandle,
 121             stream =>
 122               TAP::Parser::IteratorFactory->new( [ split /\n/ => $tap ] )
 123         }
 124     );
 125
 126     @die = ();
 127
 128     eval {
 129         local $SIG{__DIE__} = sub { push @die, @_ };
 130
 131         # use the broken CORE::close
 132         $useOrigClose = 0;
 133
 134         TAP::Harness->_close_spool($parser);
 135
 136         $useOrigClose = 1;
 137     };
 138
 139     unless ( is @die, 1, 'close failed, die as expected' ) {
 140         diag " >>> $_ <<<\n" for @die;
 141     }
 142
 143     like pop @die, qr/ Error closing TAP spool file[(] /,
 144       '...with expected message';
 145 }