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