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