xref: /openbsd-src/gnu/usr.bin/perl/cpan/Test-Simple/t/Test2/modules/API/Instance.t (revision 5486feefcc8cb79b19e014ab332cc5dfd05b3b33)
1use strict;
2use warnings;
3
4use Test2::IPC;
5use Test2::Tools::Tiny;
6use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK USE_THREADS get_tid/;
7
8ok(1, "Just to get things initialized.");
9
10# We need to control these env vars for this test
11$ENV{T2_NO_IPC} = 0;
12$ENV{T2_TRACE_STAMPS} = 0;
13# This test relies on TAP being the default formatter for non-canon instances
14$ENV{T2_FORMATTER} = 'TAP';
15
16my $CLASS = 'Test2::API::Instance';
17
18my $one = $CLASS->new;
19is_deeply(
20    $one,
21    {
22        contexts => {},
23
24        finalized => undef,
25        ipc       => undef,
26        formatter => undef,
27
28        add_uuid_via => undef,
29
30        ipc_polling    => undef,
31        ipc_drivers    => [],
32        ipc_timeout    => 30,
33        ipc_disabled   => 0,
34
35        formatters => [],
36
37        no_wait => 0,
38        loaded  => 0,
39
40        exit_callbacks            => [],
41        post_load_callbacks       => [],
42        context_acquire_callbacks => [],
43        context_init_callbacks    => [],
44        context_release_callbacks => [],
45        pre_subtest_callbacks     => [],
46
47        trace_stamps => 0,
48
49        stack => [],
50    },
51    "Got initial settings"
52);
53
54%$one = ();
55is_deeply($one, {}, "wiped object");
56
57$one->reset;
58is_deeply(
59    $one,
60    {
61        contexts => {},
62
63        ipc_polling  => undef,
64        ipc_drivers  => [],
65        ipc_timeout  => 30,
66        ipc_disabled => 0,
67
68        add_uuid_via => undef,
69
70        formatters => [],
71
72        finalized => undef,
73        ipc       => undef,
74        formatter => undef,
75
76        no_wait => 0,
77        loaded  => 0,
78
79        exit_callbacks            => [],
80        post_load_callbacks       => [],
81        context_acquire_callbacks => [],
82        context_init_callbacks    => [],
83        context_release_callbacks => [],
84        pre_subtest_callbacks     => [],
85
86        trace_stamps => 0,
87
88        stack => [],
89    },
90    "Reset Object"
91);
92
93ok(!$one->formatter_set, "no formatter set");
94$one->set_formatter('Foo');
95ok($one->formatter_set, "formatter set");
96$one->reset;
97
98my $ran = 0;
99my $callback = sub { $ran++ };
100$one->add_post_load_callback($callback);
101ok(!$ran, "did not run yet");
102is_deeply($one->post_load_callbacks, [$callback], "stored callback for later");
103
104ok(!$one->loaded, "not loaded");
105$one->load;
106ok($one->loaded, "loaded");
107is($ran, 1, "ran the callback");
108
109$one->load;
110is($ran, 1, "Did not run the callback again");
111
112$one->add_post_load_callback($callback);
113is($ran, 2, "ran the new callback");
114is_deeply($one->post_load_callbacks, [$callback, $callback], "stored callback for the record");
115
116like(
117    exception { $one->add_post_load_callback({}) },
118    qr/Post-load callbacks must be coderefs/,
119    "Post-load callbacks must be coderefs"
120);
121
122$one->reset;
123ok($one->ipc, 'got ipc');
124ok($one->finalized, "calling ipc finalized the object");
125
126$one->reset;
127ok($one->stack, 'got stack');
128ok(!$one->finalized, "calling stack did not finaliz the object");
129
130$one->reset;
131ok($one->formatter, 'Got formatter');
132ok($one->finalized, "calling format finalized the object");
133
134$one->reset;
135$one->set_formatter('Foo');
136is($one->formatter, 'Foo', "got specified formatter");
137ok($one->finalized, "calling format finalized the object");
138
139{
140    local $ENV{T2_FORMATTER} = 'TAP';
141    my $one = $CLASS->new;
142    is($one->formatter, 'Test2::Formatter::TAP', "got specified formatter");
143    ok($one->finalized, "calling format finalized the object");
144
145    local $ENV{T2_FORMATTER} = '+Test2::Formatter::TAP';
146    $one->reset;
147    is($one->formatter, 'Test2::Formatter::TAP', "got specified formatter");
148    ok($one->finalized, "calling format finalized the object");
149
150    local $ENV{T2_FORMATTER} = '+A::Fake::Module::That::Should::Not::Exist';
151    $one->reset;
152    like(
153        exception { $one->formatter },
154        qr/COULD NOT LOAD FORMATTER 'A::Fake::Module::That::Should::Not::Exist' \(set by the 'T2_FORMATTER' environment variable\)/,
155        "Bad formatter"
156    );
157}
158
159$ran = 0;
160$one->reset;
161$one->add_exit_callback($callback);
162is(@{$one->exit_callbacks}, 1, "added an exit callback");
163$one->add_exit_callback($callback);
164is(@{$one->exit_callbacks}, 2, "added another exit callback");
165
166like(
167    exception { $one->add_exit_callback({}) },
168    qr/End callbacks must be coderefs/,
169    "Exit callbacks must be coderefs"
170);
171
172$one->reset;
173$one->add_pre_subtest_callback($callback);
174is(@{$one->pre_subtest_callbacks}, 1, "added a pre-subtest callback");
175$one->add_pre_subtest_callback($callback);
176is(@{$one->pre_subtest_callbacks}, 2, "added another pre-subtest callback");
177
178like(
179    exception { $one->add_pre_subtest_callback({}) },
180    qr/Pre-subtest callbacks must be coderefs/,
181    "Pre-subtest callbacks must be coderefs"
182);
183
184if (CAN_REALLY_FORK) {
185    my $one = $CLASS->new;
186    my $pid = fork;
187    die "Failed to fork!" unless defined $pid;
188    unless($pid) { exit 0 }
189
190    is(Test2::API::Instance::_ipc_wait, 0, "No errors");
191
192    $pid = fork;
193    die "Failed to fork!" unless defined $pid;
194    unless($pid) { exit 255 }
195    my @warnings;
196    {
197        local $SIG{__WARN__} = sub { push @warnings => @_ };
198        is(Test2::API::Instance::_ipc_wait, 255, "Process exited badly");
199    }
200    like($warnings[0], qr/Process .* did not exit cleanly \(wstat: \S+, exit: 255, sig: 0\)/, "Warn about exit");
201
202    $pid = fork;
203    die "Failed to fork!" unless defined $pid;
204    unless($pid) { sleep 20; exit 0 }
205    kill('TERM', $pid) or die "Failed to send signal";
206    @warnings = ();
207    {
208        local $SIG{__WARN__} = sub { push @warnings => @_ };
209        is(Test2::API::Instance::_ipc_wait, 255, "Process exited badly");
210    }
211    like($warnings[0], qr/Process .* did not exit cleanly \(wstat: \S+, exit: 0, sig: 15\)/, "Warn about exit");
212}
213
214if (CAN_THREAD && $] ge '5.010') {
215    require threads;
216    my $one = $CLASS->new;
217
218    threads->new(sub { 1 });
219    is(Test2::API::Instance::_ipc_wait, 0, "No errors");
220
221    if (threads->can('error')) {
222        threads->new(sub {
223            close(STDERR);
224            close(STDOUT);
225            die "xxx"
226        });
227        my @warnings;
228        {
229            local $SIG{__WARN__} = sub { push @warnings => @_ };
230            is(Test2::API::Instance::_ipc_wait, 255, "Thread exited badly");
231        }
232        like($warnings[0], qr/Thread .* did not end cleanly: xxx/, "Warn about exit");
233    }
234}
235
236{
237    my $one = $CLASS->new;
238    local $? = 0;
239    $one->set_exit;
240    is($?, 0, "no errors on exit");
241}
242
243{
244    my $one = $CLASS->new;
245    $one->set__tid(1);
246    local $? = 0;
247    $one->set_exit;
248    is($?, 0, "no errors on exit");
249}
250
251{
252    my $one = $CLASS->new;
253    $one->stack->top;
254    $one->set_no_wait(1);
255    local $? = 0;
256    $one->set_exit;
257    is($?, 0, "no errors on exit");
258}
259
260{
261    my $one = $CLASS->new;
262    $one->stack->top->set_no_ending(1);
263    local $? = 0;
264    $one->set_exit;
265    is($?, 0, "no errors on exit");
266}
267
268{
269    my $one = $CLASS->new;
270    $one->load();
271    $one->stack->top->set_failed(2);
272    local $? = 0;
273    $one->set_exit;
274    is($?, 2, "number of failures");
275}
276
277{
278    my $one = $CLASS->new;
279    $one->load();
280    local $? = 500;
281    $one->set_exit;
282    is($?, 255, "set exit code to a sane number");
283}
284
285{
286    local %INC = %INC;
287    delete $INC{'Test2/IPC.pm'};
288    my $one = $CLASS->new;
289    $one->load();
290    my @events;
291    $one->stack->top->filter(sub { push @events => $_[1]; undef});
292    $one->stack->new_hub;
293    local $? = 0;
294    $one->set_exit;
295    is($?, 255, "errors on exit");
296    like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag");
297}
298
299SKIP: {
300    last SKIP if $] lt "5.008";
301    my $one = $CLASS->new;
302    my $stderr = "";
303    {
304        local $INC{'Test/Builder.pm'} = __FILE__;
305        local $Test2::API::VERSION    = '0.002';
306        local $Test::Builder::VERSION = '0.001';
307        local *STDERR;
308        open(STDERR, '>', \$stderr) or print "Failed to open new STDERR";
309
310        $one->set_exit;
311    }
312
313    is($stderr, <<'    EOT', "Got warning about version mismatch");
314
315********************************************************************************
316*                                                                              *
317*            Test::Builder -- Test2::API version mismatch detected             *
318*                                                                              *
319********************************************************************************
320   Test2::API Version: 0.002
321Test::Builder Version: 0.001
322
323This is not a supported configuration, you will have problems.
324
325    EOT
326}
327
328SKIP: {
329    last SKIP if $] lt "5.008";
330    require Test2::API::Breakage;
331    no warnings qw/redefine once/;
332    my $ran = 0;
333    local *Test2::API::Breakage::report = sub { $ran++; return "foo" };
334    use warnings qw/redefine once/;
335    my $one = $CLASS->new;
336    $one->load();
337
338    my $stderr = "";
339    {
340        local *STDERR;
341        open(STDERR, '>', \$stderr) or print "Failed to open new STDERR";
342        local $? = 255;
343        $one->set_exit;
344    }
345
346    is($stderr, <<"    EOT", "Reported bad modules");
347
348You have loaded versions of test modules known to have problems with Test2.
349This could explain some test failures.
350foo
351
352    EOT
353}
354
355
356{
357    my $one = $CLASS->new;
358    $one->load();
359    my @events;
360    $one->stack->top->filter(sub { push @events => $_[1]; undef});
361    $one->stack->new_hub;
362    ok($one->stack->top->ipc, "Have IPC");
363    $one->stack->new_hub;
364    ok($one->stack->top->ipc, "Have IPC");
365    $one->stack->top->set_ipc(undef);
366    ok(!$one->stack->top->ipc, "no IPC");
367    $one->stack->new_hub;
368    local $? = 0;
369    $one->set_exit;
370    is($?, 255, "errors on exit");
371    like($events[0]->message, qr/Test ended with extra hubs on the stack!/, "got diag");
372}
373
374if (CAN_REALLY_FORK) {
375    local $SIG{__WARN__} = sub { };
376    my $one = $CLASS->new;
377    my $pid = fork;
378    die "Failed to fork!" unless defined $pid;
379    unless ($pid) { exit 255 }
380    $one->_finalize;
381    $one->stack->top;
382
383    local $? = 0;
384    $one->set_exit;
385    is($?, 255, "errors on exit");
386
387    $one->reset();
388    $pid = fork;
389    die "Failed to fork!" unless defined $pid;
390    unless ($pid) { exit 255 }
391    $one->_finalize;
392    $one->stack->top;
393
394    local $? = 122;
395    $one->set_exit;
396    is($?, 122, "kept original exit");
397}
398
399{
400    my $one = $CLASS->new;
401    my $ctx = bless {
402        trace => Test2::EventFacet::Trace->new(frame => ['Foo::Bar', 'Foo/Bar.pm', 42, 'xxx']),
403        hub => Test2::Hub->new(),
404    }, 'Test2::API::Context';
405    $one->contexts->{1234} = $ctx;
406
407    local $? = 500;
408    my $warnings = warnings { $one->set_exit };
409    is($?, 255, "set exit code to a sane number");
410
411    is_deeply(
412        $warnings,
413        [
414            "context object was never released! This means a testing tool is behaving very badly at Foo/Bar.pm line 42.\n"
415        ],
416        "Warned about unfreed context"
417    );
418    $one->set_no_wait(0);
419}
420
421{
422    local %INC = %INC;
423    delete $INC{'Test2/IPC.pm'};
424    delete $INC{'threads.pm'};
425    ok(!USE_THREADS, "Sanity Check");
426
427    my $one = $CLASS->new;
428    ok(!$one->ipc, 'IPC not loaded, no IPC object');
429    ok($one->finalized, "calling ipc finalized the object");
430    is($one->ipc_polling, undef, "no polling defined");
431    ok(!@{$one->ipc_drivers}, "no driver");
432
433    if (CAN_THREAD) {
434        local $INC{'threads.pm'} = 1;
435        no warnings 'once';
436        local *threads::tid = sub { 0 } unless threads->can('tid');
437        $one->reset;
438        ok($one->ipc, 'IPC loaded if threads are');
439        ok($one->finalized, "calling ipc finalized the object");
440        ok($one->ipc_polling, "polling on by default");
441        is($one->ipc_drivers->[0], 'Test2::IPC::Driver::Files', "default driver");
442    }
443
444    {
445        local $INC{'Test2/IPC.pm'} = 1;
446        $one->reset;
447        ok($one->ipc, 'IPC loaded if Test2::IPC is');
448        ok($one->finalized, "calling ipc finalized the object");
449        ok($one->ipc_polling, "polling on by default");
450        is($one->ipc_drivers->[0], 'Test2::IPC::Driver::Files', "default driver");
451    }
452
453    require Test2::IPC::Driver::Files;
454    $one->reset;
455    $one->add_ipc_driver('Test2::IPC::Driver::Files');
456    ok($one->ipc, 'IPC loaded if drivers have been added');
457    ok($one->finalized, "calling ipc finalized the object");
458    ok($one->ipc_polling, "polling on by default");
459
460    my $file = __FILE__;
461    my $line = __LINE__ + 1;
462    my $warnings = warnings { $one->add_ipc_driver('Test2::IPC::Driver::Files') };
463    like(
464        $warnings->[0],
465        qr{^IPC driver Test2::IPC::Driver::Files loaded too late to be used as the global ipc driver at \Q$file\E line $line},
466        "Got warning at correct frame"
467    );
468
469    $one->reset;
470    $one->add_ipc_driver('Fake::Fake::XXX');
471    is(
472        exception { $one->ipc },
473        "IPC has been requested, but no viable drivers were found. Aborting...\n",
474        "Failed without viable IPC driver"
475    );
476}
477
478{
479    my $one = $CLASS->new;
480    $one->{ipc} = Test2::IPC::Driver::Files->new;
481
482    ok(!@{$one->context_init_callbacks}, "no callbacks");
483    is($one->ipc_polling, undef, "no polling, undef");
484
485    $one->disable_ipc_polling;
486    ok(!@{$one->context_init_callbacks}, "no callbacks");
487    is($one->ipc_polling, undef, "no polling, still undef");
488
489    my $cull = 0;
490    no warnings 'once';
491    local *Fake::Hub::cull = sub { $cull++ };
492    use warnings;
493
494    $one->enable_ipc_polling;
495    ok(defined($one->{_pid}), "pid is defined");
496    ok(defined($one->{_tid}), "tid is defined");
497    is(@{$one->context_init_callbacks}, 1, "added the callback");
498    is($one->ipc_polling, 1, "polling on");
499    $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'});
500    is($cull, 1, "called cull once");
501    $cull = 0;
502
503    $one->disable_ipc_polling;
504    is(@{$one->context_init_callbacks}, 1, "kept the callback");
505    is($one->ipc_polling, 0, "no polling, set to 0");
506    $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'});
507    is($cull, 0, "did not call cull");
508    $cull = 0;
509
510    $one->enable_ipc_polling;
511    is(@{$one->context_init_callbacks}, 1, "did not add the callback");
512    is($one->ipc_polling, 1, "polling on");
513    $one->context_init_callbacks->[0]->({'hub' => 'Fake::Hub'});
514    is($cull, 1, "called cull once");
515}
516
517{
518    require Test2::IPC::Driver::Files;
519
520    local $ENV{T2_NO_IPC} = 1;
521    my $one = $CLASS->new;
522    $one->add_ipc_driver('Test2::IPC::Driver::Files');
523    ok($one->ipc_disabled, "IPC is disabled by env var");
524    ok(!$one->ipc, 'IPC not loaded');
525
526    local $ENV{T2_NO_IPC} = 0;
527    $one->reset;
528    ok(!$one->ipc_disabled, "IPC is not disabled by env var");
529    ok($one->ipc, 'IPC loaded');
530    like(
531        exception { $one->ipc_disable },
532        qr/Attempt to disable IPC after it has been initialized/,
533        "Cannot disable IPC once it is initialized"
534    );
535
536    $one->reset;
537    ok(!$one->ipc_disabled, "IPC is not disabled by env var");
538    $one->ipc_disable;
539    ok($one->ipc_disabled, "IPC is disabled directly");
540}
541
542Test2::API::test2_ipc_wait_enable();
543
544done_testing;
545