-
Notifications
You must be signed in to change notification settings - Fork 528
/
API.pm
1718 lines (1228 loc) · 48.4 KB
/
API.pm
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
package Test2::API;
use strict;
use warnings;
use Time::HiRes qw/time/;
use Test2::Util qw/USE_THREADS/;
BEGIN {
$ENV{TEST_ACTIVE} ||= 1;
$ENV{TEST2_ACTIVE} = 1;
}
our $VERSION = '1.302197';
my $INST;
my $ENDING = 0;
sub test2_unset_is_end { $ENDING = 0 }
sub test2_get_is_end { $ENDING }
sub test2_set_is_end {
my $before = $ENDING;
($ENDING) = @_ ? @_ : (1);
# Only send the event in a transition from false to true
return if $before;
return unless $ENDING;
return unless $INST;
my $stack = $INST->stack or return;
my $root = $stack->root or return;
return unless $root->count;
return unless $$ == $INST->pid;
return unless get_tid() == $INST->tid;
my $trace = Test2::EventFacet::Trace->new(
frame => [__PACKAGE__, __FILE__, __LINE__, __PACKAGE__ . '::test2_set_is_end'],
);
my $ctx = Test2::API::Context->new(
trace => $trace,
hub => $root,
);
$ctx->send_ev2(control => { phase => 'END', details => 'Transition to END phase' });
1;
}
use Test2::API::Instance(\$INST);
# Set the exit status
END {
test2_set_is_end(); # See gh #16
$INST->set_exit();
}
sub CLONE {
my $init = test2_init_done();
my $load = test2_load_done();
return if $init && $load;
require Carp;
Carp::croak "Test2 must be fully loaded before you start a new thread!\n";
}
# See gh #16
{
no warnings;
INIT { eval 'END { test2_set_is_end() }; 1' or die $@ }
}
BEGIN {
no warnings 'once';
if($] ge '5.014' || $ENV{T2_CHECK_DEPTH} || $Test2::API::DO_DEPTH_CHECK) {
*DO_DEPTH_CHECK = sub() { 1 };
}
else {
*DO_DEPTH_CHECK = sub() { 0 };
}
}
use Test2::EventFacet::Trace();
use Test2::Util::Trace(); # Legacy
use Test2::Hub::Subtest();
use Test2::Hub::Interceptor();
use Test2::Hub::Interceptor::Terminator();
use Test2::Event::Ok();
use Test2::Event::Diag();
use Test2::Event::Note();
use Test2::Event::Plan();
use Test2::Event::Bail();
use Test2::Event::Exception();
use Test2::Event::Waiting();
use Test2::Event::Skip();
use Test2::Event::Subtest();
use Carp qw/carp croak confess/;
use Scalar::Util qw/blessed weaken/;
use Test2::Util qw/get_tid clone_io pkg_to_file gen_uid/;
our @EXPORT_OK = qw{
context release
context_do
no_context
intercept intercept_deep
run_subtest
test2_init_done
test2_load_done
test2_load
test2_start_preload
test2_stop_preload
test2_in_preload
test2_is_testing_done
test2_set_is_end
test2_unset_is_end
test2_get_is_end
test2_pid
test2_tid
test2_stack
test2_no_wait
test2_ipc_wait_enable
test2_ipc_wait_disable
test2_ipc_wait_enabled
test2_add_uuid_via
test2_add_callback_testing_done
test2_add_callback_context_aquire
test2_add_callback_context_acquire
test2_add_callback_context_init
test2_add_callback_context_release
test2_add_callback_exit
test2_add_callback_post_load
test2_add_callback_pre_subtest
test2_list_context_aquire_callbacks
test2_list_context_acquire_callbacks
test2_list_context_init_callbacks
test2_list_context_release_callbacks
test2_list_exit_callbacks
test2_list_post_load_callbacks
test2_list_pre_subtest_callbacks
test2_ipc
test2_has_ipc
test2_ipc_disable
test2_ipc_disabled
test2_ipc_drivers
test2_ipc_add_driver
test2_ipc_polling
test2_ipc_disable_polling
test2_ipc_enable_polling
test2_ipc_get_pending
test2_ipc_set_pending
test2_ipc_get_timeout
test2_ipc_set_timeout
test2_formatter
test2_formatters
test2_formatter_add
test2_formatter_set
test2_stdout
test2_stderr
test2_reset_io
test2_enable_trace_stamps
test2_disable_trace_stamps
test2_trace_stamps_enabled
};
BEGIN { require Exporter; our @ISA = qw(Exporter) }
my $STACK = $INST->stack;
my $CONTEXTS = $INST->contexts;
my $INIT_CBS = $INST->context_init_callbacks;
my $ACQUIRE_CBS = $INST->context_acquire_callbacks;
my $STDOUT = clone_io(\*STDOUT);
my $STDERR = clone_io(\*STDERR);
sub test2_stdout { $STDOUT ||= clone_io(\*STDOUT) }
sub test2_stderr { $STDERR ||= clone_io(\*STDERR) }
sub test2_post_preload_reset {
test2_reset_io();
$INST->post_preload_reset;
}
sub test2_reset_io {
$STDOUT = clone_io(\*STDOUT);
$STDERR = clone_io(\*STDERR);
}
sub test2_init_done { $INST->finalized }
sub test2_load_done { $INST->loaded }
sub test2_load { $INST->load }
sub test2_start_preload { $ENV{T2_IN_PRELOAD} = 1; $INST->start_preload }
sub test2_stop_preload { $ENV{T2_IN_PRELOAD} = 0; $INST->stop_preload }
sub test2_in_preload { $INST->preload }
sub test2_pid { $INST->pid }
sub test2_tid { $INST->tid }
sub test2_stack { $INST->stack }
sub test2_ipc_wait_enable { $INST->set_no_wait(0) }
sub test2_ipc_wait_disable { $INST->set_no_wait(1) }
sub test2_ipc_wait_enabled { !$INST->no_wait }
sub test2_enable_trace_stamps { $INST->test2_enable_trace_stamps }
sub test2_disable_trace_stamps { $INST->test2_disable_trace_stamps }
sub test2_trace_stamps_enabled { $INST->test2_trace_stamps_enabled }
sub test2_is_testing_done {
# No instance? VERY DONE!
return 1 unless $INST;
# No stack? tests must be done, it is created pretty early
my $stack = $INST->stack or return 1;
# Nothing on the stack, no root hub yet, likely have not started testing
return 0 unless @$stack;
# Stack has a slot for the root hub (see above) but it is undefined, likely
# garbage collected, test is done
my $root_hub = $stack->[0] or return 1;
# If the root hub is ended than testing is done.
return 1 if $root_hub->ended;
# Looks like we are still testing!
return 0;
}
sub test2_no_wait {
$INST->set_no_wait(@_) if @_;
$INST->no_wait;
}
sub test2_add_callback_testing_done {
my $cb = shift;
test2_add_callback_post_load(sub {
my $stack = test2_stack();
$stack->top; # Ensure we have a hub
my ($hub) = Test2::API::test2_stack->all;
$hub->set_active(1);
$hub->follow_up($cb);
});
return;
}
sub test2_add_callback_context_acquire { $INST->add_context_acquire_callback(@_) }
sub test2_add_callback_context_aquire { $INST->add_context_acquire_callback(@_) }
sub test2_add_callback_context_init { $INST->add_context_init_callback(@_) }
sub test2_add_callback_context_release { $INST->add_context_release_callback(@_) }
sub test2_add_callback_exit { $INST->add_exit_callback(@_) }
sub test2_add_callback_post_load { $INST->add_post_load_callback(@_) }
sub test2_add_callback_pre_subtest { $INST->add_pre_subtest_callback(@_) }
sub test2_list_context_aquire_callbacks { @{$INST->context_acquire_callbacks} }
sub test2_list_context_acquire_callbacks { @{$INST->context_acquire_callbacks} }
sub test2_list_context_init_callbacks { @{$INST->context_init_callbacks} }
sub test2_list_context_release_callbacks { @{$INST->context_release_callbacks} }
sub test2_list_exit_callbacks { @{$INST->exit_callbacks} }
sub test2_list_post_load_callbacks { @{$INST->post_load_callbacks} }
sub test2_list_pre_subtest_callbacks { @{$INST->pre_subtest_callbacks} }
sub test2_add_uuid_via {
$INST->set_add_uuid_via(@_) if @_;
$INST->add_uuid_via();
}
sub test2_ipc { $INST->ipc }
sub test2_has_ipc { $INST->has_ipc }
sub test2_ipc_disable { $INST->ipc_disable }
sub test2_ipc_disabled { $INST->ipc_disabled }
sub test2_ipc_add_driver { $INST->add_ipc_driver(@_) }
sub test2_ipc_drivers { @{$INST->ipc_drivers} }
sub test2_ipc_polling { $INST->ipc_polling }
sub test2_ipc_enable_polling { $INST->enable_ipc_polling }
sub test2_ipc_disable_polling { $INST->disable_ipc_polling }
sub test2_ipc_get_pending { $INST->get_ipc_pending }
sub test2_ipc_set_pending { $INST->set_ipc_pending(@_) }
sub test2_ipc_set_timeout { $INST->set_ipc_timeout(@_) }
sub test2_ipc_get_timeout { $INST->ipc_timeout() }
sub test2_ipc_enable_shm { 0 }
sub test2_formatter {
if ($ENV{T2_FORMATTER} && $ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) {
my $formatter = $1 ? $2 : "Test2::Formatter::$2";
my $file = pkg_to_file($formatter);
require $file;
return $formatter;
}
return $INST->formatter;
}
sub test2_formatters { @{$INST->formatters} }
sub test2_formatter_add { $INST->add_formatter(@_) }
sub test2_formatter_set {
my ($formatter) = @_;
croak "No formatter specified" unless $formatter;
croak "Global Formatter already set" if $INST->formatter_set;
$INST->set_formatter($formatter);
}
# Private, for use in Test2::API::Context
sub _contexts_ref { $INST->contexts }
sub _context_acquire_callbacks_ref { $INST->context_acquire_callbacks }
sub _context_init_callbacks_ref { $INST->context_init_callbacks }
sub _context_release_callbacks_ref { $INST->context_release_callbacks }
sub _add_uuid_via_ref { \($INST->{Test2::API::Instance::ADD_UUID_VIA()}) }
# Private, for use in Test2::IPC
sub _set_ipc { $INST->set_ipc(@_) }
sub context_do(&;@) {
my $code = shift;
my @args = @_;
my $ctx = context(level => 1);
my $want = wantarray;
my @out;
my $ok = eval {
$want ? @out = $code->($ctx, @args) :
defined($want) ? $out[0] = $code->($ctx, @args) :
$code->($ctx, @args) ;
1;
};
my $err = $@;
$ctx->release;
die $err unless $ok;
return @out if $want;
return $out[0] if defined $want;
return;
}
sub no_context(&;$) {
my ($code, $hid) = @_;
$hid ||= $STACK->top->hid;
my $ctx = $CONTEXTS->{$hid};
delete $CONTEXTS->{$hid};
my $ok = eval { $code->(); 1 };
my $err = $@;
$CONTEXTS->{$hid} = $ctx;
weaken($CONTEXTS->{$hid});
die $err unless $ok;
return;
};
my $UUID_VIA = _add_uuid_via_ref();
sub context {
# We need to grab these before anything else to ensure they are not
# changed.
my ($errno, $eval_error, $child_error, $extended_error) = (0 + $!, $@, $?, $^E);
my %params = (level => 0, wrapped => 0, @_);
# If something is getting a context then the sync system needs to be
# considered loaded...
$INST->load unless $INST->{loaded};
croak "context() called, but return value is ignored"
unless defined wantarray;
my $stack = $params{stack} || $STACK;
my $hub = $params{hub} || (@$stack ? $stack->[-1] : $stack->top);
# Catch an edge case where we try to get context after the root hub has
# been garbage collected resulting in a stack that has a single undef
# hub
if (!($hub && $hub->{hid}) && !exists($params{hub}) && @$stack) {
my $msg;
if ($hub && !$hub->{hid}) {
$msg = Carp::longmess("$hub has no hid! (did you attempt a testing event after done_testing?). You may be relying on a tool or plugin that was based off an old Test2 that did not require hids.");
}
else {
$msg = Carp::longmess("Attempt to get Test2 context after testing has completed (did you attempt a testing event after done_testing?)");
}
# The error message is usually masked by the global destruction, so we have to print to STDER
print STDERR $msg;
# Make sure this is a failure, we are probably already in END, so set $? to change the exit code
$? = 1;
# Now we actually die to interrupt the program flow and avoid undefined his warnings
die $msg;
}
my $hid = $hub->{hid};
my $current = $CONTEXTS->{$hid};
$_->(\%params) for @$ACQUIRE_CBS;
map $_->(\%params), @{$hub->{_context_acquire}} if $hub->{_context_acquire};
# This is for https://github.com/Test-More/test-more/issues/16
# and https://rt.perl.org/Public/Bug/Display.html?id=127774
my $phase = ${^GLOBAL_PHASE} || 'NA';
my $end_phase = $ENDING || $phase eq 'END' || $phase eq 'DESTRUCT';
my $level = 1 + $params{level};
my ($pkg, $file, $line, $sub, @other) = $end_phase ? caller(0) : caller($level);
unless ($pkg || $end_phase) {
confess "Could not find context at depth $level" unless $params{fudge};
($pkg, $file, $line, $sub, @other) = caller(--$level) while ($level >= 0 && !$pkg);
}
my $depth = $level;
$depth++ while DO_DEPTH_CHECK && !$end_phase && (!$current || $depth <= $current->{_depth} + $params{wrapped}) && caller($depth + 1);
$depth -= $params{wrapped};
my $depth_ok = !DO_DEPTH_CHECK || $end_phase || !$current || $current->{_depth} < $depth;
if ($current && $params{on_release} && $depth_ok) {
$current->{_on_release} ||= [];
push @{$current->{_on_release}} => $params{on_release};
}
# I know this is ugly....
($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_error) and return bless(
{
%$current,
_is_canon => undef,
errno => $errno,
eval_error => $eval_error,
child_error => $child_error,
_is_spawn => [$pkg, $file, $line, $sub],
},
'Test2::API::Context'
) if $current && $depth_ok;
# Handle error condition of bad level
if ($current) {
unless (${$current->{_aborted}}) {
_canon_error($current, [$pkg, $file, $line, $sub, $depth])
unless $current->{_is_canon};
_depth_error($current, [$pkg, $file, $line, $sub, $depth])
unless $depth_ok;
}
$current->release if $current->{_is_canon};
delete $CONTEXTS->{$hid};
}
# Directly bless the object here, calling new is a noticeable performance
# hit with how often this needs to be called.
my $trace = bless(
{
frame => [$pkg, $file, $line, $sub],
pid => $$,
tid => get_tid(),
cid => gen_uid(),
hid => $hid,
nested => $hub->{nested},
buffered => $hub->{buffered},
full_caller => [$pkg, $file, $line, $sub, @other],
$INST->{trace_stamps} ? (stamp => time()) : (),
$$UUID_VIA ? (
huuid => $hub->{uuid},
uuid => ${$UUID_VIA}->('context'),
) : (),
},
'Test2::EventFacet::Trace'
);
# Directly bless the object here, calling new is a noticeable performance
# hit with how often this needs to be called.
my $aborted = 0;
$current = bless(
{
_aborted => \$aborted,
stack => $stack,
hub => $hub,
trace => $trace,
_is_canon => 1,
_depth => $depth,
errno => $errno,
eval_error => $eval_error,
child_error => $child_error,
$params{on_release} ? (_on_release => [$params{on_release}]) : (),
},
'Test2::API::Context'
);
$CONTEXTS->{$hid} = $current;
weaken($CONTEXTS->{$hid});
$_->($current) for @$INIT_CBS;
map $_->($current), @{$hub->{_context_init}} if $hub->{_context_init};
$params{on_init}->($current) if $params{on_init};
($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_error);
return $current;
}
sub _depth_error {
_existing_error(@_, <<" EOT");
context() was called to retrieve an existing context, however the existing
context was created in a stack frame at the same, or deeper level. This usually
means that a tool failed to release the context when it was finished.
EOT
}
sub _canon_error {
_existing_error(@_, <<" EOT");
context() was called to retrieve an existing context, however the existing
context has an invalid internal state (!_canon_count). This should not normally
happen unless something is mucking about with internals...
EOT
}
sub _existing_error {
my ($ctx, $details, $msg) = @_;
my ($pkg, $file, $line, $sub, $depth) = @$details;
my $oldframe = $ctx->{trace}->frame;
my $olddepth = $ctx->{_depth};
# Older versions of Carp do not export longmess() function, so it needs to be called with package name
my $mess = Carp::longmess();
warn <<" EOT";
$msg
Old context details:
File: $oldframe->[1]
Line: $oldframe->[2]
Tool: $oldframe->[3]
Depth: $olddepth
New context details:
File: $file
Line: $line
Tool: $sub
Depth: $depth
Trace: $mess
Removing the old context and creating a new one...
EOT
}
sub release($;$) {
$_[0]->release;
return $_[1];
}
sub intercept(&) {
my $code = shift;
my $ctx = context();
my $events = _intercept($code, deep => 0);
$ctx->release;
return $events;
}
sub intercept_deep(&) {
my $code = shift;
my $ctx = context();
my $events = _intercept($code, deep => 1);
$ctx->release;
return $events;
}
sub _intercept {
my $code = shift;
my %params = @_;
my $ctx = context();
my $ipc;
if (my $global_ipc = test2_ipc()) {
my $driver = blessed($global_ipc);
$ipc = $driver->new;
}
my $hub = Test2::Hub::Interceptor->new(
ipc => $ipc,
no_ending => 1,
);
my @events;
$hub->listen(sub { push @events => $_[1] }, inherit => $params{deep});
$ctx->stack->top; # Make sure there is a top hub before we begin.
$ctx->stack->push($hub);
my $trace = $ctx->trace;
my $state = {};
$hub->clean_inherited(trace => $trace, state => $state);
my ($ok, $err) = (1, undef);
T2_SUBTEST_WRAPPER: {
# Do not use 'try' cause it localizes __DIE__
$ok = eval { $code->(hub => $hub, context => $ctx->snapshot); 1 };
$err = $@;
# They might have done 'BEGIN { skip_all => "whatever" }'
if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && $err->isa('Test2::Hub::Interceptor::Terminator'))) {
$ok = 1;
$err = undef;
}
}
$hub->cull;
$ctx->stack->pop($hub);
$hub->restore_inherited(trace => $trace, state => $state);
$ctx->release;
die $err unless $ok;
$hub->finalize($trace, 1)
if $ok
&& !$hub->no_ending
&& !$hub->ended;
require Test2::API::InterceptResult;
return Test2::API::InterceptResult->new_from_ref(\@events);
}
sub run_subtest {
my ($name, $code, $params, @args) = @_;
$_->($name,$code,@args)
for Test2::API::test2_list_pre_subtest_callbacks();
$params = {buffered => $params} unless ref $params;
my $inherit_trace = delete $params->{inherit_trace};
my $ctx = context();
my $parent = $ctx->hub;
# If a parent is buffered then the child must be as well.
my $buffered = $params->{buffered} || $parent->{buffered};
$ctx->note($name) unless $buffered;
my $stack = $ctx->stack || $STACK;
my $hub = $stack->new_hub(
class => 'Test2::Hub::Subtest',
%$params,
buffered => $buffered,
);
my @events;
$hub->listen(sub { push @events => $_[1] });
if ($buffered) {
if (my $format = $hub->format) {
my $hide = $format->can('hide_buffered') ? $format->hide_buffered : 1;
$hub->format(undef) if $hide;
}
}
if ($inherit_trace) {
my $orig = $code;
$code = sub {
my $base_trace = $ctx->trace;
my $trace = $base_trace->snapshot(nested => 1 + $base_trace->nested);
my $st_ctx = Test2::API::Context->new(
trace => $trace,
hub => $hub,
);
$st_ctx->do_in_context($orig, @args);
};
}
my $start_stamp = time;
my ($ok, $err, $finished);
T2_SUBTEST_WRAPPER: {
# Do not use 'try' cause it localizes __DIE__
$ok = eval { $code->(@args); 1 };
$err = $@;
# They might have done 'BEGIN { skip_all => "whatever" }'
if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) {
$ok = undef;
$err = undef;
}
else {
$finished = 1;
}
}
my $stop_stamp = time;
if ($params->{no_fork}) {
if ($$ != $ctx->trace->pid) {
warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err;
exit 255;
}
if (get_tid() != $ctx->trace->tid) {
warn $ok ? "Started new thread inside subtest, but thread never finished!\n" : $err;
exit 255;
}
}
elsif (!$parent->is_local && !$parent->ipc) {
warn $ok ? "A new process or thread was started inside subtest, but IPC is not enabled!\n" : $err;
exit 255;
}
$stack->pop($hub);
my $trace = $ctx->trace;
my $bailed = $hub->bailed_out;
if (!$finished) {
if ($bailed && !$buffered) {
$ctx->bail($bailed->reason);
}
elsif ($bailed && $buffered) {
$ok = 1;
}
else {
my $code = $hub->exit_code;
$ok = !$code;
$err = "Subtest ended with exit code $code" if $code;
}
}
$hub->finalize($trace->snapshot(huuid => $hub->uuid, hid => $hub->hid, nested => $hub->nested, buffered => $buffered), 1)
if $ok
&& !$hub->no_ending
&& !$hub->ended;
my $pass = $ok && $hub->is_passing;
my $e = $ctx->build_event(
'Subtest',
pass => $pass,
name => $name,
subtest_id => $hub->id,
subtest_uuid => $hub->uuid,
buffered => $buffered,
subevents => \@events,
start_stamp => $start_stamp,
stop_stamp => $stop_stamp,
);
my $plan_ok = $hub->check_plan;
$ctx->hub->send($e);
$ctx->failure_diag($e) unless $e->pass;
$ctx->diag("Caught exception in subtest: $err") unless $ok;
$ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count)
if defined($plan_ok) && !$plan_ok;
$ctx->bail($bailed->reason) if $bailed && $buffered;
$ctx->release;
return $pass;
}
# There is a use-cycle between API and API/Context. Context needs to use some
# API functions as the package is compiling. Test2::API::context() needs
# Test2::API::Context to be loaded, but we cannot 'require' the module there as
# it causes a very noticeable performance impact with how often context() is
# called.
require Test2::API::Context;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::API - Primary interface for writing Test2 based testing tools.
=head1 ***INTERNALS NOTE***
B<The internals of this package are subject to change at any time!> The public
methods provided will not change in backwards-incompatible ways (once there is
a stable release), but the underlying implementation details might.
B<Do not break encapsulation here!>
Currently the implementation is to create a single instance of the
L<Test2::API::Instance> Object. All class methods defer to the single
instance. There is no public access to the singleton, and that is intentional.
The class methods provided by this package provide the only functionality
publicly exposed.
This is done primarily to avoid the problems Test::Builder had by exposing its
singleton. We do not want anyone to replace this singleton, rebless it, or
directly muck with its internals. If you need to do something and cannot
because of the restrictions placed here, then please report it as an issue. If
possible, we will create a way for you to implement your functionality without
exposing things that should not be exposed.
=head1 DESCRIPTION
This package exports all the functions necessary to write and/or verify testing
tools. Using these building blocks you can begin writing test tools very
quickly. You are also provided with tools that help you to test the tools you
write.
=head1 SYNOPSIS
=head2 WRITING A TOOL
The C<context()> method is your primary interface into the Test2 framework.
package My::Ok;
use Test2::API qw/context/;
our @EXPORT = qw/my_ok/;
use base 'Exporter';
# Just like ok() from Test::More
sub my_ok($;$) {
my ($bool, $name) = @_;
my $ctx = context(); # Get a context
$ctx->ok($bool, $name);
$ctx->release; # Release the context
return $bool;
}
See L<Test2::API::Context> for a list of methods available on the context object.
=head2 TESTING YOUR TOOLS
The C<intercept { ... }> tool lets you temporarily intercept all events
generated by the test system:
use Test2::API qw/intercept/;
use My::Ok qw/my_ok/;
my $events = intercept {
# These events are not displayed
my_ok(1, "pass");
my_ok(0, "fail");
};
As of version 1.302178 this now returns an arrayref that is also an instance of
L<Test2::API::InterceptResult>. See the L<Test2::API::InterceptResult>
documentation for details on how to best use it.
=head2 OTHER API FUNCTIONS
use Test2::API qw{
test2_init_done
test2_stack
test2_set_is_end
test2_get_is_end
test2_ipc
test2_formatter_set
test2_formatter
test2_is_testing_done
};
my $init = test2_init_done();
my $stack = test2_stack();
my $ipc = test2_ipc();
test2_formatter_set($FORMATTER)
my $formatter = test2_formatter();
... And others ...
=head1 MAIN API EXPORTS
All exports are optional. You must specify subs to import.
use Test2::API qw/context intercept run_subtest/;
This is the list of exports that are most commonly needed. If you are simply
writing a tool, then this is probably all you need. If you need something and
you cannot find it here, then you can also look at L</OTHER API EXPORTS>.
These exports lack the 'test2_' prefix because of how important/common they
are. Exports in the L</OTHER API EXPORTS> section have the 'test2_' prefix to
ensure they stand out.
=head2 context(...)
Usage:
=over 4
=item $ctx = context()
=item $ctx = context(%params)
=back
The C<context()> function will always return the current context. If
there is already a context active, it will be returned. If there is not an
active context, one will be generated. When a context is generated it will
default to using the file and line number where the currently running sub was
called from.
Please see L<Test2::API::Context/"CRITICAL DETAILS"> for important rules about
what you can and cannot do with a context once it is obtained.
B<Note> This function will throw an exception if you ignore the context object
it returns.
B<Note> On perls 5.14+ a depth check is used to ensure there are no context
leaks. This cannot be safely done on older perls due to
L<https://rt.perl.org/Public/Bug/Display.html?id=127774>
You can forcefully enable it either by setting C<$ENV{T2_CHECK_DEPTH} = 1> or
C<$Test2::API::DO_DEPTH_CHECK = 1> B<BEFORE> loading L<Test2::API>.
=head3 OPTIONAL PARAMETERS
All parameters to C<context> are optional.
=over 4
=item level => $int
If you must obtain a context in a sub deeper than your entry point you can use
this to tell it how many EXTRA stack frames to look back. If this option is not
provided the default of C<0> is used.
sub third_party_tool {
my $sub = shift;
... # Does not obtain a context
$sub->();
...
}
third_party_tool(sub {
my $ctx = context(level => 1);
...
$ctx->release;
});
=item wrapped => $int
Use this if you need to write your own tool that wraps a call to C<context()>
with the intent that it should return a context object.
sub my_context {
my %params = ( wrapped => 0, @_ );
$params{wrapped}++;
my $ctx = context(%params);
...
return $ctx;
}
sub my_tool {
my $ctx = my_context();
...
$ctx->release;
}
If you do not do this, then tools you call that also check for a context will
notice that the context they grabbed was created at the same stack depth, which
will trigger protective measures that warn you and destroy the existing
context.
=item stack => $stack
Normally C<context()> looks at the global hub stack. If you are maintaining
your own L<Test2::API::Stack> instance you may pass it in to be used
instead of the global one.