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