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