File Coverage

blib/lib/IO/Async/LoopTests.pm
Criterion Covered Total %
statement 393 424 92.6
branch 27 54 50.0
condition 1 3 33.3
subroutine 76 84 90.4
pod 1 11 9.0
total 498 576 86.4


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2009-2021 -- leonerd@leonerd.org.uk
5              
6             package IO::Async::LoopTests;
7              
8 24     24   13559 use strict;
  24         178  
  24         691  
9 24     24   136 use warnings;
  24         48  
  24         626  
10              
11 24     24   117 use Exporter 'import';
  24         45  
  24         1777  
12             our @EXPORT = qw(
13             run_tests
14             );
15              
16 24     24   16129 use Test::More;
  24         1681671  
  24         228  
17 24     24   18967 use Test::Fatal;
  24         86979  
  24         1654  
18 24     24   12216 use Test::Metrics::Any;
  24         125353  
  24         290  
19 24     24   15320 use Test::Refcount;
  24         324814  
  24         286  
20              
21 24     24   14534 use IO::Async::Test qw();
  24         65  
  24         633  
22              
23 24     24   11710 use IO::Async::OS;
  24         72  
  24         828  
24              
25 24     24   12508 use IO::File;
  24         237527  
  24         3624  
26 24     24   243 use Fcntl qw( SEEK_SET );
  24         66  
  24         1534  
27 24     24   173 use POSIX qw( SIGTERM );
  24         61  
  24         416  
28 24     24   2107 use Socket qw( sockaddr_family AF_UNIX );
  24         67  
  24         1250  
29 24     24   19275 use Time::HiRes qw( time );
  24         36717  
  24         118  
30              
31             our $VERSION = '0.79';
32              
33             # Abstract Units of Time
34 24 50   24   5801 use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1;
  24         51  
  24         113532  
