1#!perl -T
2# -*- mode: cperl ; compile-command: "cd .. ; ./Build ; prove -vb t/07-*.t" -*-
3
4BEGIN { $_ = defined && /(.*)/ && $1 for @ENV{qw/ TMPDIR TEMP TMP /} } # taint vs tempfile
5use Test::More tests => 8 + 5*18;
6use strict;
7use warnings;
8
9use Test::Trap::Builder;
10my $Builder; BEGIN { $Builder = Test::Trap::Builder->new }
11
12local @ARGV; # in case some harness wants to mess with it ...
13my @argv = ('A');
14BEGIN {
15  package TT::A;
16  use base 'Test::Trap';
17  $Builder->layer( argv => $_ ) for sub {
18    my $self = shift;
19    local *ARGV = \@argv;
20    $self->{inargv} = [@argv];
21    $self->Next;
22    $self->{outargv} = [@argv];
23  };
24  $Builder->accessor( is_array => 1, simple => [qw/inargv outargv/] );
25  $Builder->accessor( flexible =>
26		      { argv => sub {
27			  $_[1] && $_[1] !~ /in/i ? $_[0]{outargv} : $_[0]{inargv};
28			},
29		      },
30		    );
31  $Builder->test( can => 'element, predicate, name', $_ ) for sub {
32    my ($got, $methods) = @_;
33    @_ = ($got, @$methods);
34    goto &Test::More::can_ok;
35  };
36  # Hack! Make perl think we have successfully required this package,
37  # so that we can "use" it, even though it can't be found:
38  $INC{'TT/A.pm'} = 'Hack!';
39}
40
41BEGIN {
42  package TT::B;
43  use base 'Test::Trap';
44  $Builder->accessor( flexible =>
45		      { leavewith => sub {
46			  my $self = shift;
47			  my $leaveby = $self->leaveby;
48			  $self->$leaveby;
49			},
50		      },
51		    );
52  # Hack! Make perl think we have successfully required this package,
53  # so that we can "use" it, even though it can't be found:
54  $INC{'TT/B.pm'} = 'Hack!';
55}
56
57BEGIN {
58  package TT::AB;
59  use base qw( TT::A TT::B );
60  $Builder->test( fail => 'name', \&Test::More::fail );
61  # Hack! Make perl think we have successfully required this package,
62  # so that we can "use" it, even though it can't be found:
63  $INC{'TT/AB.pm'} = 'Hack!';
64}
65
66BEGIN {
67  package TT::A2;
68  use base qw( TT::A );
69  $Builder->test( anotherfail => 'name', \&Test::More::fail );
70  $Builder->accessor( flexible =>
71		      { anotherouterr => sub {
72			  my $self = shift;
73			  $self->stdout . $self->stderr;
74			},
75		      },
76		    );
77  # Hack! Make perl think we have successfully required this package,
78  # so that we can "use" it, even though it can't be found:
79  $INC{'TT/A2.pm'} = 'Hack!';
80}
81
82BEGIN {
83  # Insert s'mores into Test::Trap itself ... not clean, but a nice
84  # quick thing to be able to do, in need:
85  package Test::Trap;
86  $Builder->test( pass => 'name', \&Test::More::pass );
87  $Builder->accessor( flexible =>
88		      { outerr => sub {
89			  my $self = shift;
90			  $self->stdout . $self->stderr;
91			},
92		      },
93		    );
94}
95
96BEGIN {
97  use_ok( 'Test::Trap' ); # import a standard trap/$trap
98  use_ok( 'Test::Trap', '$D', 'D' );
99  use_ok( 'TT::A',  '$A',  'A',  ':argv' );
100  use_ok( 'TT::B',  '$B',  'B' );
101  use_ok( 'TT::AB', '$AB', 'AB', ':argv' );
102  use_ok( 'TT::A2', '$A2', 'A2', ':argv' );
103}
104
105BEGIN {
106  trap {
107    package TT::badclass;
108    use base 'Test::Trap';
109    $Builder->multi_layer( trouble => qw( warn no_such_layer ) );
110  };
111  like( $trap->die,
112	qr/^\QUnknown trap layer "no_such_layer" at ${\__FILE__} line/,
113	'Bad definition: unknown layer',
114      );
115}
116
117BEGIN {
118  trap {
119    package TT::badclass3;
120    use base 'Test::Trap';
121    $Builder->test( pass => 'named', \&Test::More::pass );
122  };
123  like( $trap->die,
124	qr/^\QUnrecognized identifier named in argspec at ${\__FILE__} line/,
125	'Bad definition: test argspec typo ("named" for "name")',
126      );
127}
128
129basic( \&D, \$D, 'Unmodified Test::Trap',
130       qw( isno_A isno_B isno_AB ),
131     );
132
133basic( \&A, \$A, 'TT::A',
134       qw( isan_A isno_B isno_AB ),
135     );
136
137basic( \&B, \$B, 'TT::B',
138       qw( isno_A isa_B isno_AB ),
139     );
140
141basic( \&AB, \$AB, 'TT::AB',
142       qw( isan_A isa_B isan_AB ),
143     );
144
145basic( \&A2, \$A2, 'TT::A2',
146       qw( isan_A isno_B isno_AB ),
147     );
148
149exit 0;
150
151# compile this after the CORE::GLOBAL::exit has been set:
152
153my $argv_expected;
154my $ARGV_expected;
155
156sub isno_A {
157  my ($func, $handle, $name) = @_;
158  ok( !exists $$handle->{inargv}, "$name: no inargv internally" );
159  push @$ARGV_expected, $name;
160  ok( !exists $$handle->{outargv}, "$name: no outargv internally" );
161  is_deeply( \@ARGV, $ARGV_expected, "$name: \@ARGV modified" );
162  is_deeply( \@argv, $argv_expected, "$name: \@argv unmofied" );
163  ok( !$$handle->can('return_can'), "$name: no return_can method" );
164  ok( !$$handle->can('outargv'), "$name: no outargv method" );
165  ok( !$$handle->can('outargv_can'), "$name: no outargv_can method" );
166  ok( !$$handle->can('outargv_pass'), "$name: no outargv_pass method" );
167}
168
169sub isan_A {
170  my ($func, $handle, $name) = @_;
171  is_deeply( $$handle->{inargv}, $argv_expected, "$name: inargv present internally" );
172  push @$argv_expected, $name;
173  is_deeply( $$handle->{outargv}, $argv_expected, "$name: outargv present internally" );
174  is_deeply( \@ARGV, $ARGV_expected, "$name: \@ARGV unmodified" );
175  is_deeply( \@argv, $argv_expected, "$name: \@argv modified" );
176  ok( $$handle->can('return_can'), "$name: return_can method present" );
177  () = trap { $$handle->outargv };
178  $trap->return_is_deeply( [$argv_expected], "$name: outargv method present and functional" );
179  ok( $$handle->can('outargv_can'), "$name: outargv_can method present" );
180  ok( $$handle->can('outargv_pass'), "$name: outargv_pass method present" );
181}
182
183sub isa_B {
184  my ($func, $handle, $name) = @_;
185  () = trap { $$handle->leavewith };
186  $trap->return_is_deeply( [1], "$name: leavewith method present and functional" );
187}
188
189sub isno_B {
190  my ($func, $handle, $name) = @_;
191  ok( !$$handle->can('leavewith'), "$name: no leavewith method" );
192}
193
194sub isan_AB {
195  my ($func, $handle, $name) = @_;
196  ok( $$handle->can('stderr_fail'),    "$name: stderr_fail method present" );
197  ok( $$handle->can('argv_fail'),      "$name: argv_fail method present" );
198  ok( $$handle->can('leavewith_fail'), "$name: leavewith_fail method present" );
199TODO: {
200    local $TODO = 'Multiple inheritance still incomplete';
201    ok( $$handle->can('leavewith_can'),  "$name: leavewith_fail method present" );
202  }
203}
204
205sub isno_AB {
206  my ($func, $handle, $name) = @_;
207  ok( !$$handle->can('stderr_fail'),    "$name: no stderr_fail method" );
208  ok( !$$handle->can('argv_fail'),      "$name: no argv_fail method" );
209  ok( !$$handle->can('leavewith_fail'), "$name: no leavewith_fail method" );
210  ok( !$$handle->can('leavewith_can'),  "$name: no leavewith_can method" );
211}
212
213sub basic {
214  my ($func, $handle, $name) = @_;
215  $argv_expected ||= ['A'];
216  $ARGV_expected ||= [];
217  $func->(sub { print "Hello"; warn "Hi!\n"; push @ARGV, $name; exit 1 });
218  local $Test::Builder::Level = $Test::Builder::Level + 1;
219  is( $$handle->exit, 1, "$name: trapped exit" );
220  is( $$handle->stdout, "Hello", "$name: trapped stdout" );
221  is( $$handle->stderr, "Hi!\n", "$name: trapped stderr" );
222  is_deeply( $$handle->warn, ["Hi!\n"], "$name: trapped warnings" );
223  ok( $$handle->can('stdout_pass'), "$name: stdout_pass method present" );
224  $Test::Builder::Level++;
225  no strict 'refs';
226  $_->(@_) for @_[3..$#_];
227}
228