| 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 |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 8 | 6 | 2 | 34µs | 34µs | Test2::API::Context::release |
| 1 | 1 | 1 | 30µs | 32µs | Test2::API::Context::BEGIN@2 |
| 2 | 1 | 1 | 20µs | 20µs | Test2::API::Context::init |
| 10 | 10 | 3 | 16µs | 16µs | Test2::API::Context::DESTROY |
| 1 | 1 | 1 | 15µs | 116µs | Test2::API::Context::send_ev2 |
| 1 | 1 | 1 | 5µs | 133µs | Test2::API::Context::BEGIN@26 |
| 1 | 1 | 1 | 5µs | 18µs | Test2::API::Context::BEGIN@72 |
| 1 | 1 | 1 | 5µs | 26µs | Test2::API::Context::BEGIN@8 |
| 1 | 1 | 1 | 5µs | 25µs | Test2::API::Context::BEGIN@25 |
| 1 | 1 | 1 | 4µs | 21µs | Test2::API::Context::BEGIN@10 |
| 1 | 1 | 1 | 4µs | 19µs | Test2::API::Context::BEGIN@9 |
| 1 | 1 | 1 | 4µs | 21µs | Test2::API::Context::BEGIN@3 |
| 1 | 1 | 1 | 2µs | 2µs | Test2::API::Context::BEGIN@12 |
| 1 | 1 | 1 | 1µs | 1µs | Test2::API::Context::BEGIN@13 |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::__ANON__[:175] |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::__ANON__[:470] |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::_parse_event |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::alert |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::bail |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::build_ev2 |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::build_event |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::diag |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::do_in_context |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::done_testing |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::fail |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::fail_and_release |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::failure_diag |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::note |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::ok |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::pass |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::pass_and_release |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::plan |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::restore_error_vars |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::send_ev2_and_release |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::send_event |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::send_event_and_release |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::skip |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::snapshot |
| 0 | 0 | 0 | 0s | 0s | Test2::API::Context::throw |
| 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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 # 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 | ||||
| 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 | ||||
| 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 # 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 | ||||
| 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 | ||||
| 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__ |