35              
36             # The loop under test. We keep it in a single lexical here, so we can use
37             # is_oneref tests in the individual test suite functions
38             my $loop;
39 24     24   1716 END { undef $loop }
40              
41             =head1 NAME
42              
43             C - acceptance testing for L subclasses
44              
45             =head1 SYNOPSIS
46              
47             use IO::Async::LoopTests;
48             run_tests( 'IO::Async::Loop::Shiney', 'io' );
49              
50             =head1 DESCRIPTION
51              
52             This module contains a collection of test functions for running acceptance
53             tests on L subclasses. It is provided as a facility for
54             authors of such subclasses to ensure that the code conforms to the Loop API
55             required by L.
56              
57             =head1 TIMING
58              
59             Certain tests require the use of timers or timed delays. Normally these are
60             counted in units of seconds. By setting the environment variable
61             C to some true value, these timers run 10 times quicker,
62             being measured in units of 0.1 seconds instead. This value may be useful when
63             running the tests interactively, to avoid them taking too long. The slower
64             timers are preferred on automated smoke-testing machines, to help guard
65             against false negatives reported simply because of scheduling delays or high
66             system load while testing.
67              
68             $ TEST_QUICK_TIMERS=1 ./Build test
69              
70             =cut
71              
72             =head1 FUNCTIONS
73              
74             =cut
75              
76             =head2 run_tests
77              
78             run_tests( $class, @tests )
79              
80             Runs a test or collection of tests against the loop subclass given. The class
81             being tested is loaded by this function; the containing script does not need
82             to C or C it first.
83              
84             This function runs C to output its expected test count; the
85             containing script should not do this.
86              
87             =cut
88              
89             sub run_tests
90             {
91 24     24 1 2261 my ( $testclass, @tests ) = @_;
92              
93 24         181 ( my $file = "$testclass.pm" ) =~ s{::}{/}g;
94              
95 24         71 eval { require $file };
  24         12518  
96 24 50       134 if( $@ ) {
97 0         0 BAIL_OUT( "Unable to load $testclass - $@" );
98             }
99              
100 24         96 foreach my $test ( @tests ) {
101 24         123 $loop = $testclass->new;
102              
103 24         210 isa_ok( $loop, $testclass, '$loop' );
104              
105 24         19566 is( IO::Async::Loop->new, $loop, 'magic constructor yields $loop' );
106              
107             # Kill the reference in $ONE_TRUE_LOOP so as not to upset the refcounts
108             # and to ensure we get a new one each time
109 24         8611 undef $IO::Async::Loop::ONE_TRUE_LOOP;
110              
111 24         399 is_oneref( $loop, '$loop has refcount 1' );
112              
113 24         10210 __PACKAGE__->can( "run_tests_$test" )->();
114              
115 14         11053 is_oneref( $loop, '$loop has refcount 1 finally' );
116             }
117              
118 14         6513 done_testing;
119             }
120              
121             sub wait_for(&)
122             {
123             # Bounce via here so we don't upset refcount tests by having loop
124             # permanently set in IO::Async::Test
125 28     28 0 810 IO::Async::Test::testing_loop( $loop );
126              
127             # Override prototype - I know what I'm doing
128 28         426 &IO::Async::Test::wait_for( @_ );
129              
130 28         2027 IO::Async::Test::testing_loop( undef );
131             }
132              
133             sub time_between(&$$$)
134             {
135 14     14 0 61 my ( $code, $lower, $upper, $name ) = @_;
136              
137 14         54 my $start = time;
138 14         41 $code->();
139 14         136 my $took = ( time - $start ) / AUT;
140              
141 14 100       313 cmp_ok( $took, '>=', $lower, "$name took at least $lower seconds" ) if defined $lower;
142 14 50       6582 cmp_ok( $took, '<=', $upper * 3, "$name took no more than $upper seconds" ) if defined $upper;
143 14 50 33     5409 if( $took > $upper and $took <= $upper * 3 ) {
144 0         0 diag( "$name took longer than $upper seconds - this may just be an indication of a busy testing machine rather than a bug" );
145             }
146             }
147              
148             =head1 TEST SUITES
149              
150             The following test suite names exist, to be passed as a name in the C<@tests>
151             argument to C:
152              
153             =cut
154              
155             =head2 io
156              
157             Tests the Loop's ability to watch filehandles for IO readiness
158              
159             =cut
160              
161             sub run_tests_io
162             {
163             {
164 2 50       21 my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!";
165 2         15 $_->blocking( 0 ) for $S1, $S2;
166              
167 2         74 my $readready = 0;
168 2         5 my $writeready = 0;
169             $loop->watch_io(
170             handle => $S1,
171 2     2   6 on_read_ready => sub { $readready = 1 },
172 2         25 );
173              
174 2         11 is_oneref( $loop, '$loop has refcount 1 after watch_io on_read_ready' );
175 2         930 is( $readready, 0, '$readready still 0 before ->loop_once' );
176              
177 2         1057 $loop->loop_once( 0.1 );
178              
179 2         14 is( $readready, 0, '$readready when idle' );
180              
181 2         1171 $S2->syswrite( "data\n" );
182              
183             # We should still wait a little while even thought we expect to be ready
184             # immediately, because talking to ourself with 0 poll timeout is a race
185             # condition - we can still race with the kernel.
186              
187 2         85 $loop->loop_once( 0.1 );
188              
189 2         9 is( $readready, 1, '$readready after loop_once' );
190              
191             # Ready $S1 to clear the data
192 2         823 $S1->getline; # ignore return
193              
194 2         136 $loop->unwatch_io(
195             handle => $S1,
196             on_read_ready => 1,
197             );
198              
199             $loop->watch_io(
200             handle => $S1,
201 4     4   11 on_read_ready => sub { $readready = 1 },
202 2         19 );
203              
204 2         5 $readready = 0;
205 2         9 $S2->syswrite( "more data\n" );
206              
207 2         43 $loop->loop_once( 0.1 );
208              
209 2         52 is( $readready, 1, '$readready after ->unwatch_io/->watch_io' );
210              
211 2         814 $S1->getline; # ignore return
212              
213             $loop->watch_io(
214             handle => $S1,
215 2     2   6 on_write_ready => sub { $writeready = 1 },
216 2         91 );
217              
218 2         15 is_oneref( $loop, '$loop has refcount 1 after watch_io on_write_ready' );
219              
220 2         813 $loop->loop_once( 0.1 );
221              
222 2         10 is( $writeready, 1, '$writeready after loop_once' );
223              
224 2         759 $loop->unwatch_io(
225             handle => $S1,
226             on_write_ready => 1,
227             );
228              
229 2         4 $readready = 0;
230 2         9 $loop->loop_once( 0.1 );
231              
232 2         23 is( $readready, 0, '$readready before HUP' );
233              
234 2         1739 $S2->close;
235              
236 2         145 $readready = 0;
237 2         18 $loop->loop_once( 0.1 );
238              
239 2         15 is( $readready, 1, '$readready after HUP' );
240              
241 2         1077 $loop->unwatch_io(
242             handle => $S1,
243             on_read_ready => 1,
244             );
245             }
246              
247             # HUP of pipe - can be different to sockets on some architectures
248             {
249 2 50   2 0 7 my ( $Prd, $Pwr ) = IO::Async::OS->pipepair or die "Cannot pipepair - $!";
  2         14  
  2         52  
250 2         69 $_->blocking( 0 ) for $Prd, $Pwr;
251              
252 2         10 my $readready = 0;
253             $loop->watch_io(
254             handle => $Prd,
255 2     2   10 on_read_ready => sub { $readready = 1 },
256 2         30 );
257              
258 2         10 $loop->loop_once( 0.1 );
259              
260 2         23 is( $readready, 0, '$readready before pipe HUP' );
261              
262 2         1693 $Pwr->close;
263              
264 2         71 $readready = 0;
265 2         18 $loop->loop_once( 0.1 );
266              
267 2         13 is( $readready, 1, '$readready after pipe HUP' );
268              
269 2         1113 $loop->unwatch_io(
270             handle => $Prd,
271             on_read_ready => 1,
272             );
273             }
274              
275             SKIP: {
276 2 100       53 $loop->_CAN_ON_HANGUP or skip "Loop cannot watch_io for on_hangup", 2;
277              
278             SKIP: {
279 1 50       3 my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!";
  1         11  
280 1         18 $_->blocking( 0 ) for $S1, $S2;
281              
282 1 50       47 sockaddr_family( $S1->sockname ) == AF_UNIX or skip "Cannot reliably detect hangup condition on non AF_UNIX sockets", 1;
283              
284 1         32 my $hangup = 0;
285             $loop->watch_io(
286             handle => $S1,
287 1     1   3 on_hangup => sub { $hangup = 1 },
288 1         11 );
289              
290 1         5 $S2->close;
291              
292 1         37 $loop->loop_once( 0.1 );
293              
294 1         6 is( $hangup, 1, '$hangup after socket close' );
295              
296 1         336 $loop->unwatch_io(
297             handle => $S1,
298             on_hangup => 1,
299             );
300             }
301              
302 1 50       11 my ( $Prd, $Pwr ) = IO::Async::OS->pipepair or die "Cannot pipepair - $!";
303 1         19 $_->blocking( 0 ) for $Prd, $Pwr;
304              
305 1         4 my $hangup = 0;
306             $loop->watch_io(
307             handle => $Pwr,
308 1     1   4 on_hangup => sub { $hangup = 1 },
309 1         10 );
310              
311 1         4 $Prd->close;
312              
313 1         19 $loop->loop_once( 0.1 );
314              
315 1         5 is( $hangup, 1, '$hangup after pipe close for writing' );
316              
317 1         327 $loop->unwatch_io(
318             handle => $Pwr,
319             on_hangup => 1,
320             );
321             }
322              
323             # Check that combined read/write handlers can cancel each other
324             {
325 2 50       13 my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!";
  2         23  
326 2         19 $_->blocking( 0 ) for $S1, $S2;
327              
328 2         75 my $callcount = 0;
329             $loop->watch_io(
330             handle => $S1,
331             on_read_ready => sub {
332 2     2   7 $callcount++;
333 2         23 $loop->unwatch_io( handle => $S1, on_read_ready => 1, on_write_ready => 1 );
334             },
335             on_write_ready => sub {
336 0     0   0 $callcount++;
337 0         0 $loop->unwatch_io( handle => $S1, on_read_ready => 1, on_write_ready => 1 );
338             },
339 2         33 );
340              
341 2         11 $S2->close;
342              
343 2         79 $loop->loop_once( 0.1 );
344              
345 2         11 is( $callcount, 1, 'read/write_ready can cancel each other' );
346             }
347              
348             # Check that cross-connected handlers can cancel each other
349             {
350 2 50       1782 my ( $SA1, $SA2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!";
  2         21  
351 2 50       18 my ( $SB1, $SB2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!";
352 2         15 $_->blocking( 0 ) for $SA1, $SA2, $SB1, $SB2;
353              
354 2         125 my @handles = ( $SA1, $SB1 );
355              
356 2         5 my $callcount = 0;
357             $loop->watch_io(
358             handle => $_,
359             on_write_ready => sub {
360 2     2   6 $callcount++;
361 2         14 $loop->unwatch_io( handle => $_, on_write_ready => 1 ) for @handles;
362             },
363 2         22 ) for @handles;
364              
365 2         12 $loop->loop_once( 0.1 );
366              
367 2         12 is( $callcount, 1, 'write_ready on crosslinked handles can cancel each other' );
368             }
369              
370             # Check that error conditions that aren't true read/write-ability are still
371             # invoked
372             {
373 2 50       1114 my ( $S1, $S2 ) = IO::Async::OS->socketpair( 'inet', 'dgram' ) or die "Cannot create AF_INET/SOCK_DGRAM connected pair - $!";
  2         23  
374 2         23 $_->blocking( 0 ) for $S1, $S2;
375 2         71 $S2->close;
376              
377 2         67 my $readready = 0;
378             $loop->watch_io(
379             handle => $S1,
380 2     2   7 on_read_ready => sub { $readready = 1 },
381 2         20 );
382              
383 2         24 $S1->syswrite( "Boo!" );
384              
385 2         195 $loop->loop_once( 0.1 );
386              
387 2         11 is( $readready, 1, 'exceptional socket invokes on_read_ready' );
388              
389 2         836 $loop->unwatch_io(
390             handle => $S1,
391             on_read_ready => 1,
392             );
393             }
394              
395             # Check that regular files still report read/writereadiness
396             {
397 2 50       1113 my $F = IO::File->new_tmpfile or die "Cannot create temporary file - $!";
  2         10  
  2         467  
398              
399 2         24 $F->print( "Here's some content\n" );
400 2         59 $F->seek( 0, SEEK_SET );
401              
402 2         101 my $readready = 0;
403 2         6 my $writeready = 0;
404             $loop->watch_io(
405             handle => $F,
406 2     2   7 on_read_ready => sub { $readready = 1 },
407 2     2   8 on_write_ready => sub { $writeready = 1 },
408 2         24 );
409              
410 2         11 $loop->loop_once( 0.1 );
411              
412 2         10 is( $readready, 1, 'regular file is readready' );
413 2         871 is( $writeready, 1, 'regular file is writeready' );
414              
415 2         774 $loop->unwatch_io(
416             handle => $F,
417             on_read_ready => 1,
418             on_write_ready => 1,
419             );
420             }
421             }
422              
423             =head2 timer
424              
425             Tests the Loop's ability to handle timer events
426              
427             =cut
428              
429             sub run_tests_timer
430             {
431             # New watch/unwatch API
432              
433 2     2 0 13 cmp_ok( abs( $loop->time - time ), "<", 0.1, '$loop->time gives the current time' );
434              
435             # ->watch_time after
436             {
437 2         5 my $done;
438 2     2   29 $loop->watch_time( after => 2 * AUT, code => sub { $done = 1; } );
  2         22  
439              
440 2         10 is_oneref( $loop, '$loop has refcount 1 after watch_time' );
441              
442             time_between {
443 2     2   6 my $now = time;
444 2         11 $loop->loop_once( 5 * AUT );
445              
446             # poll might have returned just a little early, such that the TimerQueue
447             # doesn't think anything is ready yet. We need to handle that case.
448 2         45 while( !$done ) {
449 0 0       0 die "It should have been ready by now" if( time - $now > 5 * AUT );
450 0         0 $loop->loop_once( 0.1 * AUT );
451             }
452 2         803 } 1.5, 2.5, 'loop_once(5) while waiting for watch_time after';
453             }
454              
455             # ->watch_time at
456             {
457 2         629 my $done;
  2         7  
458 2     2   41 $loop->watch_time( at => time + 2 * AUT, code => sub { $done = 1; } );
  2         24  
459              
460             time_between {
461 2     2   11 my $now = time;
462 2         13 $loop->loop_once( 5 * AUT );
463              
464             # poll might have returned just a little early, such that the TimerQueue
465             # doesn't think anything is ready yet. We need to handle that case.
466 2         33 while( !$done ) {
467 0 0       0 die "It should have been ready by now" if( time - $now > 5 * AUT );
468 0         0 $loop->loop_once( 0.1 * AUT );
469             }
470 2         22 } 1.5, 2.5, 'loop_once(5) while waiting for watch_time at';
471             }
472              
473             # cancelled timer
474             {
475 2         33 my $cancelled_fired = 0;
  2         7  
476 2     0   26 my $id = $loop->watch_time( after => 1 * AUT, code => sub { $cancelled_fired = 1 } );
  0         0  
477 2         29 $loop->unwatch_time( $id );
478 2         74 undef $id;
479              
480 2         13 $loop->loop_once( 2 * AUT );
481              
482 2         22 ok( !$cancelled_fired, 'unwatched watch_time does not fire' );
483             }
484              
485             # ->watch_after negative time
486             {
487 2         17 my $done;
  2         5  
488 2     2   31 $loop->watch_time( after => -1, code => sub { $done = 1 } );
  2         14  
489              
490             time_between {
491 2     2   15 $loop->loop_once while !$done;
492 2         18 } 0, 0.1, 'loop_once while waiting for negative interval timer';
493             }
494              
495             # self-cancellation
496             {
497 2         1170 my $done;
  2         11  
  2         7  
498              
499             my $id;
500             $id = $loop->watch_time( after => 1 * AUT, code => sub {
501 2     2   26 $loop->unwatch_time( $id ); undef $id;
  2         27  
502 2         18 });
503              
504             $loop->watch_time( after => 1.1 * AUT, code => sub {
505 2     2   18 $done++;
506 2         15 });
507              
508 2     6   15 wait_for { $done };
  6         54  
509              
510 2         17 is( $done, 1, 'Other timers still fire after self-cancelling one' );
511             }
512              
513             SKIP: {
514 2 50       1247 skip "Unable to handle sub-second timers accurately", 3 unless $loop->_CAN_SUBSECOND_ACCURATELY;
  2         73  
515              
516             # Check that short delays are achievable in one ->loop_once call
517 0         0 foreach my $delay ( 0.001, 0.01, 0.1 ) {
518 0         0 my $done;
519 0         0 my $count = 0;
520 0         0 my $start = time;
521              
522 0     0   0 $loop->watch_timer( delay => $delay, code => sub { $done++ } );
  0         0  
523              
524 0         0 while( !$done ) {
525 0         0 $loop->loop_once( 1 );
526 0         0 $count++;
527 0 0       0 last if time - $start > 5; # bailout
528             }
529              
530 0         0 is( $count, 1, "One ->loop_once(1) sufficient for a single $delay second timer" );
531             }
532             }
533             }
534              
535             =head2 signal
536              
537             Tests the Loop's ability to watch POSIX signals
538              
539             =cut
540              
541             sub run_tests_signal
542             {
543 2 50   2 0 14 unless( IO::Async::OS->HAVE_SIGNALS ) {
544 0         0 SKIP: { skip "This OS does not have signals", 14; }
  0         0  
545 0         0 return;
546             }
547              
548 2         4 my $caught = 0;
549              
550 2     4   19 $loop->watch_signal( TERM => sub { $caught++ } );
  4         18  
551              
552 2         11 is_oneref( $loop, '$loop has refcount 1 after watch_signal' );
553              
554 2         842 $loop->loop_once( 0.1 );
555              
556 2         15 is( $caught, 0, '$caught idling' );
557              
558 2         1177 kill SIGTERM, $$;
559              
560 2         57 is( $caught, 0, '$caught before ->loop_once' );
561              
562 2         656 $loop->loop_once( 0.1 );
563              
564 2         11 is( $caught, 1, '$caught after ->loop_once' );
565              
566 2         769 kill SIGTERM, $$;
567              
568 2         14 is( $caught, 1, 'second raise is still deferred' );
569              
570 2         642 $loop->loop_once( 0.1 );
571              
572 2         10 is( $caught, 2, '$caught after second ->loop_once' );
573              
574 2         646 is_oneref( $loop, '$loop has refcount 1 before unwatch_signal' );
575              
576 2         683 $loop->unwatch_signal( 'TERM' );
577              
578 2         12 is_oneref( $loop, '$loop has refcount 1 after unwatch_signal' );
579              
580 2         637 my ( $cA, $cB );
581              
582 2     2   30 my $idA = $loop->attach_signal( TERM => sub { $cA = 1 } );
  2         6  
583 2     4   29 my $idB = $loop->attach_signal( TERM => sub { $cB = 1 } );
  4         17  
584              
585 2         12 is_oneref( $loop, '$loop has refcount 1 after 2 * attach_signal' );
586              
587 2         716 kill SIGTERM, $$;
588              
589 2         14 $loop->loop_once( 0.1 );
590              
591 2         9 is( $cA, 1, '$cA after raise' );
592 2         685 is( $cB, 1, '$cB after raise' );
593              
594 2         653 $loop->detach_signal( 'TERM', $idA );
595              
596 2         4 undef $cA;
597 2         5 undef $cB;
598              
599 2         56 kill SIGTERM, $$;
600              
601 2         15 $loop->loop_once( 0.1 );
602              
603 2         9 is( $cA, undef, '$cA after raise' );
604 2         764 is( $cB, 1, '$cB after raise' );
605              
606 2         638 $loop->detach_signal( 'TERM', $idB );
607              
608 2     2   200 ok( exception { $loop->attach_signal( 'this signal name does not exist', sub {} ) },
609 2         24 'Bad signal name fails' );
610              
611 2         728 undef $caught;
612 2     2   23 $loop->attach_signal( TERM => sub { $caught++ } );
  2         11  
613              
614 2         22 $loop->post_fork;
615              
616 2         59 kill SIGTERM, $$;
617              
618 2         15 $loop->loop_once( 0.1 );
619              
620 2         11 is( $caught, 1, '$caught SIGTERM after ->post_fork' );
621             }
622              
623             =head2 idle
624              
625             Tests the Loop's support for idle handlers
626              
627             =cut
628              
629             sub run_tests_idle
630             {
631 2     2 0 8 my $called = 0;
632              
633 2     2   24 my $id = $loop->watch_idle( when => 'later', code => sub { $called = 1 } );
  2         5  
634              
635 2         19 ok( defined $id, 'idle watcher id is defined' );
636              
637 2         621 is( $called, 0, 'deferred sub not yet invoked' );
638              
639 2     2   661 time_between { $loop->loop_once( 3 * AUT ) } undef, 1.0, 'loop_once(3) with deferred sub';
  2         9  
640              
641 2         16 is( $called, 1, 'deferred sub called after loop_once' );
642              
643             $loop->watch_idle( when => 'later', code => sub {
644 2         8 $loop->watch_idle( when => 'later', code => sub { $called = 2 } )
645 2     2   650 } );
  2         17  
646              
647 2         16 $loop->loop_once( 1 );
648              
649 2         22 is( $called, 1, 'inner deferral not yet invoked' );
650              
651 2         634 $loop->loop_once( 1 );
652              
653 2         15 is( $called, 2, 'inner deferral now invoked' );
654              
655 2         646 $called = 2; # set it anyway in case previous test fails
656              
657 2     0   20 $id = $loop->watch_idle( when => 'later', code => sub { $called = 20 } );
  0         0  
658              
659 2         17 $loop->unwatch_idle( $id );
660              
661             # Some loop types (e.g. UV) need to clear a pending queue first and thus the
662             # first loop_once will take zero time
663 2         20 $loop->loop_once( 0 );
664              
665 2     2   23 time_between { $loop->loop_once( 1 * AUT ) } 0.5, 1.5, 'loop_once(1) with unwatched deferral';
  2         56  
666              
667 2         23 is( $called, 2, 'unwatched deferral not called' );
668              
669 2     2   716 $id = $loop->watch_idle( when => 'later', code => sub { $called = 3 } );
  2         6  
670 2     0   32 my $timer_id = $loop->watch_time( after => 5, code => sub {} );
671              
672 2         13 $loop->loop_once( 1 );
673              
674 2         14 is( $called, 3, '$loop->later still invoked with enqueued timer' );
675              
676 2         850 $loop->unwatch_time( $timer_id );
677              
678 2     2   149 $loop->later( sub { $called = 4 } );
  2         6  
679              
680 2         10 $loop->loop_once( 1 );
681              
682 2         9 is( $called, 4, '$loop->later shortcut works' );
683             }
684              
685             =head2 process
686              
687             Tests the Loop's support for watching child processes by PID
688              
689             (Previously called C)
690              
691             =cut
692              
693             sub run_in_child(&)
694             {
695 50     50 0 75530 my $kid = fork;
696 50 50       2480 defined $kid or die "Cannot fork() - $!";
697 50 100       3971 return $kid if $kid;
698              
699 10         1049 shift->();
700 0         0 die "Fell out of run_in_child!\n";
701             }
702              
703             sub run_tests_process
704             {
705             my $kid = run_in_child {
706 2     2   917 exit( 3 );
707 12     12 0 120 };
708              
709 10         685 my $exitcode;
710              
711 10     10   1130 $loop->watch_process( $kid => sub { ( undef, $exitcode ) = @_; } );
  10         115  
712              
713 10         170 is_oneref( $loop, '$loop has refcount 1 after watch_process' );
714 10         13585 ok( !defined $exitcode, '$exitcode not defined before ->loop_once' );
715              
716 10         4040 undef $exitcode;
717 10     35   210 wait_for { defined $exitcode };
  35         435  
718              
719 10         120 ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after child exit' );
720 10         8380 is( ($exitcode >> 8), 3, 'WEXITSTATUS($exitcode) after child exit' );
721              
722             SKIP: {
723 10 50       5070 skip "This OS does not have signals", 1 unless IO::Async::OS->HAVE_SIGNALS;
  10         145  
724              
725             # We require that SIGTERM perform its default action; i.e. terminate the
726             # process. Ensure this definitely happens, in case the test harness has it
727             # ignored or handled elsewhere.
728 10         295 local $SIG{TERM} = "DEFAULT";
729              
730             $kid = run_in_child {
731 0     0   0 sleep( 10 );
732             # Just in case the parent died already and didn't kill us
733 0         0 exit( 0 );
734 10         120 };
735              
736 10     10   2535 $loop->watch_process( $kid => sub { ( undef, $exitcode ) = @_; } );
  10         120  
737              
738 10         800 kill SIGTERM, $kid;
739              
740 10         155 undef $exitcode;
741 10     25   500 wait_for { defined $exitcode };
  25         475  
742              
743 10         330 is( ($exitcode & 0x7f), SIGTERM, 'WTERMSIG($exitcode) after SIGTERM' );
744             }
745              
746             SKIP: {
747 10         7880 my %kids;
  10         30  
748              
749 10 50       770 $loop->_CAN_WATCH_ALL_PIDS or skip "Loop cannot watch_process for all PIDs", 2;
750              
751 10     14   230 $loop->watch_process( 0 => sub { my ( $kid ) = @_; delete $kids{$kid} } );
  14         70  
  14         88  
752              
753 10     6   95 %kids = map { run_in_child { exit 0 } => 1 } 1 .. 3;
  24         511  
  6         3192  
754              
755 4         20040 is( scalar keys %kids, 3, 'Waiting for 3 child processes' );
756              
757 4     26   3594 wait_for { !keys %kids };
  26         390  
758 4         66 ok( !keys %kids, 'All child processes reclaimed' );
759             }
760              
761             # Legacy API name
762 4     2   3378 $kid = run_in_child { exit 2 };
  2         1250  
763              
764 2         237 undef $exitcode;
765 2     2   283 $loop->watch_child( $kid => sub { ( undef, $exitcode ) = @_; } );
  2         27  
766 2     7   84 wait_for { defined $exitcode };
  7         155  
767              
768 2         465 is( ($exitcode >> 8), 2, '$exitcode after child exit from legacy ->watch_child' );
769             }
770             *run_tests_child = \&run_tests_process; # old name
771              
772             =head2 control
773              
774             Tests that the C, C, C and C methods
775             behave correctly
776              
777             =cut
778              
779             sub run_tests_control
780             {
781 2     2 0 9 time_between { $loop->loop_once( 0 ) } 0, 0.1, 'loop_once(0) when idle';
  2     2   19  
782              
783 2     2   20 time_between { $loop->loop_once( 2 * AUT ) } 1.5, 2.5, 'loop_once(2) when idle';
  2         8  
784              
785 2     2   67 $loop->watch_time( after => 0.1, code => sub { $loop->stop( result => "here" ) } );
  2         60  
786              
787 2     0   67 local $SIG{ALRM} = sub { die "Test timed out before ->stop" };
  0         0  
788 2         43 alarm( 1 );
789              
790 2         31 my @result = $loop->run;
791              
792 2         43 alarm( 0 );
793              
794 2         28 is_deeply( \@result, [ result => "here" ], '->stop arguments returned by ->run' );
795              
796 2     2   2448 $loop->watch_time( after => 0.1, code => sub { $loop->stop( result => "here" ) } );
  2         35  
797              
798 2         14 my $result = $loop->run;
799              
800 2         109 is( $result, "result", 'First ->stop argument returned by ->run in scalar context' );
801              
802             $loop->watch_time( after => 0.1, code => sub {
803             SKIP: {
804 2 50   2   21 unless( $loop->can( 'is_running' ) ) {
  2         34  
805 0         0 diag "Unsupported \$loop->is_running";
806 0         0 skip "Unsupported \$loop->is_running", 1;
807             }
808              
809 2         15 ok( $loop->is_running, '$loop->is_running' );
810             }
811              
812 2         1853 $loop->watch_time( after => 0.1, code => sub { $loop->stop( "inner" ) } );
  2         34  
813 2         21 my @result = $loop->run;
814 2         17 $loop->stop( @result, "outer" );
815 2         1662 } );
816              
817 2         15 @result = $loop->run;
818              
819 2         29 is_deeply( \@result, [ "inner", "outer" ], '->run can be nested properly' );
820              
821 2     2   2740 $loop->watch_time( after => 0.1, code => sub { $loop->loop_stop } );
  2         68  
822              
823 2     0   68 local $SIG{ALRM} = sub { die "Test timed out before ->loop_stop" };
  0         0  
824 2         46 alarm( 1 );
825              
826 2         39 $loop->loop_forever;
827              
828 2         64 alarm( 0 );
829              
830 2         29 ok( 1, '$loop->loop_forever interruptable by ->loop_stop' );
831             }
832              
833             =head2 metrics
834              
835             Tests that metrics are generated appropriately using L.
836              
837             =cut
838              
839             sub run_tests_metrics
840             {
841 2     2 0 6 my $loopclass = ref $loop;
842              
843 2 50       9 return unless $IO::Async::Metrics::METRICS;
844              
845             # We should already at least have the loop-type metric
846 2         35 is_metrics(
847             {
848             "io_async_loops class:$loopclass" => 1,
849             },
850             'Constructing the loop creates a loop type metric'
851             );
852              
853             # The very first call won't create timing metrics because it isn't armed yet.
854 2         1249 $loop->loop_once( 0 );
855              
856             is_metrics_from(
857 2     2   103 sub { $loop->loop_once( 0.1 ) },
858             {
859 2         31 io_async_processing_count => 1,
860             io_async_processing_total => Test::Metrics::Any::positive,
861             },
862             'loop_once(0) creates timing metrics'
863             );
864             }
865              
866             =head1 AUTHOR
867              
868             Paul Evans
869              
870             =cut
871              
872             0x55AA;