1use strict; 2use warnings; 3 4BEGIN { $Test2::API::DO_DEPTH_CHECK = 1 } 5use Test2::Tools::Tiny; 6 7use Test2::API qw{ 8 context intercept 9 test2_stack 10 test2_add_callback_context_acquire 11 test2_add_callback_context_init 12 test2_add_callback_context_release 13}; 14 15my $error = exception { context(); 1 }; 16my $exception = "context() called, but return value is ignored at " . __FILE__ . ' line ' . (__LINE__ - 1); 17like($error, qr/^\Q$exception\E/, "Got the exception" ); 18 19my $ref; 20my $frame; 21sub wrap(&) { 22 my $ctx = context(); 23 my ($pkg, $file, $line, $sub) = caller(0); 24 $frame = [$pkg, $file, $line, $sub]; 25 26 $_[0]->($ctx); 27 28 $ref = "$ctx"; 29 30 $ctx->release; 31} 32 33wrap { 34 my $ctx = shift; 35 ok($ctx->hub, "got hub"); 36 delete $ctx->trace->frame->[4]; 37 is_deeply($ctx->trace->frame, $frame, "Found place to report errors"); 38}; 39 40wrap { 41 my $ctx = shift; 42 ok("$ctx" ne "$ref", "Got a new context"); 43 my $new = context(); 44 my @caller = caller(0); 45 is_deeply( 46 $new, 47 {%$ctx, _is_canon => undef, _is_spawn => [@caller[0,1,2,3]]}, 48 "Additional call to context gets spawn" 49 ); 50 delete $ctx->trace->frame->[4]; 51 is_deeply($ctx->trace->frame, $frame, "Found place to report errors"); 52 $new->release; 53}; 54 55wrap { 56 my $ctx = shift; 57 my $snap = $ctx->snapshot; 58 59 is_deeply( 60 $snap, 61 {%$ctx, _is_canon => undef, _is_spawn => undef, _aborted => undef}, 62 "snapshot is identical except for canon/spawn/aborted" 63 ); 64 ok($ctx != $snap, "snapshot is a new instance"); 65}; 66 67my $end_ctx; 68{ # Simulate an END block... 69 local *END = sub { local *__ANON__ = 'END'; context() }; 70 my $ctx = END(); 71 $frame = [ __PACKAGE__, __FILE__, __LINE__ - 1, 'main::END' ]; 72 # "__LINE__ - 1" on the preceding line forces the value to be an IV 73 # (even though __LINE__ on its own is a PV), just as (caller)[2] is. 74 $end_ctx = $ctx->snapshot; 75 $ctx->release; 76} 77delete $end_ctx->trace->frame->[4]; 78is_deeply( $end_ctx->trace->frame, $frame, 'context is ok in an end block'); 79 80# Test event generation 81{ 82 package My::Formatter; 83 84 sub write { 85 my $self = shift; 86 my ($e) = @_; 87 push @$self => $e; 88 } 89} 90my $events = bless [], 'My::Formatter'; 91my $hub = Test2::Hub->new( 92 formatter => $events, 93); 94my $trace = Test2::EventFacet::Trace->new( 95 frame => [ 'Foo::Bar', 'foo_bar.t', 42, 'Foo::Bar::baz' ], 96); 97my $ctx = Test2::API::Context->new( 98 trace => $trace, 99 hub => $hub, 100); 101 102my $e = $ctx->build_event('Ok', pass => 1, name => 'foo'); 103is($e->pass, 1, "Pass"); 104is($e->name, 'foo', "got name"); 105is_deeply($e->trace, $trace, "Got the trace info"); 106ok(!@$events, "No events yet"); 107 108$e = $ctx->send_event('Ok', pass => 1, name => 'foo'); 109is($e->pass, 1, "Pass"); 110is($e->name, 'foo', "got name"); 111is_deeply($e->trace, $trace, "Got the trace info"); 112is(@$events, 1, "1 event"); 113is_deeply($events, [$e], "Hub saw the event"); 114pop @$events; 115 116$e = $ctx->ok(1, 'foo'); 117is($e->pass, 1, "Pass"); 118is($e->name, 'foo', "got name"); 119is_deeply($e->trace, $trace, "Got the trace info"); 120is(@$events, 1, "1 event"); 121is_deeply($events, [$e], "Hub saw the event"); 122pop @$events; 123 124$e = $ctx->note('foo'); 125is($e->message, 'foo', "got message"); 126is_deeply($e->trace, $trace, "Got the trace info"); 127is(@$events, 1, "1 event"); 128is_deeply($events, [$e], "Hub saw the event"); 129pop @$events; 130 131$e = $ctx->diag('foo'); 132is($e->message, 'foo', "got message"); 133is_deeply($e->trace, $trace, "Got the trace info"); 134is(@$events, 1, "1 event"); 135is_deeply($events, [$e], "Hub saw the event"); 136pop @$events; 137 138$e = $ctx->plan(100); 139is($e->max, 100, "got max"); 140is_deeply($e->trace, $trace, "Got the trace info"); 141is(@$events, 1, "1 event"); 142is_deeply($events, [$e], "Hub saw the event"); 143pop @$events; 144 145$e = $ctx->skip('foo', 'because'); 146is($e->name, 'foo', "got name"); 147is($e->reason, 'because', "got reason"); 148ok($e->pass, "skip events pass by default"); 149is_deeply($e->trace, $trace, "Got the trace info"); 150is(@$events, 1, "1 event"); 151is_deeply($events, [$e], "Hub saw the event"); 152pop @$events; 153 154$e = $ctx->skip('foo', 'because', pass => 0); 155ok(!$e->pass, "can override skip params"); 156pop @$events; 157 158# Test hooks 159 160my @hooks; 161$hub = test2_stack()->top; 162my $ref1 = $hub->add_context_init(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'hub_init' }); 163my $ref2 = $hub->add_context_release(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'hub_release' }); 164test2_add_callback_context_init(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'global_init' }); 165test2_add_callback_context_release(sub { die "Bad Arg" unless ref($_[0]) eq 'Test2::API::Context'; push @hooks => 'global_release' }); 166 167my $ref3 = $hub->add_context_acquire(sub { die "Bad Arg" unless ref($_[0]) eq 'HASH'; push @hooks => 'hub_acquire' }); 168test2_add_callback_context_acquire(sub { die "Bad Arg" unless ref($_[0]) eq 'HASH'; push @hooks => 'global_acquire' }); 169 170sub { 171 push @hooks => 'start'; 172 my $ctx = context(on_init => sub { push @hooks => 'ctx_init' }, on_release => sub { push @hooks => 'ctx_release' }); 173 push @hooks => 'deep'; 174 my $ctx2 = sub { 175 context(on_init => sub { push @hooks => 'ctx_init_deep' }, on_release => sub { push @hooks => 'ctx_release_deep' }); 176 }->(); 177 push @hooks => 'release_deep'; 178 $ctx2->release; 179 push @hooks => 'release_parent'; 180 $ctx->release; 181 push @hooks => 'released_all'; 182 183 push @hooks => 'new'; 184 $ctx = context(on_init => sub { push @hooks => 'ctx_init2' }, on_release => sub { push @hooks => 'ctx_release2' }); 185 push @hooks => 'release_new'; 186 $ctx->release; 187 push @hooks => 'done'; 188}->(); 189 190$hub->remove_context_init($ref1); 191$hub->remove_context_release($ref2); 192$hub->remove_context_acquire($ref3); 193@{Test2::API::_context_init_callbacks_ref()} = (); 194@{Test2::API::_context_release_callbacks_ref()} = (); 195@{Test2::API::_context_acquire_callbacks_ref()} = (); 196 197is_deeply( 198 \@hooks, 199 [qw{ 200 start 201 global_acquire 202 hub_acquire 203 global_init 204 hub_init 205 ctx_init 206 deep 207 global_acquire 208 hub_acquire 209 release_deep 210 release_parent 211 ctx_release_deep 212 ctx_release 213 hub_release 214 global_release 215 released_all 216 new 217 global_acquire 218 hub_acquire 219 global_init 220 hub_init 221 ctx_init2 222 release_new 223 ctx_release2 224 hub_release 225 global_release 226 done 227 }], 228 "Got all hook in correct order" 229); 230 231{ 232 my $ctx = context(level => -1); 233 234 my $one = Test2::API::Context->new( 235 trace => Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'blah']), 236 hub => test2_stack()->top, 237 ); 238 is($one->_depth, 0, "default depth"); 239 240 my $ran = 0; 241 my $doit = sub { 242 is_deeply(\@_, [qw/foo bar/], "got args"); 243 $ran++; 244 die "Make sure old context is restored"; 245 }; 246 247 eval { $one->do_in_context($doit, 'foo', 'bar') }; 248 249 my $spawn = context(level => -1, wrapped => -2); 250 is($spawn->trace, $ctx->trace, "Old context restored"); 251 $spawn->release; 252 $ctx->release; 253 254 ok(!exception { $one->do_in_context(sub {1}) }, "do_in_context works without an original") 255} 256 257{ 258 like(exception { Test2::API::Context->new() }, qr/The 'trace' attribute is required/, "need to have trace"); 259 260 my $trace = Test2::EventFacet::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'foo']); 261 like(exception { Test2::API::Context->new(trace => $trace) }, qr/The 'hub' attribute is required/, "need to have hub"); 262 263 my $hub = test2_stack()->top; 264 my $ctx = Test2::API::Context->new(trace => $trace, hub => $hub); 265 is($ctx->{_depth}, 0, "depth set to 0 when not defined."); 266 267 $ctx = Test2::API::Context->new(trace => $trace, hub => $hub, _depth => 1); 268 is($ctx->{_depth}, 1, "Do not reset depth"); 269 270 like( 271 exception { $ctx->release }, 272 qr/release\(\) should not be called on context that is neither canon nor a child/, 273 "Non canonical context, do not release" 274 ); 275} 276 277sub { 278 like( 279 exception { my $ctx = context(level => 20) }, 280 qr/Could not find context at depth 21/, 281 "Level sanity" 282 ); 283 284 ok( 285 !exception { 286 my $ctx = context(level => 20, fudge => 1); 287 $ctx->release; 288 }, 289 "Was able to get context when fudging level" 290 ); 291}->(); 292 293sub { 294 my ($ctx1, $ctx2); 295 sub { $ctx1 = context() }->(); 296 297 my @warnings; 298 { 299 local $SIG{__WARN__} = sub { push @warnings => @_ }; 300 $ctx2 = context(); 301 $ctx1 = undef; 302 } 303 304 $ctx2->release; 305 306 is(@warnings, 1, "1 warning"); 307 like( 308 $warnings[0], 309 qr/^context\(\) was called to retrieve an existing context, however the existing/, 310 "Got expected warning" 311 ); 312}->(); 313 314sub { 315 my $ctx = context(); 316 my $e = exception { $ctx->throw('xxx') }; 317 like($e, qr/xxx/, "got exception"); 318 319 $ctx = context(); 320 my $warnings = warnings { $ctx->alert('xxx') }; 321 like($warnings->[0], qr/xxx/, "got warning"); 322 $ctx->release; 323}->(); 324 325sub { 326 my $ctx = context; 327 328 is($ctx->_parse_event('Ok'), 'Test2::Event::Ok', "Got the Ok event class"); 329 is($ctx->_parse_event('+Test2::Event::Ok'), 'Test2::Event::Ok', "Got the +Ok event class"); 330 331 like( 332 exception { $ctx->_parse_event('+DFASGFSDFGSDGSD') }, 333 qr/Could not load event module 'DFASGFSDFGSDGSD': Can't locate DFASGFSDFGSDGSD\.pm/, 334 "Bad event type" 335 ); 336}->(); 337 338{ 339 my ($e1, $e2); 340 my $events = intercept { 341 my $ctx = context(); 342 $e1 = $ctx->ok(0, 'foo', ['xxx']); 343 $e2 = $ctx->ok(0, 'foo'); 344 $ctx->release; 345 }; 346 347 ok($e1->isa('Test2::Event::Ok'), "returned ok event"); 348 ok($e2->isa('Test2::Event::Ok'), "returned ok event"); 349 350 is($events->[0], $e1, "got ok event 1"); 351 is($events->[3], $e2, "got ok event 2"); 352 353 is($events->[2]->message, 'xxx', "event 1 diag 2"); 354 ok($events->[2]->isa('Test2::Event::Diag'), "event 1 diag 2 is diag"); 355 356 is($events->[3], $e2, "got ok event 2"); 357} 358 359sub { 360 local $! = 100; 361 local $@ = 'foobarbaz'; 362 local $? = 123; 363 364 my $ctx = context(); 365 366 is($ctx->errno, 100, "saved errno"); 367 is($ctx->eval_error, 'foobarbaz', "saved eval error"); 368 is($ctx->child_error, 123, "saved child exit"); 369 370 $! = 22; 371 $@ = 'xyz'; 372 $? = 33; 373 374 is(0 + $!, 22, "altered \$! in tool"); 375 is($@, 'xyz', "altered \$@ in tool"); 376 is($?, 33, "altered \$? in tool"); 377 378 sub { 379 my $ctx2 = context(); 380 381 $! = 42; 382 $@ = 'app'; 383 $? = 43; 384 385 is(0 + $!, 42, "altered \$! in tool (nested)"); 386 is($@, 'app', "altered \$@ in tool (nested)"); 387 is($?, 43, "altered \$? in tool (nested)"); 388 389 $ctx2->release; 390 391 is(0 + $!, 22, "restored the nested \$! in tool"); 392 is($@, 'xyz', "restored the nested \$@ in tool"); 393 is($?, 33, "restored the nested \$? in tool"); 394 }->(); 395 396 sub { 397 my $ctx2 = context(); 398 399 $! = 42; 400 $@ = 'app'; 401 $? = 43; 402 403 is(0 + $!, 42, "altered \$! in tool (nested)"); 404 is($@, 'app', "altered \$@ in tool (nested)"); 405 is($?, 43, "altered \$? in tool (nested)"); 406 407 # Will not warn since $@ is changed 408 $ctx2 = undef; 409 410 is(0 + $!, 42, 'Destroy does not reset $!'); 411 is($@, 'app', 'Destroy does not reset $@'); 412 is($?, 43, 'Destroy does not reset $?'); 413 }->(); 414 415 $ctx->release; 416 417 is($ctx->errno, 100, "restored errno"); 418 is($ctx->eval_error, 'foobarbaz', "restored eval error"); 419 is($ctx->child_error, 123, "restored child exit"); 420}->(); 421 422 423sub { 424 local $! = 100; 425 local $@ = 'foobarbaz'; 426 local $? = 123; 427 428 my $ctx = context(); 429 430 is($ctx->errno, 100, "saved errno"); 431 is($ctx->eval_error, 'foobarbaz', "saved eval error"); 432 is($ctx->child_error, 123, "saved child exit"); 433 434 $! = 22; 435 $@ = 'xyz'; 436 $? = 33; 437 438 is(0 + $!, 22, "altered \$! in tool"); 439 is($@, 'xyz', "altered \$@ in tool"); 440 is($?, 33, "altered \$? in tool"); 441 442 # Will not warn since $@ is changed 443 $ctx = undef; 444 445 is(0 + $!, 22, "Destroy does not restore \$!"); 446 is($@, 'xyz', "Destroy does not restore \$@"); 447 is($?, 33, "Destroy does not restore \$?"); 448}->(); 449 450sub { 451 require Test2::EventFacet::Info::Table; 452 453 my $events = intercept { 454 my $ctx = context(); 455 456 $ctx->fail('foo', 'bar', Test2::EventFacet::Info::Table->new(rows => [['a', 'b']])); 457 $ctx->fail_and_release('foo', 'bar', Test2::EventFacet::Info::Table->new(rows => [['a', 'b']], as_string => 'a, b')); 458 }; 459 460 is(@$events, 2, "got 2 events"); 461 462 is($events->[0]->{info}->[0]->{details}, 'bar', "got first diag"); 463 is($events->[0]->{info}->[1]->{details}, '<TABLE NOT DISPLAYED>', "second diag has default details"); 464 is_deeply( 465 $events->[0]->{info}->[1]->{table}, 466 {rows => [['a', 'b']]}, 467 "Got the table rows" 468 ); 469 470 is($events->[1]->{info}->[0]->{details}, 'bar', "got first diag"); 471 is($events->[1]->{info}->[1]->{details}, 'a, b', "second diag has custom details"); 472 is_deeply( 473 $events->[1]->{info}->[1]->{table}, 474 {rows => [['a', 'b']]}, 475 "Got the table rows" 476 ); 477 478}->(); 479 480sub ctx_destroy_test { 481 my (undef, undef, $line1) = caller(); 482 my (@warn, $line2); 483 local $SIG{__WARN__} = sub { push @warn => $_[0] }; 484 485 { my $ctx = context(); $ctx = undef } $line2 = __LINE__; 486 487 use Data::Dumper; 488# print Dumper(@warn); 489 490 like($warn[0], qr/context appears to have been destroyed without first calling release/, "Is normal context warning"); 491 like($warn[0], qr{\QContext destroyed at ${ \__FILE__ } line $line2\E}, "Reported context destruction trace"); 492 493 my $created = <<" EOT"; 494Here are the context creation details, just in case a tool forgot to call 495release(): 496 File: ${ \__FILE__ } 497 Line: $line1 498 Tool: main::ctx_destroy_test 499 EOT 500 501 like($warn[0], qr{\Q$created\E}, "Reported context creation details"); 502}; 503 504ctx_destroy_test(); 505 506done_testing; 507