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