line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Test2::API::Context; |
2
|
246
|
|
|
246
|
|
1850
|
use strict; |
|
246
|
|
|
|
|
586
|
|
|
246
|
|
|
|
|
7961
|
|
3
|
246
|
|
|
246
|
|
1348
|
use warnings; |
|
246
|
|
|
|
|
544
|
|
|
246
|
|
|
|
|
11396
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
our $VERSION = '1.302182'; |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
|
8
|
246
|
|
|
246
|
|
1567
|
use Carp qw/confess croak/; |
|
246
|
|
|
|
|
516
|
|
|
246
|
|
|
|
|
14773
|
|
9
|
246
|
|
|
246
|
|
1778
|
use Scalar::Util qw/weaken blessed/; |
|
246
|
|
|
|
|
610
|
|
|
246
|
|
|
|
|
14264
|
|
10
|
246
|
|
|
246
|
|
1819
|
use Test2::Util qw/get_tid try pkg_to_file get_tid/; |
|
246
|
|
|
|
|
603
|
|
|
246
|
|
|
|
|
14399
|
|
11
|
|
|
|
|
|
|
|
12
|
246
|
|
|
246
|
|
1739
|
use Test2::EventFacet::Trace(); |
|
246
|
|
|
|
|
569
|
|
|
246
|
|
|
|
|
5259
|
|
13
|
246
|
|
|
246
|
|
1525
|
use Test2::API(); |
|
246
|
|
|
|
|
665
|
|
|
246
|
|
|
|
|
26618
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
# Preload some key event types |
16
|
|
|
|
|
|
|
my %LOADED = ( |
17
|
|
|
|
|
|
|
map { |
18
|
|
|
|
|
|
|
my $pkg = "Test2::Event::$_"; |
19
|
|
|
|
|
|
|
my $file = "Test2/Event/$_.pm"; |
20
|
|
|
|
|
|
|
require $file unless $INC{$file}; |
21
|
|
|
|
|
|
|
( $pkg => $pkg, $_ => $pkg ) |
22
|
|
|
|
|
|
|
} qw/Ok Diag Note Plan Bail Exception Waiting Skip Subtest Pass Fail V2/ |
23
|
|
|
|
|
|
|
); |
24
|
|
|
|
|
|
|
|
25
|
246
|
|
|
246
|
|
1979
|
use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; |
|
246
|
|
|
|
|
645
|
|
|
246
|
|
|
|
|
20373
|
|
26
|
246
|
|
|
|
|
2050
|
use Test2::Util::HashBase qw{ |
27
|
|
|
|
|
|
|
stack hub trace _on_release _depth _is_canon _is_spawn _aborted |
28
|
|
|
|
|
|
|
errno eval_error child_error thrown |
29
|
246
|
|
|
246
|
|
2006
|
}; |
|
246
|
|
|
|
|
652
|
|
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
# Private, not package vars |
32
|
|
|
|
|
|
|
# It is safe to cache these. |
33
|
|
|
|
|
|
|
my $ON_RELEASE = Test2::API::_context_release_callbacks_ref(); |
34
|
|
|
|
|
|
|
my $CONTEXTS = Test2::API::_contexts_ref(); |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
sub init { |
37
|
465
|
|
|
465
|
0
|
1045
|
my $self = shift; |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
confess "The 'trace' attribute is required" |
40
|
465
|
100
|
|
|
|
1984
|
unless $self->{+TRACE}; |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
confess "The 'hub' attribute is required" |
43
|
464
|
100
|
|
|
|
1648
|
unless $self->{+HUB}; |
44
|
|
|
|
|
|
|
|
45
|
463
|
100
|
|
|
|
1864
|
$self->{+_DEPTH} = 0 unless defined $self->{+_DEPTH}; |
46
|
|
|
|
|
|
|
|
47
|
463
|
50
|
|
|
|
5351
|
$self->{+ERRNO} = $! unless exists $self->{+ERRNO}; |
48
|
463
|
50
|
|
|
|
2255
|
$self->{+EVAL_ERROR} = $@ unless exists $self->{+EVAL_ERROR}; |
49
|
463
|
50
|
|
|
|
2383
|
$self->{+CHILD_ERROR} = $? unless exists $self->{+CHILD_ERROR}; |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
245
|
|
|
245
|
1
|
465
|
sub snapshot { bless {%{$_[0]}, _is_canon => undef, _is_spawn => undef, _aborted => undef}, __PACKAGE__ } |
|
245
|
|
|
|
|
2429
|
|
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
sub restore_error_vars { |
55
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
56
|
0
|
|
|
|
|
0
|
($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub DESTROY { |
60
|
14071
|
100
|
100
|
14071
|
|
152013
|
return unless $_[0]->{+_IS_CANON} || $_[0]->{+_IS_SPAWN}; |
61
|
98
|
100
|
66
|
|
|
498
|
return if $_[0]->{+_ABORTED} && ${$_[0]->{+_ABORTED}}; |
|
98
|
|
|
|
|
7722
|
|
62
|
16
|
|
|
|
|
61
|
my ($self) = @_; |
63
|
|
|
|
|
|
|
|
64
|
16
|
|
|
|
|
78
|
my $hub = $self->{+HUB}; |
65
|
16
|
|
|
|
|
73
|
my $hid = $hub->{hid}; |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
# Do not show the warning if it looks like an exception has been thrown, or |
68
|
|
|
|
|
|
|
# if the context is not local to this process or thread. |
69
|
|
|
|
|
|
|
{ |
70
|
|
|
|
|
|
|
# Sometimes $@ is uninitialized, not a problem in this case so do not |
71
|
|
|
|
|
|
|
# show the warning about using eq. |
72
|
246
|
|
|
246
|
|
2118
|
no warnings 'uninitialized'; |
|
246
|
|
|
|
|
679
|
|
|
246
|
|
|
|
|
655790
|
|
|
16
|
|
|
|
|
40
|
|
73
|
16
|
100
|
100
|
|
|
161
|
if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) { |
74
|
5
|
|
|
|
|
32
|
require Carp; |
75
|
5
|
|
|
|
|
515
|
my $mess = Carp::longmess("Context destroyed"); |
76
|
5
|
|
66
|
|
|
631
|
my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame; |
77
|
5
|
|
|
|
|
102
|
warn <<" EOT"; |
78
|
|
|
|
|
|
|
A context appears to have been destroyed without first calling release(). |
79
|
|
|
|
|
|
|
Based on \$@ it does not look like an exception was thrown (this is not always |
80
|
|
|
|
|
|
|
a reliable test) |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
This is a problem because the global error variables (\$!, \$@, and \$?) will |
83
|
|
|
|
|
|
|
not be restored. In addition some release callbacks will not work properly from |
84
|
|
|
|
|
|
|
inside a DESTROY method. |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
Here are the context creation details, just in case a tool forgot to call |
87
|
|
|
|
|
|
|
release(): |
88
|
|
|
|
|
|
|
File: $frame->[1] |
89
|
|
|
|
|
|
|
Line: $frame->[2] |
90
|
|
|
|
|
|
|
Tool: $frame->[3] |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
Here is a trace to the code that caused the context to be destroyed, this could |
93
|
|
|
|
|
|
|
be an exit(), a goto, or simply the end of a scope: |
94
|
|
|
|
|
|
|
$mess |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
Cleaning up the CONTEXT stack... |
97
|
|
|
|
|
|
|
EOT |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
} |
100
|
|
|
|
|
|
|
|
101
|
16
|
100
|
|
|
|
240
|
return if $self->{+_IS_SPAWN}; |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
# Remove the key itself to avoid a slow memory leak |
104
|
10
|
|
|
|
|
89
|
delete $CONTEXTS->{$hid}; |
105
|
10
|
|
|
|
|
49
|
$self->{+_IS_CANON} = undef; |
106
|
|
|
|
|
|
|
|
107
|
10
|
50
|
|
|
|
67
|
if (my $cbk = $self->{+_ON_RELEASE}) { |
108
|
0
|
|
|
|
|
0
|
$_->($self) for reverse @$cbk; |
109
|
|
|
|
|
|
|
} |
110
|
10
|
100
|
|
|
|
49
|
if (my $hcbk = $hub->{_context_release}) { |
111
|
2
|
|
|
|
|
8
|
$_->($self) for reverse @$hcbk; |
112
|
|
|
|
|
|
|
} |
113
|
10
|
|
|
|
|
1182
|
$_->($self) for reverse @$ON_RELEASE; |
114
|
|
|
|
|
|
|
} |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
# release exists to implement behaviors like die-on-fail. In die-on-fail you |
117
|
|
|
|
|
|
|
# want to die after a failure, but only after diagnostics have been reported. |
118
|
|
|
|
|
|
|
# The ideal time for the die to happen is when the context is released. |
119
|
|
|
|
|
|
|
# Unfortunately die does not work in a DESTROY block. |
120
|
|
|
|
|
|
|
sub release { |
121
|
13297
|
|
|
13297
|
1
|
25581
|
my ($self) = @_; |
122
|
|
|
|
|
|
|
|
123
|
13297
|
100
|
50
|
|
|
28678
|
($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return if $self->{+THROWN}; |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return $self->{+_IS_SPAWN} = undef |
126
|
13270
|
100
|
50
|
|
|
50193
|
if $self->{+_IS_SPAWN}; |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
croak "release() should not be called on context that is neither canon nor a child" |
129
|
8283
|
100
|
|
|
|
17410
|
unless $self->{+_IS_CANON}; |
130
|
|
|
|
|
|
|
|
131
|
8282
|
|
|
|
|
13176
|
my $hub = $self->{+HUB}; |
132
|
8282
|
|
|
|
|
13685
|
my $hid = $hub->{hid}; |
133
|
|
|
|
|
|
|
|
134
|
|
|
|
|
|
|
croak "context thinks it is canon, but it is not" |
135
|
8282
|
50
|
33
|
|
|
37912
|
unless $CONTEXTS->{$hid} && $CONTEXTS->{$hid} == $self; |
136
|
|
|
|
|
|
|
|
137
|
|
|
|
|
|
|
# Remove the key itself to avoid a slow memory leak |
138
|
8282
|
|
|
|
|
15445
|
$self->{+_IS_CANON} = undef; |
139
|
8282
|
|
|
|
|
21463
|
delete $CONTEXTS->{$hid}; |
140
|
|
|
|
|
|
|
|
141
|
8282
|
100
|
|
|
|
18261
|
if (my $cbk = $self->{+_ON_RELEASE}) { |
142
|
2
|
|
|
|
|
5
|
$_->($self) for reverse @$cbk; |
143
|
|
|
|
|
|
|
} |
144
|
8282
|
100
|
|
|
|
17292
|
if (my $hcbk = $hub->{_context_release}) { |
145
|
47
|
|
|
|
|
116
|
$_->($self) for reverse @$hcbk; |
146
|
|
|
|
|
|
|
} |
147
|
8282
|
|
|
|
|
18238
|
$_->($self) for reverse @$ON_RELEASE; |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
# Do this last so that nothing else changes them. |
150
|
|
|
|
|
|
|
# If one of the hooks dies then these do not get restored, this is |
151
|
|
|
|
|
|
|
# intentional |
152
|
8282
|
|
|
|
|
31024
|
($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR}; |
153
|
|
|
|
|
|
|
|
154
|
8282
|
|
|
|
|
19867
|
return; |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
sub do_in_context { |
158
|
7
|
|
|
7
|
1
|
20
|
my $self = shift; |
159
|
7
|
|
|
|
|
24
|
my ($sub, @args) = @_; |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# We need to update the pid/tid and error vars. |
162
|
7
|
|
|
|
|
20
|
my $clone = $self->snapshot; |
163
|
7
|
|
|
|
|
33
|
@$clone{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} = ($!, $@, $?); |
164
|
7
|
|
|
|
|
32
|
$clone->{+TRACE} = $clone->{+TRACE}->snapshot(pid => $$, tid => get_tid()); |
165
|
|
|
|
|
|
|
|
166
|
7
|
|
|
|
|
18
|
my $hub = $clone->{+HUB}; |
167
|
7
|
|
|
|
|
27
|
my $hid = $hub->hid; |
168
|
|
|
|
|
|
|
|
169
|
7
|
|
|
|
|
65
|
my $old = $CONTEXTS->{$hid}; |
170
|
|
|
|
|
|
|
|
171
|
7
|
|
|
|
|
14
|
$clone->{+_IS_CANON} = 1; |
172
|
7
|
|
|
|
|
30
|
$CONTEXTS->{$hid} = $clone; |
173
|
7
|
|
|
|
|
33
|
weaken($CONTEXTS->{$hid}); |
174
|
7
|
|
|
|
|
29
|
my ($ok, $err) = &try($sub, @args); |
175
|
7
|
|
|
7
|
|
39
|
my ($rok, $rerr) = try { $clone->release }; |
|
7
|
|
|
|
|
16
|
|
176
|
7
|
|
|
|
|
30
|
delete $clone->{+_IS_CANON}; |
177
|
|
|
|
|
|
|
|
178
|
7
|
100
|
|
|
|
16
|
if ($old) { |
179
|
1
|
|
|
|
|
3
|
$CONTEXTS->{$hid} = $old; |
180
|
1
|
|
|
|
|
5
|
weaken($CONTEXTS->{$hid}); |
181
|
|
|
|
|
|
|
} |
182
|
|
|
|
|
|
|
else { |
183
|
6
|
|
|
|
|
18
|
delete $CONTEXTS->{$hid}; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
7
|
100
|
|
|
|
21
|
die $err unless $ok; |
187
|
6
|
50
|
|
|
|
29
|
die $rerr unless $rok; |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
sub done_testing { |
191
|
83
|
|
|
83
|
1
|
252
|
my $self = shift; |
192
|
83
|
|
|
|
|
476
|
$self->hub->finalize($self->trace, 1); |
193
|
83
|
|
|
|
|
270
|
return; |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
sub throw { |
197
|
23
|
|
|
23
|
1
|
79
|
my ($self, $msg) = @_; |
198
|
23
|
|
|
|
|
65
|
$self->{+THROWN} = 1; |
199
|
23
|
50
|
|
|
|
90
|
${$self->{+_ABORTED}}++ if $self->{+_ABORTED}; |
|
23
|
|
|
|
|
61
|
|
200
|
23
|
50
|
66
|
|
|
140
|
$self->release if $self->{+_IS_CANON} || $self->{+_IS_SPAWN}; |
201
|
23
|
|
|
|
|
90
|
$self->trace->throw($msg); |
202
|
|
|
|
|
|
|
} |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
sub alert { |
205
|
3
|
|
|
3
|
1
|
14
|
my ($self, $msg) = @_; |
206
|
3
|
|
|
|
|
12
|
$self->trace->alert($msg); |
207
|
|
|
|
|
|
|
} |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
sub send_ev2_and_release { |
210
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
211
|
0
|
|
|
|
|
0
|
my $out = $self->send_ev2(@_); |
212
|
0
|
|
|
|
|
0
|
$self->release; |
213
|
0
|
|
|
|
|
0
|
return $out; |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
sub send_ev2 { |
217
|
214
|
|
|
214
|
1
|
705
|
my $self = shift; |
218
|
|
|
|
|
|
|
|
219
|
214
|
|
|
|
|
1042
|
my $e; |
220
|
|
|
|
|
|
|
{ |
221
|
214
|
|
|
|
|
645
|
local $Carp::CarpLevel = $Carp::CarpLevel + 1; |
|
214
|
|
|
|
|
1170
|
|
222
|
|
|
|
|
|
|
$e = Test2::Event::V2->new( |
223
|
214
|
|
|
|
|
1837
|
trace => $self->{+TRACE}->snapshot, |
224
|
|
|
|
|
|
|
@_, |
225
|
|
|
|
|
|
|
); |
226
|
|
|
|
|
|
|
} |
227
|
|
|
|
|
|
|
|
228
|
214
|
100
|
|
|
|
1453
|
if ($self->{+_ABORTED}) { |
229
|
3
|
|
|
|
|
12
|
my $f = $e->facet_data; |
230
|
3
|
50
|
33
|
|
|
41
|
${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate); |
|
0
|
|
33
|
|
|
0
|
|
231
|
|
|
|
|
|
|
} |
232
|
214
|
|
|
|
|
1581
|
$self->{+HUB}->send($e); |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
sub build_ev2 { |
236
|
3
|
|
|
3
|
0
|
21
|
my $self = shift; |
237
|
|
|
|
|
|
|
|
238
|
3
|
|
|
|
|
5
|
local $Carp::CarpLevel = $Carp::CarpLevel + 1; |
239
|
|
|
|
|
|
|
Test2::Event::V2->new( |
240
|
3
|
|
|
|
|
11
|
trace => $self->{+TRACE}->snapshot, |
241
|
|
|
|
|
|
|
@_, |
242
|
|
|
|
|
|
|
); |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
|
245
|
|
|
|
|
|
|
sub send_event_and_release { |
246
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
247
|
0
|
|
|
|
|
0
|
my $out = $self->send_event(@_); |
248
|
0
|
|
|
|
|
0
|
$self->release; |
249
|
0
|
|
|
|
|
0
|
return $out; |
250
|
|
|
|
|
|
|
} |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
sub send_event { |
253
|
1239
|
|
|
1239
|
1
|
2198
|
my $self = shift; |
254
|
1239
|
|
|
|
|
1996
|
my $event = shift; |
255
|
1239
|
|
|
|
|
3476
|
my %args = @_; |
256
|
|
|
|
|
|
|
|
257
|
1239
|
|
66
|
|
|
4060
|
my $pkg = $LOADED{$event} || $self->_parse_event($event); |
258
|
|
|
|
|
|
|
|
259
|
1239
|
|
|
|
|
1993
|
my $e; |
260
|
|
|
|
|
|
|
{ |
261
|
1239
|
|
|
|
|
2175
|
local $Carp::CarpLevel = $Carp::CarpLevel + 1; |
|
1239
|
|
|
|
|
2345
|
|
262
|
|
|
|
|
|
|
$e = $pkg->new( |
263
|
1239
|
|
|
|
|
5044
|
trace => $self->{+TRACE}->snapshot, |
264
|
|
|
|
|
|
|
%args, |
265
|
|
|
|
|
|
|
); |
266
|
|
|
|
|
|
|
} |
267
|
|
|
|
|
|
|
|
268
|
1239
|
100
|
|
|
|
3506
|
if ($self->{+_ABORTED}) { |
269
|
1138
|
|
|
|
|
3584
|
my $f = $e->facet_data; |
270
|
1138
|
100
|
100
|
|
|
7543
|
${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate); |
|
29
|
|
66
|
|
|
187
|
|
271
|
|
|
|
|
|
|
} |
272
|
1239
|
|
|
|
|
4868
|
$self->{+HUB}->send($e); |
273
|
|
|
|
|
|
|
} |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
sub build_event { |
276
|
121
|
|
|
121
|
1
|
245
|
my $self = shift; |
277
|
121
|
|
|
|
|
209
|
my $event = shift; |
278
|
121
|
|
|
|
|
632
|
my %args = @_; |
279
|
|
|
|
|
|
|
|
280
|
121
|
|
33
|
|
|
493
|
my $pkg = $LOADED{$event} || $self->_parse_event($event); |
281
|
|
|
|
|
|
|
|
282
|
121
|
|
|
|
|
364
|
local $Carp::CarpLevel = $Carp::CarpLevel + 1; |
283
|
|
|
|
|
|
|
$pkg->new( |
284
|
121
|
|
|
|
|
503
|
trace => $self->{+TRACE}->snapshot, |
285
|
|
|
|
|
|
|
%args, |
286
|
|
|
|
|
|
|
); |
287
|
|
|
|
|
|
|
} |
288
|
|
|
|
|
|
|
|
289
|
|
|
|
|
|
|
sub pass { |
290
|
2
|
|
|
2
|
1
|
12
|
my $self = shift; |
291
|
2
|
|
|
|
|
4
|
my ($name) = @_; |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
my $e = bless( |
294
|
|
|
|
|
|
|
{ |
295
|
2
|
|
|
|
|
4
|
trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), |
|
2
|
|
|
|
|
31
|
|
296
|
|
|
|
|
|
|
name => $name, |
297
|
|
|
|
|
|
|
}, |
298
|
|
|
|
|
|
|
"Test2::Event::Pass" |
299
|
|
|
|
|
|
|
); |
300
|
|
|
|
|
|
|
|
301
|
2
|
|
|
|
|
11
|
$self->{+HUB}->send($e); |
302
|
2
|
|
|
|
|
5
|
return $e; |
303
|
|
|
|
|
|
|
} |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
sub pass_and_release { |
306
|
1905
|
|
|
1905
|
1
|
3632
|
my $self = shift; |
307
|
1905
|
|
|
|
|
3849
|
my ($name) = @_; |
308
|
|
|
|
|
|
|
|
309
|
|
|
|
|
|
|
my $e = bless( |
310
|
|
|
|
|
|
|
{ |
311
|
1905
|
|
|
|
|
2979
|
trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), |
|
1905
|
|
|
|
|
19719
|
|
312
|
|
|
|
|
|
|
name => $name, |
313
|
|
|
|
|
|
|
}, |
314
|
|
|
|
|
|
|
"Test2::Event::Pass" |
315
|
|
|
|
|
|
|
); |
316
|
|
|
|
|
|
|
|
317
|
1905
|
|
|
|
|
9023
|
$self->{+HUB}->send($e); |
318
|
1905
|
|
|
|
|
6655
|
$self->release; |
319
|
1905
|
|
|
|
|
14878
|
return 1; |
320
|
|
|
|
|
|
|
} |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
sub fail { |
323
|
2
|
|
|
2
|
1
|
12
|
my $self = shift; |
324
|
2
|
|
|
|
|
7
|
my ($name, @diag) = @_; |
325
|
|
|
|
|
|
|
|
326
|
|
|
|
|
|
|
my $e = bless( |
327
|
|
|
|
|
|
|
{ |
328
|
2
|
|
|
|
|
5
|
trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), |
|
2
|
|
|
|
|
23
|
|
329
|
|
|
|
|
|
|
name => $name, |
330
|
|
|
|
|
|
|
}, |
331
|
|
|
|
|
|
|
"Test2::Event::Fail" |
332
|
|
|
|
|
|
|
); |
333
|
|
|
|
|
|
|
|
334
|
2
|
|
|
|
|
9
|
for my $msg (@diag) { |
335
|
2
|
100
|
|
|
|
8
|
if (ref($msg) eq 'Test2::EventFacet::Info::Table') { |
336
|
1
|
|
|
|
|
5
|
$e->add_info({tag => 'DIAG', debug => 1, $msg->info_args}); |
337
|
|
|
|
|
|
|
} |
338
|
|
|
|
|
|
|
else { |
339
|
1
|
|
|
|
|
11
|
$e->add_info({tag => 'DIAG', debug => 1, details => $msg}); |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
} |
342
|
|
|
|
|
|
|
|
343
|
2
|
|
|
|
|
12
|
$self->{+HUB}->send($e); |
344
|
2
|
|
|
|
|
6
|
return $e; |
345
|
|
|
|
|
|
|
} |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
sub fail_and_release { |
348
|
27
|
|
|
27
|
1
|
73
|
my $self = shift; |
349
|
27
|
|
|
|
|
72
|
my ($name, @diag) = @_; |
350
|
|
|
|
|
|
|
|
351
|
|
|
|
|
|
|
my $e = bless( |
352
|
|
|
|
|
|
|
{ |
353
|
27
|
|
|
|
|
59
|
trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), |
|
27
|
|
|
|
|
270
|
|
354
|
|
|
|
|
|
|
name => $name, |
355
|
|
|
|
|
|
|
}, |
356
|
|
|
|
|
|
|
"Test2::Event::Fail" |
357
|
|
|
|
|
|
|
); |
358
|
|
|
|
|
|
|
|
359
|
27
|
|
|
|
|
87
|
for my $msg (@diag) { |
360
|
21
|
100
|
|
|
|
63
|
if (ref($msg) eq 'Test2::EventFacet::Info::Table') { |
361
|
1
|
|
|
|
|
5
|
$e->add_info({tag => 'DIAG', debug => 1, $msg->info_args}); |
362
|
|
|
|
|
|
|
} |
363
|
|
|
|
|
|
|
else { |
364
|
20
|
|
|
|
|
91
|
$e->add_info({tag => 'DIAG', debug => 1, details => $msg}); |
365
|
|
|
|
|
|
|
} |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
|
368
|
27
|
|
|
|
|
114
|
$self->{+HUB}->send($e); |
369
|
27
|
|
|
|
|
97
|
$self->release; |
370
|
27
|
|
|
|
|
158
|
return 0; |
371
|
|
|
|
|
|
|
} |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
sub ok { |
374
|
27
|
|
|
27
|
1
|
338
|
my $self = shift; |
375
|
27
|
|
|
|
|
125
|
my ($pass, $name, $on_fail) = @_; |
376
|
|
|
|
|
|
|
|
377
|
27
|
|
|
|
|
146
|
my $hub = $self->{+HUB}; |
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
my $e = bless { |
380
|
27
|
|
|
|
|
90
|
trace => bless( {%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'), |
|
27
|
|
|
|
|
465
|
|
381
|
|
|
|
|
|
|
pass => $pass, |
382
|
|
|
|
|
|
|
name => $name, |
383
|
|
|
|
|
|
|
}, 'Test2::Event::Ok'; |
384
|
27
|
|
|
|
|
303
|
$e->init; |
385
|
|
|
|
|
|
|
|
386
|
27
|
|
|
|
|
312
|
$hub->send($e); |
387
|
27
|
100
|
|
|
|
284
|
return $e if $pass; |
388
|
|
|
|
|
|
|
|
389
|
6
|
|
|
|
|
41
|
$self->failure_diag($e); |
390
|
|
|
|
|
|
|
|
391
|
6
|
100
|
100
|
|
|
35
|
if ($on_fail && @$on_fail) { |
392
|
1
|
|
|
|
|
6
|
$self->diag($_) for @$on_fail; |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
|
395
|
6
|
|
|
|
|
32
|
return $e; |
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
sub failure_diag { |
399
|
18
|
|
|
18
|
0
|
37
|
my $self = shift; |
400
|
18
|
|
|
|
|
42
|
my ($e) = @_; |
401
|
|
|
|
|
|
|
|
402
|
|
|
|
|
|
|
# Figure out the debug info, this is typically the file name and line |
403
|
|
|
|
|
|
|
# number, but can also be a custom message. If no trace object is provided |
404
|
|
|
|
|
|
|
# then we have nothing useful to display. |
405
|
18
|
|
|
|
|
60
|
my $name = $e->name; |
406
|
18
|
|
|
|
|
51
|
my $trace = $e->trace; |
407
|
18
|
50
|
|
|
|
86
|
my $debug = $trace ? $trace->debug : "[No trace info available]"; |
408
|
|
|
|
|
|
|
|
409
|
|
|
|
|
|
|
# Create the initial diagnostics. If the test has a name we put the debug |
410
|
|
|
|
|
|
|
# info on a second line, this behavior is inherited from Test::Builder. |
411
|
18
|
100
|
|
|
|
146
|
my $msg = defined($name) |
412
|
|
|
|
|
|
|
? qq[Failed test '$name'\n$debug.\n] |
413
|
|
|
|
|
|
|
: qq[Failed test $debug.\n]; |
414
|
|
|
|
|
|
|
|
415
|
18
|
|
|
|
|
62
|
$self->diag($msg); |
416
|
|
|
|
|
|
|
} |
417
|
|
|
|
|
|
|
|
418
|
|
|
|
|
|
|
sub skip { |
419
|
19
|
|
|
19
|
1
|
44
|
my $self = shift; |
420
|
19
|
|
|
|
|
55
|
my ($name, $reason, @extra) = @_; |
421
|
19
|
|
|
|
|
74
|
$self->send_event( |
422
|
|
|
|
|
|
|
'Skip', |
423
|
|
|
|
|
|
|
name => $name, |
424
|
|
|
|
|
|
|
reason => $reason, |
425
|
|
|
|
|
|
|
pass => 1, |
426
|
|
|
|
|
|
|
@extra, |
427
|
|
|
|
|
|
|
); |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
sub note { |
431
|
198
|
|
|
198
|
1
|
433
|
my $self = shift; |
432
|
198
|
|
|
|
|
464
|
my ($message) = @_; |
433
|
198
|
|
|
|
|
597
|
$self->send_event('Note', message => $message); |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
sub diag { |
437
|
775
|
|
|
775
|
1
|
1329
|
my $self = shift; |
438
|
775
|
|
|
|
|
1530
|
my ($message) = @_; |
439
|
775
|
|
|
|
|
1395
|
my $hub = $self->{+HUB}; |
440
|
775
|
|
|
|
|
2171
|
$self->send_event( |
441
|
|
|
|
|
|
|
'Diag', |
442
|
|
|
|
|
|
|
message => $message, |
443
|
|
|
|
|
|
|
); |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
|
446
|
|
|
|
|
|
|
sub plan { |
447
|
228
|
|
|
228
|
1
|
915
|
my ($self, $max, $directive, $reason) = @_; |
448
|
228
|
|
|
|
|
1113
|
$self->send_event('Plan', max => $max, directive => $directive, reason => $reason); |
449
|
|
|
|
|
|
|
} |
450
|
|
|
|
|
|
|
|
451
|
|
|
|
|
|
|
sub bail { |
452
|
8
|
|
|
8
|
1
|
36
|
my ($self, $reason) = @_; |
453
|
8
|
|
|
|
|
33
|
$self->send_event('Bail', reason => $reason); |
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
|
456
|
|
|
|
|
|
|
sub _parse_event { |
457
|
5
|
|
|
5
|
|
19
|
my $self = shift; |
458
|
5
|
|
|
|
|
10
|
my $event = shift; |
459
|
|
|
|
|
|
|
|
460
|
5
|
|
|
|
|
8
|
my $pkg; |
461
|
5
|
100
|
|
|
|
30
|
if ($event =~ m/^\+(.*)/) { |
462
|
3
|
|
|
|
|
10
|
$pkg = $1; |
463
|
|
|
|
|
|
|
} |
464
|
|
|
|
|
|
|
else { |
465
|
2
|
|
|
|
|
6
|
$pkg = "Test2::Event::$event"; |
466
|
|
|
|
|
|
|
} |
467
|
|
|
|
|
|
|
|
468
|
5
|
100
|
|
|
|
18
|
unless ($LOADED{$pkg}) { |
469
|
3
|
|
|
|
|
22
|
my $file = pkg_to_file($pkg); |
470
|
3
|
|
|
3
|
|
21
|
my ($ok, $err) = try { require $file }; |
|
3
|
|
|
|
|
948
|
|
471
|
3
|
100
|
|
|
|
35
|
$self->throw("Could not load event module '$pkg': $err") |
472
|
|
|
|
|
|
|
unless $ok; |
473
|
|
|
|
|
|
|
|
474
|
2
|
|
|
|
|
7
|
$LOADED{$pkg} = $pkg; |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
|
477
|
4
|
50
|
|
|
|
45
|
confess "'$pkg' is not a subclass of 'Test2::Event'" |
478
|
|
|
|
|
|
|
unless $pkg->isa('Test2::Event'); |
479
|
|
|
|
|
|
|
|
480
|
4
|
|
|
|
|
14
|
$LOADED{$event} = $pkg; |
481
|
|
|
|
|
|
|
|
482
|
4
|
|
|
|
|
18
|
return $pkg; |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
1; |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
__END__ |
488
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
=pod |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
=encoding UTF-8 |
492
|
|
|
|
|
|
|
|
493
|
|
|
|
|
|
|
=head1 NAME |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
Test2::API::Context - Object to represent a testing context. |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
=head1 DESCRIPTION |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
The context object is the primary interface for authors of testing tools |
500
|
|
|
|
|
|
|
written with L<Test2>. The context object represents the context in |
501
|
|
|
|
|
|
|
which a test takes place (File and Line Number), and provides a quick way to |
502
|
|
|
|
|
|
|
generate events from that context. The context object also takes care of |
503
|
|
|
|
|
|
|
sending events to the correct L<Test2::Hub> instance. |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
=head1 SYNOPSIS |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
In general you will not be creating contexts directly. To obtain a context you |
508
|
|
|
|
|
|
|
should always use C<context()> which is exported by the L<Test2::API> module. |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
use Test2::API qw/context/; |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
sub my_ok { |
513
|
|
|
|
|
|
|
my ($bool, $name) = @_; |
514
|
|
|
|
|
|
|
my $ctx = context(); |
515
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
if ($bool) { |
517
|
|
|
|
|
|
|
$ctx->pass($name); |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
else { |
520
|
|
|
|
|
|
|
$ctx->fail($name); |
521
|
|
|
|
|
|
|
} |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
$ctx->release; # You MUST do this! |
524
|
|
|
|
|
|
|
return $bool; |
525
|
|
|
|
|
|
|
} |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
Context objects make it easy to wrap other tools that also use context. Once |
528
|
|
|
|
|
|
|
you grab a context, any tool you call before releasing your context will |
529
|
|
|
|
|
|
|
inherit it: |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
sub wrapper { |
532
|
|
|
|
|
|
|
my ($bool, $name) = @_; |
533
|
|
|
|
|
|
|
my $ctx = context(); |
534
|
|
|
|
|
|
|
$ctx->diag("wrapping my_ok"); |
535
|
|
|
|
|
|
|
|
536
|
|
|
|
|
|
|
my $out = my_ok($bool, $name); |
537
|
|
|
|
|
|
|
$ctx->release; # You MUST do this! |
538
|
|
|
|
|
|
|
return $out; |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
=head1 CRITICAL DETAILS |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
=over 4 |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
=item you MUST always use the context() sub from Test2::API |
546
|
|
|
|
|
|
|
|
547
|
|
|
|
|
|
|
Creating your own context via C<< Test2::API::Context->new() >> will almost never |
548
|
|
|
|
|
|
|
produce a desirable result. Use C<context()> which is exported by L<Test2::API>. |
549
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
There are a handful of cases where a tool author may want to create a new |
551
|
|
|
|
|
|
|
context by hand, which is why the C<new> method exists. Unless you really know |
552
|
|
|
|
|
|
|
what you are doing you should avoid this. |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
=item You MUST always release the context when done with it |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
Releasing the context tells the system you are done with it. This gives it a |
557
|
|
|
|
|
|
|
chance to run any necessary callbacks or cleanup tasks. If you forget to |
558
|
|
|
|
|
|
|
release the context it will try to detect the problem and warn you about it. |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
=item You MUST NOT pass context objects around |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
When you obtain a context object it is made specifically for your tool and any |
563
|
|
|
|
|
|
|
tools nested within. If you pass a context around you run the risk of polluting |
564
|
|
|
|
|
|
|
other tools with incorrect context information. |
565
|
|
|
|
|
|
|
|
566
|
|
|
|
|
|
|
If you are certain that you want a different tool to use the same context you |
567
|
|
|
|
|
|
|
may pass it a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of |
568
|
|
|
|
|
|
|
the context that is safe to pass around or store. |
569
|
|
|
|
|
|
|
|
570
|
|
|
|
|
|
|
=item You MUST NOT store or cache a context for later |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
As long as a context exists for a given hub, all tools that try to get a |
573
|
|
|
|
|
|
|
context will get the existing instance. If you try to store the context you |
574
|
|
|
|
|
|
|
will pollute other tools with incorrect context information. |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
If you are certain that you want to save the context for later, you can use a |
577
|
|
|
|
|
|
|
snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context |
578
|
|
|
|
|
|
|
that is safe to pass around or store. |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
C<context()> has some mechanisms to protect you if you do cause a context to |
581
|
|
|
|
|
|
|
persist beyond the scope in which it was obtained. In practice you should not |
582
|
|
|
|
|
|
|
rely on these protections, and they are fairly noisy with warnings. |
583
|
|
|
|
|
|
|
|
584
|
|
|
|
|
|
|
=item You SHOULD obtain your context as soon as possible in a given tool |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
You never know what tools you call from within your own tool will need a |
587
|
|
|
|
|
|
|
context. Obtaining the context early ensures that nested tools can find the |
588
|
|
|
|
|
|
|
context you want them to find. |
589
|
|
|
|
|
|
|
|
590
|
|
|
|
|
|
|
=back |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
=head1 METHODS |
593
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
=over 4 |
595
|
|
|
|
|
|
|
|
596
|
|
|
|
|
|
|
=item $ctx->done_testing; |
597
|
|
|
|
|
|
|
|
598
|
|
|
|
|
|
|
Note that testing is finished. If no plan has been set this will generate a |
599
|
|
|
|
|
|
|
Plan event. |
600
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
=item $clone = $ctx->snapshot() |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
This will return a shallow clone of the context. The shallow clone is safe to |
604
|
|
|
|
|
|
|
store for later. |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
=item $ctx->release() |
607
|
|
|
|
|
|
|
|
608
|
|
|
|
|
|
|
This will release the context. This runs cleanup tasks, and several important |
609
|
|
|
|
|
|
|
hooks. It will also restore C<$!>, C<$?>, and C<$@> to what they were when the |
610
|
|
|
|
|
|
|
context was created. |
611
|
|
|
|
|
|
|
|
612
|
|
|
|
|
|
|
B<Note:> If a context is acquired more than once an internal refcount is kept. |
613
|
|
|
|
|
|
|
C<release()> decrements the ref count, none of the other actions of |
614
|
|
|
|
|
|
|
C<release()> will occur unless the refcount hits 0. This means only the last |
615
|
|
|
|
|
|
|
call to C<release()> will reset C<$?>, C<$!>, C<$@>,and run the cleanup tasks. |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
=item $ctx->throw($message) |
618
|
|
|
|
|
|
|
|
619
|
|
|
|
|
|
|
This will throw an exception reporting to the file and line number of the |
620
|
|
|
|
|
|
|
context. This will also release the context for you. |
621
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
=item $ctx->alert($message) |
623
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
This will issue a warning from the file and line number of the context. |
625
|
|
|
|
|
|
|
|
626
|
|
|
|
|
|
|
=item $stack = $ctx->stack() |
627
|
|
|
|
|
|
|
|
628
|
|
|
|
|
|
|
This will return the L<Test2::API::Stack> instance the context used to find |
629
|
|
|
|
|
|
|
the current hub. |
630
|
|
|
|
|
|
|
|
631
|
|
|
|
|
|
|
=item $hub = $ctx->hub() |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
This will return the L<Test2::Hub> instance the context recognizes as the |
634
|
|
|
|
|
|
|
current one to which all events should be sent. |
635
|
|
|
|
|
|
|
|
636
|
|
|
|
|
|
|
=item $dbg = $ctx->trace() |
637
|
|
|
|
|
|
|
|
638
|
|
|
|
|
|
|
This will return the L<Test2::EventFacet::Trace> instance used by the context. |
639
|
|
|
|
|
|
|
|
640
|
|
|
|
|
|
|
=item $ctx->do_in_context(\&code, @args); |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
Sometimes you have a context that is not current, and you want things to use it |
643
|
|
|
|
|
|
|
as the current one. In these cases you can call |
644
|
|
|
|
|
|
|
C<< $ctx->do_in_context(sub { ... }) >>. The codeblock will be run, and |
645
|
|
|
|
|
|
|
anything inside of it that looks for a context will find the one on which the |
646
|
|
|
|
|
|
|
method was called. |
647
|
|
|
|
|
|
|
|
648
|
|
|
|
|
|
|
This B<DOES NOT> affect context on other hubs, only the hub used by the context |
649
|
|
|
|
|
|
|
will be affected. |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
my $ctx = ...; |
652
|
|
|
|
|
|
|
$ctx->do_in_context(sub { |
653
|
|
|
|
|
|
|
my $ctx = context(); # returns the $ctx the sub is called on |
654
|
|
|
|
|
|
|
}); |
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
B<Note:> The context will actually be cloned, the clone will be used instead of |
657
|
|
|
|
|
|
|
the original. This allows the thread id, process id, and error variables to be correct without |
658
|
|
|
|
|
|
|
modifying the original context. |
659
|
|
|
|
|
|
|
|
660
|
|
|
|
|
|
|
=item $ctx->restore_error_vars() |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
This will set C<$!>, C<$?>, and C<$@> to what they were when the context was |
663
|
|
|
|
|
|
|
created. There is no localization or anything done here, calling this method |
664
|
|
|
|
|
|
|
will actually set these vars. |
665
|
|
|
|
|
|
|
|
666
|
|
|
|
|
|
|
=item $! = $ctx->errno() |
667
|
|
|
|
|
|
|
|
668
|
|
|
|
|
|
|
The (numeric) value of C<$!> when the context was created. |
669
|
|
|
|
|
|
|
|
670
|
|
|
|
|
|
|
=item $? = $ctx->child_error() |
671
|
|
|
|
|
|
|
|
672
|
|
|
|
|
|
|
The value of C<$?> when the context was created. |
673
|
|
|
|
|
|
|
|
674
|
|
|
|
|
|
|
=item $@ = $ctx->eval_error() |
675
|
|
|
|
|
|
|
|
676
|
|
|
|
|
|
|
The value of C<$@> when the context was created. |
677
|
|
|
|
|
|
|
|
678
|
|
|
|
|
|
|
=back |
679
|
|
|
|
|
|
|
|
680
|
|
|
|
|
|
|
=head2 EVENT PRODUCTION METHODS |
681
|
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
B<Which one do I use?> |
683
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
The C<pass*> and C<fail*> are optimal if they meet your situation, using one of |
685
|
|
|
|
|
|
|
them will always be the most optimal. That said they are optimal by eliminating |
686
|
|
|
|
|
|
|
many features. |
687
|
|
|
|
|
|
|
|
688
|
|
|
|
|
|
|
Method such as C<ok>, and C<note> are shortcuts for generating common 1-task |
689
|
|
|
|
|
|
|
events based on the old API, however they are forward compatible, and easy to |
690
|
|
|
|
|
|
|
use. If these meet your needs then go ahead and use them, but please check back |
691
|
|
|
|
|
|
|
often for alternatives that may be added. |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
If you want to generate new style events, events that do many things at once, |
694
|
|
|
|
|
|
|
then you want the C<*ev2*> methods. These let you directly specify which facets |
695
|
|
|
|
|
|
|
you wish to use. |
696
|
|
|
|
|
|
|
|
697
|
|
|
|
|
|
|
=over 4 |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
=item $event = $ctx->pass() |
700
|
|
|
|
|
|
|
|
701
|
|
|
|
|
|
|
=item $event = $ctx->pass($name) |
702
|
|
|
|
|
|
|
|
703
|
|
|
|
|
|
|
This will send and return an L<Test2::Event::Pass> event. You may optionally |
704
|
|
|
|
|
|
|
provide a C<$name> for the assertion. |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
The L<Test2::Event::Pass> is a specially crafted and optimized event, using |
707
|
|
|
|
|
|
|
this will help the performance of passing tests. |
708
|
|
|
|
|
|
|
|
709
|
|
|
|
|
|
|
=item $true = $ctx->pass_and_release() |
710
|
|
|
|
|
|
|
|
711
|
|
|
|
|
|
|
=item $true = $ctx->pass_and_release($name) |
712
|
|
|
|
|
|
|
|
713
|
|
|
|
|
|
|
This is a combination of C<pass()> and C<release()>. You can use this if you do |
714
|
|
|
|
|
|
|
not plan to do anything with the context after sending the event. This helps |
715
|
|
|
|
|
|
|
write more clear and compact code. |
716
|
|
|
|
|
|
|
|
717
|
|
|
|
|
|
|
sub shorthand { |
718
|
|
|
|
|
|
|
my ($bool, $name) = @_; |
719
|
|
|
|
|
|
|
my $ctx = context(); |
720
|
|
|
|
|
|
|
return $ctx->pass_and_release($name) if $bool; |
721
|
|
|
|
|
|
|
|
722
|
|
|
|
|
|
|
... Handle a failure ... |
723
|
|
|
|
|
|
|
} |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
sub longform { |
726
|
|
|
|
|
|
|
my ($bool, $name) = @_; |
727
|
|
|
|
|
|
|
my $ctx = context(); |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
if ($bool) { |
730
|
|
|
|
|
|
|
$ctx->pass($name); |
731
|
|
|
|
|
|
|
$ctx->release; |
732
|
|
|
|
|
|
|
return 1; |
733
|
|
|
|
|
|
|
} |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
... Handle a failure ... |
736
|
|
|
|
|
|
|
} |
737
|
|
|
|
|
|
|
|
738
|
|
|
|
|
|
|
=item my $event = $ctx->fail() |
739
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
=item my $event = $ctx->fail($name) |
741
|
|
|
|
|
|
|
|
742
|
|
|
|
|
|
|
=item my $event = $ctx->fail($name, @diagnostics) |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
This lets you send an L<Test2::Event::Fail> event. You may optionally provide a |
745
|
|
|
|
|
|
|
C<$name> and C<@diagnostics> messages. |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
Diagnostics messages can be simple strings, data structures, or instances of |
748
|
|
|
|
|
|
|
L<Test2::EventFacet::Info::Table> (which are converted inline into the |
749
|
|
|
|
|
|
|
L<Test2::EventFacet::Info> structure). |
750
|
|
|
|
|
|
|
|
751
|
|
|
|
|
|
|
=item my $false = $ctx->fail_and_release() |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
=item my $false = $ctx->fail_and_release($name) |
754
|
|
|
|
|
|
|
|
755
|
|
|
|
|
|
|
=item my $false = $ctx->fail_and_release($name, @diagnostics) |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
This is a combination of C<fail()> and C<release()>. This can be used to write |
758
|
|
|
|
|
|
|
clearer and shorter code. |
759
|
|
|
|
|
|
|
|
760
|
|
|
|
|
|
|
sub shorthand { |
761
|
|
|
|
|
|
|
my ($bool, $name) = @_; |
762
|
|
|
|
|
|
|
my $ctx = context(); |
763
|
|
|
|
|
|
|
return $ctx->fail_and_release($name) unless $bool; |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
... Handle a success ... |
766
|
|
|
|
|
|
|
} |
767
|
|
|
|
|
|
|
|
768
|
|
|
|
|
|
|
sub longform { |
769
|
|
|
|
|
|
|
my ($bool, $name) = @_; |
770
|
|
|
|
|
|
|
my $ctx = context(); |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
unless ($bool) { |
773
|
|
|
|
|
|
|
$ctx->pass($name); |
774
|
|
|
|
|
|
|
$ctx->release; |
775
|
|
|
|
|
|
|
return 1; |
776
|
|
|
|
|
|
|
} |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
... Handle a success ... |
779
|
|
|
|
|
|
|
} |
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
=item $event = $ctx->ok($bool, $name) |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
=item $event = $ctx->ok($bool, $name, \@on_fail) |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
B<NOTE:> Use of this method is discouraged in favor of C<pass()> and C<fail()> |
787
|
|
|
|
|
|
|
which produce L<Test2::Event::Pass> and L<Test2::Event::Fail> events. These |
788
|
|
|
|
|
|
|
newer event types are faster and less crufty. |
789
|
|
|
|
|
|
|
|
790
|
|
|
|
|
|
|
This will create an L<Test2::Event::Ok> object for you. If C<$bool> is false |
791
|
|
|
|
|
|
|
then an L<Test2::Event::Diag> event will be sent as well with details about the |
792
|
|
|
|
|
|
|
failure. If you do not want automatic diagnostics you should use the |
793
|
|
|
|
|
|
|
C<send_event()> method directly. |
794
|
|
|
|
|
|
|
|
795
|
|
|
|
|
|
|
The third argument C<\@on_fail>) is an optional set of diagnostics to be sent in |
796
|
|
|
|
|
|
|
the event of a test failure. Unlike with C<fail()> these diagnostics must be |
797
|
|
|
|
|
|
|
plain strings, data structures are not supported. |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
=item $event = $ctx->note($message) |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
Send an L<Test2::Event::Note>. This event prints a message to STDOUT. |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
=item $event = $ctx->diag($message) |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
Send an L<Test2::Event::Diag>. This event prints a message to STDERR. |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
=item $event = $ctx->plan($max) |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
=item $event = $ctx->plan(0, 'SKIP', $reason) |
810
|
|
|
|
|
|
|
|
811
|
|
|
|
|
|
|
This can be used to send an L<Test2::Event::Plan> event. This event |
812
|
|
|
|
|
|
|
usually takes either a number of tests you expect to run. Optionally you can |
813
|
|
|
|
|
|
|
set the expected count to 0 and give the 'SKIP' directive with a reason to |
814
|
|
|
|
|
|
|
cause all tests to be skipped. |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
=item $event = $ctx->skip($name, $reason); |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
Send an L<Test2::Event::Skip> event. |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
=item $event = $ctx->bail($reason) |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
This sends an L<Test2::Event::Bail> event. This event will completely |
823
|
|
|
|
|
|
|
terminate all testing. |
824
|
|
|
|
|
|
|
|
825
|
|
|
|
|
|
|
=item $event = $ctx->send_ev2(%facets) |
826
|
|
|
|
|
|
|
|
827
|
|
|
|
|
|
|
This lets you build and send a V2 event directly from facets. The event is |
828
|
|
|
|
|
|
|
returned after it is sent. |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
This example sends a single assertion, a note (comment for stdout in |
831
|
|
|
|
|
|
|
Test::Builder talk) and sets the plan to 1. |
832
|
|
|
|
|
|
|
|
833
|
|
|
|
|
|
|
my $event = $ctx->send_event( |
834
|
|
|
|
|
|
|
plan => {count => 1}, |
835
|
|
|
|
|
|
|
assert => {pass => 1, details => "A passing assert"}, |
836
|
|
|
|
|
|
|
info => [{tag => 'NOTE', details => "This is a note"}], |
837
|
|
|
|
|
|
|
); |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
=item $event = $ctx->build_e2(%facets) |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
This is the same as C<send_ev2()>, except it builds and returns the event |
842
|
|
|
|
|
|
|
without sending it. |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
=item $event = $ctx->send_ev2_and_release($Type, %parameters) |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
This is a combination of C<send_ev2()> and C<release()>. |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
sub shorthand { |
849
|
|
|
|
|
|
|
my $ctx = context(); |
850
|
|
|
|
|
|
|
return $ctx->send_ev2_and_release(assert => {pass => 1, details => 'foo'}); |
851
|
|
|
|
|
|
|
} |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
sub longform { |
854
|
|
|
|
|
|
|
my $ctx = context(); |
855
|
|
|
|
|
|
|
my $event = $ctx->send_ev2(assert => {pass => 1, details => 'foo'}); |
856
|
|
|
|
|
|
|
$ctx->release; |
857
|
|
|
|
|
|
|
return $event; |
858
|
|
|
|
|
|
|
} |
859
|
|
|
|
|
|
|
|
860
|
|
|
|
|
|
|
=item $event = $ctx->send_event($Type, %parameters) |
861
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
B<It is better to use send_ev2() in new code.> |
863
|
|
|
|
|
|
|
|
864
|
|
|
|
|
|
|
This lets you build and send an event of any type. The C<$Type> argument should |
865
|
|
|
|
|
|
|
be the event package name with C<Test2::Event::> left off, or a fully |
866
|
|
|
|
|
|
|
qualified package name prefixed with a '+'. The event is returned after it is |
867
|
|
|
|
|
|
|
sent. |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
my $event = $ctx->send_event('Ok', ...); |
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
or |
872
|
|
|
|
|
|
|
|
873
|
|
|
|
|
|
|
my $event = $ctx->send_event('+Test2::Event::Ok', ...); |
874
|
|
|
|
|
|
|
|
875
|
|
|
|
|
|
|
=item $event = $ctx->build_event($Type, %parameters) |
876
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
B<It is better to use build_ev2() in new code.> |
878
|
|
|
|
|
|
|
|
879
|
|
|
|
|
|
|
This is the same as C<send_event()>, except it builds and returns the event |
880
|
|
|
|
|
|
|
without sending it. |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
=item $event = $ctx->send_event_and_release($Type, %parameters) |
883
|
|
|
|
|
|
|
|
884
|
|
|
|
|
|
|
B<It is better to use send_ev2_and_release() in new code.> |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
This is a combination of C<send_event()> and C<release()>. |
887
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
sub shorthand { |
889
|
|
|
|
|
|
|
my $ctx = context(); |
890
|
|
|
|
|
|
|
return $ctx->send_event_and_release(Pass => { name => 'foo' }); |
891
|
|
|
|
|
|
|
} |
892
|
|
|
|
|
|
|
|
893
|
|
|
|
|
|
|
sub longform { |
894
|
|
|
|
|
|
|
my $ctx = context(); |
895
|
|
|
|
|
|
|
my $event = $ctx->send_event(Pass => { name => 'foo' }); |
896
|
|
|
|
|
|
|
$ctx->release; |
897
|
|
|
|
|
|
|
return $event; |
898
|
|
|
|
|
|
|
} |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
=back |
901
|
|
|
|
|
|
|
|
902
|
|
|
|
|
|
|
=head1 HOOKS |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
There are 2 types of hooks, init hooks, and release hooks. As the names |
905
|
|
|
|
|
|
|
suggest, these hooks are triggered when contexts are created or released. |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
=head2 INIT HOOKS |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
These are called whenever a context is initialized. That means when a new |
910
|
|
|
|
|
|
|
instance is created. These hooks are B<NOT> called every time something |
911
|
|
|
|
|
|
|
requests a context, just when a new one is created. |
912
|
|
|
|
|
|
|
|
913
|
|
|
|
|
|
|
=head3 GLOBAL |
914
|
|
|
|
|
|
|
|
915
|
|
|
|
|
|
|
This is how you add a global init callback. Global callbacks happen for every |
916
|
|
|
|
|
|
|
context for any hub or stack. |
917
|
|
|
|
|
|
|
|
918
|
|
|
|
|
|
|
Test2::API::test2_add_callback_context_init(sub { |
919
|
|
|
|
|
|
|
my $ctx = shift; |
920
|
|
|
|
|
|
|
... |
921
|
|
|
|
|
|
|
}); |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
=head3 PER HUB |
924
|
|
|
|
|
|
|
|
925
|
|
|
|
|
|
|
This is how you add an init callback for all contexts created for a given hub. |
926
|
|
|
|
|
|
|
These callbacks will not run for other hubs. |
927
|
|
|
|
|
|
|
|
928
|
|
|
|
|
|
|
$hub->add_context_init(sub { |
929
|
|
|
|
|
|
|
my $ctx = shift; |
930
|
|
|
|
|
|
|
... |
931
|
|
|
|
|
|
|
}); |
932
|
|
|
|
|
|
|
|
933
|
|
|
|
|
|
|
=head3 PER CONTEXT |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
This is how you specify an init hook that will only run if your call to |
936
|
|
|
|
|
|
|
C<context()> generates a new context. The callback will be ignored if |
937
|
|
|
|
|
|
|
C<context()> is returning an existing context. |
938
|
|
|
|
|
|
|
|
939
|
|
|
|
|
|
|
my $ctx = context(on_init => sub { |
940
|
|
|
|
|
|
|
my $ctx = shift; |
941
|
|
|
|
|
|
|
... |
942
|
|
|
|
|
|
|
}); |
943
|
|
|
|
|
|
|
|
944
|
|
|
|
|
|
|
=head2 RELEASE HOOKS |
945
|
|
|
|
|
|
|
|
946
|
|
|
|
|
|
|
These are called whenever a context is released. That means when the last |
947
|
|
|
|
|
|
|
reference to the instance is about to be destroyed. These hooks are B<NOT> |
948
|
|
|
|
|
|
|
called every time C<< $ctx->release >> is called. |
949
|
|
|
|
|
|
|
|
950
|
|
|
|
|
|
|
=head3 GLOBAL |
951
|
|
|
|
|
|
|
|
952
|
|
|
|
|
|
|
This is how you add a global release callback. Global callbacks happen for every |
953
|
|
|
|
|
|
|
context for any hub or stack. |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
Test2::API::test2_add_callback_context_release(sub { |
956
|
|
|
|
|
|
|
my $ctx = shift; |
957
|
|
|
|
|
|
|
... |
958
|
|
|
|
|
|
|
}); |
959
|
|
|
|
|
|
|
|
960
|
|
|
|
|
|
|
=head3 PER HUB |
961
|
|
|
|
|
|
|
|
962
|
|
|
|
|
|
|
This is how you add a release callback for all contexts created for a given |
963
|
|
|
|
|
|
|
hub. These callbacks will not run for other hubs. |
964
|
|
|
|
|
|
|
|
965
|
|
|
|
|
|
|
$hub->add_context_release(sub { |
966
|
|
|
|
|
|
|
my $ctx = shift; |
967
|
|
|
|
|
|
|
... |
968
|
|
|
|
|
|
|
}); |
969
|
|
|
|
|
|
|
|
970
|
|
|
|
|
|
|
=head3 PER CONTEXT |
971
|
|
|
|
|
|
|
|
972
|
|
|
|
|
|
|
This is how you add release callbacks directly to a context. The callback will |
973
|
|
|
|
|
|
|
B<ALWAYS> be added to the context that gets returned, it does not matter if a |
974
|
|
|
|
|
|
|
new one is generated, or if an existing one is returned. |
975
|
|
|
|
|
|
|
|
976
|
|
|
|
|
|
|
my $ctx = context(on_release => sub { |
977
|
|
|
|
|
|
|
my $ctx = shift; |
978
|
|
|
|
|
|
|
... |
979
|
|
|
|
|
|
|
}); |
980
|
|
|
|
|
|
|
|
981
|
|
|
|
|
|
|
=head1 THIRD PARTY META-DATA |
982
|
|
|
|
|
|
|
|
983
|
|
|
|
|
|
|
This object consumes L<Test2::Util::ExternalMeta> which provides a consistent |
984
|
|
|
|
|
|
|
way for you to attach meta-data to instances of this class. This is useful for |
985
|
|
|
|
|
|
|
tools, plugins, and other extensions. |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
=head1 SOURCE |
988
|
|
|
|
|
|
|
|
989
|
|
|
|
|
|
|
The source code repository for Test2 can be found at |
990
|
|
|
|
|
|
|
F<http://github.com/Test-More/test-more/>. |
991
|
|
|
|
|
|
|
|
992
|
|
|
|
|
|
|
=head1 MAINTAINERS |
993
|
|
|
|
|
|
|
|
994
|
|
|
|
|
|
|
=over 4 |
995
|
|
|
|
|
|
|
|
996
|
|
|
|
|
|
|
=item Chad Granum E<lt>exodist@cpan.orgE<gt> |
997
|
|
|
|
|
|
|
|
998
|
|
|
|
|
|
|
=back |
999
|
|
|
|
|
|
|
|
1000
|
|
|
|
|
|
|
=head1 AUTHORS |
1001
|
|
|
|
|
|
|
|
1002
|
|
|
|
|
|
|
=over 4 |
1003
|
|
|
|
|
|
|
|
1004
|
|
|
|
|
|
|
=item Chad Granum E<lt>exodist@cpan.orgE<gt> |
1005
|
|
|
|
|
|
|
|
1006
|
|
|
|
|
|
|
=item Kent Fredric E<lt>kentnl@cpan.orgE<gt> |
1007
|
|
|
|
|
|
|
|
1008
|
|
|
|
|
|
|
=back |
1009
|
|
|
|
|
|
|
|
1010
|
|
|
|
|
|
|
=head1 COPYRIGHT |
1011
|
|
|
|
|
|
|
|
1012
|
|
|
|
|
|
|
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>. |
1013
|
|
|
|
|
|
|
|
1014
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or |
1015
|
|
|
|
|
|
|
modify it under the same terms as Perl itself. |
1016
|
|
|
|
|
|
|
|
1017
|
|
|
|
|
|
|
See F<http://dev.perl.org/licenses/> |
1018
|
|
|
|
|
|
|
|
1019
|
|
|
|
|
|
|
=cut |