Commit | Line | Data |
b965d173 |
1 | #!/usr/bin/perl -w |
2 | |
3 | BEGIN { |
5e2a19fc |
4 | if ( $ENV{PERL_CORE} ) { |
5 | chdir 't'; |
6 | @INC = ( '../lib', 'lib' ); |
7 | } |
8 | else { |
9 | unshift @INC, 't/lib'; |
b965d173 |
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; |
b965d173 |
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 | |
5e2a19fc |
69 | my @spool = ( $ENV{PERL_CORE} ? ('spool') : ( 't', 'spool' ) ); |
70 | $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool); |
b965d173 |
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 | |
5e2a19fc |
102 | my $spoolDir = quotemeta( |
103 | File::Spec->catfile( @spool, qw( source_tests harness ) ) ); |
b965d173 |
104 | |
5e2a19fc |
105 | like pop @die, qr/ Can't write $spoolDir \( /, '...with expected message'; |
b965d173 |
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 => TAP::Parser::Iterator->new( [ split /\n/ => $tap ] ) |
122 | } |
123 | ); |
124 | |
125 | @die = (); |
126 | |
127 | eval { |
128 | local $SIG{__DIE__} = sub { push @die, @_ }; |
129 | |
130 | # use the broken CORE::close |
131 | $useOrigClose = 0; |
132 | |
133 | TAP::Harness->_close_spool($parser); |
134 | |
135 | $useOrigClose = 1; |
136 | }; |
137 | |
138 | unless ( is @die, 1, 'close failed, die as expected' ) { |
139 | diag " >>> $_ <<<\n" for @die; |
140 | } |
141 | |
142 | like pop @die, qr/ Error closing TAP spool file[(] /, |
143 | '...with expected message'; |
144 | } |