Profile of Test2/API/Context.pm

← Index
NYTProf Performance Profile «line view»
For t/bug-md-11.t
Run on Fri Mar 8 13:27:24 2024
Reported on Fri Mar 8 13:30:23 2024

Filename | /home/micha/.plenv/versions/5.38.2/lib/perl5/site_perl/5.38.2/Test2/API/Context.pm
Statements | Executed 172 statements in 1.92ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
8 | 6 | 2 | 34µs | 34µs | Test2::API::Context::::releaseTest2::API::Context::release
1 | 1 | 1 | 30µs | 32µs | Test2::API::Context::::BEGIN@2Test2::API::Context::BEGIN@2
2 | 1 | 1 | 20µs | 20µs | Test2::API::Context::::initTest2::API::Context::init
10 | 10 | 3 | 16µs | 16µs | Test2::API::Context::::DESTROYTest2::API::Context::DESTROY
1 | 1 | 1 | 15µs | 116µs | Test2::API::Context::::send_ev2Test2::API::Context::send_ev2
1 | 1 | 1 | 5µs | 133µs | Test2::API::Context::::BEGIN@26Test2::API::Context::BEGIN@26
1 | 1 | 1 | 5µs | 18µs | Test2::API::Context::::BEGIN@72Test2::API::Context::BEGIN@72
1 | 1 | 1 | 5µs | 26µs | Test2::API::Context::::BEGIN@8Test2::API::Context::BEGIN@8
1 | 1 | 1 | 5µs | 25µs | Test2::API::Context::::BEGIN@25Test2::API::Context::BEGIN@25
1 | 1 | 1 | 4µs | 21µs | Test2::API::Context::::BEGIN@10Test2::API::Context::BEGIN@10
1 | 1 | 1 | 4µs | 19µs | Test2::API::Context::::BEGIN@9Test2::API::Context::BEGIN@9
1 | 1 | 1 | 4µs | 21µs | Test2::API::Context::::BEGIN@3Test2::API::Context::BEGIN@3
1 | 1 | 1 | 2µs | 2µs | Test2::API::Context::::BEGIN@12Test2::API::Context::BEGIN@12
1 | 1 | 1 | 1µs | 1µs | Test2::API::Context::::BEGIN@13Test2::API::Context::BEGIN@13
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::__ANON__[:175]Test2::API::Context::__ANON__[:175]
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::__ANON__[:470]Test2::API::Context::__ANON__[:470]
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::_parse_eventTest2::API::Context::_parse_event
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::alertTest2::API::Context::alert
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::bailTest2::API::Context::bail
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::build_ev2Test2::API::Context::build_ev2
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::build_eventTest2::API::Context::build_event
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::diagTest2::API::Context::diag
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::do_in_contextTest2::API::Context::do_in_context
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::done_testingTest2::API::Context::done_testing
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::failTest2::API::Context::fail
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::fail_and_releaseTest2::API::Context::fail_and_release
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::failure_diagTest2::API::Context::failure_diag
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::noteTest2::API::Context::note
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::okTest2::API::Context::ok
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::passTest2::API::Context::pass
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::pass_and_releaseTest2::API::Context::pass_and_release
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::planTest2::API::Context::plan
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::restore_error_varsTest2::API::Context::restore_error_vars
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::send_ev2_and_releaseTest2::API::Context::send_ev2_and_release
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::send_eventTest2::API::Context::send_event
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::send_event_and_releaseTest2::API::Context::send_event_and_release
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::skipTest2::API::Context::skip
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::snapshotTest2::API::Context::snapshot
0 | 0 | 0 | 0s | 0s | Test2::API::Context::::throwTest2::API::Context::throw

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package Test2::API::Context;
2 | 2 | 25µs | 2 | 34µs | # spent 32µs (30+2) within Test2::API::Context::BEGIN@2 which was called: # once (30µs+2µs) by Test::Builder::BEGIN@18 at line 2 use strict; # spent 32µs making 1 call to Test2::API::Context::BEGIN@2 # spent 2µs making 1 call to strict::import
3 | 2 | 27µs | 2 | 39µs | # spent 21µs (4+17) within Test2::API::Context::BEGIN@3 which was called: # once (4µs+17µs) by Test::Builder::BEGIN@18 at line 3 use warnings; # spent 21µs making 1 call to Test2::API::Context::BEGIN@3 # spent 17µs making 1 call to warnings::import
4 |  |  |  |  |
5 | 1 | 300ns |  |  | our $VERSION = '1.302198';
6 |  |  |  |  |
7 |  |  |  |  |
8 | 2 | 18µs | 2 | 46µs | # spent 26µs (5+21) within Test2::API::Context::BEGIN@8 which was called: # once (5µs+21µs) by Test::Builder::BEGIN@18 at line 8 use Carp qw/confess croak/; # spent 26µs making 1 call to Test2::API::Context::BEGIN@8 # spent 21µs making 1 call to Exporter::import
9 | 2 | 22µs | 2 | 34µs | # spent 19µs (4+15) within Test2::API::Context::BEGIN@9 which was called: # once (4µs+15µs) by Test::Builder::BEGIN@18 at line 9 use Scalar::Util qw/weaken blessed/; # spent 19µs making 1 call to Test2::API::Context::BEGIN@9 # spent 15µs making 1 call to Exporter::import
10 | 2 | 15µs | 2 | 38µs | # spent 21µs (4+17) within Test2::API::Context::BEGIN@10 which was called: # once (4µs+17µs) by Test::Builder::BEGIN@18 at line 10 use Test2::Util qw/get_tid try pkg_to_file get_tid/; # spent 21µs making 1 call to Test2::API::Context::BEGIN@10 # spent 17µs making 1 call to Exporter::import
11 |  |  |  |  |
12 | 2 | 9µs | 1 | 2µs | # spent 2µs within Test2::API::Context::BEGIN@12 which was called: # once (2µs+0s) by Test::Builder::BEGIN@18 at line 12 use Test2::EventFacet::Trace(); # spent 2µs making 1 call to Test2::API::Context::BEGIN@12
13 | 2 | 66µs | 1 | 1µs | # spent 1µs within Test2::API::Context::BEGIN@13 which was called: # once (1µs+0s) by Test::Builder::BEGIN@18 at line 13 use Test2::API(); # spent 1µs making 1 call to Test2::API::Context::BEGIN@13
14 |  |  |  |  |
15 |  |  |  |  | # Preload some key event types
16 |  |  |  |  | my %LOADED = (
17 |  |  |  |  | map {
18 | 13 | 10µs |  |  | my $pkg = "Test2::Event::$_";
19 | 12 | 2µs |  |  | my $file = "Test2/Event/$_.pm";
20 | 12 | 174µs |  |  | require $file unless $INC{$file};
21 | 12 | 5µs |  |  | ( $pkg => $pkg, $_ => $pkg )
22 |  |  |  |  | } qw/Ok Diag Note Plan Bail Exception Waiting Skip Subtest Pass Fail V2/
23 |  |  |  |  | );
24 |  |  |  |  |
25 | 2 | 21µs | 2 | 45µs | # spent 25µs (5+20) within Test2::API::Context::BEGIN@25 which was called: # once (5µs+20µs) by Test::Builder::BEGIN@18 at line 25 use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/; # spent 25µs making 1 call to Test2::API::Context::BEGIN@25 # spent 20µs making 1 call to Exporter::import
26 | 1 | 3µs | 1 | 128µs | # spent 133µs (5+128) within Test2::API::Context::BEGIN@26 which was called: # once (5µs+128µs) by Test::Builder::BEGIN@18 at line 29 use Test2::Util::HashBase qw{ # spent 128µs making 1 call to Test2::Util::HashBase::import
27 |  |  |  |  | stack hub trace _on_release _depth _is_canon _is_spawn _aborted
28 |  |  |  |  | errno eval_error child_error thrown
29 | 1 | 188µs | 1 | 133µs | }; # spent 133µs making 1 call to Test2::API::Context::BEGIN@26
30 |  |  |  |  |
31 |  |  |  |  | # Private, not package vars
32 |  |  |  |  | # It is safe to cache these.
33 | 1 | 1µs | 1 | 6µs | my $ON_RELEASE = Test2::API::_context_release_callbacks_ref(); # spent 6µs making 1 call to Test2::API::_context_release_callbacks_ref
34 | 1 | 500ns | 1 | 3µs | my $CONTEXTS = Test2::API::_contexts_ref(); # spent 3µs making 1 call to Test2::API::_contexts_ref
35 |  |  |  |  |
36 |  |  |  |  | # spent 20µs within Test2::API::Context::init which was called 2 times, avg 10µs/call: # 2 times (20µs+0s) by Test2::Util::HashBase::_new at line 155 of Test2/Util/HashBase.pm, avg 10µs/call sub init {
37 | 2 | 300ns |  |  | my $self = shift;
38 |  |  |  |  |
39 |  |  |  |  | confess "The 'trace' attribute is required"
40 | 2 | 600ns |  |  | unless $self->{+TRACE};
41 |  |  |  |  |
42 |  |  |  |  | confess "The 'hub' attribute is required"
43 | 2 | 600ns |  |  | unless $self->{+HUB};
44 |  |  |  |  |
45 | 2 | 1µs |  |  | $self->{+_DEPTH} = 0 unless defined $self->{+_DEPTH};
46 |  |  |  |  |
47 | 2 | 13µs |  |  | $self->{+ERRNO} = $! unless exists $self->{+ERRNO};
48 | 2 | 1µs |  |  | $self->{+EVAL_ERROR} = $@ unless exists $self->{+EVAL_ERROR};
49 | 2 | 4µs |  |  | $self->{+CHILD_ERROR} = $? unless exists $self->{+CHILD_ERROR};
50 |  |  |  |  | }
51 |  |  |  |  |
52 |  |  |  |  | sub snapshot { bless {%{$_[0]}, _is_canon => undef, _is_spawn => undef, _aborted => undef}, __PACKAGE__ }
53 |  |  |  |  |
54 |  |  |  |  | sub restore_error_vars {
55 |  |  |  |  | my $self = shift;
56 |  |  |  |  | ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR};
57 |  |  |  |  | }
58 |  |  |  |  |
59 |  |  |  |  | # spent 16µs within Test2::API::Context::DESTROY which was called 10 times, avg 2µs/call: # once (9µs+0s) by Test::Builder::reset_outputs at line 1415 of Test/Builder.pm # once (2µs+0s) by Test::Builder::ok at line 734 of Test/Builder.pm # once (700ns+0s) by Test2::API::test2_set_is_end at line 48 of Test2/API.pm # once (700ns+0s) by Test::Builder::done_testing at line 620 of Test/Builder.pm # once (700ns+0s) by Test::Builder::current_test at line 1464 of Test/Builder.pm # once (700ns+0s) by Test::Builder::reset at line 453 of Test/Builder.pm # once (600ns+0s) by Test::Builder::use_numbers at line 1229 of Test/Builder.pm # once (600ns+0s) by Test2::API::Instance::set_exit at line 551 of Test2/API/Instance.pm # once (500ns+0s) by Test::Builder::reset at line 483 of Test/Builder.pm # once (400ns+0s) by Test::Builder::expected_tests at line 556 of Test/Builder.pm sub DESTROY {
60 | 10 | 40µs |  |  | return unless $_[0]->{+_IS_CANON} || $_[0]->{+_IS_SPAWN};
61 |  |  |  |  | return if $_[0]->{+_ABORTED} && ${$_[0]->{+_ABORTED}};
62 |  |  |  |  | my ($self) = @_;
63 |  |  |  |  |
64 |  |  |  |  | my $hub = $self->{+HUB};
65 |  |  |  |  | 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 | 2 | 1.21ms | 2 | 31µs | # spent 18µs (5+13) within Test2::API::Context::BEGIN@72 which was called: # once (5µs+13µs) by Test::Builder::BEGIN@18 at line 72 no warnings 'uninitialized'; # spent 18µs making 1 call to Test2::API::Context::BEGIN@72 # spent 13µs making 1 call to warnings::unimport
73 |  |  |  |  | if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) {
74 |  |  |  |  | require Carp;
75 |  |  |  |  | my $mess = Carp::longmess("Context destroyed");
76 |  |  |  |  | my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame;
77 |  |  |  |  | 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 |  |  |  |  | return if $self->{+_IS_SPAWN};
102 |  |  |  |  |
103 |  |  |  |  | # Remove the key itself to avoid a slow memory leak
104 |  |  |  |  | delete $CONTEXTS->{$hid};
105 |  |  |  |  | $self->{+_IS_CANON} = undef;
106 |  |  |  |  |
107 |  |  |  |  | if (my $cbk = $self->{+_ON_RELEASE}) {
108 |  |  |  |  | $_->($self) for reverse @$cbk;
109 |  |  |  |  | }
110 |  |  |  |  | if (my $hcbk = $hub->{_context_release}) {
111 |  |  |  |  | $_->($self) for reverse @$hcbk;
112 |  |  |  |  | }
113 |  |  |  |  | $_->($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 |  |  |  |  | # spent 34µs within Test2::API::Context::release which was called 8 times, avg 4µs/call: # 3 times (10µs+0s) by Test2::API::release at line 570 of Test2/API.pm, avg 3µs/call # once (9µs+0s) by Test::Builder::ok at line 733 of Test/Builder.pm # once (6µs+0s) by Test::Builder::reset at line 447 of Test/Builder.pm # once (5µs+0s) by Test::Builder::reset at line 481 of Test/Builder.pm # once (2µs+0s) by Test::Builder::expected_tests at line 553 of Test/Builder.pm # once (2µs+0s) by Test::Builder::reset_outputs at line 1411 of Test/Builder.pm sub release {
121 | 8 | 2µs |  |  | my ($self) = @_;
122 |  |  |  |  |
123 | 8 | 1µs |  |  | ($!, $@, $?) = @$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 | 8 | 12µs |  |  | if $self->{+_IS_SPAWN};
127 |  |  |  |  |
128 |  |  |  |  | croak "release() should not be called on context that is neither canon nor a child"
129 | 4 | 700ns |  |  | unless $self->{+_IS_CANON};
130 |  |  |  |  |
131 | 4 | 700ns |  |  | my $hub = $self->{+HUB};
132 | 4 | 1µs |  |  | my $hid = $hub->{hid};
133 |  |  |  |  |
134 |  |  |  |  | croak "context thinks it is canon, but it is not"
135 | 4 | 3µs |  |  | unless $CONTEXTS->{$hid} && $CONTEXTS->{$hid} == $self;
136 |  |  |  |  |
137 |  |  |  |  | # Remove the key itself to avoid a slow memory leak
138 | 4 | 2µs |  |  | $self->{+_IS_CANON} = undef;
139 | 4 | 2µs |  |  | delete $CONTEXTS->{$hid};
140 |  |  |  |  |
141 | 4 | 1µs |  |  | if (my $cbk = $self->{+_ON_RELEASE}) {
142 |  |  |  |  | $_->($self) for reverse @$cbk;
143 |  |  |  |  | }
144 | 4 | 1µs |  |  | if (my $hcbk = $hub->{_context_release}) {
145 |  |  |  |  | $_->($self) for reverse @$hcbk;
146 |  |  |  |  | }
147 | 4 | 2µs |  |  | $_->($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 | 4 | 6µs |  |  | ($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR};
153 |  |  |  |  |
154 | 4 | 6µs |  |  | return;
155 |  |  |  |  | }
156 |  |  |  |  |
157 |  |  |  |  | sub do_in_context {
158 |  |  |  |  | my $self = shift;
159 |  |  |  |  | my ($sub, @args) = @_;
160 |  |  |  |  |
161 |  |  |  |  | # We need to update the pid/tid and error vars.
162 |  |  |  |  | my $clone = $self->snapshot;
163 |  |  |  |  | @$clone{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} = ($!, $@, $?);
164 |  |  |  |  | $clone->{+TRACE} = $clone->{+TRACE}->snapshot(pid => $$, tid => get_tid());
165 |  |  |  |  |
166 |  |  |  |  | my $hub = $clone->{+HUB};
167 |  |  |  |  | my $hid = $hub->hid;
168 |  |  |  |  |
169 |  |  |  |  | my $old = $CONTEXTS->{$hid};
170 |  |  |  |  |
171 |  |  |  |  | $clone->{+_IS_CANON} = 1;
172 |  |  |  |  | $CONTEXTS->{$hid} = $clone;
173 |  |  |  |  | weaken($CONTEXTS->{$hid});
174 |  |  |  |  | my ($ok, $err) = &try($sub, @args);
175 |  |  |  |  | my ($rok, $rerr) = try { $clone->release };
176 |  |  |  |  | delete $clone->{+_IS_CANON};
177 |  |  |  |  |
178 |  |  |  |  | if ($old) {
179 |  |  |  |  | $CONTEXTS->{$hid} = $old;
180 |  |  |  |  | weaken($CONTEXTS->{$hid});
181 |  |  |  |  | }
182 |  |  |  |  | else {
183 |  |  |  |  | delete $CONTEXTS->{$hid};
184 |  |  |  |  | }
185 |  |  |  |  |
186 |  |  |  |  | die $err unless $ok;
187 |  |  |  |  | die $rerr unless $rok;
188 |  |  |  |  | }
189 |  |  |  |  |
190 |  |  |  |  | sub done_testing {
191 |  |  |  |  | my $self = shift;
192 |  |  |  |  | $self->hub->finalize($self->trace, 1);
193 |  |  |  |  | return;
194 |  |  |  |  | }
195 |  |  |  |  |
196 |  |  |  |  | sub throw {
197 |  |  |  |  | my ($self, $msg) = @_;
198 |  |  |  |  | $self->{+THROWN} = 1;
199 |  |  |  |  | ${$self->{+_ABORTED}}++ if $self->{+_ABORTED};
200 |  |  |  |  | $self->release if $self->{+_IS_CANON} || $self->{+_IS_SPAWN};
201 |  |  |  |  | $self->trace->throw($msg);
202 |  |  |  |  | }
203 |  |  |  |  |
204 |  |  |  |  | sub alert {
205 |  |  |  |  | my ($self, $msg) = @_;
206 |  |  |  |  | $self->trace->alert($msg);
207 |  |  |  |  | }
208 |  |  |  |  |
209 |  |  |  |  | sub send_ev2_and_release {
210 |  |  |  |  | my $self = shift;
211 |  |  |  |  | my $out = $self->send_ev2(@_);
212 |  |  |  |  | $self->release;
213 |  |  |  |  | return $out;
214 |  |  |  |  | }
215 |  |  |  |  |
216 |  |  |  |  | # spent 116µs (15+101) within Test2::API::Context::send_ev2 which was called: # once (15µs+101µs) by Test2::API::test2_set_is_end at line 46 of Test2/API.pm sub send_ev2 {
217 | 1 | 200ns |  |  | my $self = shift;
218 |  |  |  |  |
219 | 1 | 500ns |  |  | my $e;
220 |  |  |  |  | {
221 | 2 | 1µs |  |  | local $Carp::CarpLevel = $Carp::CarpLevel + 1;
222 |  |  |  |  | $e = Test2::Event::V2->new(
223 | 1 | 6µs | 2 | 19µs | trace => $self->{+TRACE}->snapshot, # spent 16µs making 1 call to Test2::Util::HashBase::_new # spent 3µs making 1 call to Test2::EventFacet::Trace::snapshot
224 |  |  |  |  | @_,
225 |  |  |  |  | );
226 |  |  |  |  | }
227 |  |  |  |  |
228 | 1 | 400ns |  |  | if ($self->{+_ABORTED}) {
229 |  |  |  |  | my $f = $e->facet_data;
230 |  |  |  |  | ${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate);
231 |  |  |  |  | }
232 | 1 | 5µs | 1 | 82µs | $self->{+HUB}->send($e); # spent 82µs making 1 call to Test2::Hub::send
233 |  |  |  |  | }
234 |  |  |  |  |
235 |  |  |  |  | sub build_ev2 {
236 |  |  |  |  | my $self = shift;
237 |  |  |  |  |
238 |  |  |  |  | local $Carp::CarpLevel = $Carp::CarpLevel + 1;
239 |  |  |  |  | Test2::Event::V2->new(
240 |  |  |  |  | trace => $self->{+TRACE}->snapshot,
241 |  |  |  |  | @_,
242 |  |  |  |  | );
243 |  |  |  |  | }
244 |  |  |  |  |
245 |  |  |  |  | sub send_event_and_release {
246 |  |  |  |  | my $self = shift;
247 |  |  |  |  | my $out = $self->send_event(@_);
248 |  |  |  |  | $self->release;
249 |  |  |  |  | return $out;
250 |  |  |  |  | }
251 |  |  |  |  |
252 |  |  |  |  | sub send_event {
253 |  |  |  |  | my $self = shift;
254 |  |  |  |  | my $event = shift;
255 |  |  |  |  | my %args = @_;
256 |  |  |  |  |
257 |  |  |  |  | my $pkg = $LOADED{$event} || $self->_parse_event($event);
258 |  |  |  |  |
259 |  |  |  |  | my $e;
260 |  |  |  |  | {
261 |  |  |  |  | local $Carp::CarpLevel = $Carp::CarpLevel + 1;
262 |  |  |  |  | $e = $pkg->new(
263 |  |  |  |  | trace => $self->{+TRACE}->snapshot,
264 |  |  |  |  | %args,
265 |  |  |  |  | );
266 |  |  |  |  | }
267 |  |  |  |  |
268 |  |  |  |  | if ($self->{+_ABORTED}) {
269 |  |  |  |  | my $f = $e->facet_data;
270 |  |  |  |  | ${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate);
271 |  |  |  |  | }
272 |  |  |  |  | $self->{+HUB}->send($e);
273 |  |  |  |  | }
274 |  |  |  |  |
275 |  |  |  |  | sub build_event {
276 |  |  |  |  | my $self = shift;
277 |  |  |  |  | my $event = shift;
278 |  |  |  |  | my %args = @_;
279 |  |  |  |  |
280 |  |  |  |  | my $pkg = $LOADED{$event} || $self->_parse_event($event);
281 |  |  |  |  |
282 |  |  |  |  | local $Carp::CarpLevel = $Carp::CarpLevel + 1;
283 |  |  |  |  | $pkg->new(
284 |  |  |  |  | trace => $self->{+TRACE}->snapshot,
285 |  |  |  |  | %args,
286 |  |  |  |  | );
287 |  |  |  |  | }
288 |  |  |  |  |
289 |  |  |  |  | sub pass {
290 |  |  |  |  | my $self = shift;
291 |  |  |  |  | my ($name) = @_;
292 |  |  |  |  |
293 |  |  |  |  | my $e = bless(
294 |  |  |  |  | {
295 |  |  |  |  | trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
296 |  |  |  |  | name => $name,
297 |  |  |  |  | },
298 |  |  |  |  | "Test2::Event::Pass"
299 |  |  |  |  | );
300 |  |  |  |  |
301 |  |  |  |  | $self->{+HUB}->send($e);
302 |  |  |  |  | return $e;
303 |  |  |  |  | }
304 |  |  |  |  |
305 |  |  |  |  | sub pass_and_release {
306 |  |  |  |  | my $self = shift;
307 |  |  |  |  | my ($name) = @_;
308 |  |  |  |  |
309 |  |  |  |  | my $e = bless(
310 |  |  |  |  | {
311 |  |  |  |  | trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
312 |  |  |  |  | name => $name,
313 |  |  |  |  | },
314 |  |  |  |  | "Test2::Event::Pass"
315 |  |  |  |  | );
316 |  |  |  |  |
317 |  |  |  |  | $self->{+HUB}->send($e);
318 |  |  |  |  | $self->release;
319 |  |  |  |  | return 1;
320 |  |  |  |  | }
321 |  |  |  |  |
322 |  |  |  |  | sub fail {
323 |  |  |  |  | my $self = shift;
324 |  |  |  |  | my ($name, @diag) = @_;
325 |  |  |  |  |
326 |  |  |  |  | my $e = bless(
327 |  |  |  |  | {
328 |  |  |  |  | trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
329 |  |  |  |  | name => $name,
330 |  |  |  |  | },
331 |  |  |  |  | "Test2::Event::Fail"
332 |  |  |  |  | );
333 |  |  |  |  |
334 |  |  |  |  | for my $msg (@diag) {
335 |  |  |  |  | if (ref($msg) eq 'Test2::EventFacet::Info::Table') {
336 |  |  |  |  | $e->add_info({tag => 'DIAG', debug => 1, $msg->info_args});
337 |  |  |  |  | }
338 |  |  |  |  | else {
339 |  |  |  |  | $e->add_info({tag => 'DIAG', debug => 1, details => $msg});
340 |  |  |  |  | }
341 |  |  |  |  | }
342 |  |  |  |  |
343 |  |  |  |  | $self->{+HUB}->send($e);
344 |  |  |  |  | return $e;
345 |  |  |  |  | }
346 |  |  |  |  |
347 |  |  |  |  | sub fail_and_release {
348 |  |  |  |  | my $self = shift;
349 |  |  |  |  | my ($name, @diag) = @_;
350 |  |  |  |  |
351 |  |  |  |  | my $e = bless(
352 |  |  |  |  | {
353 |  |  |  |  | trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
354 |  |  |  |  | name => $name,
355 |  |  |  |  | },
356 |  |  |  |  | "Test2::Event::Fail"
357 |  |  |  |  | );
358 |  |  |  |  |
359 |  |  |  |  | for my $msg (@diag) {
360 |  |  |  |  | if (ref($msg) eq 'Test2::EventFacet::Info::Table') {
361 |  |  |  |  | $e->add_info({tag => 'DIAG', debug => 1, $msg->info_args});
362 |  |  |  |  | }
363 |  |  |  |  | else {
364 |  |  |  |  | $e->add_info({tag => 'DIAG', debug => 1, details => $msg});
365 |  |  |  |  | }
366 |  |  |  |  | }
367 |  |  |  |  |
368 |  |  |  |  | $self->{+HUB}->send($e);
369 |  |  |  |  | $self->release;
370 |  |  |  |  | return 0;
371 |  |  |  |  | }
372 |  |  |  |  |
373 |  |  |  |  | sub ok {
374 |  |  |  |  | my $self = shift;
375 |  |  |  |  | my ($pass, $name, $on_fail) = @_;
376 |  |  |  |  |
377 |  |  |  |  | my $hub = $self->{+HUB};
378 |  |  |  |  |
379 |  |  |  |  | my $e = bless {
380 |  |  |  |  | trace => bless( {%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
381 |  |  |  |  | pass => $pass,
382 |  |  |  |  | name => $name,
383 |  |  |  |  | }, 'Test2::Event::Ok';
384 |  |  |  |  | $e->init;
385 |  |  |  |  |
386 |  |  |  |  | $hub->send($e);
387 |  |  |  |  | return $e if $pass;
388 |  |  |  |  |
389 |  |  |  |  | $self->failure_diag($e);
390 |  |  |  |  |
391 |  |  |  |  | if ($on_fail && @$on_fail) {
392 |  |  |  |  | $self->diag($_) for @$on_fail;
393 |  |  |  |  | }
394 |  |  |  |  |
395 |  |  |  |  | return $e;
396 |  |  |  |  | }
397 |  |  |  |  |
398 |  |  |  |  | sub failure_diag {
399 |  |  |  |  | my $self = shift;
400 |  |  |  |  | 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 |  |  |  |  | my $name = $e->name;
406 |  |  |  |  | my $trace = $e->trace;
407 |  |  |  |  | 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 |  |  |  |  | my $msg = defined($name)
412 |  |  |  |  | ? qq[Failed test '$name'\n$debug.\n]
413 |  |  |  |  | : qq[Failed test $debug.\n];
414 |  |  |  |  |
415 |  |  |  |  | $self->diag($msg);
416 |  |  |  |  | }
417 |  |  |  |  |
418 |  |  |  |  | sub skip {
419 |  |  |  |  | my $self = shift;
420 |  |  |  |  | my ($name, $reason, @extra) = @_;
421 |  |  |  |  | $self->send_event(
422 |  |  |  |  | 'Skip',
423 |  |  |  |  | name => $name,
424 |  |  |  |  | reason => $reason,
425 |  |  |  |  | pass => 1,
426 |  |  |  |  | @extra,
427 |  |  |  |  | );
428 |  |  |  |  | }
429 |  |  |  |  |
430 |  |  |  |  | sub note {
431 |  |  |  |  | my $self = shift;
432 |  |  |  |  | my ($message) = @_;
433 |  |  |  |  | $self->send_event('Note', message => $message);
434 |  |  |  |  | }
435 |  |  |  |  |
436 |  |  |  |  | sub diag {
437 |  |  |  |  | my $self = shift;
438 |  |  |  |  | my ($message) = @_;
439 |  |  |  |  | my $hub = $self->{+HUB};
440 |  |  |  |  | $self->send_event(
441 |  |  |  |  | 'Diag',
442 |  |  |  |  | message => $message,
443 |  |  |  |  | );
444 |  |  |  |  | }
445 |  |  |  |  |
446 |  |  |  |  | sub plan {
447 |  |  |  |  | my ($self, $max, $directive, $reason) = @_;
448 |  |  |  |  | $self->send_event('Plan', max => $max, directive => $directive, reason => $reason);
449 |  |  |  |  | }
450 |  |  |  |  |
451 |  |  |  |  | sub bail {
452 |  |  |  |  | my ($self, $reason) = @_;
453 |  |  |  |  | $self->send_event('Bail', reason => $reason);
454 |  |  |  |  | }
455 |  |  |  |  |
456 |  |  |  |  | sub _parse_event {
457 |  |  |  |  | my $self = shift;
458 |  |  |  |  | my $event = shift;
459 |  |  |  |  |
460 |  |  |  |  | my $pkg;
461 |  |  |  |  | if ($event =~ m/^\+(.*)/) {
462 |  |  |  |  | $pkg = $1;
463 |  |  |  |  | }
464 |  |  |  |  | else {
465 |  |  |  |  | $pkg = "Test2::Event::$event";
466 |  |  |  |  | }
467 |  |  |  |  |
468 |  |  |  |  | unless ($LOADED{$pkg}) {
469 |  |  |  |  | my $file = pkg_to_file($pkg);
470 |  |  |  |  | my ($ok, $err) = try { require $file };
471 |  |  |  |  | $self->throw("Could not load event module '$pkg': $err")
472 |  |  |  |  | unless $ok;
473 |  |  |  |  |
474 |  |  |  |  | $LOADED{$pkg} = $pkg;
475 |  |  |  |  | }
476 |  |  |  |  |
477 |  |  |  |  | confess "'$pkg' is not a subclass of 'Test2::Event'"
478 |  |  |  |  | unless $pkg->isa('Test2::Event');
479 |  |  |  |  |
480 |  |  |  |  | $LOADED{$event} = $pkg;
481 |  |  |  |  |
482 |  |  |  |  | return $pkg;
483 |  |  |  |  | }
484 |  |  |  |  |
485 | 1 | 5µs |  |  | 1;
486 |  |  |  |  |
487 |  |  |  |  | __END__