Commit | Line | Data |
b965d173 |
1 | #!/usr/bin/perl -w |
2 | |
3 | BEGIN { |
2adbc9b6 |
4 | unshift @INC, 't/lib'; |
b965d173 |
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; |
b965d173 |
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 | |
2adbc9b6 |
63 | my @spool = ( 't', 'spool' ); |
5e2a19fc |
64 | $ENV{PERL_TEST_HARNESS_DUMP_TAP} = File::Spec->catfile(@spool); |
b965d173 |
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 | |
5e2a19fc |
96 | my $spoolDir = quotemeta( |
97 | File::Spec->catfile( @spool, qw( source_tests harness ) ) ); |
b965d173 |
98 | |
5e2a19fc |
99 | like pop @die, qr/ Can't write $spoolDir \( /, '...with expected message'; |
b965d173 |
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( |
f7c69158 |
114 | { spool => $spoolHandle, |
115 | stream => |
116 | TAP::Parser::IteratorFactory->new( [ split /\n/ => $tap ] ) |
b965d173 |
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 | } |