IO-Async-0.804000755001750001750 015001742754 11635 5ustar00leoleo000000000000IO-Async-0.804/.editorconfig000444001750001750 5315001742754 14405 0ustar00leoleo000000000000root = true [*.{pm,pl,t}] indent_size = 3 IO-Async-0.804/Build.PL000444001750001750 204615001742754 13270 0ustar00leoleo000000000000use v5; use strict; use warnings; use Module::Build; my $build = Module::Build->new( module_name => 'IO::Async', requires => { 'perl' => '5.014', 'Future' => '0.44', # ->catch 'Future::Utils' => '0.18', # try_repeat 'Exporter' => '5.57', 'File::stat' => 0, 'IO::Poll' => 0, 'List::Util' => 0, # Require Socket 2.029 on MSWin32 because of AF_UNIX (RT133018) ( 'Socket' => ( $^O eq "MSWin32" ? '2.029' : '2.007' ) ), 'Storable' => 0, 'Struct::Dumb' => 0, 'Time::HiRes' => 0, }, recommends => { 'IO::Socket::IP' => 0, }, test_requires => { 'File::Temp' => 0, 'Test::Future::IO::Impl' => 0, 'Test::Metrics::Any' => 0, 'Test2::V0' => '0.000149', }, configure_requires => { 'Module::Build' => '0.4004', # test_requires }, license => 'perl', create_license => 1, create_readme => 1, meta_merge => { resources => { x_IRC => "irc://irc.perl.org/#io-async", }, }, ); $build->create_build_script; IO-Async-0.804/Changes000444001750001750 12547715001742754 13345 0ustar00leoleo000000000000Revision history for IO-Async 0.804 2025-04-22 [CHANGES] * Add extra LoopTests tests for IO and timer operation after a ->post_fork call, in order to help test RT152635 * Remove duplicate `use VERSION` declaration from helper package in TimeQueue.pm 0.803 2024-01-29 [CHANGES] * Module style updates: + Use perl v5.14 for `//` operator and `package NAME VER` syntax + Updated Pod style + Swapped unit tests from `Test::More` to `Test2::V0` + Removed several now-unnecessary test-time dependencies [BUGFIXES] * Take the first name for each aliased signal in case of aliased names (RT145759) 0.802 2022-08-15 [CHANGES] * PreĆ«mptively use Future ->udata API from upcoming release, to avoid depending on it being a hashref * Report correct caller file + line number in nested test calls to wait_for {} [BUGFIXES] * Use 'SOCK_STREAM' instead of hardcoded 1 in t/50resolver.t * Skip exceptional socket condition test on cygwin because it seems always to fail there * Avoid harmless warnings about undef at global destruction (RT142754) 0.801 2021-12-15 [BUGFIXES] * Remove extraneous test-time use of Data::Dump (RT140143) 0.800 2021-11-11 [CHANGES] * Bumped up to three-digit minor version number * Added IO::Async::OS->signum2name * Implement Future::IO->waitpid API * Skip the `spawn` Routine model if POSIX fork() is not available * Replace getaddrinfo / getnameinfo with virtual mocking functions for unit-testing the resolve, so as not to rely on local platform resolver behaviours 0.79 2021-08-06 [CHANGES] * Permit IO::Async::Routine or Function by module+func names instead of CODE reference * Added new Routine/Function model of `spawn` * Implement IO::Async::Resolver by module+func rather than code [BUGFIXES] * Require Socket 2.029 on MSWin32 because of AF_UNIX fix (RT133018) 0.78 2021-01-21 [CHANGES] * Warn on attempts to ->connect to INADDR(6)_LOOPBACK as some OSes (e.g. OpenBSD) do not allow it * Various fixes for IO::Async::LoopTests to better support IO::Async::Loop::UV: + Insert some ->loop_once(0) calls between timing tests to allow libuv to clear its pending queues + Allow loops to declare that they cannot perform all-child PID watch and skip the relevant tests for it if so * Have $loop->later return a future instance if not passed any code (RT133240) [BUGFIXES] * Accept more error codes for failure to resolve missing hostname (RT131109) * Defend against some undef values at global destruction time (RT132677) 0.77 2020-05-13 [CHANGES] * Updated for Metrics::Any 0.05 * Report an info-type gauge metric to track loop types * Loop processing time should be a timer metric, not a distribution * Don't bother reporting zero-byte stream read/write metrics [BUGFIXES] * Skip metrics-related unit tests if metrics aren't active, even though we depend on Test::Metrics::Any * Account for MSWin32's EWOULDBLOCK in t/70future-io.t 0.76 2020-05-05 [CHANGES] * Initial attempt at providing metrics via Metrics::Any * Renamed ->(un)watch_child API to ->(un)watch_process * Renamed 'child' LoopTests suite to 'process' 0.75 2019-11-26 00:06:59 [CHANGES] * Remember to keep O_NONBLOCK off on IO::Async::Channel sync mode filehandles * Added IO::Async::Process->finish_future * Added IO::Async::Routine->result_future * Future-returning version of IO::Async::Function->stop * Don't load IO::Socket or Sereal modules unless required [BUGFIXES] * Refresh the sigpipe in ->post_fork if required (RT128588) * Fix some spelling mistakes (RT130087) * Skip the async getprotobyname() test if it doesn't work synchronously (RT131029) 0.74 2019-06-27 18:44:38 [CHANGES] * Warn about IO::Async::Stream using autoflush on a blocking handle * Implement queuing priorities for IO::Async::Function calls (RT129918) * Send a terminating signal to a ->run_process process on cancellation (RT129225) * Optionally make ->run_process future fail when process exits non-zero (RT129225) * Implement the Future::IO->syswrite API [BUGFIXES] * Skip t/70future-io.t unless Future::IO is available (RT129807) * Remember to set O_NONBLOCK on IO::Async::Channel async mode filehandles (RT129879) * Handle Windows 7 which returns ENETDOWN to failed AF_UNIX connect() (RT129806) 0.73 2019-06-12 16:49:28 [CHANGES] * Provide an IO::Async implementation of Future::IO * Added $loop->run_process (RT129225) * Clear $ONE_TRUE_LOOP in $loop->fork so that child processes can do IO::Async::Loop->new successfully * Added $notifier->adopted_futures accessor (RT127818) * Various docs fixes 0.72 2018-04-02 19:34:27 [CHANGES] * Expanded docs on Stream's on_read sub return values * Overridable timeout for IO::Async::Test::wait_for * Hide IO::Async::ChildManager as an internal implementation detail; move the docs into main IO::Async::Loop * Added $loop->open_process; suggest using that instead of ->open_child * Begin implementation of $loop->is_running method (part of RT123780) [BUGFIXES] * Make IO::Async::Future->await wait until it's ready * Fix calculation of periodic timer in 'skip' mode (RT124414) * Perform synchronous getaddrinfo shortcut even for service-less lookups * Make sure that errors from underlying read/write functions are debug-logged by IO::Async::Stream 0.71 2016/12/22 15:05:50 [CHANGES] * Added 'prefork' option to IO::Async::Channel (RT115920) - thanks GMARLER * Prefer Sereal Channel encoding if that module is available * Ensure that IaFunction still prints debug information on futures * Miscellaneous spelling fixes in docs - thanks genio [BUGFIXES] * 'use lib ".";' for perl 5.24 * Make t/50resolver.t less sensitive to EAI_NONAME vs EAI_NODATA because some resolvers lie (RT113429) * Fix error message linefeed tests in t/50resolver.t (RT119369) * Ensure that SIGPIPE is ignored if it's still at its default value 0.70 2015/12/15 18:17:43 [CHANGES] * Support perl 5.8.x (tested on 5.8.9, presumed working as far as 5.8.4) 0.69 2015/11/09 19:56:58 [CHANGES] * Use Future->catch instead of poorly-implemented string-eq test * Use L<...> instead of C<...> in docs where appropriate (RT107417) (thanks Arthur Axel 'fREW' Schmidt) [BUGFIXES] * Don't silently swallow Listener acceptor failures (RT107806) * Don't silently swallow other ->connect errors * Remember to ->unwatch_io before setting IaHandle's handle to undef 0.68 2015/07/31 20:07:48 [CHANGES] * Allow IO::Async::Function body to 'die' with an ARRAYref to set more details on failed Future * Have IO::Async::Resolver calls indicate the failed resolver name * Have IO::Async::Resolver's getaddrinfo and getnameinfo resolvers give error numbers in failure result * Added 'init_code' parameter to IO::Async::Function (RT104127) * Added IO::Async::Channel->encode, ->send_encoded; deprecate the old ->send_frozen method * Added IO::Async::Test::wait_for_future [BUGFIXES] * Clean up after 'on_hangup' loop tests (RT106061) * Make ->stop + ->start on IO::Async::Timer::Periodic not forget the first_interval (RT100927) 0.67 2015/06/01 15:06:13 [CHANGES] * Add a ->post_fork method to IO::Async::Loop in case subclasses should take specific action (RT104130) * Remove IO::Async::MergePoint entirely * Add debug_printf() calls to IO::Async::Process * Various documentation additions [BUGFIXES] * Remember to actually delete unused filehandles from the pollmask (RT103922) 0.66 2015/04/17 20:36:39 [CHANGES] * Created IO::Async::Debug * Ignore SIGPIPE by default (RT92024) * IaSocket->bind now returns a Future * Added IaSocket->bind resolver support and neatened up UDP examples in synopsis/documentation [BUGFIXES] * Correct call to unpack() in IaStream example (RT103143) * Don't silently eat accept() failures in IaListener (RT102677) * Remember to add the new resolver instance to $loop in ->set_resolver (RT103446) * Correct implementation of ->unwatch_io on IaLoop::Poll to prevent 100% CPU spin (RT103445) * Ensure that an exception thrown by Timer::Periodic's on_tick doesn't prevent rescheduling 0.65 2015/02/15 14:28:02 [CHANGES] * Optionally allow IO::Async::Channel to use 'Sereal' serialisation * Added documentation about the 'env' Child Manager key and copying %ENV * Take OS "preferred loop subclass" hints from IO::Async::OS directly [BUGFIXES] * Nested $stream->read_* inside read_* cause double-completion of Future (RT101774) * Implement IO::Async::Loop::Poll directly on _poll() syscall wrapper, thus avoiding many bugs in IO::Poll (RT93141) * Ensure that IO::Async::Loop::Select can cope with callbacks that remove other IO handle watches (RT101919) * Silently upgrade watched IO handles to O_NONBLOCK (RT102044) * Complain about unrecognised keys to ->extract_addrinfo (RT101453) 0.64 2014/10/17 17:51:07 [CHANGES] * Make specific mention of 'TCP' and 'UDP' around socket examples where appropriate * Allow construction of an IO::Async::Handle using fileno integers directly * Provide a better search for 'all open filehandles' via IO::Async::OS on Linux (RT97942) * Allow IO::Async::Listener to have handle_constructor or handle_class as a subclass method (RT97208) * Clarify documentation on how to use IO::Async::Process's on_exception event (RT98929) [BUGFIXES] * Ensure that Stream's write Futures are also informed of write errors (RT97433) * Remember to ->remove_child the individual workers of an IO::Async::Function (RT99552) * Fix IO::Async::Function synopsis example (RT97713) 0.63 2014/07/11 15:09:08 [CHANGES] * Allow Notifier subclasses to last-ditch handle unrecognised ->configure() params * Added $notifier->adopt_future * Added $notifier->invoke_error and 'on_error' event * Ensure that TimeQueue inserts in FIFO order for equal timestamps * Kill remaining docs to long-dead IO::Async::Sequencer [BUGFIXES] * Cygwin needs the SELECT_CONNECT_EVEC OS hint as well * Probe for a broken port to perform listen() tests on by using ReuseAddr => 1 so it matches what IO::Async will do (RT84051) 0.62 2014/03/27 23:15:25 [CHANGES] * Added IO::Async::Future->{done,fail}_later * Allow overriding of debug log file or file descriptor * Avoid Future's and_then/or_else methods * Allow Channel->recv in async mode to return a Future (RT91180) * Ensure that Function ->call Futures cancel correctly * Added $routine->kill * Kill the 'getaddrinfo' => 'getaddrinfo_array' legacy redirection * Allow Loop's resolver to be changed to a different object [BUGFIXES] * Avoid relying on strong forward references in Future, by creating intentional cycles on pending Futures. Workaround for bugfix in upcoming Future release. 0.61 2013/10/15 01:10:51 [CHANGES] * Some OSes lack signals; forbid the ->*_signal methods, and use waitpid() polling for child processes if so * Rearrangement of $loop->listen and IO::Async::Listener logic to allow Listener subclasses to use listen extensions (e.g. SSL) * Allow ->listen to construct new Stream or Socket handles * Updated documentation and tests to emphasise futures with resolver and ->listen * Support spawning threads and watching for exit * Support IO::Async::Routine based on threads * Various MSWin32 improvements and fixes - it now passes tests \o/ * Declare that MSWin32 does not support POSIX-like fork(); skip all unit tests and functionallity based on it if so Note: These changes break IO::Async::SSL versions 0.12 or older. [BUGFIXES] * Ensure that $stream->write( CODE, on_write/write_len ) works correctly With many thanks to Mithaldu for the use of his Windows smoker for development and testing of the MSWin32 fixes 0.60 2013/09/19 14:26:22 [CHANGES] * Updated for Future 0.16 - no longer needs 'return' argument for Future::Utils functions * $stream->connect() ought to default socktype => "stream" [BUGFIXES] * Fix unit tests to better handle INADDR_LOOPBACK not being 127.0.0.1 * Skip-guard ->socket("inet6") unit tests on machines unable to socket(AF_INET6) * Remmeber to ->accept connections to testing socket in t/63handle-connect.t 0.59 CHANGES: * Allow IO::Async::Stream to define custom reader/writer methods * Support writeready-for-read and readready-for-write in Stream * Allow Stream->write() on_write and write_len args * Neatened and documented Future ->fail arguments and conventions * Added Stream on_writeable_{start,stop} events * Added Handle->socket, ->bind and ->connect methods * Revamp of Loop->connect logic; allow passing through an IO::Async::Handle instance BUGFIXES: * Ensure that stream read EOF state is visible during queued on_read events that caused it * Fix 'return ... or die' precendence bug in Resolver (RT87051) * Need to poll() for POLLPRI on MSWin32 and Cygwin 0.58 CHANGES: * Added Stream read watermarks BUGFIXES: * Fix weakself event handlers' use of "shift or return" 0.57 CHANGES: * Allow Stream->write from a Future, CODE that returns Future, Future that returns CODE, etc... * Added Future-returning Stream->read_* methods and ->push_on_read * Return a flush-complete notification Future from Stream->write * Allow Timer::Periodic to stop itself from its own on_tick event * Wrap transport on_{read,write}_eof from Protocol::Stream 0.56 CHANGES: * Added $loop->delay_future and $loop->timeout_future * Added $future->loop accessor * Use a faster splice()-based mechanism for the ARRAY-based TimeQueue * Updated for Future::Utils 0.12 'repeat' function BUGFIXES: * Ensure that Process from => "" works * If select() returns -1 ignore the bit vectors * pipe() on Windows doesn't play with select(); emulate ->pipepair using ->socketpair * Correct use of S_ISREG and stat() 0.55 CHANGES: * Try to ensure IO::Async::OS->socket returns an IO::Socket::IP instance for PF_INET or PF_INET6 if it is available * Don't bother testing subsecond loop_once behaviour because most loops can't actually do it * Use Future::Utils instead of CPS, removing a dependency * Removed IO::Async::Sequencer * Print a deprecation warning on old loop classes with old timer support 0.54 CHANGES: * Use Future instead of CPS::Future * Created IO::Async::Future subclass * Initial support for Futures on Loops * Rewrite lots of internals to use Futures instead of MergePoints or other logic * Renamed all "task" to "future" in APIs * Allow packing of inet/inet6 address structures to omit the IP or port and presume passive or port 0 * Removed $notifier->get_loop synonym * Make IO::Async::MergePoint throw a deprecation warning 0.53 CHANGES: * Added IO_ASYNC_WATCHDOG debugging support BUGFIXES: * Remember to return a task from Function->call even if it's queued (RT79248) 0.52 CHANGES: * Initial attempt at Tasks using CPS::Future * Minor fixes to timer LoopTests to prevent spurious failures of sub-second timing * Declare dependence on perl 5.10 now we're using 5.10 features * Removed long-since deprecated IO::Async::DetachedCode 0.51 CHANGES: * Split much code out to new IO::Async::OS heirarchy * Drop dead dependency on Test::Warn * Smaller simpler signal handling, avoid POSIX::SigSet * Expose getfamilybyname and getsocktypebyname as OS methods BUGFIXES: * Many small MSWin32 fixes that might help pass some tests. Likely still incomplete though 0.50 CHANGES: * Added IO::Async::File * Added filename mode of IO::Async::FileStream * Make Heap dependency optional by reimplementing a tiny but less efficient version of TimeQueue using a plain array * No longer need MB-only Build.PL BUGFIXES: * Round up select() and poll() timeouts to nearest milisecond, might help correct wait-time vs. gettimeofday() mismatches * Fake read- and write-readiness of S_ISREG filehandles in select() on MSWin32 * select() for exceptional status on MSWin32 to check for connect() failures * Don't unit-test that getsockname() works on socketpair()ed sockets 0.49 CHANGES: * Fix watch_time => enqueue_timer conversions; fix unit tests and Timer implementations 0.48 CHANGES: * Support Channel long-running on_recv handler * Support Channel directly between two Routines, in sync. mode at both ends * Added Loop->{watch,unwatch}_time API * Added Function->restart and max_worker_calls parameter * Support other reschedule policies for Timer::Periodic to allow tick skipping, or drift BUGFIXES: * Fix example in Routine SYNOPSIS (thanks apeiron) * Connector should check definedness of local_{host,port} rather than existence 0.47 CHANGES: * Support $listener->listen( v6only => ... ) * Added new data-passing $loop->run and $loop->stop methods BUGFIXES: * Emulate ->socketpair on MSWin32 by connecting to a temporary socket * Account for EWOULDBLOCK on MSWin32 * Don't try reading STDIN to block awaiting a signal in unit-tests * Allow zero-delay Countdown timers (RT75954) * Handle dup2() collisions in ChildManager filehandle setups (RT75573) * Fix race condition in t/33process.t (RT75573) * Ensure Timer->stop doesn't fail if the timer isn't running (RT75571) * Possibly-fix some cygwin test failures (RT71706) * Ensure that 'passive' getaddrinfo hint is handled in both synchronous and numeric cases 0.46 ADDITIONS: * IO::Async::Routine + IO::Async::Channel * IO::Async::Process->kill method CHANGES: * Use Socket 1.93 rather than dual-dependency logic on Socket::GetAddrInfo * Rewrote ::Function based on ::Routine and ::Channel * Cleaner refcount behaviour in ::Process * ::Process no longer waits for EOF condition on write-only pipes * Don't unit-test the reading end of a pipe for HUP condition * Documentation updates * Removed documentation for long-since deprecated $loop->detach_child and ->detach_code methods 0.45 CHANGES: * Added Timer->is_expired predicate, remove_on_expire parameter (RT71767) BUGFIXES: * Use fd3/4 in ::Function rather than STDIN/STDOUT, to avoid corrupting the return channel if the body function prints (RT72448) * Better error detection around setuid/setgid/setgroups (RT72407) * IO::Handle->binmode is not available as a method before perl 5.12; use CORE::binmode() instead * Don't attempt to invoke a missing on_notifier callback in Loop->listen (RT71768) 0.44 CHANGES: * Allow Process to have sockets as handles; including datagram sockets BUGFIXES: * Extract TimeQueue entiries before firing them, in case they do something weird like cancelling themselves (RT70231) * Test dollarbang for EWOULDBLOCK which might help MSWin32 * Cope correctly with Function handles in the presence of -CS or PERL_UNICODE=S 0.43 CHANGES: * Allow IO::Async::Notifier to be used as a non-principle mixin class * Provide Notifier->loop accessor * Added (still-experimental) Notifier debug features * Deleted various deprecated features: + Notifier to Handle upgrade + Loop->enable_childmanager, Loop->disable_childmanager * Print deprecation warnings on Loop->detach_code, Loop->detach_child * Minor improvements to LoopTests 0.42 BUGFIXES: * Test Stream encoding errors on a sequence which still returns U+FFFD immediately on 5.14.0 (RT69020) 0.41 CHANGES: * Support 'encoding' parameter in IO::Async::Stream * Allow IO::Async::Stream->write with an empty string, for the side-effect of setting an on_flush handler * Support 'first_interval' parameter to IO::Async::Timer::Periodic * Expanded documentation of timers BUGFIXES: * Explicitly 'use IO::Handle;' 0.40 ADDITIONS: * Added IO::Async::FileStream - RT66520 * Added IO::Async::Stream 'close_on_read_eof' parameter * Added IO::Async::Listener 'on_accept_failure' event CHANGES: * Allow Loop->listen to be extended via extensions, similar to ->connect * Autoflush streams used in Function::Worker objects by default * Default Resolver to idle_timeout=30, min_workers=0 BUGFIXES: * Don't convert method names to CODErefs during _capture_weakself as it breaks dynamic dispatch and code reload - RT65785 * Only calculate Timer::Periodic's next tick time if it actually has a Loop * Put primary GID first in a 'setgroups' list, otherwise some BSDs get upset - RT65127 * Load getaddrinfo() from Socket or Socket::GetAddrInfo in t/50resolver.t * Remove the anonymous Listener from the Loop if Loop->listen fails - RT66168 * Supply LocalPort => 0 to IO::Socket::INET constructor explicitly during testing 0.39 CHANGES: * Added IO::Async::Notifier 'notifier_name' parameter, which may be used in debugging code in a later version * Added IO::Async::Stream on_write_eof event * Complain about unrecognised keys in IO::Async::Loop->watch_io and IO::Async::Stream->write BUGFIXES: * Don't claim on_hangup supported except on those places we know it will be (Linux, FreeBSD >= 8.0) * Fixed race condition in t/41detached-code.t * Fixed race condition in IO::Async::Function 0.38 ADDITIONS: * IO::Async::Function * IO::Async::Loop->notifiers accessor CHANGES: * Symbolic flags in IO::Async::Resolver as convenience for commonly used flag constants * Distribution now uses Test::Fatal rather than Test::Exception * Resolver is now a subclass of Function, not DetachedCode BUGFIXES: * More robust detection of Socket vs Socket::GetAddrInfo * Portability fix for ChildManager's FD_CLOEXEC flag 0.37 ADDITIONS: * Handle->close_read, ->close_write * Stream on_read_eof event * extract_addrinfo conveniences for 'inet', 'inet6' and 'unix' CHANGES: * Allow Process filehandles to set up plain pipes without read/write behaviour on the associated Stream * Renamed Loop->unpack_addrinfo to ->extract_addrinfo * Prepare for Socket::getaddrinfo() in core; prefer it to Socket::GetAddrInfo::getaddrinfo() 0.36 ADDITIONS: * IO::Async::Process CHANGES: * Allow prequeuing of ->write data in Stream * Check that signal handling remains properly deferred in LoopTests * Miscellaneous documentation and examples updates BUGFIXES: * RT 64558 - getaddrinfo() returns duplicate addresses for localhost * Don't rely on having NI_NUMERICSERV 0.35 ADDITIONS: * Loop->unpack_addrinfo CHANGES: * Recognise 'inet' and 'unix' as socket families * Recognise 'stream', 'dgram' and 'raw' as socket types * Recognise nicer HASH-based addrinfo layout in ->connect and ->listen * Listener now has on_stream / on_socket as full events, not just CODEref parameters * Make Resolver->getaddrinfo try synchronously if given numeric names * Make Resolver->getnameinfo run synchronously if given NI_NUMERICHOST|NI_NUMERICSERV flags * Try to combine small data buffers from Stream->write calls if possible BUGFIXES: * Linefeed in die case of getaddrinfo_hash to preserve exeception string * Deconfigure Protocol->transport after it is closed 0.34 ADDITIONS: * New Notifier methods ->_replace_weakself, ->maybe_invoke_event, ->maybe_make_event_cb * New Protocol method ->connect * New subclass Protocol::LineStream * Direct Resolver->getaddrinfo and ->getnameinfo methods CHANGES: * New Protocol::Stream->new( handle => $io ) parameters, which creates an IO::Async::Stream to use as a transport * Renamed Loop->detach_child to Loop->fork * Pass errno values into ->connect on_connect_error and ->listen on_listen_error * Support timeouts on Resolver operations * Allow direct access to Resolver via Loop->resolver BUGFIXES: * Make sure Protocol::Stream handles writersub and on_flush callback 0.33 ADDITIONS: * Allow watching child PID 0, to capture every child process exit * $loop->time accessor * Stream->write( sub { ... } ) dynamic stream generation * Stream->write( $data, on_flush => sub { ... } ) callback CHANGES: * IO::Async::Loop->new magic constructor now caches the loop; useful for wrapping modules, other event system integration, etc.. 0.32 ADDITIONS: * IO::Async::Timer::Absolute * Listener accessors for ->sockname, ->family, ->socktype CHANGES: * Implement and document Handle's want_{read,write}ready parameters * Rearranged documentation for Notifier subclasses; new EVENTS sections * Correct location for #io-async channel on irc.perl.org 0.31 ADDITIONS: * Delegate Protocol->close method and on_closed continuation to its transport object * Stream->new_for_stdin, ->new_for_stdout, ->new_for_stdio * Support Listener->new( handle => $fh ) * IO::Async::PID notifier subclass CHANGES: * Better documentation of Listener and Connector addr and addrs arguments BUGFIXES: * INADDR_ANY/INADDR_LOOPBACK fixes inside BSD jails with restricted networking 0.30 ADDITIONS: * Added IO::Async::Socket * Added IO::Async::Protocol and ::Protocol::Stream * Added on_stream and on_socket continuations for $loop->connect and Listener CHANGES: * Emulate socketpair(AF_INET,...) * Allow IO::Async::Stream 's read_len and write_len to be configured per-instance * Allow a Stream object without an on_read handler BUGFIXES: * Cope with exceptional-state sockets in Loop::Poll 0.29 CHANGES: * Don't require 'CODE' refs for callbacks/continations; this allows the use of CODEref objects, &{} operator overloads, or other things that are callable * Implement 'read_all' and 'write_all' options on IO::Async::Stream * Allow IO::Async::Stream subclasses to override on_closed BUGFIXES: * Work around some OSes not implementing SO_ACCEPTCONN * Ensure Handle's on_read_ready/on_write_ready callbacks also take a $self reference 0.28 BUGFIXES: * Ensure that Timer->start returns $self even when not in a Loop * Accept bare GLOB refs as IO::Async::Listener handles; upgrade them to IO::Socket refs if required * Applied documentation patch from RT 55375 - thanks to Chris Williams 0.27 CHANGES: * Implement 'autoflush' option on IO::Async::Stream BUGFIXES: * Avoid $_ breaking stored signal handler references when invoking them * Ignore EINTR from sysread/syswrite * More reliable socket address tests - don't rely on uninitialised padding bytes between struct members 0.26 BUGFIXES: * Connect to INADDR_LOOPBACK rather than INADDR_ANY during t/24listener.t; hopefully fixes FAILs on OpenBSD * Fix IO::Async::Stream during combined read/write-ready of a closed stream 0.25 CHANGES: * Accept 'stream'/'dgram'/'raw' as symbolic shortcuts for socket types in connect/listen operations - avoids 'use Socket' * Accept IO::Handle-derived objects in ChildManager setup keys as well as raw GLOB refs BUGFIXES: * Various changes to test scripts to hopefully improve portability or reliability during smoke tests 0.24 ADDITIONS: * Timer subclasses - Countdown and Periodic * Idleness event watching via low-level 'watch_io/unwatch_io' methods and higher-level 'later' method * Added the missing 'unwatch_child' method * Shareable acceptance testing suite for IO::Async::Loop subclasses for better testing in subclass implementations CHANGES: * More future-proof API version checking for subclasses - requires subclasses to declare their version. ### pre-0.24 Loop subclasses are no longer compatible. ### * Entirely remove the need to $loop->enable_childmanager by calling waitpid() in 'watch_child'. 0.23 CHANGES: * Rearranged IO::Async::Listener to be a constructable Notifier suclass * Allow Signal, Timer and Listener to act as base classes as well as standalone with callbacks * Renamed IO::Async::Loop::IO_Poll to ::Poll; created transparent backward-compatibility wrapper 0.22 CHANGES: * Added tcp-proxy.pl example * More documentation on IO::Async::Notifier subclass-override methods * Documented that IO::Async::MergePoint is just an Async::MergePoint * Various small updates to keep CPANTS happy BUGFIXES: * Don't test Async::MergePoint locally as it's now a separate dist, and the tests here were reporting false negatives. 0.21 CHANGES: * Added "use warnings" to all modules * Created Notifier->configure method to allow changing properties of a Notifier or subclass after construction * New 'examples' dir with some small example scripts BUGFIXES: * More robust timing tests to avoid some spurious test failures due to busy testing servers or other non-issues 0.20 CHANGES: * Major reworking of underlying Loop implementation: + Unified low-level IO, timer and signal watches as callbacks + Split IO handle parts of Notifier into new IO::Async::Handle class + Created Timer and Signal subclasses of Notifier These changes will require a compatible upgrade to the underlying Loop implementation. * Hide SignalProxy and TimeQueue from CPAN's indexer, as they are internal-only details that don't need exposing there. * Loop magic constructor now warns if a specifically-requested class is not available * Allow multiple attachment of signals via Loop->attach_signal or new Signal objects 0.19 CHANGES: * Allow control of Sequencer's pipelining * Documentation fixes * Allow Loop->run_child to take a 'setup' array * Added 'setuid', 'setgid' and 'setgroups' child setup operations * Support 'on_notifier' in Loop->listen BUGFIXES: * carp before return in Stream->write so it actually prints * Ensure Streams still work after being closed and reopened by ->set_handle * If IO::Socket->new() fails, try again with generic ->socket (makes IPv6 work on platforms without IO::Socket::INET6) 0.18 CHANGES: * Allow Sequencer to be a base class as well as using constructor callbacks * Use signal names from Config.pm rather than relying on POSIX.pm. Covers more signals that way BUGFIXES: * Gracefully handle accept() returning EAGAIN * Fixed handling of IO::Socket->getsockopt( SOL_SOCKET, SO_ERROR ) 0.17 CHANGES: * Added Stream->close_when_empty and ->close_now. Added docs * Added OS abstractions of socketpair() and pipe() * Many documentation changes and updates BUGFIXES: * Properly handle stream read/write errors; close immediately rather than deferring until empty. * Various CPAN testers somketest bug fixes * Fixed http://rt.cpan.org/Ticket/Display.html?id=38476 0.16 ADDITIONS: * Loop->requeue_timer() * Magic constructor in IO::Async::Loop which tries to find the best subclass * 'chdir' and 'nice' ChildManager operations CHANGES: * Make sure that top-level objects are refcount-clean by using Test::Refcount, and Scalar::Util::weaken() BUGFIXES: * Keep perl 5.6.1 happy by not passing LocalPort => 0 when constructing IO::Socket::INETs * Pass the Type option to IO::Socket::INET constructor in test scripts 0.15 REMOVALS: * IO::Async::Set subclasses and IO::Async::Buffer have now been entirely removed. CHANGES: * Support handle-less IO::Async::Sequencer, like ::Notifier * Set SO_REUSEADDR on listening sockets by default * Allow Loop->listen() on a plain filehandle containing a socket * No longer any need to explcitly call Loop->enable_childmanager BUGFIXES: * IO::Async::Loop->_adjust_timeout actually works properly * Notifier->close() only runs on_closed callback if it actually closed - allows for neater cross-connected Notifiers * Made Notifier->want_{read,write}ready more efficient * Notifier->close() on a child notifier works * Loop->listen() should take the first successful address, rather than trying them all 0.14 REMOVALS: * IO::Async::Set subclasses and IO::Async::Buffer are now completely deprecated. Any attempt to use them will fail immediately. ADDITIONS: * 'keep' ChildManager operation * IO::Async::Test::wait_for_stream() * Loop->listen() * IO::Async::Sequencer class CHANGES: * Support dynamic swapping of temporary 'on_read' handlers in Stream * Now requires Socket::GetAddrInfo >= 0.08 * Further shortcuts in ChildManager setup keys - IO references and simple string operation names * Support handle-less IO::Async::Notifiers that have IO handles added to them later * Allow 'setup' key to Loop->detach_code() * Various documentation updates BUGFIXES: * Allow the same filehandle to be 'dup'ed more than once in ChildManager 0.13 CHANGES: * Flush all awaiting data from Stream when it becomes writeready * Supply a real IO::Async::Test module to allow testing in 3rd party distros * Various documentation fixes BUGFIXES: * Don't rely on STDOUT being writable during test scripts 0.12 CHANGES: * Allow Notifiers that are write-only. * Added ChildManager->open and ->run; with ->open_child and ->run_child on the containing Loop. * Moved IO::Async::Loop::Glib out to its own CPAN dist, to simplify Build.PL and testing scripts BUGFIXES: * Make sure to "use IO::Socket" in IO::Async::Connector * Pass 'socktype' argument to ->connect during testing 0.11 INCOMPATIBLE CHANGES: * Renamed IO::Async::Set::* to IO::Async::Loop::* - provided backward-compatibility wrappers around old names. IO::Async::Set::GMainLoop has become IO::Async::Lib::Glib * Renamed IO::Async::Buffer to IO::Async::Stream - provided backward- compatibility wrapper around old name. * Loop->get_childmanager() and ->get_sigproxy() no longer allowed CHANGES: * Extended ->loop_once() and ->loop() feature out to all IO::Async::Loop classes * Added IO::Async::Resolver and IO::Async::Connector, plus Loop integration * Allow write-only IO::Async::Notifiers that have no read handle or readiness callback. 0.10 INCOMPATIBLE CHANGES: * Renamed events and methods in IO::Async::Notifier to better fit the naming scheme of normal Perl handles. Backward-compatibility hooks are currently provided, but will be removed in a later release. Any code using the old names should be updated CHANGES: * Allow DetachedCode to have multiple back-end worker processes. * Control if a back-end worker exits when the code "die"s * Added 'close()' method on Notifiers/Buffers. Sensible behaviour on buffers with queued data to send * Reset %SIG hash in ChildManager->detach_child() BUGFIXES: * Clean up temporary directory during testing * Shut down DetachedCode workers properly on object deref * Better handling of borderline timing failures in t/11set-*.t * Close old handles before dup2()ing new ones when detaching code * Various other minor test script improvements 0.09 CHANGES: * Added TimeQueue object and integration with IO::Async::Set and subclasses. * Added MergePoint object * Added 'on_closed' callback support to IO::Async::Notifier BUGFIXES: * Don't depend on system locale when checking string value of $! * Fixed test scripts to more closely approximate real code behaviour in the presence of poll() vs. deferred signal delivery 0.08 CHANGES: * Added ChildManager->detach_child() method * Added DetachedCode object BUGFIXES: * Better tests for presence of Glib to improve test false failures * More lenient times in test script 11set-IO-Poll-timing to allow for variances at test time * Avoid bugs in post_select()/post_poll() caused by some notifier callbacks removing other notifiers from the set 0.07 BUGFIXES: * Avoid race condition in t/30childmanager.t - wait for child process to actually exit * Avoid race condition in IO::Async::ChildManager->spawn() by waiting for SIGCHLD+pipe close, rather than SIGCHLD+pipe data 0.06 CHANGES: * Allow 'env' setup key to ChildManager->spawn() to change the child's %ENV * Updated the way some of the ->spawn() tests are conducted. There seems to be massive failures reported on cpantesters against 0.05. These changes won't fix the bugs, but should assist in reporting and tracking them down. BUGFIXES: * Don't rely on existence of /bin/true - test for /usr/bin/true as well, fall back on "$^X -e 1" * Avoid kernel race condition in t/32childmanager-spawn-setup.t by proper use of select() when testing. 0.05 CHANGES: * Added ChildManager object * Added singleton storage in IO::Async::Set to store a SignalProxy or ChildManager conveniently BUGFIXES: * Workaround for a bug in IO::Poll version 0.05 0.04 CHANGES: * Added dynamic signal attach / detach methods to SignalProxy * Buffer now has on_read_error / on_write_error callbacks for handling IO errors on underlying sysread()/syswrite() calls 0.03 CHANGES: * No longer build_requires 'Glib' - print a warning if it's not installed but carry on anyway. * IO_Poll->loop_once() now returns the result from the poll() call * Added concept of nested child notifiers within Notifier object BUGFIXES: * Fix to test scripts that call IO_Poll's loop_once() with a timeout of zero. This can cause a kernel race condition, so supply some small non-zero value instead. 0.02 INCOMPATIBLE CHANGES: * Event methods/callback functions now called "on_*" to distinguish them * Callback functions now pass $self as first argument to simplify called code CHANGES: * Improved POD in Notifier.pm and Buffer.pm BUGFIXES: * GMainLoop.pm - return 1 from callbacks so that glib doesn't remove our IO sources * GMainLoop.pm - make sure re-asserting want_writeready actually adds the IO source again 0.01 First version, released on an unsuspecting world. IO-Async-0.804/LICENSE000444001750001750 4653415001742754 13033 0ustar00leoleo000000000000This software is copyright (c) 2025 by Paul Evans . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2025 by Paul Evans . This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Perl Artistic License 1.0 --- This software is Copyright (c) 2025 by Paul Evans . This is free software, licensed under: The Perl Artistic License 1.0 The "Artistic License" Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder as specified below. "Copyright Holder" is whoever is named in the copyright or copyrights for the package. "You" is you, if you're thinking about copying or distributing this Package. "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as uunet.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) give non-standard executables non-standard names, and clearly document the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. You may embed this Package's interpreter within an executable of yours (by linking); this shall be construed as a mere form of aggregation, provided that the complete Standard Version of the interpreter is so embedded. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whoever generated them, and may be sold commercially, and may be aggregated with this Package. If such scripts or library files are aggregated with this Package via the so-called "undump" or "unexec" methods of producing a binary executable image, then distribution of such an image shall neither be construed as a distribution of this Package nor shall it fall under the restrictions of Paragraphs 3 and 4, provided that you do not represent such an executable image as a Standard Version of this Package. 7. C subroutines (or comparably compiled subroutines in other languages) supplied by you and linked into this Package in order to emulate subroutines and variables of the language defined by this Package shall not be considered part of this Package, but are the equivalent of input as in Paragraph 6, provided these subroutines do not change the language in any way that would cause it to fail the regression tests for the language. 8. Aggregation of this Package with a commercial distribution is always permitted provided that the use of this Package is embedded; that is, when no overt attempt is made to make this Package's interfaces visible to the end user of the commercial distribution. Such use shall not be construed as a distribution of this Package. 9. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 10. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End IO-Async-0.804/MANIFEST000444001750001750 501315001742754 13122 0ustar00leoleo000000000000.editorconfig Build.PL Changes examples/chat-server.pl examples/echo-server.pl examples/netcat-client.pl examples/readwrite-futures.pl examples/tail-logfile.pl examples/tcp-proxy.pl examples/whoami-server.pl lib/Future/IO/Impl/IOAsync.pm lib/IO/Async.pm lib/IO/Async/Channel.pm lib/IO/Async/Debug.pm lib/IO/Async/File.pm lib/IO/Async/FileStream.pm lib/IO/Async/Function.pm lib/IO/Async/Future.pm lib/IO/Async/Handle.pm lib/IO/Async/Internals/ChildManager.pm lib/IO/Async/Internals/Connector.pm lib/IO/Async/Internals/FunctionWorker.pm lib/IO/Async/Internals/TimeQueue.pm lib/IO/Async/Listener.pm lib/IO/Async/Loop.pm lib/IO/Async/Loop/Poll.pm lib/IO/Async/Loop/Select.pm lib/IO/Async/LoopTests.pm lib/IO/Async/Metrics.pm lib/IO/Async/Notifier.pm lib/IO/Async/OS.pm lib/IO/Async/OS/cygwin.pm lib/IO/Async/OS/linux.pm lib/IO/Async/OS/MSWin32.pm lib/IO/Async/PID.pm lib/IO/Async/Process.pm lib/IO/Async/Protocol.pm lib/IO/Async/Protocol/LineStream.pm lib/IO/Async/Protocol/Stream.pm lib/IO/Async/Resolver.pm lib/IO/Async/Routine.pm lib/IO/Async/Signal.pm lib/IO/Async/Socket.pm lib/IO/Async/Stream.pm lib/IO/Async/Test.pm lib/IO/Async/Timer.pm lib/IO/Async/Timer/Absolute.pm lib/IO/Async/Timer/Countdown.pm lib/IO/Async/Timer/Periodic.pm LICENSE MANIFEST This list of files META.json META.yml README t/00use.t t/01timequeue.t t/02os.t t/03loop-magic.t t/04notifier.t t/05notifier-loop.t t/06notifier-mixin.t t/07notifier-future.t t/10loop-poll-io.t t/10loop-select-io.t t/11loop-poll-timer.t t/11loop-select-timer.t t/12loop-poll-signal.t t/12loop-select-signal.t t/13loop-poll-idle.t t/13loop-select-idle.t t/14loop-poll-process.t t/14loop-select-process.t t/15loop-poll-control.t t/15loop-select-control.t t/16loop-poll-metrics.t t/16loop-select-metrics.t t/18loop-poll-legacy.t t/18loop-select-legacy.t t/19loop-future.t t/19test.t t/20handle.t t/21stream-1read.t t/21stream-2write.t t/21stream-3split.t t/21stream-4encoding.t t/22timer-absolute.t t/22timer-countdown.t t/22timer-periodic.t t/23signal.t t/24listener.t t/25socket.t t/26pid.t t/27file.t t/28filestream.t t/30loop-fork.t t/31loop-spawnchild.t t/32loop-spawnchild-setup.t t/33process.t t/34process-handles.t t/35loop-openprocess.t t/36loop-runchild.t t/37loop-child-root.t t/38loop-thread.t t/39loop-runproccess.t t/40channel.t t/41routine.t t/42function.t t/50resolver.t t/51loop-connect.t t/52loop-listen.t t/53loop-extend.t t/60protocol.t t/61protocol-stream.t t/62protocol-linestream.t t/63handle-connect.t t/64handle-bind.t t/70future-io.t t/99pod.t t/RoutineTester.pm t/StupidLoop.pm t/TimeAbout.pm IO-Async-0.804/META.json000444001750001750 1333015001742754 13433 0ustar00leoleo000000000000{ "abstract" : "Asynchronous event-driven programming", "author" : [ "Paul Evans " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4234", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "IO-Async", "prereqs" : { "configure" : { "requires" : { "Module::Build" : "0.4004" } }, "runtime" : { "recommends" : { "IO::Socket::IP" : "0" }, "requires" : { "Exporter" : "5.57", "File::stat" : "0", "Future" : "0.44", "Future::Utils" : "0.18", "IO::Poll" : "0", "List::Util" : "0", "Socket" : "2.007", "Storable" : "0", "Struct::Dumb" : "0", "Time::HiRes" : "0", "perl" : "5.014" } }, "test" : { "requires" : { "File::Temp" : "0", "Test2::V0" : "0.000149", "Test::Future::IO::Impl" : "0", "Test::Metrics::Any" : "0" } } }, "provides" : { "Future::IO::Impl::IOAsync" : { "file" : "lib/Future/IO/Impl/IOAsync.pm", "version" : "0.804" }, "IO::Async" : { "file" : "lib/IO/Async.pm", "version" : "0.804" }, "IO::Async::Channel" : { "file" : "lib/IO/Async/Channel.pm", "version" : "0.804" }, "IO::Async::Debug" : { "file" : "lib/IO/Async/Debug.pm", "version" : "0.804" }, "IO::Async::File" : { "file" : "lib/IO/Async/File.pm", "version" : "0.804" }, "IO::Async::FileStream" : { "file" : "lib/IO/Async/FileStream.pm", "version" : "0.804" }, "IO::Async::Function" : { "file" : "lib/IO/Async/Function.pm", "version" : "0.804" }, "IO::Async::Future" : { "file" : "lib/IO/Async/Future.pm", "version" : "0.804" }, "IO::Async::Handle" : { "file" : "lib/IO/Async/Handle.pm", "version" : "0.804" }, "IO::Async::Internals::ChildManager" : { "file" : "lib/IO/Async/Internals/ChildManager.pm", "version" : "0.804" }, "IO::Async::Internals::FunctionWorker" : { "file" : "lib/IO/Async/Internals/FunctionWorker.pm", "version" : "0.804" }, "IO::Async::Listener" : { "file" : "lib/IO/Async/Listener.pm", "version" : "0.804" }, "IO::Async::Loop" : { "file" : "lib/IO/Async/Loop.pm", "version" : "0.804" }, "IO::Async::Loop::Poll" : { "file" : "lib/IO/Async/Loop/Poll.pm", "version" : "0.804" }, "IO::Async::Loop::Select" : { "file" : "lib/IO/Async/Loop/Select.pm", "version" : "0.804" }, "IO::Async::LoopTests" : { "file" : "lib/IO/Async/LoopTests.pm", "version" : "0.804" }, "IO::Async::Metrics" : { "file" : "lib/IO/Async/Metrics.pm", "version" : "0.804" }, "IO::Async::Notifier" : { "file" : "lib/IO/Async/Notifier.pm", "version" : "0.804" }, "IO::Async::OS" : { "file" : "lib/IO/Async/OS.pm", "version" : "0.804" }, "IO::Async::OS::MSWin32" : { "file" : "lib/IO/Async/OS/MSWin32.pm", "version" : "0.804" }, "IO::Async::OS::cygwin" : { "file" : "lib/IO/Async/OS/cygwin.pm", "version" : "0.804" }, "IO::Async::OS::linux" : { "file" : "lib/IO/Async/OS/linux.pm", "version" : "0.804" }, "IO::Async::PID" : { "file" : "lib/IO/Async/PID.pm", "version" : "0.804" }, "IO::Async::Process" : { "file" : "lib/IO/Async/Process.pm", "version" : "0.804" }, "IO::Async::Protocol" : { "file" : "lib/IO/Async/Protocol.pm", "version" : "0.804" }, "IO::Async::Protocol::LineStream" : { "file" : "lib/IO/Async/Protocol/LineStream.pm", "version" : "0.804" }, "IO::Async::Protocol::Stream" : { "file" : "lib/IO/Async/Protocol/Stream.pm", "version" : "0.804" }, "IO::Async::Resolver" : { "file" : "lib/IO/Async/Resolver.pm", "version" : "0.804" }, "IO::Async::Routine" : { "file" : "lib/IO/Async/Routine.pm", "version" : "0.804" }, "IO::Async::Signal" : { "file" : "lib/IO/Async/Signal.pm", "version" : "0.804" }, "IO::Async::Socket" : { "file" : "lib/IO/Async/Socket.pm", "version" : "0.804" }, "IO::Async::Stream" : { "file" : "lib/IO/Async/Stream.pm", "version" : "0.804" }, "IO::Async::Test" : { "file" : "lib/IO/Async/Test.pm", "version" : "0.804" }, "IO::Async::Timer" : { "file" : "lib/IO/Async/Timer.pm", "version" : "0.804" }, "IO::Async::Timer::Absolute" : { "file" : "lib/IO/Async/Timer/Absolute.pm", "version" : "0.804" }, "IO::Async::Timer::Countdown" : { "file" : "lib/IO/Async/Timer/Countdown.pm", "version" : "0.804" }, "IO::Async::Timer::Periodic" : { "file" : "lib/IO/Async/Timer/Periodic.pm", "version" : "0.804" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ], "x_IRC" : "irc://irc.perl.org/#io-async" }, "version" : "0.804", "x_serialization_backend" : "JSON::PP version 4.16" } IO-Async-0.804/META.yml000444001750001750 747415001742754 13257 0ustar00leoleo000000000000--- abstract: 'Asynchronous event-driven programming' author: - 'Paul Evans ' build_requires: File::Temp: '0' Test2::V0: '0.000149' Test::Future::IO::Impl: '0' Test::Metrics::Any: '0' configure_requires: Module::Build: '0.4004' dynamic_config: 1 generated_by: 'Module::Build version 0.4234, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: IO-Async provides: Future::IO::Impl::IOAsync: file: lib/Future/IO/Impl/IOAsync.pm version: '0.804' IO::Async: file: lib/IO/Async.pm version: '0.804' IO::Async::Channel: file: lib/IO/Async/Channel.pm version: '0.804' IO::Async::Debug: file: lib/IO/Async/Debug.pm version: '0.804' IO::Async::File: file: lib/IO/Async/File.pm version: '0.804' IO::Async::FileStream: file: lib/IO/Async/FileStream.pm version: '0.804' IO::Async::Function: file: lib/IO/Async/Function.pm version: '0.804' IO::Async::Future: file: lib/IO/Async/Future.pm version: '0.804' IO::Async::Handle: file: lib/IO/Async/Handle.pm version: '0.804' IO::Async::Internals::ChildManager: file: lib/IO/Async/Internals/ChildManager.pm version: '0.804' IO::Async::Internals::FunctionWorker: file: lib/IO/Async/Internals/FunctionWorker.pm version: '0.804' IO::Async::Listener: file: lib/IO/Async/Listener.pm version: '0.804' IO::Async::Loop: file: lib/IO/Async/Loop.pm version: '0.804' IO::Async::Loop::Poll: file: lib/IO/Async/Loop/Poll.pm version: '0.804' IO::Async::Loop::Select: file: lib/IO/Async/Loop/Select.pm version: '0.804' IO::Async::LoopTests: file: lib/IO/Async/LoopTests.pm version: '0.804' IO::Async::Metrics: file: lib/IO/Async/Metrics.pm version: '0.804' IO::Async::Notifier: file: lib/IO/Async/Notifier.pm version: '0.804' IO::Async::OS: file: lib/IO/Async/OS.pm version: '0.804' IO::Async::OS::MSWin32: file: lib/IO/Async/OS/MSWin32.pm version: '0.804' IO::Async::OS::cygwin: file: lib/IO/Async/OS/cygwin.pm version: '0.804' IO::Async::OS::linux: file: lib/IO/Async/OS/linux.pm version: '0.804' IO::Async::PID: file: lib/IO/Async/PID.pm version: '0.804' IO::Async::Process: file: lib/IO/Async/Process.pm version: '0.804' IO::Async::Protocol: file: lib/IO/Async/Protocol.pm version: '0.804' IO::Async::Protocol::LineStream: file: lib/IO/Async/Protocol/LineStream.pm version: '0.804' IO::Async::Protocol::Stream: file: lib/IO/Async/Protocol/Stream.pm version: '0.804' IO::Async::Resolver: file: lib/IO/Async/Resolver.pm version: '0.804' IO::Async::Routine: file: lib/IO/Async/Routine.pm version: '0.804' IO::Async::Signal: file: lib/IO/Async/Signal.pm version: '0.804' IO::Async::Socket: file: lib/IO/Async/Socket.pm version: '0.804' IO::Async::Stream: file: lib/IO/Async/Stream.pm version: '0.804' IO::Async::Test: file: lib/IO/Async/Test.pm version: '0.804' IO::Async::Timer: file: lib/IO/Async/Timer.pm version: '0.804' IO::Async::Timer::Absolute: file: lib/IO/Async/Timer/Absolute.pm version: '0.804' IO::Async::Timer::Countdown: file: lib/IO/Async/Timer/Countdown.pm version: '0.804' IO::Async::Timer::Periodic: file: lib/IO/Async/Timer/Periodic.pm version: '0.804' recommends: IO::Socket::IP: '0' requires: Exporter: '5.57' File::stat: '0' Future: '0.44' Future::Utils: '0.18' IO::Poll: '0' List::Util: '0' Socket: '2.007' Storable: '0' Struct::Dumb: '0' Time::HiRes: '0' perl: '5.014' resources: IRC: irc://irc.perl.org/#io-async license: http://dev.perl.org/licenses/ version: '0.804' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' IO-Async-0.804/README000444001750001750 2674115001742754 12704 0ustar00leoleo000000000000NAME IO::Async - Asynchronous event-driven programming SYNOPSIS use IO::Async::Stream; use IO::Async::Loop; my $loop = IO::Async::Loop->new; $loop->connect( host => "some.other.host", service => 12345, socktype => 'stream', on_stream => sub { my ( $stream ) = @_; $stream->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*\n)// ) { print "Received a line $1"; } return 0; } ); $stream->write( "An initial line here\n" ); $loop->add( $stream ); }, on_resolve_error => sub { die "Cannot resolve - $_[-1]\n"; }, on_connect_error => sub { die "Cannot connect - $_[0] failed $_[-1]\n"; }, ); $loop->run; DESCRIPTION This collection of modules allows programs to be written that perform asynchronous filehandle IO operations. A typical program using them would consist of a single subclass of IO::Async::Loop to act as a container of other objects, which perform the actual IO work required by the program. As well as IO handles, the loop also supports timers and signal handlers, and includes more higher-level functionality built on top of these basic parts. Because there are a lot of classes in this collection, the following overview gives a brief description of each. Notifiers The base class of all the event handling subclasses is IO::Async::Notifier. It does not perform any IO operations itself, but instead acts as a base class to build the specific IO functionality upon. It can also coordinate a collection of other Notifiers contained within it, forming a tree structure. The following sections describe particular types of Notifier. File Handle IO An IO::Async::Handle object is a Notifier that represents a single IO handle being managed. While in most cases it will represent a single filehandle, such as a socket (for example, an IO::Socket::INET connection), it is possible to have separate reading and writing handles (most likely for a program's STDIN and STDOUT streams, or a pair of pipes connected to a child process). The IO::Async::Stream class is a subclass of IO::Async::Handle which maintains internal incoming and outgoing data buffers. In this way, it implements bidirectional buffering of a byte stream, such as a TCP socket. The class automatically handles reading of incoming data into the incoming buffer, and writing of the outgoing buffer. Methods or callbacks are used to inform when new incoming data is available, or when the outgoing buffer is empty. While stream-based sockets can be handled using using IO::Async::Stream, datagram or raw sockets do not provide a bytestream. For these, the IO::Async::Socket class is another subclass of IO::Async::Handle which maintains an outgoing packet queue, and informs of packet receipt using a callback or method. The IO::Async::Listener class is another subclass of IO::Async::Handle which facilitates the use of listen(2)-mode sockets. When a new connection is available on the socket it will accept(2) it and pass the new client socket to its callback function. Timers An IO::Async::Timer::Absolute object represents a timer that expires at a given absolute time in the future. An IO::Async::Timer::Countdown object represents a count time timer, which will invoke a callback after a given delay. It can be stopped and restarted. An IO::Async::Timer::Periodic object invokes a callback at regular intervals from its initial start time. It is reliable and will not drift due to the time taken to run the callback. The IO::Async::Loop also supports methods for managing timed events on a lower level. Events may be absolute, or relative in time to the time they are installed. Signals An IO::Async::Signal object represents a POSIX signal, which will invoke a callback when the given signal is received by the process. Multiple objects watching the same signal can be used; they will all invoke in no particular order. Processes Management An IO::Async::PID object invokes its event when a given child process exits. An IO::Async::Process object can start a new child process running either a given block of code, or executing a given command, set up pipes on its filehandles, write to or read from these pipes, and invoke its event when the child process exits. Loops The IO::Async::Loop object class represents an abstract collection of IO::Async::Notifier objects, and manages the actual filehandle IO watchers, timers, signal handlers, and other functionality. It performs all of the abstract collection management tasks, and leaves the actual OS interactions to a particular subclass for the purpose. IO::Async::Loop::Poll uses an IO::Poll object for this test. IO::Async::Loop::Select uses the select(2) syscall. Other subclasses of loop may appear on CPAN under their own dists; see the "SEE ALSO" section below for more detail. As well as these general-purpose classes, the IO::Async::Loop constructor also supports looking for OS-specific subclasses, in case a more efficient implementation exists for the specific OS it runs on. Child Processes The IO::Async::Loop object provides a number of methods to facilitate the running of child processes. spawn_child is primarily a wrapper around the typical fork(2)/exec(2) style of starting child processes, and run_child provide a method similar to perl's readpipe (which is used to implement backticks ``). File Change Watches The IO::Async::File object observes changes to stat(2) properties of a file, directory, or other filesystem object. It invokes callbacks when properties change. This is used by IO::Async::FileStream which presents the same events as a IO::Async::Stream but operates on a regular file on the filesystem, observing it for updates. Asynchronous Co-routines and Functions The IO::Async framework generally provides mechanisms for multiplexing IO tasks between different handles, so there aren't many occasions when it is necessary to run code in another thread or process. Two cases where this does become useful are when: * A large amount of computationally-intensive work needs to be performed. * An OS or library-level function needs to be called, that will block, and no asynchronous version is supplied. For these cases, an instance of IO::Async::Function can be used around a code block, to execute it in a worker child process or set of processes. The code in the sub-process runs isolated from the main program, communicating only by function call arguments and return values. This can be used to solve problems involving state-less library functions. An IO::Async::Routine object wraps a code block running in a separate process to form a kind of co-routine. Communication with it happens via IO::Async::Channel objects. It can be used to solve any sort of problem involving keeping a possibly-stateful co-routine running alongside the rest of an asynchronous program. Futures An IO::Async::Future object represents a single outstanding action that is yet to complete, such as a name resolution operation or a socket connection. It stands in contrast to a IO::Async::Notifier, which is an object that represents an ongoing source of activity, such as a readable filehandle of bytes or a POSIX signal. Futures are a recent addition to the IO::Async API and details are still subject to change and experimentation. In general, methods that support Futures return a new Future object to represent the outstanding operation. If callback functions are supplied as well, these will be fired in addition to the Future object becoming ready. Any failures that are reported will, in general, use the same conventions for the Future's fail arguments to relate it to the legacy on_error-style callbacks. $on_NAME_error->( $message, @argmuents ) $f->fail( $message, NAME, @arguments ) where $message is a message intended for humans to read (so that this is the message displayed by $f->get if the failure is not otherwise caught), NAME is the name of the failing operation. If the failure is due to a failed system call, the value of $! will be the final argument. The message should not end with a linefeed. Networking The IO::Async::Loop provides several methods for performing network-based tasks. Primarily, the connect and listen methods allow the creation of client or server network sockets. Additionally, the resolve method allows the use of the system's name resolvers in an asynchronous way, to resolve names into addresses, or vice versa. These methods are fully IPv6-capable if the underlying operating system is. Protocols The IO::Async::Protocol class provides storage for a IO::Async::Handle object, to act as a transport for some protocol. It allows a level of independence from the actual transport being for that protocol, allowing it to be easily reused. The IO::Async::Protocol::Stream subclass provides further support for protocols based on stream connections, such as TCP sockets. TODO This collection of modules is still very much in development. As a result, some of the potentially-useful parts or features currently missing are: * Consider further ideas on Solaris' ports, BSD's Kevents and anything that might be useful on Win32. * Consider some form of persistent object wrapper in the form of an IO::Async::Object, based on IO::Async::Routine. * IO::Async::Protocol::Datagram * Support for watching filesystem entries for change. Extract logic from IO::Async::File and define a Loop watch/unwatch method pair. * Define more Future-returning methods. Consider also one-shot Futures on things like IO::Async::Process exits, or IO::Async::Handle close. SUPPORT Bugs may be reported via RT at https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Async Support by IRC may also be found on irc.perl.org in the #io-async channel. SEE ALSO As well as the two loops supplied in this distribution, many more exist on CPAN. At the time of writing this includes: * IO::Async::Loop::AnyEvent - use IO::Async with AnyEvent * IO::Async::Loop::Epoll - use IO::Async with epoll on Linux * IO::Async::Loop::Event - use IO::Async with Event * IO::Async::Loop::EV - use IO::Async with EV * IO::Async::Loop::Glib - use IO::Async with Glib or GTK * IO::Async::Loop::KQueue - use IO::Async with kqueue * IO::Async::Loop::Mojo - use IO::Async with Mojolicious * IO::Async::Loop::POE - use IO::Async with POE * IO::Async::Loop::Ppoll - use IO::Async with ppoll(2) Additionally, some other event loops or modules also support being run on top of IO::Async: * AnyEvent::Impl::IOAsync - AnyEvent adapter for IO::Async * Gungho::Engine::IO::Async - IO::Async Engine * POE::Loop::IO_Async - IO::Async event loop support for POE AUTHOR Paul Evans IO-Async-0.804/examples000755001750001750 015001742754 13453 5ustar00leoleo000000000000IO-Async-0.804/examples/chat-server.pl000444001750001750 262415001742754 16374 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Loop; use IO::Async::Stream; my $PORT = 12345; my $loop = IO::Async::Loop->new; my $listener = ChatListener->new; $loop->add( $listener ); $listener->listen( service => $PORT, socktype => 'stream', )->on_done( sub { my ( $listener ) = @_; my $socket = $listener->read_handle; printf STDERR "Listening on %s:%d\n", $socket->sockhost, $socket->sockport; })->get; $loop->run; package ChatListener; use base qw( IO::Async::Listener ); my @clients; sub on_stream { my $self = shift; my ( $stream ) = @_; # $socket is just an IO::Socket reference my $socket = $stream->read_handle; my $peeraddr = $socket->peerhost . ":" . $socket->peerport; # Inform the others $_->write( "$peeraddr joins\n" ) for @clients; $stream->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*\n)// ) { # eat a line from the stream input # Reflect it to all but the stream who wrote it $_ == $self or $_->write( "$peeraddr: $1" ) for @clients; } return 0; }, on_closed => sub { my ( $self ) = @_; @clients = grep { $_ != $self } @clients; # Inform the others $_->write( "$peeraddr leaves\n" ) for @clients; }, ); $loop->add( $stream ); push @clients, $stream; } IO-Async-0.804/examples/echo-server.pl000444001750001750 256715001742754 16401 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Getopt::Long; use IO::Async::Loop; use IO::Async::Listener; my $PORT = 12345; my $FAMILY; my $V6ONLY; GetOptions( 'port|p=i' => \$PORT, '4' => sub { $FAMILY = "inet" }, '6' => sub { $FAMILY = "inet6" }, 'v6only=i' => \$V6ONLY, ) or exit 1; my $loop = IO::Async::Loop->new; my $listener = IO::Async::Listener->new( on_stream => sub { my $self = shift; my ( $stream ) = @_; my $socket = $stream->read_handle; my $peeraddr = $socket->peerhost . ":" . $socket->peerport; print STDERR "Accepted new connection from $peeraddr\n"; $stream->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*\n)// ) { # eat a line from the stream input $self->write( $1 ); } return 0; }, on_closed => sub { print STDERR "Connection from $peeraddr closed\n"; }, ); $loop->add( $stream ); }, ); $loop->add( $listener ); $listener->listen( service => $PORT, socktype => 'stream', family => $FAMILY, v6only => $V6ONLY, )->on_done( sub { my ( $listener ) = @_; my $socket = $listener->read_handle; printf STDERR "Listening on %s:%d\n", $socket->sockhost, $socket->sockport; })->get; $loop->run; IO-Async-0.804/examples/netcat-client.pl000444001750001750 270115001742754 16677 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Loop; use IO::Async::Stream; my $CRLF = "\x0d\x0a"; # because \r\n is not portable my $HOST = shift @ARGV or die "Need HOST"; my $PORT = shift @ARGV or die "Need PORT"; my $loop = IO::Async::Loop->new; my $socket = $loop->connect( host => $HOST, service => $PORT, socktype => 'stream', )->get; # $socket is just an IO::Socket reference my $peeraddr = $socket->peerhost . ":" . $socket->peerport; print STDERR "Connected to $peeraddr\n"; # We need to create a cross-connected pair of Streams. Can't do that # easily without a temporary variable my ( $socketstream, $stdiostream ); $socketstream = IO::Async::Stream->new( handle => $socket, on_read => sub { my ( undef, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*)$CRLF// ) { $stdiostream->write( $1 . "\n" ); } return 0; }, on_closed => sub { print STDERR "Closed connection to $peeraddr\n"; $stdiostream->close_when_empty; }, ); $loop->add( $socketstream ); $stdiostream = IO::Async::Stream->new_for_stdio( on_read => sub { my ( undef, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*)\n// ) { $socketstream->write( $1 . $CRLF ); } return 0; }, on_closed => sub { $socketstream->close_when_empty; }, ); $loop->add( $stdiostream ); $loop->await_all( $socketstream->new_close_future, $stdiostream->new_close_future ); IO-Async-0.804/examples/readwrite-futures.pl000444001750001750 60115001742754 17603 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Loop; use IO::Async::Stream; my $loop = IO::Async::Loop->new; $loop->add( my $stdin = IO::Async::Stream->new_for_stdin( on_read => sub { 0 } ) ); $loop->add( my $stdout = IO::Async::Stream->new_for_stdout ); $stdout->write( sub { return undef if $stdin->is_read_eof; return $stdin->read_atmost( 64 * 1024 ); })->get; IO-Async-0.804/examples/tail-logfile.pl000444001750001750 112615001742754 16515 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Loop; use IO::Async::FileStream; my $FILE = shift @ARGV or die "Need FILE"; my $loop = IO::Async::Loop->new; open my $fh, "<", $FILE or die "Cannot open $FILE for reading - $!"; my $filestream = IO::Async::FileStream->new( read_handle => $fh, on_initial => sub { my ( $self ) = @_; $self->seek_to_last( "\n" ); }, on_read => sub { my ( undef, $buffref ) = @_; while( $$buffref =~ s/^(.*)\n// ) { print "$FILE: $1\n"; } return 0; }, ); $loop->add( $filestream ); $loop->run; IO-Async-0.804/examples/tcp-proxy.pl000444001750001750 362515001742754 16120 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Loop; use IO::Async::Stream; use IO::Async::Listener; my $LISTEN_PORT = 12345; my $CONNECT_HOST = "localhost"; my $CONNECT_PORT = 80; my $loop = IO::Async::Loop->new; my $listener = ProxyListener->new; $loop->add( $listener ); $listener->listen( service => $LISTEN_PORT, socktype => 'stream', )->get; $loop->run; package ProxyListener; use base qw( IO::Async::Listener ); sub on_stream { my $self = shift; my ( $stream1 ) = @_; # $socket is just an IO::Socket reference my $socket1 = $stream1->read_handle; my $peeraddr = $socket1->peerhost . ":" . $socket1->peerport; print STDERR "Accepted new connection from $peeraddr\n"; $loop->connect( host => $CONNECT_HOST, service => $CONNECT_PORT, on_stream => sub { my ( $stream2 ) = @_; $stream1->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; # Just copy all the data $stream2->write( $$buffref ); $$buffref = ""; return 0; }, on_closed => sub { $stream2->close_when_empty; print STDERR "Connection from $peeraddr closed\n"; }, ); $stream2->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; # Just copy all the data $stream1->write( $$buffref ); $$buffref = ""; return 0; }, on_closed => sub { $stream1->close_when_empty; print STDERR "Connection to $CONNECT_HOST:$CONNECT_PORT closed\n"; }, ); $loop->add( $stream1 ); $loop->add( $stream2 ); }, on_resolve_error => sub { print STDERR "Cannot resolve - $_[0]\n"; }, on_connect_error => sub { print STDERR "Cannot connect\n"; }, ); } IO-Async-0.804/examples/whoami-server.pl000444001750001750 244715001742754 16744 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Loop; use IO::Async::Stream; use IO::Async::Listener; my $PORT = 12345; my $loop = IO::Async::Loop->new; my $listener = IO::Async::Listener->new( on_accept => sub { my $self = shift; my ( $socket ) = @_; # $socket is just an IO::Socket reference my $peeraddr = $socket->peerhost . ":" . $socket->peerport; my $clientstream = IO::Async::Stream->new( write_handle => $socket, ); $loop->add( $clientstream ); $clientstream->write( "Your address is " . $peeraddr . "\n" ); $loop->resolver->getnameinfo( addr => $socket->peername, on_resolved => sub { my ( $host, $service ) = @_; $clientstream->write( "You are $host:$service\n" ); $clientstream->close_when_empty; }, on_error => sub { $clientstream->write( "Cannot resolve your address - $_[-1]\n" ); $clientstream->close_when_empty; }, ); }, ); $loop->add( $listener ); $listener->listen( service => $PORT, socktype => 'stream', )->on_done( sub { my ( $listener ) = @_; my $socket = $listener->read_handle; printf STDERR "Listening on %s:%d\n", $socket->sockhost, $socket->sockport; })->get; $loop->run; IO-Async-0.804/lib000755001750001750 015001742754 12403 5ustar00leoleo000000000000IO-Async-0.804/lib/Future000755001750001750 015001742754 13655 5ustar00leoleo000000000000IO-Async-0.804/lib/Future/IO000755001750001750 015001742754 14164 5ustar00leoleo000000000000IO-Async-0.804/lib/Future/IO/Impl000755001750001750 015001742754 15065 5ustar00leoleo000000000000IO-Async-0.804/lib/Future/IO/Impl/IOAsync.pm000444001750001750 522515001742754 17071 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2019-2024 -- leonerd@leonerd.org.uk package Future::IO::Impl::IOAsync 0.804; use v5.14; use warnings; use base qw( Future::IO::ImplBase ); =head1 NAME C - implement C using C =head1 DESCRIPTION This module provides an implementation for L which uses L. There are no additional methods to use in this module; it simply has to be loaded, and will provide the C implementation methods. use Future::IO; use Future::IO::Impl::IOAsync; my $f = Future::IO->sleep(5); ... =cut use IO::Async::Loop; __PACKAGE__->APPLY; my $loop; sub sleep { shift; my ( $secs ) = @_; return ( $loop //= IO::Async::Loop->new )->delay_future( after => $secs ); } my %watching_read_by_fileno; # {fileno} => [@futures] # Not (yet) part of Future::IO API but it seems a useful way to build this sub ready_for_read { shift; my ( $fh ) = @_; my $watching = $watching_read_by_fileno{ $fh->fileno } //= []; $loop //= IO::Async::Loop->new; my $f = $loop->new_future; my $was = scalar @$watching; push @$watching, $f; return $f if $was; $loop->watch_io( handle => $fh, on_read_ready => sub { $watching->[0]->done; shift @$watching; return if scalar @$watching; $loop->unwatch_io( handle => $fh, on_read_ready => 1, ); delete $watching_read_by_fileno{ $fh->fileno }; }, ); return $f; } my %watching_write_by_fileno; # {fileno} => [@futures] sub ready_for_write { shift; my ( $fh ) = @_; my $watching = $watching_write_by_fileno{ $fh->fileno } //= []; $loop //= IO::Async::Loop->new; my $f = $loop->new_future; my $was = scalar @$watching; push @$watching, $f; return $f if $was; $loop->watch_io( handle => $fh, on_write_ready => sub { $watching->[0]->done; shift @$watching; return if scalar @$watching; $loop->unwatch_io( handle => $fh, on_write_ready => 1, ); delete $watching_write_by_fileno{ $fh->fileno }; }, ); return $f; } sub waitpid { shift; my ( $pid ) = @_; my $f = ( $loop //= IO::Async::Loop->new )->new_future; $loop->watch_process( $pid, sub { my ( undef, $wstatus ) = @_; $f->done( $wstatus ); } ); $f->on_cancel( sub { $loop->unwatch_process( $pid ) } ); return $f; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO000755001750001750 015001742754 12712 5ustar00leoleo000000000000IO-Async-0.804/lib/IO/Async.pm000444001750001750 2715415001742754 14513 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2008-2024 -- leonerd@leonerd.org.uk package IO::Async 0.804; use v5.14; use warnings; # This package contains no code other than a declaration of the version. # It is provided simply to keep CPAN happy: # cpan -i IO::Async =head1 NAME C - Asynchronous event-driven programming =head1 SYNOPSIS use IO::Async::Stream; use IO::Async::Loop; my $loop = IO::Async::Loop->new; $loop->connect( host => "some.other.host", service => 12345, socktype => 'stream', on_stream => sub { my ( $stream ) = @_; $stream->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*\n)// ) { print "Received a line $1"; } return 0; } ); $stream->write( "An initial line here\n" ); $loop->add( $stream ); }, on_resolve_error => sub { die "Cannot resolve - $_[-1]\n"; }, on_connect_error => sub { die "Cannot connect - $_[0] failed $_[-1]\n"; }, ); $loop->run; =head1 DESCRIPTION This collection of modules allows programs to be written that perform asynchronous filehandle IO operations. A typical program using them would consist of a single subclass of L to act as a container of other objects, which perform the actual IO work required by the program. As well as IO handles, the loop also supports timers and signal handlers, and includes more higher-level functionality built on top of these basic parts. Because there are a lot of classes in this collection, the following overview gives a brief description of each. =head2 Notifiers The base class of all the event handling subclasses is L. It does not perform any IO operations itself, but instead acts as a base class to build the specific IO functionality upon. It can also coordinate a collection of other Notifiers contained within it, forming a tree structure. The following sections describe particular types of Notifier. =head2 File Handle IO An L object is a Notifier that represents a single IO handle being managed. While in most cases it will represent a single filehandle, such as a socket (for example, an L connection), it is possible to have separate reading and writing handles (most likely for a program's C and C streams, or a pair of pipes connected to a child process). The L class is a subclass of L which maintains internal incoming and outgoing data buffers. In this way, it implements bidirectional buffering of a byte stream, such as a TCP socket. The class automatically handles reading of incoming data into the incoming buffer, and writing of the outgoing buffer. Methods or callbacks are used to inform when new incoming data is available, or when the outgoing buffer is empty. While stream-based sockets can be handled using using L, datagram or raw sockets do not provide a bytestream. For these, the L class is another subclass of L which maintains an outgoing packet queue, and informs of packet receipt using a callback or method. The L class is another subclass of L which facilitates the use of C-mode sockets. When a new connection is available on the socket it will C it and pass the new client socket to its callback function. =head2 Timers An L object represents a timer that expires at a given absolute time in the future. An L object represents a count time timer, which will invoke a callback after a given delay. It can be stopped and restarted. An L object invokes a callback at regular intervals from its initial start time. It is reliable and will not drift due to the time taken to run the callback. The L also supports methods for managing timed events on a lower level. Events may be absolute, or relative in time to the time they are installed. =head2 Signals An L object represents a POSIX signal, which will invoke a callback when the given signal is received by the process. Multiple objects watching the same signal can be used; they will all invoke in no particular order. =head2 Processes Management An L object invokes its event when a given child process exits. An L object can start a new child process running either a given block of code, or executing a given command, set up pipes on its filehandles, write to or read from these pipes, and invoke its event when the child process exits. =head2 Loops The L object class represents an abstract collection of L objects, and manages the actual filehandle IO watchers, timers, signal handlers, and other functionality. It performs all of the abstract collection management tasks, and leaves the actual OS interactions to a particular subclass for the purpose. L uses an L object for this test. L uses the C syscall. Other subclasses of loop may appear on CPAN under their own dists; see the L section below for more detail. As well as these general-purpose classes, the L constructor also supports looking for OS-specific subclasses, in case a more efficient implementation exists for the specific OS it runs on. =head2 Child Processes The L object provides a number of methods to facilitate the running of child processes. C is primarily a wrapper around the typical C/C style of starting child processes, and C provide a method similar to perl's C (which is used to implement backticks C<``>). =head2 File Change Watches The L object observes changes to C properties of a file, directory, or other filesystem object. It invokes callbacks when properties change. This is used by L which presents the same events as a L but operates on a regular file on the filesystem, observing it for updates. =head2 Asynchronous Co-routines and Functions The C framework generally provides mechanisms for multiplexing IO tasks between different handles, so there aren't many occasions when it is necessary to run code in another thread or process. Two cases where this does become useful are when: =over 4 =item * A large amount of computationally-intensive work needs to be performed. =item * An OS or library-level function needs to be called, that will block, and no asynchronous version is supplied. =back For these cases, an instance of L can be used around a code block, to execute it in a worker child process or set of processes. The code in the sub-process runs isolated from the main program, communicating only by function call arguments and return values. This can be used to solve problems involving state-less library functions. An L object wraps a code block running in a separate process to form a kind of co-routine. Communication with it happens via L objects. It can be used to solve any sort of problem involving keeping a possibly-stateful co-routine running alongside the rest of an asynchronous program. =head2 Futures An L object represents a single outstanding action that is yet to complete, such as a name resolution operation or a socket connection. It stands in contrast to a L, which is an object that represents an ongoing source of activity, such as a readable filehandle of bytes or a POSIX signal. Futures are a recent addition to the C API and details are still subject to change and experimentation. In general, methods that support Futures return a new Future object to represent the outstanding operation. If callback functions are supplied as well, these will be fired in addition to the Future object becoming ready. Any failures that are reported will, in general, use the same conventions for the Future's C arguments to relate it to the legacy C-style callbacks. $on_NAME_error->( $message, @argmuents ) $f->fail( $message, NAME, @arguments ) where C<$message> is a message intended for humans to read (so that this is the message displayed by C<< $f->get >> if the failure is not otherwise caught), C is the name of the failing operation. If the failure is due to a failed system call, the value of C<$!> will be the final argument. The message should not end with a linefeed. =head2 Networking The L provides several methods for performing network-based tasks. Primarily, the C and C methods allow the creation of client or server network sockets. Additionally, the C method allows the use of the system's name resolvers in an asynchronous way, to resolve names into addresses, or vice versa. These methods are fully IPv6-capable if the underlying operating system is. =head2 Protocols The L class provides storage for a L object, to act as a transport for some protocol. It allows a level of independence from the actual transport being for that protocol, allowing it to be easily reused. The L subclass provides further support for protocols based on stream connections, such as TCP sockets. =head1 TODO This collection of modules is still very much in development. As a result, some of the potentially-useful parts or features currently missing are: =over 4 =item * Consider further ideas on Solaris' I, BSD's I and anything that might be useful on Win32. =item * Consider some form of persistent object wrapper in the form of an C, based on L. =item * C =item * Support for watching filesystem entries for change. Extract logic from L and define a Loop watch/unwatch method pair. =item * Define more L-returning methods. Consider also one-shot Futures on things like L exits, or L close. =back =head1 SUPPORT Bugs may be reported via RT at https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Async Support by IRC may also be found on F in the F<#io-async> channel. =cut =head1 SEE ALSO As well as the two loops supplied in this distribution, many more exist on CPAN. At the time of writing this includes: =over 4 =item * L - use IO::Async with AnyEvent =item * L - use IO::Async with epoll on Linux =item * L - use IO::Async with Event =item * L - use IO::Async with EV =item * L - use IO::Async with Glib or GTK =item * L - use IO::Async with kqueue =item * L - use IO::Async with Mojolicious =item * L - use IO::Async with POE =item * L - use IO::Async with ppoll(2) =back Additionally, some other event loops or modules also support being run on top of C: =over 4 =item * L - AnyEvent adapter for IO::Async =item * L - IO::Async Engine =item * L - IO::Async event loop support for POE =back =cut =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async000755001750001750 015001742754 13767 5ustar00leoleo000000000000IO-Async-0.804/lib/IO/Async/Channel.pm000444001750001750 3321115001742754 16052 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2024 -- leonerd@leonerd.org.uk package IO::Async::Channel 0.804; use v5.14; use warnings; use base qw( IO::Async::Notifier ); use Carp; use IO::Async::Stream; =head1 NAME C - pass values into or out from an L =head1 DESCRIPTION A C object allows Perl values to be passed into or out of an L. It is intended to be used primarily with a Routine object rather than independently. For more detail and examples on how to use this object see also the documentation for L. A Channel object is shared between the main process of the program and the process running within the Routine. In the main process it will be used in asynchronous mode, and in the Routine process it will be used in synchronous mode. In asynchronous mode all methods return immediately and use L-style futures or callback functions. In synchronous within the Routine process the methods block until they are ready and may be used for flow-control within the routine. Alternatively, a Channel may be shared between two different Routine objects, and not used directly by the controlling program. The channel itself represents a FIFO of Perl reference values. New values may be put into the channel by the C method in either mode. Values may be retrieved from it by the C method. Values inserted into the Channel are snapshot by the C method. Any changes to referred variables will not be observed by the other end of the Channel after the C method returns. =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 codec => STR Gives the name of the encoding method used to represent values over the channel. This can be set to C to use the core L module. As this only supports references, to pass a single scalar value, C a SCALAR reference to it, and dereference the result of C. If the L and L modules are installed, this can be set to C instead, and will use those to perform the encoding and decoding. This optional dependency may give higher performance than using C. If these modules are available, then this option is picked by default. =cut =head1 CONSTRUCTOR =cut =head2 new $channel = IO::Async::Channel->new; Returns a new C object. This object reference itself should be shared by both sides of a Ced process. After C the two C methods may be used to configure the object for operation on either end. While this object does in fact inherit from L, it should not be added to a Loop object directly; event management will be handled by its containing L object. =cut # Undocumented convenience constructors for running IaRoutine in 'spawn' mode sub new_sync { my $class = shift; my ( $fd ) = @_; my $self = $class->new; $self->setup_sync_mode( $fd ); return $self; } sub new_stdin { shift->new_sync( \*STDIN ); } sub new_stdout { shift->new_sync( \*STDOUT ); } sub DESTROY { my $self = shift; eval { $self->close }; # ignore any error } =head1 METHODS The following methods documented in C expressions return L instances. =cut =head2 configure $channel->configure( %params ); Similar to the standard C method on L, this is used to change details of the Channel's operation. =over 4 =item on_recv => CODE May only be set on an async mode channel. If present, will be invoked whenever a new value is received, rather than using the C method. $on_recv->( $channel, $data ); =item on_eof => CODE May only be set on an async mode channel. If present, will be invoked when the channel gets closed by the peer. $on_eof->( $channel ); =back =cut my $DEFAULT_CODEC; sub _default_codec { $DEFAULT_CODEC ||= do { my $HAVE_SEREAL = defined eval { require Sereal::Encoder; require Sereal::Decoder }; $HAVE_SEREAL ? "Sereal" : "Storable"; }; } sub _init { my $self = shift; my ( $params ) = @_; $params->{codec} //= _default_codec; $self->SUPER::_init( $params ); } sub configure { my $self = shift; my %params = @_; foreach (qw( on_recv on_eof )) { next unless exists $params{$_}; $self->{mode} and $self->{mode} eq "async" or croak "Can only configure $_ in async mode"; $self->{$_} = delete $params{$_}; $self->_build_stream; } if( my $codec = delete $params{codec} ) { @{ $self }{qw( encode decode )} = ( $self->can( "_make_codec_$codec" ) or croak "Unrecognised codec name '$codec'" )->(); } $self->SUPER::configure( %params ); } sub _make_codec_Storable { require Storable; return \&Storable::freeze, \&Storable::thaw; } sub _make_codec_Sereal { require Sereal::Encoder; require Sereal::Decoder; my $encoder; my $decoder; # "thread safety" to Sereal::{Encoder,Decoder} means that the variables get # reset to undef in new threads. We should defend against that. return sub { ( $encoder ||= Sereal::Encoder->new )->encode( $_[0] ) }, sub { ( $decoder ||= Sereal::Decoder->new )->decode( $_[0] ) }; } =head2 send $channel->send( $data ); Pushes the data stored in the given Perl reference into the FIFO of the Channel, where it can be received by the other end. When called on a synchronous mode Channel this method may block if a C call on the underlying filehandle blocks. When called on an asynchronous mode channel this method will not block. =cut my %SENDMETHODS; sub send { my $self = shift; my ( $data ) = @_; defined( my $mode = $self->{mode} ) or die "Cannot ->send without being set up"; my $code = ( $SENDMETHODS{$mode} ||= $self->can( "_send_$mode" ) ) or die "IO::Async::Channel cannot send in unrecognised mode '$mode'"; $self->$code( $data ); } *_send_sync = *_send_async = sub { my ( $self, $data ) = @_; $self->send_encoded( $self->{encode}->( $data ) ); }; =head2 send_encoded $channel->send_encoded( $record ); A variant of the C method; this method pushes the byte record given. This should be the result of a call to C. =cut sub send_encoded { my $self = shift; my ( $record ) = @_; my $bytes = pack( "I", length $record ) . $record; defined $self->{mode} or die "Cannot ->send without being set up"; return $self->_sendbytes_sync( $bytes ) if $self->{mode} eq "sync"; return $self->_sendbytes_async( $bytes ) if $self->{mode} eq "async"; } =head2 encode $record = $channel->encode( $data ); Takes a Perl reference and returns a serialised string that can be passed to C. The following two forms are equivalent $channel->send( $data ); $channel->send_encoded( $channel->encode( $data ) ); This is provided for the use-case where data needs to be serialised into a fixed string to "snapshot it" but not sent yet; the returned string can be saved and sent at a later time. $record = IO::Async::Channel->encode( $data ); This can also be used as a class method, in case it is inconvenient to operate on a particular object instance, or when one does not exist yet. In this case it will encode using whatever is the default codec for C. =cut my $default_encode; sub encode { my $self = shift; my ( $data ) = @_; return ( ref $self ? $self->{encode} : $default_encode ||= do { ( $self->can( "_make_codec_" . _default_codec )->() )[0] } )->( $data ); } =head2 recv $data = $channel->recv; When called on a synchronous mode Channel this method will block until a Perl reference value is available from the other end and then return it. If the Channel is closed this method will return C. Since only references may be passed and all Perl references are true the truth of the result of this method can be used to detect that the channel is still open and has not yet been closed. $data = await $channel->recv; When called on an asynchronous mode Channel this method returns a future which will eventually yield the next Perl reference value that becomes available from the other end. If the Channel is closed, the future will fail with an C failure. $channel->recv( %args ); When not returning a future, takes the following named arguments: =over 8 =item on_recv => CODE Called when a new Perl reference value is available. Will be passed the Channel object and the reference data. $on_recv->( $channel, $data ); =item on_eof => CODE Called if the Channel was closed before a new value was ready. Will be passed the Channel object. $on_eof->( $channel ); =back =cut my %RECVMETHODS; sub recv { my $self = shift; defined( my $mode = $self->{mode} ) or die "Cannot ->recv without being set up"; my $code = ( $RECVMETHODS{$mode} ||= $self->can( "_recv_$mode" ) ) or die "IO::Async::Channel cannot recv in unrecognised mode '$mode'"; return $self->$code( @_ ); } =head2 close $channel->close; Closes the channel. Causes a pending C on the other end to return undef or the queued C callbacks to be invoked. =cut my %CLOSEMETHODS; sub close { my $self = shift; defined( my $mode = $self->{mode} ) or return; my $code = ( $CLOSEMETHODS{$mode} ||= $self->can( "_close_$mode" ) ) or die "IO::Async::Channel cannot close in unrecognised mode '$mode'"; return $self->$code; } # Leave this undocumented for now sub setup_sync_mode { my $self = shift; ( $self->{fh} ) = @_; $self->{mode} = "sync"; # Since we're communicating binary structures and not Unicode text we need to # enable binmode binmode $self->{fh}; defined and $_->blocking( 1 ) for $self->{read_handle}, $self->{write_handle}; $self->{fh}->autoflush(1); } sub _read_exactly { $_[1] = ""; while( length $_[1] < $_[2] ) { my $n = read( $_[0], $_[1], $_[2]-length $_[1], length $_[1] ); defined $n or return undef; $n or return ""; } return $_[2]; } sub _recv_sync { my $self = shift; my $n = _read_exactly( $self->{fh}, my $lenbuffer, 4 ); defined $n or die "Cannot read - $!"; length $n or return undef; my $len = unpack( "I", $lenbuffer ); $n = _read_exactly( $self->{fh}, my $record, $len ); defined $n or die "Cannot read - $!"; length $n or return undef; return $self->{decode}->( $record ); } sub _sendbytes_sync { my $self = shift; my ( $bytes ) = @_; $self->{fh}->print( $bytes ); } sub _close_sync { my $self = shift; $self->{fh}->close; } # Leave this undocumented for now sub setup_async_mode { my $self = shift; my %args = @_; exists $args{$_} and $self->{$_} = delete $args{$_} for qw( read_handle write_handle ); keys %args and croak "Unrecognised keys for setup_async_mode: " . join( ", ", keys %args ); defined and $_->blocking( 0 ) for $self->{read_handle}, $self->{write_handle}; $self->{mode} = "async"; } sub _build_stream { my $self = shift; return $self->{stream} ||= do { $self->{on_result_queue} = []; my $stream = IO::Async::Stream->new( read_handle => $self->{read_handle}, write_handle => $self->{write_handle}, autoflush => 1, on_read => $self->_capture_weakself( '_on_stream_read' ) ); $self->add_child( $stream ); $stream; }; } sub _sendbytes_async { my $self = shift; my ( $bytes ) = @_; $self->_build_stream->write( $bytes ); } sub _recv_async { my $self = shift; my %args = @_; my $on_recv = $args{on_recv}; my $on_eof = $args{on_eof}; my $stream = $self->_build_stream; my $f; $f = $stream->loop->new_future unless !defined wantarray; push @{ $self->{on_result_queue} }, sub { my ( $self, $type, $result ) = @_; if( $type eq "recv" ) { $f->done( $result ) if $f and !$f->is_cancelled; $on_recv->( $self, $result ) if $on_recv; } else { $f->fail( "EOF waiting for Channel recv", eof => ) if $f and !$f->is_cancelled; $on_eof->( $self ) if $on_eof; } }; return $f; } sub _close_async { my $self = shift; if( my $stream = $self->{stream} ) { $stream->close_when_empty; } else { $_ and $_->close for $self->{read_handle}, $self->{write_handle}; } undef $_ for $self->{read_handle}, $self->{write_handle}; } sub _on_stream_read { my $self = shift or return; my ( $stream, $buffref, $eof ) = @_; if( $eof ) { while( my $on_result = shift @{ $self->{on_result_queue} } ) { $on_result->( $self, eof => ); } $self->{on_eof}->( $self ) if $self->{on_eof}; return; } return 0 unless length( $$buffref ) >= 4; my $len = unpack( "I", $$buffref ); return 0 unless length( $$buffref ) >= 4 + $len; my $record = $self->{decode}->( substr( $$buffref, 4, $len ) ); substr( $$buffref, 0, 4 + $len ) = ""; if( my $on_result = shift @{ $self->{on_result_queue} } ) { $on_result->( $self, recv => $record ); } else { $self->{on_recv}->( $self, $record ); } return 1; } sub _extract_read_handle { my $self = shift; return undef if !$self->{mode}; croak "Cannot extract filehandle" if $self->{mode} ne "async"; $self->{mode} = "dead"; return $self->{read_handle}; } sub _extract_write_handle { my $self = shift; return undef if !$self->{mode}; croak "Cannot extract filehandle" if $self->{mode} ne "async"; $self->{mode} = "dead"; return $self->{write_handle}; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Debug.pm000444001750001750 605215001742754 15513 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2015-2024 -- leonerd@leonerd.org.uk package IO::Async::Debug 0.804; use v5.14; use warnings; our $DEBUG = $ENV{IO_ASYNC_DEBUG} || 0; our $DEBUG_FD = $ENV{IO_ASYNC_DEBUG_FD}; our $DEBUG_FILE = $ENV{IO_ASYNC_DEBUG_FILE}; our $DEBUG_FH; our %DEBUG_FLAGS = map { $_ => 1 } split m/,/, $ENV{IO_ASYNC_DEBUG_FLAGS} || ""; =head1 NAME C - debugging control and support for L =head1 DESCRIPTION The following methods and behaviours are still experimental and may change or even be removed in future. Debugging support is enabled by an environment variable called C having a true value. When debugging is enabled, the C and C methods on L (and their C variants) are altered such that when the event is fired, a debugging line is printed, using the C method. This identifes the name of the event. By default, the line is only printed if the caller of one of these methods is the same package as the object is blessed into, allowing it to print the events of the most-derived class, without the extra verbosity of the lower-level events of its parent class used to create it. All calls regardless of caller can be printed by setting a number greater than 1 as the value of C. By default the debugging log goes to C, but two other environment variables can redirect it. If C is set, it names a file which will be opened for writing, and logging written into it. Otherwise, if C is set, it gives a file descriptor number that logging should be written to. If opening the named file or file descriptor fails then the log will be written to C as normal. Extra debugging flags can be set in a comma-separated list in an environment variable called C. The presence of these flags can cause extra information to be written to the log. Full details on these flags will be documented by the implementing classes. Typically these flags take the form of one or more capital letters indicating the class, followed by one or more lowercase letters enabling some particular feature within that class. =cut sub logf { my ( $fmt, @args ) = @_; $DEBUG_FH ||= do { my $fh; if( $DEBUG_FILE ) { open $fh, ">", $DEBUG_FILE or undef $fh; } elsif( $DEBUG_FD ) { $fh = IO::Handle->new; $fh->fdopen( $DEBUG_FD, "w" ) or undef $fh; } $fh ||= \*STDERR; $fh->autoflush; $fh; }; printf $DEBUG_FH $fmt, @args; } sub log_hexdump { my ( $bytes ) = @_; foreach my $chunk ( $bytes =~ m/(.{1,16})/sg ) { my $chunk_hex = join " ", map { sprintf "%02X", ord $_ } split //, $chunk; ( my $chunk_safe = $chunk ) =~ s/[^\x20-\x7e]/./g; logf " | %-48s | %-16s |\n", $chunk_hex, $chunk_safe; } } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/File.pm000444001750001750 1212015001742754 15355 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2012-2024 -- leonerd@leonerd.org.uk package IO::Async::File 0.804; use v5.14; use warnings; use base qw( IO::Async::Timer::Periodic ); use Carp; use File::stat; # No point watching blksize or blocks my @STATS = qw( dev ino mode nlink uid gid rdev size atime mtime ctime ); =head1 NAME C - watch a file for changes =head1 SYNOPSIS use IO::Async::File; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $file = IO::Async::File->new( filename => "config.ini", on_mtime_changed => sub { my ( $self ) = @_; print STDERR "Config file has changed\n"; reload_config( $self->handle ); } ); $loop->add( $file ); $loop->run; =head1 DESCRIPTION This subclass of L watches an open filehandle or named filesystem entity for changes in its C fields. It invokes various events when the values of these fields change. It is most often used to watch a file for size changes; for this task see also L. While called "File", it is not required that the watched filehandle be a regular file. It is possible to watch anything that C may be called on, such as directories or other filesystem entities. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters. =head2 on_dev_changed $new_dev, $old_dev =head2 on_ino_changed $new_ino, $old_ino =head2 ... =head2 on_ctime_changed $new_ctime, $old_ctime Invoked when each of the individual C fields have changed. All the C fields are supported apart from C and C. Each is passed the new and old values of the field. =head2 on_devino_changed $new_stat, $old_stat Invoked when either of the C or C fields have changed. It is passed two L instances containing the complete old and new C fields. This can be used to observe when a named file is renamed; it will not be observed to happen on opened filehandles. =head2 on_stat_changed $new_stat, $old_stat Invoked when any of the C fields have changed. It is passed two L instances containing the old and new C fields. =cut =head1 PARAMETERS The following named parameters may be passed to C or C. =head2 handle => IO The opened filehandle to watch for C changes if C is not supplied. =head2 filename => STRING Optional. If supplied, watches the named file rather than the filehandle given in C. The file will be opened for reading and then watched for renames. If the file is renamed, the new filename is opened and tracked similarly after closing the previous file. =head2 interval => NUM Optional. The interval in seconds to poll the filehandle using C looking for size changes. A default of 2 seconds will be applied if not defined. =cut sub _init { my $self = shift; my ( $params ) = @_; $params->{interval} ||= 2; $self->SUPER::_init( $params ); $self->start; } sub configure { my $self = shift; my %params = @_; if( exists $params{filename} ) { my $filename = delete $params{filename}; $self->{filename} = $filename; $self->_reopen_file; } elsif( exists $params{handle} ) { $self->{handle} = delete $params{handle}; $self->{last_stat} = stat $self->{handle}; } foreach ( @STATS, "devino", "stat" ) { $self->{"on_${_}_changed"} = delete $params{"on_${_}_changed"} if exists $params{"on_${_}_changed"}; } $self->SUPER::configure( %params ); } sub _add_to_loop { my $self = shift; if( !defined $self->{filename} and !defined $self->{handle} ) { croak "IO::Async::File needs either a filename or a handle"; } return $self->SUPER::_add_to_loop( @_ ); } sub _reopen_file { my $self = shift; my $path = $self->{filename}; open $self->{handle}, "<", $path or croak "Cannot open $path for reading - $!"; $self->{last_stat} = stat $self->{handle}; } sub on_tick { my $self = shift; my $old = $self->{last_stat}; my $new = stat( defined $self->{filename} ? $self->{filename} : $self->{handle} ); my $any_changed; foreach my $stat ( @STATS ) { next if $old->$stat == $new->$stat; $any_changed++; $self->maybe_invoke_event( "on_${stat}_changed", $new->$stat, $old->$stat ); } if( $old->dev != $new->dev or $old->ino != $new->ino ) { $self->maybe_invoke_event( on_devino_changed => $new, $old ); $self->_reopen_file; } if( $any_changed ) { $self->maybe_invoke_event( on_stat_changed => $new, $old ); $self->{last_stat} = $new; } } =head1 METHODS =cut =head2 handle $handle = $file->handle; Returns the filehandle currently associated with the instance; either the one passed to the C parameter, or opened from the C parameter. =cut sub handle { my $self = shift; return $self->{handle}; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/FileStream.pm000444001750001750 2477515001742754 16554 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2024 -- leonerd@leonerd.org.uk package IO::Async::FileStream 0.804; use v5.14; use warnings; use base qw( IO::Async::Stream ); use IO::Async::File; use Carp; use Fcntl qw( SEEK_SET SEEK_CUR ); =head1 NAME C - read the tail of a file =head1 SYNOPSIS use IO::Async::FileStream; use IO::Async::Loop; my $loop = IO::Async::Loop->new; open my $logh, "<", "var/logs/daemon.log" or die "Cannot open logfile - $!"; my $filestream = IO::Async::FileStream->new( read_handle => $logh, on_initial => sub { my ( $self ) = @_; $self->seek_to_last( "\n" ); }, on_read => sub { my ( $self, $buffref ) = @_; while( $$buffref =~ s/^(.*\n)// ) { print "Received a line $1"; } return 0; }, ); $loop->add( $filestream ); $loop->run; =head1 DESCRIPTION This subclass of L allows reading the end of a regular file which is being appended to by some other process. It invokes the C event when more data has been added to the file. This class provides an API identical to L when given a C; it should be treated similarly. In particular, it can be given an C handler, or subclassed to provide an C method, or even used as the C for an L object. It will not support writing. To watch a file, directory, or other filesystem entity for updates of other properties, such as C, see also L. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters. Because this is a subclass of L in read-only mode, all the events supported by C relating to the read handle are supported here. This is not a full list; see also the documentation relating to L. =head2 $ret = on_read \$buffer, $eof Invoked when more data is available in the internal receiving buffer. Note that C<$eof> only indicates that all the data currently available in the file has now been read; in contrast to a regular L, this object will not stop watching after this condition. Instead, it will continue watching the file for updates. =head2 on_truncated Invoked when the file size shrinks. If this happens, it is presumed that the file content has been replaced. Reading will then commence from the start of the file. =head2 on_initial $size Invoked the first time the file is looked at. It is passed the initial size of the file. The code implementing this method can use the C or C methods to set the initial read position in the file to skip over some initial content. This method may be useful to skip initial content in the file, if the object should only respond to new content added after it was created. =cut sub _init { my $self = shift; my ( $params ) = @_; $self->SUPER::_init( $params ); $params->{close_on_read_eof} = 0; $self->{last_size} = undef; $self->add_child( $self->{file} = IO::Async::File->new( on_devino_changed => $self->_replace_weakself( 'on_devino_changed' ), on_size_changed => $self->_replace_weakself( 'on_size_changed' ), ) ); } =head1 PARAMETERS The following named parameters may be passed to C or C, in addition to the parameters relating to reading supported by L. =head2 filename => STRING Optional. If supplied, watches the named file rather than the filehandle given in C. The file will be opened by the constructor, and then watched for renames. If the file is renamed, the new filename is opened and tracked similarly after closing the previous file. =head2 interval => NUM Optional. The interval in seconds to poll the filehandle using C looking for size changes. A default of 2 seconds will be applied if not defined. =cut sub configure { my $self = shift; my %params = @_; foreach (qw( on_truncated on_initial )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } foreach (qw( interval )) { $self->{file}->configure( $_ => delete $params{$_} ) if exists $params{$_}; } if( exists $params{filename} ) { $self->{file}->configure( filename => delete $params{filename} ); $params{read_handle} = $self->{file}->handle; } elsif( exists $params{handle} or exists $params{read_handle} ) { my $handle = delete $params{handle} // delete $params{read_handle}; $self->{file}->configure( handle => $handle ); $params{read_handle} = $self->{file}->handle; } croak "Cannot have a write_handle in a ".ref($self) if defined $params{write_handle}; $self->SUPER::configure( %params ); if( $self->read_handle and !defined $self->{last_size} ) { my $size = (stat $self->read_handle)[7]; $self->{last_size} = $size; local $self->{running_initial} = 1; $self->maybe_invoke_event( on_initial => $size ); } } =head1 METHODS =cut # Replace IO::Async::Handle's implementation sub _watch_read { my $self = shift; my ( $want ) = @_; if( $want ) { $self->{file}->start if !$self->{file}->is_running; } else { $self->{file}->stop; } } sub _watch_write { my $self = shift; my ( $want ) = @_; croak "Cannot _watch_write in " . ref($self) if $want; } sub on_devino_changed { my $self = shift or return; $self->{renamed} = 1; $self->debug_printf( "read tail of old file" ); $self->read_more; } sub on_size_changed { my $self = shift or return; my ( $size ) = @_; if( $size < $self->{last_size} ) { $self->maybe_invoke_event( on_truncated => ); $self->{last_pos} = 0; } $self->{last_size} = $size; $self->debug_printf( "read_more" ); $self->read_more; } sub read_more { my $self = shift; sysseek( $self->read_handle, $self->{last_pos}, SEEK_SET ) if defined $self->{last_pos}; $self->on_read_ready; $self->{last_pos} = sysseek( $self->read_handle, 0, SEEK_CUR ); # == systell if( $self->{last_pos} < $self->{last_size} ) { $self->loop->later( sub { $self->read_more } ); } elsif( $self->{renamed} ) { $self->debug_printf( "reopening for rename" ); $self->{last_size} = 0; if( $self->{last_pos} ) { $self->maybe_invoke_event( on_truncated => ); $self->{last_pos} = 0; $self->loop->later( sub { $self->read_more } ); } $self->configure( read_handle => $self->{file}->handle ); undef $self->{renamed}; } } sub write { carp "Cannot ->write from a ".ref($_[0]); } =head2 seek $filestream->seek( $offset, $whence ); Callable only during the C event. Moves the read position in the filehandle to the given offset. C<$whence> is interpreted as for C, should be either C, C or C. Will be set to C if not provided. Normally this would be used to seek to the end of the file, for example on_initial => sub { my ( $self, $filesize ) = @_; $self->seek( $filesize ); } =cut sub seek { my $self = shift; my ( $offset, $whence ) = @_; $self->{running_initial} or croak "Cannot ->seek except during on_initial"; $whence //= SEEK_SET; sysseek( $self->read_handle, $offset, $whence ); } =head2 seek_to_last $success = $filestream->seek_to_last( $str_pattern, %opts ); Callable only during the C event. Attempts to move the read position in the filehandle to just after the last occurrence of a given match. C<$str_pattern> may be a literal string or regexp pattern. Returns a true value if the seek was successful, or false if not. Takes the following named arguments: =over 8 =item blocksize => INT Optional. Read the file in blocks of this size. Will take a default of 8KiB if not defined. =item horizon => INT Optional. Give up looking for a match after this number of bytes. Will take a default value of 4 times the blocksize if not defined. To force it to always search through the entire file contents, set this explicitly to C<0>. =back Because regular file reading happens synchronously, this entire method operates entirely synchronously. If the file is very large, it may take a while to read back through the entire contents. While this is happening no other events can be invoked in the process. When looking for a string or regexp match, this method appends the previously-read buffer to each block read from the file, in case a match becomes split across two reads. If C is reduced to a very small value, take care to ensure it isn't so small that a match may not be noticed. This is most likely useful for seeking after the last complete line in a line-based log file, to commence reading from the end, while still managing to capture any partial content that isn't yet a complete line. on_initial => sub { my $self = shift; $self->seek_to_last( "\n" ); } =cut sub seek_to_last { my $self = shift; my ( $str_pattern, %opts ) = @_; $self->{running_initial} or croak "Cannot ->seek_to_last except during on_initial"; my $offset = $self->{last_size}; my $blocksize = $opts{blocksize} || 8192; $opts{horizon} //= $blocksize * 4; my $horizon = $opts{horizon} ? $offset - $opts{horizon} : 0; $horizon = 0 if $horizon < 0; my $re = ref $str_pattern ? $str_pattern : qr/\Q$str_pattern\E/; my $prev = ""; while( $offset > $horizon ) { my $len = $blocksize; $len = $offset if $len > $offset; $offset -= $len; sysseek( $self->read_handle, $offset, SEEK_SET ); sysread( $self->read_handle, my $buffer, $blocksize ); # TODO: If $str_pattern is a plain string this could be more efficient # using rindex if( () = ( $buffer . $prev ) =~ m/$re/sg ) { # $+[0] will be end of last match my $pos = $offset + $+[0]; $self->seek( $pos ); return 1; } $prev = $buffer; } $self->seek( $horizon ); return 0; } =head1 TODO =over 4 =item * Move the actual file update watching code into L, possibly as a new watch/unwatch method pair C. =item * Consider if a construction-time parameter of C or C might be neater than a small code block in C, if that turns out to be the only or most common form of use. =back =cut =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Function.pm000444001750001750 5143315001742754 16275 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2024 -- leonerd@leonerd.org.uk package IO::Async::Function 0.804; use v5.14; use warnings; use base qw( IO::Async::Notifier ); use IO::Async::Timer::Countdown; use Carp; use List::Util qw( first ); use Struct::Dumb qw( readonly_struct ); readonly_struct Pending => [qw( priority f )]; =head1 NAME C - call a function asynchronously =head1 SYNOPSIS use Future::AsyncAwait; use IO::Async::Function; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $function = IO::Async::Function->new( code => sub { my ( $number ) = @_; return is_prime( $number ); }, ); $loop->add( $function ); my $isprime = await $function->call( args => [ 123454321 ], ); print "123454321 " . ( $isprime ? "is" : "is not" ) . " a prime number\n"; =head1 DESCRIPTION This subclass of L wraps a function body in a collection of worker processes, to allow it to execute independently of the main process. The object acts as a proxy to the function, allowing invocations to be made by passing in arguments, and invoking a continuation in the main process when the function returns. The object represents the function code itself, rather than one specific invocation of it. It can be called multiple times, by the C method. Multiple outstanding invocations can be called; they will be dispatched in the order they were queued. If only one worker process is used then results will be returned in the order they were called. If multiple are used, then each request will be sent in the order called, but timing differences between each worker may mean results are returned in a different order. Since the code block will be called multiple times within the same child process, it must take care not to modify any of its state that might affect subsequent calls. Since it executes in a child process, it cannot make any modifications to the state of the parent program. Therefore, all the data required to perform its task must be represented in the call arguments, and all of the result must be represented in the return values. The Function object is implemented using an L with two L objects to pass calls into and results out from it. The L framework generally provides mechanisms for multiplexing IO tasks between different handles, so there aren't many occasions when such an asynchronous function is necessary. Two cases where this does become useful are: =over 4 =item 1. When a large amount of computationally-intensive work needs to be performed (for example, the C test in the example in the C). =item 2. When a blocking OS syscall or library-level function needs to be called, and no nonblocking or asynchronous version is supplied. This is used by L. =back This object is ideal for representing "pure" functions; that is, blocks of code which have no stateful effect on the process, and whose result depends only on the arguments passed in. For a more general co-routine ability, see also L. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 code => CODE The body of the function to execute. @result = $code->( @args ); =head2 init_code => CODE Optional. If defined, this is invoked exactly once in every child process or thread, after it is created, but before the first invocation of the function body itself. $init_code->(); =head2 module => STRING =head2 func => STRING I An alternative to the C argument, which names a module to load and a function to call within it. C should give a perl module name (i.e. C, not a filename like F), and C should give the basename of a function within that module (i.e. without the module name prefixed). It will be invoked, without extra arguments, as the main code body of the object. The task of loading this module and resolving the resulting function from it is only performed on the remote worker side, so the controlling process will not need to actually load the module. =head2 init_func => STRING or ARRAY [ STRING, ... ] Optional addition to the C and C alternatives. Names a function within the module to call each time a new worker is created. If this value is an array reference, its first element must be a string giving the name of the function; the remaining values are passed to that function as arguments. =head2 model => "fork" | "thread" | "spawn" Optional. Requests a specific L model. If not supplied, leaves the default choice up to Routine. =head2 min_workers => INT =head2 max_workers => INT The lower and upper bounds of worker processes to try to keep running. The actual number running at any time will be kept somewhere between these bounds according to load. =head2 max_worker_calls => INT Optional. If provided, stop a worker process after it has processed this number of calls. (New workers may be started to replace stopped ones, within the bounds given above). =head2 idle_timeout => NUM Optional. If provided, idle worker processes will be shut down after this amount of time, if there are more than C of them. =head2 exit_on_die => BOOL Optional boolean, controls what happens after the C throws an exception. If missing or false, the worker will continue running to process more requests. If true, the worker will be shut down. A new worker might be constructed by the C method to replace it, if necessary. =head2 setup => ARRAY Optional array reference. Specifies the C key to pass to the underlying L when setting up new worker processes. =cut sub _init { my $self = shift; $self->SUPER::_init( @_ ); $self->{min_workers} = 1; $self->{max_workers} = 8; $self->{workers} = {}; # {$id} => IaFunction:Worker $self->{pending_queue} = []; } sub configure { my $self = shift; my %params = @_; my %worker_params; foreach (qw( model exit_on_die max_worker_calls )) { $self->{$_} = $worker_params{$_} = delete $params{$_} if exists $params{$_}; } if( keys %worker_params ) { foreach my $worker ( $self->_worker_objects ) { $worker->configure( %worker_params ); } } if( exists $params{idle_timeout} ) { my $timeout = delete $params{idle_timeout}; if( !$timeout ) { $self->remove_child( delete $self->{idle_timer} ) if $self->{idle_timer}; } elsif( my $idle_timer = $self->{idle_timer} ) { $idle_timer->configure( delay => $timeout ); } else { $self->{idle_timer} = IO::Async::Timer::Countdown->new( delay => $timeout, on_expire => $self->_capture_weakself( sub { my $self = shift or return; my $workers = $self->{workers}; # Shut down atmost one idle worker, starting from the highest # ID. Since we search from lowest to assign work, this tries # to ensure we'll shut down the least useful ones first, # keeping more useful ones in memory (page/cache warmth, etc..) foreach my $id ( reverse sort keys %$workers ) { next if $workers->{$id}{busy}; $workers->{$id}->stop; last; } # Still more? $self->{idle_timer}->start if $self->workers_idle > $self->{min_workers}; } ), ); $self->add_child( $self->{idle_timer} ); } } foreach (qw( min_workers max_workers )) { $self->{$_} = delete $params{$_} if exists $params{$_}; # TODO: something about retuning } my $need_restart; foreach (qw( init_code code module init_func func setup )) { $need_restart++, $self->{$_} = delete $params{$_} if exists $params{$_}; } defined $self->{code} and defined $self->{func} and croak "Cannot ->configure both 'code' and 'func'"; defined $self->{func} and !defined $self->{module} and croak "'func' parameter requires a 'module' as well"; $self->SUPER::configure( %params ); if( $need_restart and $self->loop ) { $self->stop; $self->start; } } sub _add_to_loop { my $self = shift; $self->SUPER::_add_to_loop( @_ ); $self->start; } sub _remove_from_loop { my $self = shift; $self->stop; $self->SUPER::_remove_from_loop( @_ ); } =head1 METHODS The following methods documented in C expressions return L instances. =cut =head2 start $function->start; Start the worker processes =cut sub start { my $self = shift; $self->_new_worker for 1 .. $self->{min_workers}; } =head2 stop $function->stop; Stop the worker processes $f = $function->stop; I If called in non-void context, returns a L instance that will complete once every worker process has stopped and exited. This may be useful for waiting until all of the processes are waited on, or other edge-cases, but is not otherwise particularly useful. =cut sub stop { my $self = shift; $self->{stopping} = 1; my @f; foreach my $worker ( $self->_worker_objects ) { defined wantarray ? push @f, $worker->stop : $worker->stop; } return Future->needs_all( @f ) if defined wantarray; } =head2 restart $function->restart; Gracefully stop and restart all the worker processes. =cut sub restart { my $self = shift; $self->stop; $self->start; } =head2 call @result = await $function->call( %params ); Schedules an invocation of the contained function to be executed on one of the worker processes. If a non-busy worker is available now, it will be called immediately. If not, it will be queued and sent to the next free worker that becomes available. The request will already have been serialised by the marshaller, so it will be safe to modify any referenced data structures in the arguments after this call returns. The C<%params> hash takes the following keys: =over 8 =item args => ARRAY A reference to the array of arguments to pass to the code. =item priority => NUM Optional. Defines the sorting order when no workers are available and calls must be queued for later. A default of zero will apply if not provided. Higher values cause the call to be considered more important, and will be placed earlier in the queue than calls with a smaller value. Calls of equal priority are still handled in FIFO order. =back If the function body returns normally the list of results are provided as the (successful) result of returned future. If the function throws an exception this results in a failed future. In the special case that the exception is in fact an unblessed C reference, this array is unpacked and used as-is for the C result. If the exception is not such a reference, it is used as the first argument to C, in the category of C. $f->done( @result ); $f->fail( @{ $exception } ); $f->fail( $exception, error => ); =head2 call (void) $function->call( %params ); When not returning a future, the C, C and C arguments give continuations to handle successful results or failure. =over 8 =item on_result => CODE A continuation that is invoked when the code has been executed. If the code returned normally, it is called as: $on_result->( 'return', @values ) If the code threw an exception, or some other error occurred such as a closed connection or the process died, it is called as: $on_result->( 'error', $exception_name ) =item on_return => CODE and on_error => CODE An alternative to C. Two continuations to use in either of the circumstances given above. They will be called directly, without the leading 'return' or 'error' value. =back =cut sub debug_printf_call { my $self = shift; $self->debug_printf( "CALL" ); } sub debug_printf_result { my $self = shift; $self->debug_printf( "RESULT" ); } sub debug_printf_failure { my $self = shift; my ( $err ) = @_; $self->debug_printf( "FAIL $err" ); } sub call { my $self = shift; my %params = @_; # TODO: possibly just queue this? $self->loop or croak "Cannot ->call on a Function not yet in a Loop"; my $args = delete $params{args}; ref $args eq "ARRAY" or croak "Expected 'args' to be an array"; my ( $on_done, $on_fail ); if( defined $params{on_result} ) { my $on_result = delete $params{on_result}; ref $on_result or croak "Expected 'on_result' to be a reference"; $on_done = sub { $on_result->( return => @_ ); }; $on_fail = sub { my ( $err, @values ) = @_; $on_result->( error => @values ); }; } elsif( defined $params{on_return} and defined $params{on_error} ) { my $on_return = delete $params{on_return}; ref $on_return or croak "Expected 'on_return' to be a reference"; my $on_error = delete $params{on_error}; ref $on_error or croak "Expected 'on_error' to be a reference"; $on_done = $on_return; $on_fail = $on_error; } elsif( !defined wantarray ) { croak "Expected either 'on_result' or 'on_return' and 'on_error' keys, or to return a Future"; } $self->debug_printf_call( @$args ); my $request = IO::Async::Channel->encode( $args ); my $future; if( my $worker = $self->_get_worker ) { $future = $self->_call_worker( $worker, $request ); } else { $self->debug_printf( "QUEUE" ); my $queue = $self->{pending_queue}; my $next = Pending( my $priority = $params{priority} || 0, my $wait_f = $self->loop->new_future, ); if( $priority ) { my $idx = first { $queue->[$_]->priority < $priority } 0 .. $#$queue; splice @$queue, $idx // $#$queue+1, 0, ( $next ); } else { push @$queue, $next; } $future = $wait_f->then( sub { my ( $self, $worker ) = @_; $self->_call_worker( $worker, $request ); }); } $future->on_done( $self->_capture_weakself( sub { my $self = shift or return; $self->debug_printf_result( @_ ); })); $future->on_fail( $self->_capture_weakself( sub { my $self = shift or return; $self->debug_printf_failure( @_ ); })); $future->on_done( $on_done ) if $on_done; $future->on_fail( $on_fail ) if $on_fail; return $future if defined wantarray; # Caller is not going to keep hold of the Future, so we have to ensure it # stays alive somehow $self->adopt_future( $future->else( sub { Future->done } ) ); } sub _worker_objects { my $self = shift; return values %{ $self->{workers} }; } =head2 workers $count = $function->workers; Returns the total number of worker processes available =cut sub workers { my $self = shift; return scalar keys %{ $self->{workers} }; } =head2 workers_busy $count = $function->workers_busy; Returns the number of worker processes that are currently busy =cut sub workers_busy { my $self = shift; return scalar grep { $_->{busy} } $self->_worker_objects; } =head2 workers_idle $count = $function->workers_idle; Returns the number of worker processes that are currently idle =cut sub workers_idle { my $self = shift; return scalar grep { !$_->{busy} } $self->_worker_objects; } sub _new_worker { my $self = shift; my $worker = IO::Async::Function::Worker->new( ( map { $_ => $self->{$_} } qw( model init_code code module init_func func setup exit_on_die ) ), max_calls => $self->{max_worker_calls}, on_finish => $self->_capture_weakself( sub { my $self = shift or return; my ( $worker ) = @_; return if $self->{stopping}; $self->_new_worker if $self->workers < $self->{min_workers}; $self->_dispatch_pending; } ), ); $self->add_child( $worker ); return $self->{workers}{$worker->id} = $worker; } sub _get_worker { my $self = shift; foreach ( sort keys %{ $self->{workers} } ) { return $self->{workers}{$_} if !$self->{workers}{$_}{busy}; } if( $self->workers < $self->{max_workers} ) { return $self->_new_worker; } return undef; } sub _call_worker { my $self = shift; my ( $worker, $type, $args ) = @_; my $future = $worker->call( $type, $args ); if( $self->workers_idle == 0 ) { $self->{idle_timer}->stop if $self->{idle_timer}; } return $future; } sub _dispatch_pending { my $self = shift; while( my $next = shift @{ $self->{pending_queue} } ) { my $worker = $self->_get_worker or return; my $f = $next->f; next if $f->is_cancelled; $self->debug_printf( "UNQUEUE" ); $f->done( $self, $worker ); return; } if( $self->workers_idle > $self->{min_workers} ) { $self->{idle_timer}->start if $self->{idle_timer} and !$self->{idle_timer}->is_running; } } package # hide from indexer IO::Async::Function::Worker; use base qw( IO::Async::Routine ); use Carp; use IO::Async::Channel; use IO::Async::Internals::FunctionWorker; sub new { my $class = shift; my %params = @_; my $arg_channel = IO::Async::Channel->new; my $ret_channel = IO::Async::Channel->new; my $send_initial; if( defined( my $code = $params{code} ) ) { my $init_code = $params{init_code}; $params{code} = sub { $init_code->() if defined $init_code; IO::Async::Internals::FunctionWorker::runloop( $code, $arg_channel, $ret_channel ); }; } elsif( defined( my $func = $params{func} ) ) { my $module = $params{module}; my $init_func = $params{init_func}; my @init_args; $params{module} = "IO::Async::Internals::FunctionWorker"; $params{func} = "run_worker"; ( $init_func, @init_args ) = @$init_func if ref( $init_func ) eq "ARRAY"; $send_initial = [ $module, $func, $init_func, @init_args ]; } delete @params{qw( init_code init_func )}; my $worker = $class->SUPER::new( %params, channels_in => [ $arg_channel ], channels_out => [ $ret_channel ], ); $worker->{arg_channel} = $arg_channel; $worker->{ret_channel} = $ret_channel; $worker->{send_initial} = $send_initial if $send_initial; return $worker; } sub _add_to_loop { my $self = shift; $self->SUPER::_add_to_loop( @_ ); $self->{arg_channel}->send( delete $self->{send_initial} ) if $self->{send_initial}; } sub configure { my $self = shift; my %params = @_; exists $params{$_} and $self->{$_} = delete $params{$_} for qw( exit_on_die max_calls ); $self->SUPER::configure( %params ); } sub stop { my $worker = shift; $worker->{arg_channel}->close; my $ret; $ret = $worker->result_future if defined wantarray; if( my $function = $worker->parent ) { delete $function->{workers}{$worker->id}; if( $worker->{busy} ) { $worker->{remove_on_idle}++; } else { $function->remove_child( $worker ); } } return $ret; } sub call { my $worker = shift; my ( $args ) = @_; $worker->{arg_channel}->send_encoded( $args ); $worker->{busy} = 1; $worker->{max_calls}--; return $worker->{ret_channel}->recv->then( # on recv $worker->_capture_weakself( sub { my ( $worker, $result ) = @_; my ( $type, @values ) = @$result; $worker->stop if !$worker->{max_calls} or $worker->{exit_on_die} && $type eq "e"; if( $type eq "r" ) { return Future->done( @values ); } elsif( $type eq "e" ) { return Future->fail( @values ); } else { die "Unrecognised type from worker - $type\n"; } } ), # on EOF $worker->_capture_weakself( sub { my ( $worker ) = @_; $worker->stop; return Future->fail( "closed", "closed" ); } ) )->on_ready( $worker->_capture_weakself( sub { my ( $worker, $f ) = @_; $worker->{busy} = 0; my $function = $worker->parent; $function->_dispatch_pending if $function; $function->remove_child( $worker ) if $function and $worker->{remove_on_idle}; })); } =head1 EXAMPLES =head2 Extended Error Information on Failure The array-unpacking form of exception indiciation allows the function body to more precicely control the resulting failure from the C future. my $divider = IO::Async::Function->new( code => sub { my ( $numerator, $divisor ) = @_; $divisor == 0 and die [ "Cannot divide by zero", div_zero => $numerator, $divisor ]; return $numerator / $divisor; } ); =head1 NOTES For the record, 123454321 is 11111 * 11111, a square number, and therefore not prime. =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Future.pm000444001750001750 650215001742754 15737 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2013-2024 -- leonerd@leonerd.org.uk package IO::Async::Future 0.804; use v5.14; use warnings; use base qw( Future ); Future->VERSION( '0.05' ); # to respect subclassing # Newer versions of Future have a proper subclassing-data API; for older # versions we just treat it as a hashref use constant FUTURE_HAS_UDATA => defined Future->can( "udata" ); use Carp; =head1 NAME C - use L with L =head1 SYNOPSIS use Future::AsyncAwait; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $future = $loop->new_future; $loop->watch_time( after => 3, code => sub { $future->done( "Done" ) } ); print await( $future ), "\n"; =head1 DESCRIPTION This subclass of L stores a reference to the L instance that created it, allowing the C method to block until the Future is ready. These objects should not be constructed directly; instead the C method on the containing Loop should be used. For a full description on how to use Futures, see the L documentation. =cut =head1 CONSTRUCTORS New C objects should be constructed by using the following methods on the C. For more detail see the L documentation. $future = $loop->new_future; Returns a new pending Future. $future = $loop->delay_future( %args ); Returns a new Future that will become done at a given time. $future = $loop->timeout_future( %args ); Returns a new Future that will become failed at a given time. =cut sub new { my $proto = shift; my $self = $proto->SUPER::new; my $loop; if( ref $proto ) { $loop = $proto->loop; } else { $loop = shift; } if( FUTURE_HAS_UDATA ) { $self->set_udata( loop => $loop ); } else { $self->{loop} = $loop; } return $self; } =head1 METHODS =cut =head2 loop $loop = $future->loop; Returns the underlying L object. =cut sub loop { my $self = shift; return FUTURE_HAS_UDATA ? $self->udata( "loop" ) : $self->{loop}; } sub await { my $self = shift; $self->loop->await( $self ); } =head2 done_later $future->done_later( @result ); A shortcut to calling the C method in a C idle watch on the underlying Loop object. Ensures that a returned Future object is not ready immediately, but will wait for the next IO round. Like C, returns C<$future> itself to allow easy chaining. =cut sub done_later { my $self = shift; my @result = @_; $self->loop->later( sub { $self->done( @result ) } ); return $self; } =head2 fail_later $future->fail_later( $exception, @details ); A shortcut to calling the C method in a C idle watch on the underlying Loop object. Ensures that a returned Future object is not ready immediately, but will wait for the next IO round. Like C, returns C<$future> itself to allow easy chaining. =cut sub fail_later { my $self = shift; my ( $exception, @details ) = @_; $exception or croak "Expected a true exception"; $self->loop->later( sub { $self->fail( $exception, @details ) } ); return $self; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Handle.pm000444001750001750 4210315001742754 15675 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2006-2024 -- leonerd@leonerd.org.uk package IO::Async::Handle 0.804; use v5.14; use warnings; use base qw( IO::Async::Notifier ); use Carp; use IO::Handle; # give methods to bare IO handles use Future; use Future::Utils qw( try_repeat ); use IO::Async::OS; =head1 NAME C - event callbacks for a non-blocking file descriptor =head1 SYNOPSIS This class is likely not to be used directly, because subclasses of it exist to handle more specific cases. Here is an example of how it would be used to watch a listening socket for new connections. In real code, it is likely that the C<< Loop->listen >> method would be used instead. use IO::Socket::INET; use IO::Async::Handle; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $socket = IO::Socket::INET->new( LocalPort => 1234, Listen => 1 ); my $handle = IO::Async::Handle->new( handle => $socket, on_read_ready => sub { my $new_client = $socket->accept; ... }, ); $loop->add( $handle ); For most other uses with sockets, pipes or other filehandles that carry a byte stream, the L class is likely to be more suitable. For non-stream sockets, see L. =head1 DESCRIPTION This subclass of L allows non-blocking IO on filehandles. It provides event handlers for when the filehandle is read- or write-ready. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_read_ready Invoked when the read handle becomes ready for reading. =head2 on_write_ready Invoked when the write handle becomes ready for writing. =head2 on_closed Optional. Invoked when the handle becomes closed. This handler is invoked before the filehandles are closed and the Handle removed from its containing Loop. The C will still return the containing Loop object. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 read_handle => IO =head2 write_handle => IO The reading and writing IO handles. Each must implement the C method. Primarily used for passing C / C; see the SYNOPSIS section of L for an example. =head2 handle => IO The IO handle for both reading and writing; instead of passing each separately as above. Must implement C method in way that C does. =head2 read_fileno => INT =head2 write_fileno => INT File descriptor numbers for reading and writing. If these are given as an alternative to C or C then a new C instance will be constructed around each. =head2 on_read_ready => CODE =head2 on_write_ready => CODE =head2 on_closed => CODE CODE references for event handlers. =head2 want_readready => BOOL =head2 want_writeready => BOOL If present, enable or disable read- or write-ready notification as per the C and C methods. It is required that a matching C or C are available for any handle that is provided; either passed as a callback CODE reference or as an overridden the method. I.e. if only a C is given, then C can be absent. If C is used as a shortcut, then both read and write-ready callbacks or methods are required. If no IO handles are provided at construction time, the object is still created but will not yet be fully-functional as a Handle. IO handles can be assigned later using the C or C methods, or by C. This may be useful when constructing an object to represent a network connection, before the C has actually been performed yet. =cut sub configure { my $self = shift; my %params = @_; if( exists $params{on_read_ready} ) { $self->{on_read_ready} = delete $params{on_read_ready}; undef $self->{cb_r}; $self->_watch_read(0), $self->_watch_read(1) if $self->want_readready; } if( exists $params{on_write_ready} ) { $self->{on_write_ready} = delete $params{on_write_ready}; undef $self->{cb_w}; $self->_watch_write(0), $self->_watch_write(1) if $self->want_writeready; } if( exists $params{on_closed} ) { $self->{on_closed} = delete $params{on_closed}; } if( defined $params{read_fileno} and defined $params{write_fileno} and $params{read_fileno} == $params{write_fileno} ) { $params{handle} = IO::Handle->new_from_fd( $params{read_fileno}, "r+" ); delete $params{read_fileno}; delete $params{write_fileno}; } else { $params{read_handle} = IO::Handle->new_from_fd( delete $params{read_fileno}, "r" ) if defined $params{read_fileno}; $params{write_handle} = IO::Handle->new_from_fd( delete $params{write_fileno}, "w" ) if defined $params{write_fileno}; } # 'handle' is a shortcut for setting read_ and write_ if( exists $params{handle} ) { $params{read_handle} = $params{handle}; $params{write_handle} = $params{handle}; delete $params{handle}; } if( exists $params{read_handle} ) { my $read_handle = delete $params{read_handle}; if( defined $read_handle ) { if( !defined eval { $read_handle->fileno } ) { croak 'Expected that read_handle can ->fileno'; } unless( $self->can_event( 'on_read_ready' ) ) { croak 'Expected either a on_read_ready callback or an ->on_read_ready method'; } my @layers = PerlIO::get_layers( $read_handle ); if( grep m/^encoding\(/, @layers or grep m/^utf8$/, @layers ) { # Only warn for now, because if it's UTF-8 by default but only # passes ASCII then all will be well carp "Constructing a ".ref($self)." with an encoding-enabled handle may not read correctly"; } $self->{read_handle} = $read_handle; $self->want_readready( defined $read_handle ); } else { $self->want_readready( 0 ); undef $self->{read_handle}; } # In case someone has reopened the filehandles during an on_closed handler undef $self->{handle_closing}; } if( exists $params{write_handle} ) { my $write_handle = delete $params{write_handle}; if( defined $write_handle ) { if( !defined eval { $write_handle->fileno } ) { croak 'Expected that write_handle can ->fileno'; } unless( $self->can_event( 'on_write_ready' ) ) { # This used not to be fatal. Make it just a warning for now. carp 'A write handle was provided but neither a on_write_ready callback nor an ->on_write_ready method were. Perhaps you mean \'read_handle\' instead?'; } $self->{write_handle} = $write_handle; } else { $self->want_writeready( 0 ); undef $self->{write_handle}; } # In case someone has reopened the filehandles during an on_closed handler undef $self->{handle_closing}; } if( exists $params{want_readready} ) { $self->want_readready( delete $params{want_readready} ); } if( exists $params{want_writeready} ) { $self->want_writeready( delete $params{want_writeready} ); } $self->SUPER::configure( %params ); } # We'll be calling these any of three times # adding to/removing from loop # caller en/disables readiness checking # changing filehandle sub _watch_read { my $self = shift; my ( $want ) = @_; my $loop = $self->loop or return; my $fh = $self->read_handle or return; if( $want ) { $self->{cb_r} ||= $self->make_event_cb( 'on_read_ready' ); $loop->watch_io( handle => $fh, on_read_ready => $self->{cb_r}, ); } else { $loop->unwatch_io( handle => $fh, on_read_ready => 1, ); } } sub _watch_write { my $self = shift; my ( $want ) = @_; my $loop = $self->loop or return; my $fh = $self->write_handle or return; if( $want ) { $self->{cb_w} ||= $self->make_event_cb( 'on_write_ready' ); $loop->watch_io( handle => $fh, on_write_ready => $self->{cb_w}, ); } else { $loop->unwatch_io( handle => $fh, on_write_ready => 1, ); } } sub _add_to_loop { my $self = shift; my ( $loop ) = @_; $self->_watch_read(1) if $self->want_readready; $self->_watch_write(1) if $self->want_writeready; } sub _remove_from_loop { my $self = shift; my ( $loop ) = @_; $self->_watch_read(0); $self->_watch_write(0); } sub notifier_name { my $self = shift; my @parts; if( length( my $name = $self->SUPER::notifier_name ) ) { push @parts, $name; } my $r = $self->read_fileno; my $w = $self->write_fileno; if( defined $r and defined $w and $r == $w ) { push @parts, "rw=$r"; } elsif( defined $r and defined $w ) { push @parts, "r=$r,w=$w"; } elsif( defined $r ) { push @parts, "r=$r"; } elsif( defined $w ) { push @parts, "w=$w"; } return join ",", @parts; } =head1 METHODS The following methods documented in C expressions return L instances. =cut =head2 set_handle $handle->set_handles( %params ); Sets new reading or writing filehandles. Equivalent to calling the C method with the same parameters. =cut sub set_handles { my $self = shift; my %params = @_; $self->configure( exists $params{read_handle} ? ( read_handle => $params{read_handle} ) : (), exists $params{write_handle} ? ( write_handle => $params{write_handle} ) : (), ); } =head2 set_handle $handle->set_handle( $fh ); Shortcut for $handle->configure( handle => $fh ); =cut sub set_handle { my $self = shift; my ( $fh ) = @_; $self->configure( handle => $fh ); } =head2 close $handle->close; This method calls C on the underlying IO handles. This method will then remove the handle from its containing loop. =cut sub close { my $self = shift; # Prevent infinite loops if there's two crosslinked handles return if $self->{handle_closing}; $self->{handle_closing} = 1; $self->want_readready( 0 ); $self->want_writeready( 0 ); my $read_handle = delete $self->{read_handle}; $read_handle->close if defined $read_handle; my $write_handle = delete $self->{write_handle}; $write_handle->close if defined $write_handle; $self->_closed; } sub _closed { my $self = shift; $self->maybe_invoke_event( on_closed => ); if( $self->{close_futures} ) { $_->done for @{ $self->{close_futures} }; } $self->remove_from_parent; } =head2 close_read =head2 close_write $handle->close_read; $handle->close_write; Closes the underlying read or write handle, and deconfigures it from the object. Neither of these methods will invoke the C event, nor remove the object from the Loop if there is still one open handle in the object. Only when both handles are closed, will C be fired, and the object removed. =cut sub close_read { my $self = shift; $self->want_readready( 0 ); my $read_handle = delete $self->{read_handle}; $read_handle->close if defined $read_handle; $self->_closed if !$self->{write_handle}; } sub close_write { my $self = shift; $self->want_writeready( 0 ); my $write_handle = delete $self->{write_handle}; $write_handle->close if defined $write_handle; $self->_closed if !$self->{read_handle}; } =head2 new_close_future await $handle->new_close_future; Returns a new L object which will become done when the handle is closed. Cancelling the C<$future> will remove this notification ability but will not otherwise affect the C<$handle>. =cut sub new_close_future { my $self = shift; push @{ $self->{close_futures} }, my $future = $self->loop->new_future; $future->on_cancel( $self->_capture_weakself( sub { my $self = shift or return; my $future = shift; @{ $self->{close_futures} } = grep { $_ and $_ != $future } @{ $self->{close_futures} }; }) ); return $future; } =head2 read_handle =head2 write_handle $handle = $handle->read_handle; $handle = $handle->write_handle; These accessors return the underlying IO handles. =cut sub read_handle { my $self = shift; return $self->{read_handle}; } sub write_handle { my $self = shift; return $self->{write_handle}; } =head2 read_fileno =head2 write_fileno $fileno = $handle->read_fileno; $fileno = $handle->write_fileno; These accessors return the file descriptor numbers of the underlying IO handles. =cut sub read_fileno { my $self = shift; my $handle = $self->read_handle or return undef; return $handle->fileno; } sub write_fileno { my $self = shift; my $handle = $self->write_handle or return undef; return $handle->fileno; } =head2 want_readready =head2 want_writeready $value = $handle->want_readready; $oldvalue = $handle->want_readready( $newvalue ); $value = $handle->want_writeready; $oldvalue = $handle->want_writeready( $newvalue ); These are the accessor for the C and C properties, which define whether the object is interested in knowing about read- or write-readiness on the underlying file handle. =cut sub want_readready { my $self = shift; if( @_ ) { my ( $new ) = @_; $new = !!$new; return $new if !$new == !$self->{want_readready}; # compare bools if( $new ) { defined $self->read_handle or croak 'Cannot want_readready in a Handle with no read_handle'; } my $old = $self->{want_readready}; $self->{want_readready} = $new; $self->_watch_read( $new ); return $old; } else { return $self->{want_readready}; } } sub want_writeready { my $self = shift; if( @_ ) { my ( $new ) = @_; $new = !!$new; return $new if !$new == !$self->{want_writeready}; # compare bools if( $new ) { defined $self->write_handle or croak 'Cannot want_writeready in a Handle with no write_handle'; } my $old = $self->{want_writeready}; $self->{want_writeready} = $new; $self->_watch_write( $new ); return $old; } else { return $self->{want_writeready}; } } =head2 socket $handle->socket( $ai ); Convenient shortcut to creating a socket handle, as given by an addrinfo structure, and setting it as the read and write handle for the object. C<$ai> may be either a C or C reference of the same form as given to L's C method. This method returns nothing if it succeeds, or throws an exception if it fails. =cut sub socket { my $self = shift; my ( $ai ) = @_; # TODO: Something about closing the old one? my ( $family, $socktype, $protocol ) = IO::Async::OS->extract_addrinfo( $ai ); my $sock = IO::Async::OS->socket( $family, $socktype, $protocol ); $sock->blocking( 0 ); $self->set_handle( $sock ); } =head2 bind $handle = await $handle->bind( %args ); Performs a C resolver operation with the C flag set, and then attempts to bind a socket handle of any of the return values. =head2 bind (1 argument) $handle = await $handle->bind( $ai ); When invoked with a single argument, this method is a convenient shortcut to creating a socket handle and Cing it to the address as given by an addrinfo structure, and setting it as the read and write handle for the object. C<$ai> may be either a C or C reference of the same form as given to L's C method. The returned future returns the handle object itself for convenience. =cut sub bind { my $self = shift; if( @_ == 1 ) { my ( $ai ) = @_; $self->socket( $ai ); my $addr = ( IO::Async::OS->extract_addrinfo( $ai ) )[3]; $self->read_handle->bind( $addr ) or return Future->fail( "Cannot bind - $!", bind => $self->read_handle, $addr, $! ); return Future->done( $self ); } $self->loop->resolver->getaddrinfo( passive => 1, @_ )->then( sub { my @addrs = @_; try_repeat { my $ai = shift; $self->bind( $ai ); } foreach => \@addrs, until => sub { shift->is_done }; }); } =head2 connect $handle = await $handle->connect( %args ); A convenient wrapper for calling the C method on the underlying L object. =cut sub connect { my $self = shift; my %args = @_; my $loop = $self->loop or croak "Cannot ->connect a Handle that is not in a Loop"; $self->debug_printf( "CONNECT " . join( ", ", # These args should be stringy ( map { defined $args{$_} ? "$_=$args{$_}" : () } qw( host service family socktype protocol local_host local_service ) ) ) ); return $self->loop->connect( %args, handle => $self ); } =head1 SEE ALSO =over 4 =item * L - Supply object methods for I/O handles =back =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Listener.pm000444001750001750 3434415001742754 16277 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2008-2024 -- leonerd@leonerd.org.uk package IO::Async::Listener 0.804; use v5.14; use warnings; use base qw( IO::Async::Handle ); use IO::Async::Handle; use IO::Async::OS; use Future 0.33; # ->catch use Errno qw( EAGAIN EWOULDBLOCK ); use Socket qw( sockaddr_family SOL_SOCKET SO_ACCEPTCONN SO_TYPE ); use Carp; =head1 NAME C - listen on network sockets for incoming connections =head1 SYNOPSIS use Future::AsyncAwait; use IO::Async::Listener; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $listener = IO::Async::Listener->new( on_stream => sub { my ( undef, $stream ) = @_; $stream->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; $self->write( $$buffref ); $$buffref = ""; return 0; }, ); $loop->add( $stream ); }, ); $loop->add( $listener ); await $listener->listen( service => "echo", socktype => 'stream', ); $loop->run; This object can also be used indirectly via an L: use IO::Async::Stream; use IO::Async::Loop; my $loop = IO::Async::Loop->new; await $loop->listen( service => "echo", socktype => 'stream', on_stream => sub { ... }, ); $loop->run; =head1 DESCRIPTION This subclass of L adds behaviour which watches a socket in listening mode, to accept incoming connections on them. A Listener can be constructed and given a existing socket in listening mode. Alternatively, the Listener can construct a socket by calling the C method. Either a list of addresses can be provided, or a service name can be looked up using the underlying loop's C method. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_accept $clientsocket | $handle Invoked whenever a new client connects to the socket. If neither C nor C parameters are set, this will be invoked with the new client socket directly. If a handle constructor or class are set, this will be invoked with the newly-constructed handle, having the new socket already configured onto it. =head2 on_stream $stream An alternative to C, this is passed an instance of L when a new client connects. This is provided as a convenience for the common case that a Stream object is required as the transport for a Protocol object. This is now vaguely deprecated in favour of using C with a handle constructor or class. =head2 on_socket $socket Similar to C, but constructs an instance of L. This is most useful for C or C sockets. This is now vaguely deprecated in favour of using C with a handle constructor or class. =head2 on_accept_error $socket, $errno Optional. Invoked if the C syscall indicates an error (other than C or C). If not provided, failures of C will be passed to the main C handler. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 on_accept => CODE =head2 on_stream => CODE =head2 on_socket => CODE CODE reference for the event handlers. Because of the mutually-exclusive nature of their behaviour, only one of these may be set at a time. Setting one will remove the other two. =head2 handle => IO The IO handle containing an existing listen-mode socket. =head2 handle_constructor => CODE Optional. If defined, gives a CODE reference to be invoked every time a new client socket is accepted from the listening socket. It is passed the listener object itself, and is expected to return a new instance of L or a subclass, used to wrap the new client socket. $handle = $handle_constructor->( $listener ); This can also be given as a subclass method $handle = $listener->handle_constructor(); =head2 handle_class => STRING Optional. If defined and C isn't, then new wrapper handles are constructed by invoking the C method on the given class name, passing in no additional parameters. $handle = $handle_class->new(); This can also be given as a subclass method $handle = $listener->handle_class->new; =head2 acceptor => STRING|CODE Optional. If defined, gives the name of a method or a CODE reference to use to implement the actual accept behaviour. This will be invoked as: ( $accepted ) = await $listener->acceptor( $socket ); ( $handle ) = await $listener->acceptor( $socket, handle => $handle ); It is invoked with the listening socket as its its argument, and optionally an L instance as a named parameter, and is expected to return a C that will eventually yield the newly-accepted socket or handle instance, if such was provided. =cut sub _init { my $self = shift; $self->SUPER::_init( @_ ); $self->{acceptor} = "_accept"; } my @acceptor_events = qw( on_accept on_stream on_socket ); sub configure { my $self = shift; my %params = @_; if( grep exists $params{$_}, @acceptor_events ) { grep( defined $_, @params{@acceptor_events} ) <= 1 or croak "Can only set at most one of 'on_accept', 'on_stream' or 'on_socket'"; # Don't exists-test, so we'll clear the other two $self->{$_} = delete $params{$_} for @acceptor_events; } croak "Cannot set 'on_read_ready' on a Listener" if exists $params{on_read_ready}; if( defined $params{handle} ) { my $handle = delete $params{handle}; # Sanity check it - it may be a bare GLOB ref, not an IO::Socket-derived handle defined getsockname( $handle ) or croak "IO handle $handle does not have a sockname"; # So now we know it's at least some kind of socket. Is it listening? # SO_ACCEPTCONN would tell us, but not all OSes implement it. Since it's # only a best-effort sanity check, we won't mind if the OS doesn't. my $acceptconn = getsockopt( $handle, SOL_SOCKET, SO_ACCEPTCONN ); !defined $acceptconn or unpack( "I", $acceptconn ) or croak "Socket is not accepting connections"; # This is a bit naughty but hopefully nobody will mind... bless $handle, "IO::Socket" if ref( $handle ) eq "GLOB"; $self->SUPER::configure( read_handle => $handle ); } elsif( exists $params{handle} ) { delete $params{handle}; $self->SUPER::configure( read_handle => undef ); } unless( grep $self->can_event( $_ ), @acceptor_events ) { croak "Expected to be able to 'on_accept', 'on_stream' or 'on_socket'"; } foreach (qw( acceptor handle_constructor handle_class )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } if( keys %params ) { croak "Cannot pass though configuration keys to underlying Handle - " . join( ", ", keys %params ); } } sub on_read_ready { my $self = shift; my $socket = $self->read_handle; my $on_done; my %acceptor_params; if( $on_done = $self->can_event( "on_stream" ) ) { # TODO: It doesn't make sense to put a SOCK_DGRAM in an # IO::Async::Stream but currently we don't detect this require IO::Async::Stream; $acceptor_params{handle} = IO::Async::Stream->new; } elsif( $on_done = $self->can_event( "on_socket" ) ) { require IO::Async::Socket; $acceptor_params{handle} = IO::Async::Socket->new; } # on_accept needs to be last in case of multiple layers of subclassing elsif( $on_done = $self->can_event( "on_accept" ) ) { my $handle; # Test both params before moving on to either method if( my $constructor = $self->{handle_constructor} ) { $handle = $self->{handle_constructor}->( $self ); } elsif( my $class = $self->{handle_class} ) { $handle = $class->new; } elsif( $self->can( "handle_constructor" ) ) { $handle = $self->handle_constructor; } elsif( $self->can( "handle_class" ) ) { $handle = $self->handle_class->new; } $acceptor_params{handle} = $handle if $handle; } else { die "ARG! Missing on_accept,on_stream,on_socket!"; } my $acceptor = $self->acceptor; my $f = $self->$acceptor( $socket, %acceptor_params )->on_done( sub { my ( $result ) = @_ or return; # false-alarm $on_done->( $self, $result ); })->catch( accept => sub { my ( $message, $name, @args ) = @_; my ( $socket, $dollarbang ) = @args; $self->maybe_invoke_event( on_accept_error => $socket, $dollarbang ) or $self->invoke_error( "accept() failed - $dollarbang", accept => $socket, $dollarbang ); }); # TODO: Consider if this wants a more fine-grained place to report # non-accept() failures (such as SSL) to $self->adopt_future( $f ); } sub _accept { my $self = shift; my ( $listen_sock, %params ) = @_; my $accepted = $listen_sock->accept; if( defined $accepted ) { $accepted->blocking( 0 ); if( my $handle = $params{handle} ) { $handle->set_handle( $accepted ); return Future->done( $handle ); } else { return Future->done( $accepted ); } } elsif( $! == EAGAIN or $! == EWOULDBLOCK ) { return Future->done; } else { return Future->fail( "Cannot accept() - $!", accept => $listen_sock, $! ); } } =head1 METHODS The following methods documented in C expressions return L instances. =cut =head2 acceptor $acceptor = $listener->acceptor; Returns the currently-set C method name or code reference. This may be of interest to Loop C extension methods that wish to extend or wrap it. =cut sub acceptor { my $self = shift; return $self->{acceptor}; } sub is_listening { my $self = shift; return ( defined $self->sockname ); } =head2 sockname $name = $listener->sockname; Returns the C of the underlying listening socket =cut sub sockname { my $self = shift; my $handle = $self->read_handle or return undef; return $handle->sockname; } =head2 family $family = $listener->family; Returns the socket address family of the underlying listening socket =cut sub family { my $self = shift; my $sockname = $self->sockname or return undef; return sockaddr_family( $sockname ); } =head2 socktype $socktype = $listener->socktype; Returns the socket type of the underlying listening socket =cut sub socktype { my $self = shift; my $handle = $self->read_handle or return undef; return $handle->sockopt(SO_TYPE); } =head2 listen await $listener->listen( %params ); This method sets up a listening socket and arranges for the acceptor callback to be invoked each time a new connection is accepted on the socket. Most parameters given to this method are passed into the C method of the L object. In addition, the following arguments are also recognised directly: =over 8 =item on_listen => CODE Optional. A callback that is invoked when the listening socket is ready. Similar to that on the underlying loop method, except it is passed the listener object itself. $on_listen->( $listener ); =back =cut sub listen { my $self = shift; my ( %params ) = @_; my $loop = $self->loop; defined $loop or croak "Cannot listen when not a member of a Loop"; # TODO: defer? if( my $on_listen = delete $params{on_listen} ) { $params{on_listen} = sub { $on_listen->( $self ) }; } $loop->listen( listener => $self, %params ); } =head1 EXAMPLES =head2 Listening on UNIX Sockets The C argument can be passed an existing socket already in listening mode, making it possible to listen on other types of socket such as UNIX sockets. use IO::Async::Listener; use IO::Socket::UNIX; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $listener = IO::Async::Listener->new( on_stream => sub { my ( undef, $stream ) = @_; $stream->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; $self->write( $$buffref ); $$buffref = ""; return 0; }, ); $loop->add( $stream ); }, ); $loop->add( $listener ); my $socket = IO::Socket::UNIX->new( Local => "echo.sock", Listen => 1, ) or die "Cannot make UNIX socket - $!\n"; $listener->listen( handle => $socket, ); $loop->run; =head2 Passing Plain Socket Addresses The C or C parameters should contain a definition of a plain socket address in a form that the L C method can use. This example shows how to listen on TCP port 8001 on address 10.0.0.1: $listener->listen( addr => { family => "inet", socktype => "stream", port => 8001, ip => "10.0.0.1", }, ... ); This example shows another way to listen on a UNIX socket, similar to the earlier example: $listener->listen( addr => { family => "unix", socktype => "stream", path => "echo.sock", }, ... ); =head2 Using A Kernel-Assigned Port Number Rather than picking a specific port number, is it possible to ask the kernel to assign one arbitrarily that is currently free. This can be done by requesting port number 0 (which is actually the default if no port number is otherwise specified). To determine which port number the kernel actually picked, inspect the C accessor on the actual socket filehandle. Either use the L returned by the C method: $listener->listen( addr => { family => "inet" }, )->on_done( sub { my ( $listener ) = @_; my $socket = $listener->read_handle; say "Now listening on port ", $socket->sockport; }); Or pass an C continuation: $listener->listen( addr => { family => "inet" }, on_listen => sub { my ( $listener ) = @_; my $socket = $listener->read_handle; say "Now listening on port ", $socket->sockport; }, ); =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Loop.pm000444001750001750 25541415001742754 15446 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2007-2024 -- leonerd@leonerd.org.uk package IO::Async::Loop 0.804; use v5.14; use warnings; # When editing this value don't forget to update the docs below use constant NEED_API_VERSION => '0.33'; # Base value but some classes might override use constant _CAN_ON_HANGUP => 0; # Most Loop implementations do not accurately handle sub-second timers. # This only matters for unit tests use constant _CAN_SUBSECOND_ACCURATELY => 0; # Does the loop implementation support IO_ASYNC_WATCHDOG? use constant _CAN_WATCHDOG => 0; # Does the loop support ->watch_process on PID 0 to observe all exits? use constant _CAN_WATCH_ALL_PIDS => 1; # Watchdog configuration constants use constant WATCHDOG_ENABLE => $ENV{IO_ASYNC_WATCHDOG}; use constant WATCHDOG_INTERVAL => $ENV{IO_ASYNC_WATCHDOG_INTERVAL} || 10; use constant WATCHDOG_SIGABRT => $ENV{IO_ASYNC_WATCHDOG_SIGABRT}; use Carp; use Time::HiRes qw(); # empty import use POSIX qw( WNOHANG ); use Scalar::Util qw( refaddr weaken ); use Socket qw( SO_REUSEADDR AF_INET6 IPPROTO_IPV6 IPV6_V6ONLY ); use IO::Async::OS; use IO::Async::Metrics '$METRICS'; use constant HAVE_SIGNALS => IO::Async::OS->HAVE_SIGNALS; use constant HAVE_POSIX_FORK => IO::Async::OS->HAVE_POSIX_FORK; use constant HAVE_THREADS => IO::Async::OS->HAVE_THREADS; # Never sleep for more than 1 second if a signal proxy is registered, to avoid # a borderline race condition. # There is a race condition in perl involving signals interacting with XS code # that implements blocking syscalls. There is a slight chance a signal will # arrive in the XS function, before the blocking itself. Perl will not run our # (safe) deferred signal handler in this case. To mitigate this, if we have a # signal proxy, we'll adjust the maximal timeout. The signal handler will be # run when the XS function returns. our $MAX_SIGWAIT_TIME = 1; # Also, never sleep for more than 1 second if the OS does not support signals # and we have child watches registered (so we must use waitpid() polling) our $MAX_CHILDWAIT_TIME = 1; # Maybe our calling program will have a suggested hint of a specific Loop # class or list of classes to use our $LOOP; # Undocumented; used only by the test scripts. # Setting this value true will avoid the IO::Async::Loop::$^O candidate in the # magic constructor our $LOOP_NO_OS; # SIGALRM handler for watchdog $SIG{ALRM} = sub { # There are two extra frames here; this one and the signal handler itself local $Carp::CarpLevel = $Carp::CarpLevel + 2; if( WATCHDOG_SIGABRT ) { print STDERR Carp::longmess( "Watchdog timeout" ); kill ABRT => $$; } else { Carp::confess( "Watchdog timeout" ); } } if WATCHDOG_ENABLE; # There are two default values that might apply; undef or "DEFAULT" $SIG{PIPE} = "IGNORE" if ( $SIG{PIPE} || "DEFAULT" ) eq "DEFAULT"; =head1 NAME C - core loop of the C framework =head1 SYNOPSIS use IO::Async::Stream; use IO::Async::Timer::Countdown; use IO::Async::Loop; my $loop = IO::Async::Loop->new; $loop->add( IO::Async::Timer::Countdown->new( delay => 10, on_expire => sub { print "10 seconds have passed\n" }, )->start ); $loop->add( IO::Async::Stream->new_for_stdin( on_read => sub { my ( $self, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*)\n// ) { print "You typed a line $1\n"; } return 0; }, ) ); $loop->run; =head1 DESCRIPTION This module provides an abstract class which implements the core loop of the L framework. Its primary purpose is to store a set of L objects or subclasses of them. It handles all of the lower-level set manipulation actions, and leaves the actual IO readiness testing/notification to the concrete class that implements it. It also provides other functionality such as signal handling, child process managing, and timers. See also the two bundled Loop subclasses: =over 4 =item L =item L =back Or other subclasses that may appear on CPAN which are not part of the core L distribution. =head2 Ignoring SIGPIPE Since version I<0.66> loading this module automatically ignores C, as it is highly unlikely that the default-terminate action is the best course of action for an L-based program to take. If at load time the handler disposition is still set as C, it is set to ignore. If already another handler has been placed there by the program code, it will be left undisturbed. =cut # Internal constructor used by subclasses sub __new { my $class = shift; our $VERSION; # Detect if the API version provided by the subclass is sufficient $class->can( "API_VERSION" ) or die "$class is too old for IO::Async $VERSION; it does not provide \->API_VERSION\n"; $class->API_VERSION >= NEED_API_VERSION or die "$class is too old for IO::Async $VERSION; we need API version >= ".NEED_API_VERSION.", it provides ".$class->API_VERSION."\n"; WATCHDOG_ENABLE and !$class->_CAN_WATCHDOG and warn "$class cannot implement IO_ASYNC_WATCHDOG\n"; my $self = bless { notifiers => {}, # {nkey} = notifier iowatches => {}, # {fd} = [ $on_read_ready, $on_write_ready, $on_hangup ] sigattaches => {}, # {sig} => \@callbacks childmanager => undef, childwatches => {}, # {pid} => $code threadwatches => {}, # {tid} => $code timequeue => undef, deferrals => [], os => {}, # A generic scratchpad for IO::Async::OS to store whatever it wants }, $class; $METRICS and $METRICS->inc_gauge( loops => [ class => ref $self ] ); # It's possible this is a specific subclass constructor. We still want the # magic IO::Async::Loop->new constructor to yield this if it's the first # one our $ONE_TRUE_LOOP ||= $self; # Legacy support - temporary until all CPAN classes are updated; bump NEEDAPI version at that point my $old_timer = $self->can( "enqueue_timer" ) != \&enqueue_timer; if( $old_timer != ( $self->can( "cancel_timer" ) != \&cancel_timer ) ) { die "$class should overload both ->enqueue_timer and ->cancel_timer, or neither"; } if( $old_timer ) { warnings::warnif( deprecated => "Enabling old_timer workaround for old loop class " . $class ); } $self->{old_timer} = $old_timer; return $self; } sub DESTROY { my $self = shift; $METRICS and $METRICS->dec_gauge( loops => [ class => ref $self ] ); } =head1 MAGIC CONSTRUCTOR =head2 new $loop = IO::Async::Loop->new; This function attempts to find a good subclass to use, then calls its constructor. It works by making a list of likely candidate classes, then trying each one in turn, Cing the module then calling its C method. If either of these operations fails, the next subclass is tried. If no class was successful, then an exception is thrown. The constructed object is cached, and will be returned again by a subsequent call. The cache will also be set by a constructor on a specific subclass. This behaviour makes it possible to simply use the normal constructor in a module that wishes to interact with the main program's Loop, such as an integration module for another event system. For example, the following two C<$loop> variables will refer to the same object: use IO::Async::Loop; use IO::Async::Loop::Poll; my $loop_poll = IO::Async::Loop::Poll->new; my $loop = IO::Async::Loop->new; While it is not advised to do so under normal circumstances, if the program really wishes to construct more than one Loop object, it can call the constructor C, or invoke one of the subclass-specific constructors directly. The list of candidates is formed from the following choices, in this order: =over 4 =item * $ENV{IO_ASYNC_LOOP} If this environment variable is set, it should contain a comma-separated list of subclass names. These names may or may not be fully-qualified; if a name does not contain C<::> then it will have C prepended to it. This allows the end-user to specify a particular choice to fit the needs of his use of a program using L. =item * $IO::Async::Loop::LOOP If this scalar is set, it should contain a comma-separated list of subclass names. These may or may not be fully-qualified, as with the above case. This allows a program author to suggest a loop module to use. In cases where the module subclass is a hard requirement, such as GTK programs using C, it would be better to use the module specifically and invoke its constructor directly. =item * IO::Async::OS->LOOP_PREFER_CLASSES The L hints module for the given OS is then consulted to see if it suggests any other module classes specific to the given operating system. =item * $^O The module called C is tried next. This allows specific OSes, such as the ever-tricky C, to provide an implementation that might be more efficient than the generic ones, or even work at all. This option is now discouraged in favour of the L hint instead. At some future point it may be removed entirely, given as currently only C uses it. =item * Poll and Select Finally, if no other choice has been made by now, the built-in C module is chosen. This should always work, but in case it doesn't, the C, C or equivalent with a zero-second timeout, and process any currently-pending IO conditions before the code is invoked, but it will not block for a non-zero amount of time. This method is implemented using the C method, with the C parameter set to C. It will return an ID value that can be passed to C if required. I: If no C<$code> value is passed, a L will be returned instead. This allows for constructs such as: await $loop->later; =cut sub later { my $self = shift; my ( $code ) = @_; return $self->watch_idle( when => 'later', code => $code ) if $code; my $f = $self->new_future; my $id = $self->watch_idle( when => 'later', code => sub { $f->done unless $f->is_ready; } ); $f->on_cancel( sub { $self->unwatch_idle( $id ); } ); return $f; } =head2 spawn_child $loop->spawn_child( %params ); This method creates a new child process to run a given code block or command. The C<%params> hash takes the following keys: =over 8 =item command => ARRAY or STRING Either a reference to an array containing the command and its arguments, or a plain string containing the command. This value is passed into perl's C function. =item code => CODE A block of code to execute in the child process. It will be called in scalar context inside an C block. =item setup => ARRAY A reference to an array which gives file descriptors to set up in the child process before running the code or command. See below. =item on_exit => CODE A continuation to be called when the child processes exits. It will be invoked in the following way: $on_exit->( $pid, $exitcode, $dollarbang, $dollarat ) The second argument is passed the plain perl C<$?> value. =back Exactly one of the C or C keys must be specified. If the C key is used, the given array or string is executed using the C function. If the C key is used, the return value will be used as the C code from the child if it returns (or 255 if it returned C or thows an exception). Case | ($exitcode >> 8) | $dollarbang | $dollarat --------------+------------------------+-------------+---------- exec succeeds | exit code from program | 0 | "" exec fails | 255 | $! | "" $code returns | return value | $! | "" $code dies | 255 | $! | $@ It is usually more convenient to use the C method in simple cases where an external program is being started in order to interact with it via file IO, or even C when only the final result is required, rather than interaction while it is running. =head3 C array This array gives a list of file descriptor operations to perform in the child process after it has been Ced from the parent, before running the code or command. It consists of name/value pairs which are ordered; the operations are performed in the order given. =over 8 =item fdI => ARRAY Gives an operation on file descriptor I. The first element of the array defines the operation to be performed: =over 4 =item [ 'close' ] The file descriptor will be closed. =item [ 'dup', $io ] The file descriptor will be Ced from the given IO handle. =item [ 'open', $mode, $file ] The file descriptor will be opened from the named file in the given mode. The C<$mode> string should be in the form usually given to the C function; such as '<' or '>>'. =item [ 'keep' ] The file descriptor will not be closed; it will be left as-is. =back A non-reference value may be passed as a shortcut, where it would contain the name of the operation with no arguments (i.e. for the C and C operations). =item IO => ARRAY Shortcut for passing C>, where I is the fileno of the IO reference. In this case, the key must be a reference that implements the C method. This is mostly useful for $handle => 'keep' =item fdI => IO A shortcut for the C case given above. =item stdin => ... =item stdout => ... =item stderr => ... Shortcuts for C, C and C respectively. =item env => HASH A reference to a hash to set as the child process's environment. Note that this will entirely set a new environment, completely replacing the existing one. If you want to simply add new keys or change the values of some keys without removing the other existing ones, you can simply copy C<%ENV> into the hash before setting new keys: env => { %ENV, ANOTHER => "key here", } =item nice => INT Change the child process's scheduling priority using C. =item chdir => STRING Change the child process's working directory using C. =item setuid => INT =item setgid => INT Change the child process's effective UID or GID. =item setgroups => ARRAY Change the child process's groups list, to those groups whose numbers are given in the ARRAY reference. On most systems, only the privileged superuser change user or group IDs. L will B check before detaching the child process whether this is the case. If setting both the primary GID and the supplementary groups list, it is suggested to set the primary GID first. Moreover, some operating systems may require that the supplementary groups list contains the primary GID. =back If no directions for what to do with C, C and C are given, a default of C is implied. All other file descriptors will be closed, unless a C operation is given for them. If C is used, be sure to place it after any other operations that might require superuser privileges, such as C or opening special files. Z<> my ( $pipeRd, $pipeWr ) = IO::Async::OS->pipepair; $loop->spawn_child( command => "/usr/bin/my-command", setup => [ stdin => [ "open", "<", "/dev/null" ], stdout => $pipeWr, stderr => [ "open", ">>", "/var/log/mycmd.log" ], chdir => "/", ] on_exit => sub { my ( $pid, $exitcode ) = @_; my $status = ( $exitcode >> 8 ); print "Command exited with status $status\n"; }, ); $loop->spawn_child( code => sub { do_something; # executes in a child process return 1; }, on_exit => sub { my ( $pid, $exitcode, $dollarbang, $dollarat ) = @_; my $status = ( $exitcode >> 8 ); print "Child process exited with status $status\n"; print " OS error was $dollarbang, exception was $dollarat\n"; }, ); =cut sub spawn_child { my $self = shift; my %params = @_; my $childmanager = $self->{childmanager} ||= $self->__new_feature( "IO::Async::Internals::ChildManager" ); $childmanager->spawn_child( %params ); } =head2 open_process $process = $loop->open_process( %params ); I This creates a new child process to run the given code block or command, and attaches filehandles to it that the parent will watch. This method is a light wrapper around constructing a new L object, adding it to the loop, and returning it. The C<%params> hash is passed directly to the L constructor. =cut sub open_process { my $self = shift; my %params = @_; $params{on_exit} and croak "Cannot pass 'on_exit' parameter through ->open_process"; require IO::Async::Process; my $process = IO::Async::Process->new( %params ); $self->add( $process ); return $process; } =head2 open_child $pid = $loop->open_child( %params ); A back-compatibility wrapper to calling L and returning the PID of the newly-constructed L instance. The C continuation likewise will be invoked with the PID rather than the process instance. $on_finish->( $pid, $exitcode ); Similarly, a C continuation is accepted, though note its arguments come in a different order to those of the Process's C: $on_error->( $pid, $exitcode, $errno, $exception ); This method should not be used in new code; instead use L directly. =cut sub open_child { my $self = shift; my %params = @_; my $on_finish = delete $params{on_finish}; ref $on_finish or croak "Expected 'on_finish' to be a reference"; $params{on_finish} = sub { my ( $process, $exitcode ) = @_; $on_finish->( $process->pid, $exitcode ); }; if( my $on_error = delete $params{on_error} ) { ref $on_error or croak "Expected 'on_error' to be a reference"; $params{on_exception} = sub { my ( $process, $exception, $errno, $exitcode ) = @_; # Swap order $on_error->( $process->pid, $exitcode, $errno, $exception ); }; } return $self->open_process( %params )->pid; } =head2 run_process @results = await $loop->run_process( %params ); ( $exitcode, $stdout ) = await $loop->run_process( ... ); # by default I Creates a new child process to run the given code block or command, optionally capturing its STDOUT and STDERR streams. By default the returned future will yield the exit code and content of the STDOUT stream, but the C argument can be used to alter what is requested and returned. =over 8 =item command => ARRAY or STRING =item code => CODE The command or code to run in the child process (as per the C method) =item stdin => STRING Optional. String to pass in to the child process's STDIN stream. =item setup => ARRAY Optional reference to an array to pass to the underlying C method. =item capture => ARRAY Optional reference to an array giving a list of names of values which should be returned by resolving future. Values will be returned in the same order as in the list. Valid choices are: C, C, C. =item cancel_signal => STRING Optional. Name (or number) of the signal to send to the process if the returned future is cancelled. Defaults to C. Use empty string or zero disable sending a signal on cancellation. =item fail_on_nonzero => BOOL Optional. If true, the returned future will fail if the process exits with a nonzero status. The failure will contain a message, the C category name, and the capture values that were requested. Future->fail( $message, process => @captures ); =back This method is intended mainly as an IO::Async-compatible replacement for the perl C function (`backticks`), allowing it to replace my $output = `command here`; with my ( $exitcode, $output ) = await $loop->run_process( command => "command here", ); Z<> my ( $exitcode, $stdout ) = await $loop->run_process( command => "/bin/ps", ); my $status = ( $exitcode >> 8 ); print "ps exited with status $status\n"; =cut sub _run_process { my $self = shift; my %params = @_; $params{on_finish} and croak "Unrecognised parameter on_finish"; my $capture = delete $params{capture} // [qw(exitcode stdout)]; ref $capture eq "ARRAY" or croak "Expected 'capture' to be an array reference"; my %subparams; my %results; if( my $child_stdin = delete $params{stdin} ) { ref $child_stdin and croak "Expected 'stdin' not to be a reference"; $subparams{stdin} = { from => $child_stdin }; } foreach (qw( code command setup notifier_name )) { $subparams{$_} = delete $params{$_}; } foreach my $name ( @$capture ) { grep { $_ eq $name } qw( exitcode stdout stderr ) or croak "Unexpected capture $name"; $subparams{stdout} = { into => \$results{stdout} } if $name eq "stdout"; $subparams{stderr} = { into => \$results{stderr} } if $name eq "stderr"; } my $cancel_signal = delete $params{cancel_signal} // "TERM"; my $fail_on_nonzero = delete $params{fail_on_nonzero}; croak "Unrecognised parameters " . join( ", ", keys %params ) if keys %params; my $future = $self->new_future; require IO::Async::Process; my $process = IO::Async::Process->new( %subparams, on_finish => sub { ( undef, $results{exitcode} ) = @_; if( $fail_on_nonzero and $results{exitcode} > 0 ) { $future->fail( "Process failed with exit code $results{exitcode}\n", process => @results{ @$capture } ); } else { $future->done( @results{ @$capture } ); } }, ); $future->on_cancel(sub { $process->kill( $cancel_signal ); }) if $cancel_signal; $self->add( $process ); return ( $future, $process ); } sub run_process { my $self = shift; return ( $self->_run_process( @_ ) )[0]; } =head2 run_child $pid = $loop->run_child( %params ); A back-compatibility wrapper for L, returning the PID and taking an C continuation instead of returning a Future. This creates a new child process to run the given code block or command, capturing its STDOUT and STDERR streams. When the process exits, a continuation is invoked being passed the exitcode, and content of the streams. Takes the following named arguments in addition to those taken by C: =over 8 =item on_finish => CODE A continuation to be called when the child process exits and closed its STDOUT and STDERR streams. It will be invoked in the following way: $on_finish->( $pid, $exitcode, $stdout, $stderr ); The second argument is passed the plain perl C<$?> value. =back This method should not be used in new code; instead use L directly. =cut sub run_child { my $self = shift; my %params = @_; my $on_finish = delete $params{on_finish}; ref $on_finish or croak "Expected 'on_finish' to be a reference"; my ( $f, $process ) = $self->_run_process( %params, capture => [qw( exitcode stdout stderr )], ); my $pid = $process->pid; $f->on_done( sub { undef $f; # capture cycle $on_finish->( $pid, @_ ); }); return $pid; } =head2 resolver $resolver = $loop->resolver; Returns the internally-stored L object, used for name resolution operations by the C, C and C methods. =cut sub resolver { my $self = shift; return $self->{resolver} ||= do { require IO::Async::Resolver; my $resolver = IO::Async::Resolver->new; $self->add( $resolver ); $resolver; } } =head2 set_resolver $loop->set_resolver( $resolver ); Sets the internally-stored L object. In most cases this method should not be required, but it may be used to provide an alternative resolver for special use-cases. =cut sub set_resolver { my $self = shift; my ( $resolver ) = @_; $resolver->can( $_ ) or croak "Resolver is unsuitable as it does not implement $_" for qw( resolve getaddrinfo getnameinfo ); $self->{resolver} = $resolver; $self->add( $resolver ); } =head2 resolve @result = await $loop->resolve( %params ); This method performs a single name resolution operation. It uses an internally-stored L object. For more detail, see the C method on the L class. =cut sub resolve { my $self = shift; my ( %params ) = @_; $self->resolver->resolve( %params ); } =head2 connect $handle|$socket = await $loop->connect( %params ); This method performs a non-blocking connection to a given address or set of addresses, returning a L which represents the operation. On completion, the future will yield the connected socket handle, or the given L object. There are two modes of operation. Firstly, a list of addresses can be provided which will be tried in turn. Alternatively as a convenience, if a host and service name are provided instead of a list of addresses, these will be resolved using the underlying loop's C method into the list of addresses. When attempting to connect to any among a list of addresses, there may be failures among the first attempts, before a valid connection is made. For example, the resolver may have returned some IPv6 addresses, but only IPv4 routes are valid on the system. In this case, the first C syscall will fail. This isn't yet a fatal error, if there are more addresses to try, perhaps some IPv4 ones. For this reason, it is possible that the operation eventually succeeds even though some system calls initially fail. To be aware of individual failures, the optional C callback can be used. This will be invoked on each individual C or C failure, which may be useful for debugging or logging. Because this module simply uses the C resolver, it will be fully IPv6-aware if the underlying platform's resolver is. This allows programs to be fully IPv6-capable. In plain address mode, the C<%params> hash takes the following keys: =over 8 =item addrs => ARRAY Reference to an array of (possibly-multiple) address structures to attempt to connect to. Each should be in the layout described for C. Such a layout is returned by the C named resolver. =item addr => HASH or ARRAY Shortcut for passing a single address to connect to; it may be passed directly with this key, instead of in another array on its own. This should be in a format recognised by L's C method. This example shows how to use the C functions to construct one for TCP port 8001 on address 10.0.0.1: $loop->connect( addr => { family => "inet", socktype => "stream", port => 8001, ip => "10.0.0.1", }, ... ); This example shows another way to connect to a UNIX socket at F. $loop->connect( addr => { family => "unix", socktype => "stream", path => "echo.sock", }, ... ); =item peer => IO Shortcut for constructing an address to connect to the given IO handle, which must be a L or subclass, and is presumed to be a local listening socket (perhaps on C or C). This is convenient for connecting to a local filehandle, for example during a unit test or similar. =item local_addrs => ARRAY =item local_addr => HASH or ARRAY Optional. Similar to the C or C parameters, these specify a local address or set of addresses to C the socket to before Cing it. =back When performing the resolution step too, the C or C keys are ignored, and instead the following keys are taken: =over 8 =item host => STRING =item service => STRING The hostname and service name to connect to. =item local_host => STRING =item local_service => STRING Optional. The hostname and/or service name to C the socket to locally before connecting to the peer. =item family => INT =item socktype => INT =item protocol => INT =item flags => INT Optional. Other arguments to pass along with C and C to the C call. =item socktype => STRING Optionally may instead be one of the values C<'stream'>, C<'dgram'> or C<'raw'> to stand for C, C or C. This utility is provided to allow the caller to avoid a separate C only for importing these constants. =back It is necessary to pass the C hint to the resolver when resolving the host/service names into an address, as some OS's C functions require this hint. A warning is emitted if neither C nor C hint is defined when performing a C lookup. To avoid this warning while still specifying no particular C hint (perhaps to invoke some OS-specific behaviour), pass C<0> as the C value. In either case, it also accepts the following arguments: =over 8 =item handle => IO::Async::Handle Optional. If given a L object or a subclass (such as L or L its handle will be set to the newly-connected socket on success, and that handle used as the result of the future instead. =item on_fail => CODE Optional. After an individual C or C syscall has failed, this callback is invoked to inform of the error. It is passed the name of the syscall that failed, the arguments that were passed to it, and the error it generated. I.e. $on_fail->( "socket", $family, $socktype, $protocol, $! ); $on_fail->( "bind", $sock, $address, $! ); $on_fail->( "connect", $sock, $address, $! ); Because of the "try all" nature when given a list of multiple addresses, this callback may be invoked multiple times, even before an eventual success. =back This method accepts an C parameter; see the C section below. =head2 connect (void) $loop->connect( %params ); When not returning a future, additional parameters can be given containing the continuations to invoke on success or failure. =over 8 =item on_connected => CODE A continuation that is invoked on a successful C call to a valid socket. It will be passed the connected socket handle, as an C object. $on_connected->( $handle ); =item on_stream => CODE An alternative to C, a continuation that is passed an instance of L when the socket is connected. This is provided as a convenience for the common case that a Stream object is required as the transport for a Protocol object. $on_stream->( $stream ) =item on_socket => CODE Similar to C, but constructs an instance of L. This is most useful for C or C sockets. $on_socket->( $socket ); =item on_connect_error => CODE A continuation that is invoked after all of the addresses have been tried, and none of them succeeded. It will be passed the most significant error that occurred, and the name of the operation it occurred in. Errors from the C syscall are considered most significant, then C, then finally C. $on_connect_error->( $syscall, $! ); =item on_resolve_error => CODE A continuation that is invoked when the name resolution attempt fails. This is invoked in the same way as the C continuation for the C method. =back =cut sub connect { my $self = shift; my ( %params ) = @_; my $extensions; if( $extensions = delete $params{extensions} and @$extensions ) { my ( $ext, @others ) = @$extensions; my $method = "${ext}_connect"; # TODO: Try to 'require IO::Async::$ext' $self->can( $method ) or croak "Extension method '$method' is not available"; return $self->$method( %params, ( @others ? ( extensions => \@others ) : () ), ); } my $handle = $params{handle}; my $on_done; # Legacy callbacks if( my $on_connected = delete $params{on_connected} ) { $on_done = $on_connected; } elsif( my $on_stream = delete $params{on_stream} ) { defined $handle and croak "Cannot pass 'on_stream' with a handle object as well"; require IO::Async::Stream; # TODO: It doesn't make sense to put a SOCK_DGRAM in an # IO::Async::Stream but currently we don't detect this $handle = IO::Async::Stream->new; $on_done = $on_stream; } elsif( my $on_socket = delete $params{on_socket} ) { defined $handle and croak "Cannot pass 'on_socket' with a handle object as well"; require IO::Async::Socket; $handle = IO::Async::Socket->new; $on_done = $on_socket; } elsif( !defined wantarray ) { croak "Expected 'on_connected' or 'on_stream' callback or to return a Future"; } my $on_connect_error; if( $on_connect_error = $params{on_connect_error} ) { # OK } elsif( !defined wantarray ) { croak "Expected 'on_connect_error' callback"; } my $on_resolve_error; if( $on_resolve_error = $params{on_resolve_error} ) { # OK } elsif( !defined wantarray and exists $params{host} || exists $params{local_host} ) { croak "Expected 'on_resolve_error' callback or to return a Future"; } my $connector = $self->{connector} ||= $self->__new_feature( "IO::Async::Internals::Connector" ); my $future = $connector->connect( %params ); $future = $future->then( sub { $handle->set_handle( shift ); return Future->done( $handle ) }) if $handle; $future->on_done( $on_done ) if $on_done; $future->on_fail( sub { $on_connect_error->( @_[2,3] ) if $on_connect_error and $_[1] eq "connect"; $on_resolve_error->( $_[2] ) if $on_resolve_error and $_[1] eq "resolve"; } ); return $future if defined wantarray; # Caller is not going to keep hold of the Future, so we have to ensure it # stays alive somehow $future->on_ready( sub { undef $future } ); # intentional cycle } =head2 listen $listener = await $loop->listen( %params ); This method sets up a listening socket and arranges for an acceptor callback to be invoked each time a new connection is accepted on the socket. Internally it creates an instance of L and adds it to the Loop if not given one in the arguments. Addresses may be given directly, or they may be looked up using the system's name resolver, or a socket handle may be given directly. If multiple addresses are given, or resolved from the service and hostname, then each will be attempted in turn until one succeeds. In named resolver mode, the C<%params> hash takes the following keys: =over 8 =item service => STRING The service name to listen on. =item host => STRING The hostname to listen on. Optional. Will listen on all addresses if not supplied. =item family => INT =item socktype => INT =item protocol => INT =item flags => INT Optional. Other arguments to pass along with C and C to the C call. =item socktype => STRING Optionally may instead be one of the values C<'stream'>, C<'dgram'> or C<'raw'> to stand for C, C or C. This utility is provided to allow the caller to avoid a separate C only for importing these constants. =back It is necessary to pass the C hint to the resolver when resolving the host/service names into an address, as some OS's C functions require this hint. A warning is emitted if neither C nor C hint is defined when performing a C lookup. To avoid this warning while still specifying no particular C hint (perhaps to invoke some OS-specific behaviour), pass C<0> as the C value. In plain address mode, the C<%params> hash takes the following keys: =over 8 =item addrs => ARRAY Reference to an array of (possibly-multiple) address structures to attempt to listen on. Each should be in the layout described for C. Such a layout is returned by the C named resolver. =item addr => ARRAY Shortcut for passing a single address to listen on; it may be passed directly with this key, instead of in another array of its own. This should be in a format recognised by L's C method. See also the C section. =back In direct socket handle mode, the following keys are taken: =over 8 =item handle => IO The listening socket handle. =back In either case, the following keys are also taken: =over 8 =item on_fail => CODE Optional. A callback that is invoked if a syscall fails while attempting to create a listening sockets. It is passed the name of the syscall that failed, the arguments that were passed to it, and the error generated. I.e. $on_fail->( "socket", $family, $socktype, $protocol, $! ); $on_fail->( "sockopt", $sock, $optname, $optval, $! ); $on_fail->( "bind", $sock, $address, $! ); $on_fail->( "listen", $sock, $queuesize, $! ); =item queuesize => INT Optional. The queue size to pass to the C calls. If not supplied, then 3 will be given instead. =item reuseaddr => BOOL Optional. If true or not supplied then the C socket option will be set. To prevent this, pass a false value such as 0. =item v6only => BOOL Optional. If defined, sets or clears the C socket option on C sockets. This option disables the ability of C socket to accept connections from C addresses. Not all operating systems allow this option to be disabled. =back An alternative which gives more control over the listener, is to create the L object directly and add it explicitly to the Loop. This method accepts an C parameter; see the C section below. =head2 listen (void) $loop->listen( %params ); When not returning a future, additional parameters can be given containing the continuations to invoke on success or failure. =over 8 =item on_notifier => CODE Optional. A callback that is invoked when the Listener object is ready to receive connections. The callback is passed the Listener object itself. $on_notifier->( $listener ); If this callback is required, it may instead be better to construct the Listener object directly. =item on_listen => CODE Optional. A callback that is invoked when the listening socket is ready. Typically this would be used in the name resolver case, in order to inspect the socket's sockname address, or otherwise inspect the filehandle. $on_listen->( $socket ) =item on_listen_error => CODE A continuation this is invoked after all of the addresses have been tried, and none of them succeeded. It will be passed the most significant error that occurred, and the name of the operation it occurred in. Errors from the C syscall are considered most significant, then C, then C, then finally C. =item on_resolve_error => CODE A continuation that is invoked when the name resolution attempt fails. This is invoked in the same way as the C continuation for the C method. =back =cut sub listen { my $self = shift; my ( %params ) = @_; my $remove_on_error; my $listener = $params{listener} ||= do { $remove_on_error++; require IO::Async::Listener; # Our wrappings of these don't want $listener my %listenerparams; for (qw( on_accept on_stream on_socket )) { next unless exists $params{$_}; croak "Cannot ->listen with '$_' and 'listener'" if $params{listener}; my $code = delete $params{$_}; $listenerparams{$_} = sub { shift; goto &$code; }; } my $listener = IO::Async::Listener->new( %listenerparams ); $self->add( $listener ); $listener }; my $extensions; if( $extensions = delete $params{extensions} and @$extensions ) { my ( $ext, @others ) = @$extensions; # We happen to know we break older IO::Async::SSL if( $ext eq "SSL" and $IO::Async::SSL::VERSION < '0.12001' ) { croak "IO::Async::SSL version too old; need at least 0.12_001; found $IO::Async::SSL::VERSION"; } my $method = "${ext}_listen"; # TODO: Try to 'require IO::Async::$ext' $self->can( $method ) or croak "Extension method '$method' is not available"; my $f = $self->$method( %params, ( @others ? ( extensions => \@others ) : () ), ); $f->on_fail( sub { $self->remove( $listener ) } ) if $remove_on_error; return $f; } my $on_notifier = delete $params{on_notifier}; # optional my $on_listen_error = delete $params{on_listen_error}; my $on_resolve_error = delete $params{on_resolve_error}; # Shortcut if( $params{addr} and not $params{addrs} ) { $params{addrs} = [ delete $params{addr} ]; } my $f; if( my $handle = delete $params{handle} ) { $f = $self->_listen_handle( $listener, $handle, %params ); } elsif( my $addrs = delete $params{addrs} ) { $on_listen_error or defined wantarray or croak "Expected 'on_listen_error' or to return a Future"; $f = $self->_listen_addrs( $listener, $addrs, %params ); } elsif( defined $params{service} ) { $on_listen_error or defined wantarray or croak "Expected 'on_listen_error' or to return a Future"; $on_resolve_error or defined wantarray or croak "Expected 'on_resolve_error' or to return a Future"; $f = $self->_listen_hostservice( $listener, delete $params{host}, delete $params{service}, %params ); } else { croak "Expected either 'service' or 'addrs' or 'addr' arguments"; } $f->on_done( $on_notifier ) if $on_notifier; if( my $on_listen = $params{on_listen} ) { $f->on_done( sub { $on_listen->( shift->read_handle ) } ); } $f->on_fail( sub { my ( $message, $how, @rest ) = @_; $on_listen_error->( @rest ) if $on_listen_error and $how eq "listen"; $on_resolve_error->( @rest ) if $on_resolve_error and $how eq "resolve"; }); $f->on_fail( sub { $self->remove( $listener ) } ) if $remove_on_error; return $f if defined wantarray; # Caller is not going to keep hold of the Future, so we have to ensure it # stays alive somehow $f->on_ready( sub { undef $f } ); # intentional cycle } sub _listen_handle { my $self = shift; my ( $listener, $handle, %params ) = @_; $listener->configure( handle => $handle ); return $self->new_future->done( $listener ); } sub _listen_addrs { my $self = shift; my ( $listener, $addrs, %params ) = @_; my $queuesize = $params{queuesize} || 3; my $on_fail = $params{on_fail}; !defined $on_fail or ref $on_fail or croak "Expected 'on_fail' to be a reference"; my $reuseaddr = 1; $reuseaddr = 0 if defined $params{reuseaddr} and not $params{reuseaddr}; my $v6only = $params{v6only}; my ( $listenerr, $binderr, $sockopterr, $socketerr ); foreach my $addr ( @$addrs ) { my ( $family, $socktype, $proto, $address ) = IO::Async::OS->extract_addrinfo( $addr ); my $sock; unless( $sock = IO::Async::OS->socket( $family, $socktype, $proto ) ) { $socketerr = $!; $on_fail->( socket => $family, $socktype, $proto, $! ) if $on_fail; next; } $sock->blocking( 0 ); if( $reuseaddr ) { unless( $sock->sockopt( SO_REUSEADDR, 1 ) ) { $sockopterr = $!; $on_fail->( sockopt => $sock, SO_REUSEADDR, 1, $! ) if $on_fail; next; } } if( defined $v6only and $family == AF_INET6 ) { unless( $sock->setsockopt( IPPROTO_IPV6, IPV6_V6ONLY, $v6only ) ) { $sockopterr = $!; $on_fail->( sockopt => $sock, IPV6_V6ONLY, $v6only, $! ) if $on_fail; next; } } unless( $sock->bind( $address ) ) { $binderr = $!; $on_fail->( bind => $sock, $address, $! ) if $on_fail; next; } unless( $sock->listen( $queuesize ) ) { $listenerr = $!; $on_fail->( listen => $sock, $queuesize, $! ) if $on_fail; next; } return $self->_listen_handle( $listener, $sock, %params ); } my $f = $self->new_future; return $f->fail( "Cannot listen() - $listenerr", listen => listen => $listenerr ) if $listenerr; return $f->fail( "Cannot bind() - $binderr", listen => bind => $binderr ) if $binderr; return $f->fail( "Cannot setsockopt() - $sockopterr", listen => sockopt => $sockopterr ) if $sockopterr; return $f->fail( "Cannot socket() - $socketerr", listen => socket => $socketerr ) if $socketerr; die 'Oops; $loop->listen failed but no error cause was found'; } sub _listen_hostservice { my $self = shift; my ( $listener, $host, $service, %params ) = @_; $host ||= ""; $service //= ""; my %gai_hints; exists $params{$_} and $gai_hints{$_} = $params{$_} for qw( family socktype protocol flags ); defined $gai_hints{socktype} or defined $gai_hints{protocol} or carp "Attempting to ->listen without either 'socktype' or 'protocol' hint is not portable"; $self->resolver->getaddrinfo( host => $host, service => $service, passive => 1, %gai_hints, )->then( sub { my @addrs = @_; $self->_listen_addrs( $listener, \@addrs, %params ); }); } =head1 OS ABSTRACTIONS Because the Magic Constructor searches for OS-specific subclasses of the Loop, several abstractions of OS services are provided, in case specific OSes need to give different implementations on that OS. =cut =head2 signame2num $signum = $loop->signame2num( $signame ); Legacy wrappers around L functions. =cut sub signame2num { shift; IO::Async::OS->signame2num( @_ ) } =head2 time $time = $loop->time; Returns the current UNIX time in fractional seconds. This is currently equivalent to C but provided here as a utility for programs to obtain the time current used by L for its own timing purposes. =cut sub time { my $self = shift; return Time::HiRes::time; } =head2 fork $pid = $loop->fork( %params ); This method creates a new child process to run a given code block, returning its process ID. =over 8 =item code => CODE A block of code to execute in the child process. It will be called in scalar context inside an C block. The return value will be used as the C code from the child if it returns (or 255 if it returned C or thows an exception). =item on_exit => CODE A optional continuation to be called when the child processes exits. It will be invoked in the following way: $on_exit->( $pid, $exitcode ); The second argument is passed the plain perl C<$?> value. This key is optional; if not supplied, the calling code should install a handler using the C method. =item keep_signals => BOOL Optional boolean. If missing or false, any CODE references in the C<%SIG> hash will be removed and restored back to C in the child process. If true, no adjustment of the C<%SIG> hash will be performed. =back =cut sub fork { my $self = shift; my %params = @_; HAVE_POSIX_FORK or croak "POSIX fork() is not available"; my $code = $params{code} or croak "Expected 'code' as a CODE reference"; my $kid = fork; defined $kid or croak "Cannot fork() - $!"; if( $kid == 0 ) { unless( $params{keep_signals} ) { foreach( keys %SIG ) { next if m/^__(WARN|DIE)__$/; $SIG{$_} = "DEFAULT" if ref $SIG{$_} eq "CODE"; } } # If the child process wants to use an IO::Async::Loop it needs to make # a new one, so this value is never useful undef our $ONE_TRUE_LOOP; my $exitvalue = eval { $code->() }; defined $exitvalue or $exitvalue = -1; POSIX::_exit( $exitvalue ); } if( defined $params{on_exit} ) { $self->watch_process( $kid => $params{on_exit} ); } $METRICS and $METRICS->inc_counter( forks => ); return $kid; } =head2 create_thread $tid = $loop->create_thread( %params ); This method creates a new (non-detached) thread to run the given code block, returning its thread ID. =over 8 =item code => CODE A block of code to execute in the thread. It is called in the context given by the C argument, and its return value will be available to the C callback. It is called inside an C block; if it fails the exception will be caught. =item context => "scalar" | "list" | "void" Optional. Gives the calling context that C is invoked in. Defaults to C if not supplied. =item on_joined => CODE Callback to invoke when the thread function returns or throws an exception. If it returned, this callback will be invoked with its result $on_joined->( return => @result ); If it threw an exception the callback is invoked with the value of C<$@> $on_joined->( died => $! ); =back =cut # It is basically impossible to have any semblance of order on global # destruction, and even harder again to rely on when threads are going to be # terminated and joined. Instead of ensuring we join them all, just detach any # we no longer care about at END time my %threads_to_detach; # {$tid} = $thread_weakly END { $_ and $_->detach for values %threads_to_detach; } sub create_thread { my $self = shift; my %params = @_; HAVE_THREADS or croak "Threads are not available"; eval { require threads } or croak "This Perl does not support threads"; my $code = $params{code} or croak "Expected 'code' as a CODE reference"; my $on_joined = $params{on_joined} or croak "Expected 'on_joined' as a CODE reference"; my $threadwatches = $self->{threadwatches}; unless( $self->{thread_join_pipe} ) { ( my $rd, $self->{thread_join_pipe} ) = IO::Async::OS->pipepair or croak "Cannot pipepair - $!"; $rd->blocking( 0 ); $self->{thread_join_pipe}->autoflush(1); $self->watch_io( handle => $rd, on_read_ready => sub { sysread $rd, my $buffer, 8192 or return; # There's a race condition here in that we might have read from # the pipe after the returning thread has written to it but before # it has returned. We'll grab the actual $thread object and # forcibly ->join it here to ensure we wait for its result. foreach my $tid ( unpack "N*", $buffer ) { my ( $thread, $on_joined ) = @{ delete $threadwatches->{$tid} } or die "ARGH: Can't find threadwatch for tid $tid\n"; $on_joined->( $thread->join ); delete $threads_to_detach{$tid}; } } ); } my $wr = $self->{thread_join_pipe}; my $context = $params{context} || "scalar"; my ( $thread ) = threads->create( sub { my ( @ret, $died ); eval { $context eq "list" ? ( @ret = $code->() ) : $context eq "scalar" ? ( $ret[0] = $code->() ) : $code->(); 1; } or $died = $@; $wr->syswrite( pack "N", threads->tid ); return died => $died if $died; return return => @ret; } ); $threadwatches->{$thread->tid} = [ $thread, $on_joined ]; weaken( $threads_to_detach{$thread->tid} = $thread ); return $thread->tid; } =head1 LOW-LEVEL METHODS As C is an abstract base class, specific subclasses of it are required to implement certain methods that form the base level of functionality. They are not recommended for applications to use; see instead the various event objects or higher level methods listed above. These methods should be considered as part of the interface contract required to implement a C subclass. =cut =head2 API_VERSION IO::Async::Loop->API_VERSION; This method will be called by the magic constructor on the class before it is constructed, to ensure that the specific implementation will support the required API. This method should return the API version that the loop implementation supports. The magic constructor will use that class, provided it declares a version at least as new as the version documented here. The current API version is C<0.49>. This method may be implemented using C; e.g use constant API_VERSION => '0.49'; =cut sub pre_wait { my $self = shift; $METRICS and $self->{processing_start} and $METRICS->report_timer( processing_time => Time::HiRes::tv_interval $self->{processing_start} ); } sub post_wait { my $self = shift; $METRICS and $self->{processing_start} = [ Time::HiRes::gettimeofday ]; } =head2 watch_io $loop->watch_io( %params ); This method installs callback functions which will be invoked when the given IO handle becomes read- or write-ready. The C<%params> hash takes the following keys: =over 8 =item handle => IO The IO handle to watch. =item on_read_ready => CODE Optional. A CODE reference to call when the handle becomes read-ready. =item on_write_ready => CODE Optional. A CODE reference to call when the handle becomes write-ready. =back There can only be one filehandle of any given fileno registered at any one time. For any one filehandle, there can only be one read-readiness and/or one write-readiness callback at any one time. Registering a new one will remove an existing one of that type. It is not required that both are provided. Applications should use a L or L instead of using this method. If the filehandle does not yet have the C flag set, it will be enabled by this method. This will ensure that any subsequent C, C, or similar will not block on the filehandle. =cut # This class specifically does NOT implement this method, so that subclasses # are forced to. The constructor will be checking.... sub __watch_io { my $self = shift; my %params = @_; my $handle = delete $params{handle} or croak "Expected 'handle'"; defined eval { $handle->fileno } or croak "Expected that 'handle' has defined ->fileno"; # Silent "upgrade" to O_NONBLOCK $handle->blocking and $handle->blocking(0); my $watch = ( $self->{iowatches}->{$handle->fileno} ||= [] ); $watch->[0] = $handle; if( exists $params{on_read_ready} ) { $watch->[1] = delete $params{on_read_ready}; } if( exists $params{on_write_ready} ) { $watch->[2] = delete $params{on_write_ready}; } if( exists $params{on_hangup} ) { $self->_CAN_ON_HANGUP or croak "Cannot watch_io for 'on_hangup' in ".ref($self); $watch->[3] = delete $params{on_hangup}; } keys %params and croak "Unrecognised keys for ->watch_io - " . join( ", ", keys %params ); } =head2 unwatch_io $loop->unwatch_io( %params ); This method removes a watch on an IO handle which was previously installed by C. The C<%params> hash takes the following keys: =over 8 =item handle => IO The IO handle to remove the watch for. =item on_read_ready => BOOL If true, remove the watch for read-readiness. =item on_write_ready => BOOL If true, remove the watch for write-readiness. =back Either or both callbacks may be removed at once. It is not an error to attempt to remove a callback that is not present. If both callbacks were provided to the C method and only one is removed by this method, the other shall remain. =cut sub __unwatch_io { my $self = shift; my %params = @_; my $handle = delete $params{handle} or croak "Expected 'handle'"; my $watch = $self->{iowatches}->{$handle->fileno} or return; if( delete $params{on_read_ready} ) { undef $watch->[1]; } if( delete $params{on_write_ready} ) { undef $watch->[2]; } if( delete $params{on_hangup} ) { $self->_CAN_ON_HANGUP or croak "Cannot watch_io for 'on_hangup' in ".ref($self); undef $watch->[3]; } if( not $watch->[1] and not $watch->[2] and not $watch->[3] ) { delete $self->{iowatches}->{$handle->fileno}; } keys %params and croak "Unrecognised keys for ->unwatch_io - " . join( ", ", keys %params ); } =head2 watch_signal $loop->watch_signal( $signal, $code ); This method adds a new signal handler to watch the given signal. =over 8 =item $signal The name of the signal to watch to. This should be a bare name like C. =item $code A CODE reference to the handling callback. =back There can only be one callback per signal name. Registering a new one will remove an existing one. Applications should use a L object, or call C instead of using this method. This and C are optional; a subclass may implement neither, or both. If it implements neither then signal handling will be performed by the base class using a self-connected pipe to interrupt the main IO blocking. =cut sub watch_signal { my $self = shift; my ( $signal, $code ) = @_; HAVE_SIGNALS or croak "This OS cannot ->watch_signal"; IO::Async::OS->loop_watch_signal( $self, $signal, $code ); } =head2 unwatch_signal $loop->unwatch_signal( $signal ); This method removes the signal callback for the given signal. =over 8 =item $signal The name of the signal to watch to. This should be a bare name like C. =back =cut sub unwatch_signal { my $self = shift; my ( $signal ) = @_; HAVE_SIGNALS or croak "This OS cannot ->unwatch_signal"; IO::Async::OS->loop_unwatch_signal( $self, $signal ); } =head2 watch_time $id = $loop->watch_time( %args ); This method installs a callback which will be called at the specified time. The time may either be specified as an absolute value (the C key), or as a delay from the time it is installed (the C key). The returned C<$id> value can be used to identify the timer in case it needs to be cancelled by the C method. Note that this value may be an object reference, so if it is stored, it should be released after it has been fired or cancelled, so the object itself can be freed. The C<%params> hash takes the following keys: =over 8 =item at => NUM The absolute system timestamp to run the event. =item after => NUM The delay after now at which to run the event, if C is not supplied. A zero or negative delayed timer should be executed as soon as possible; the next time the C method is invoked. =item now => NUM The time to consider as now if calculating an absolute time based on C; defaults to C if not specified. =item code => CODE CODE reference to the continuation to run at the allotted time. =back Either one of C or C is required. For more powerful timer functionality as a L (so it can be used as a child within another Notifier), see instead the L object and its subclasses. These C<*_time> methods are optional; a subclass may implement neither or both of them. If it implements neither, then the base class will manage a queue of timer events. This queue should be handled by the C method implemented by the subclass, using the C<_adjust_timeout> and C<_manage_queues> methods. This is the newer version of the API, replacing C. It is unspecified how this method pair interacts with the older C triplet. =cut sub watch_time { my $self = shift; my %args = @_; # Renamed args if( exists $args{after} ) { $args{delay} = delete $args{after}; } elsif( exists $args{at} ) { $args{time} = delete $args{at}; } else { croak "Expected one of 'at' or 'after'"; } if( $self->{old_timer} ) { $self->enqueue_timer( %args ); } else { my $timequeue = $self->{timequeue} ||= $self->__new_feature( "IO::Async::Internals::TimeQueue" ); my $time = $self->_build_time( %args ); my $code = $args{code}; $timequeue->enqueue( time => $time, code => $code ); } } =head2 unwatch_time $loop->unwatch_time( $id ) Removes a timer callback previously created by C. This is the newer version of the API, replacing C. It is unspecified how this method pair interacts with the older C triplet. =cut sub unwatch_time { my $self = shift; my ( $id ) = @_; if( $self->{old_timer} ) { $self->cancel_timer( $id ); } else { my $timequeue = $self->{timequeue} ||= $self->__new_feature( "IO::Async::Internals::TimeQueue" ); $timequeue->cancel( $id ); } } sub _build_time { my $self = shift; my %params = @_; my $time; if( exists $params{time} ) { $time = $params{time}; } elsif( exists $params{delay} ) { my $now = exists $params{now} ? $params{now} : $self->time; $time = $now + $params{delay}; } else { croak "Expected either 'time' or 'delay' keys"; } return $time; } =head2 enqueue_timer $id = $loop->enqueue_timer( %params ); An older version of C. This method should not be used in new code but is retained for legacy purposes. For simple watch/unwatch behaviour use instead the new C method; though note it has differently-named arguments. For requeueable timers, consider using an L or L instead. =cut sub enqueue_timer { my $self = shift; my ( %params ) = @_; # Renamed args $params{after} = delete $params{delay} if exists $params{delay}; $params{at} = delete $params{time} if exists $params{time}; my $code = $params{code}; return [ $self->watch_time( %params ), $code ]; } =head2 cancel_timer $loop->cancel_timer( $id ); An older version of C. This method should not be used in new code but is retained for legacy purposes. =cut sub cancel_timer { my $self = shift; my ( $id ) = @_; $self->unwatch_time( $id->[0] ); } =head2 requeue_timer $newid = $loop->requeue_timer( $id, %params ); Reschedule an existing timer, moving it to a new time. The old timer is removed and will not be invoked. The C<%params> hash takes the same keys as C, except for the C argument. The requeue operation may be implemented as a cancel + enqueue, which may mean the ID changes. Be sure to store the returned C<$newid> value if it is required. This method should not be used in new code but is retained for legacy purposes. For requeueable, consider using an L or L instead. =cut sub requeue_timer { my $self = shift; my ( $id, %params ) = @_; $self->unwatch_time( $id->[0] ); return $self->enqueue_timer( %params, code => $id->[1] ); } =head2 watch_idle $id = $loop->watch_idle( %params ); This method installs a callback which will be called at some point in the near future. The C<%params> hash takes the following keys: =over 8 =item when => STRING Specifies the time at which the callback will be invoked. See below. =item code => CODE CODE reference to the continuation to run at the allotted time. =back The C parameter defines the time at which the callback will later be invoked. Must be one of the following values: =over 8 =item later Callback is invoked after the current round of IO events have been processed by the loop's underlying C method. If a new idle watch is installed from within a C callback, the installed one will not be invoked during this round. It will be deferred for the next time C is called, after any IO events have been handled. =back If there are pending idle handlers, then the C method will use a zero timeout; it will return immediately, having processed any IO events and idle handlers. The returned C<$id> value can be used to identify the idle handler in case it needs to be removed, by calling the C method. Note this value may be a reference, so if it is stored it should be released after the callback has been invoked or cancled, so the referrant itself can be freed. This and C are optional; a subclass may implement neither, or both. If it implements neither then idle handling will be performed by the base class, using the C<_adjust_timeout> and C<_manage_queues> methods. =cut sub watch_idle { my $self = shift; my %params = @_; my $code = delete $params{code}; ref $code or croak "Expected 'code' to be a reference"; my $when = delete $params{when} or croak "Expected 'when'"; # Future-proofing for other idle modes $when eq "later" or croak "Expected 'when' to be 'later'"; my $deferrals = $self->{deferrals}; push @$deferrals, $code; return \$deferrals->[-1]; } =head2 unwatch_idle $loop->unwatch_idle( $id ); Cancels a previously-installed idle handler. =cut sub unwatch_idle { my $self = shift; my ( $id ) = @_; my $deferrals = $self->{deferrals}; my $idx; \$deferrals->[$_] == $id and ( $idx = $_ ), last for 0 .. $#$deferrals; splice @$deferrals, $idx, 1, () if defined $idx; } sub _reap_children { my ( $childwatches ) = @_; while( 1 ) { my $zid = waitpid( -1, WNOHANG ); # PIDs on MSWin32 can be negative last if !defined $zid or $zid == 0 or $zid == -1; my $status = $?; if( defined $childwatches->{$zid} ) { $childwatches->{$zid}->( $zid, $status ); delete $childwatches->{$zid}; } if( defined $childwatches->{0} ) { $childwatches->{0}->( $zid, $status ); # Don't delete it } } } =head2 watch_process $loop->watch_process( $pid, $code ); This method adds a new handler for the termination of the given child process PID, or all child processes. =over 8 =item $pid The PID to watch. Will report on all child processes if this is 0. =item $code A CODE reference to the exit handler. It will be invoked as $code->( $pid, $? ) The second argument is passed the plain perl C<$?> value. =back After invocation, the handler for a PID-specific watch is automatically removed. The all-child watch will remain until it is removed by C. This and C are optional; a subclass may implement neither, or both. If it implements neither then child watching will be performed by using C to install a C handler, which will use C to look for exited child processes. If both a PID-specific and an all-process watch are installed, there is no ordering guarantee as to which will be called first. B that not all loop classes may be able to support the all-child watch. The basic Select and Poll-based classes provided by this distribution do, and those built on top of similar OS-specific mechanisms such as Linux's Epoll probably will, but typically those built on top of other event systems such as F or F may not be able, as the underlying event system may not provide the necessary hooks to support it. =cut sub watch_process { my $self = shift; my ( $pid, $code ) = @_; if( $self->API_VERSION < 0.76 and ( $self->can( "watch_child" ) // 0 ) != \&watch_child ) { # Invoke legacy loop API return $self->watch_child( @_ ); } my $childwatches = $self->{childwatches}; croak "Already have a handler for $pid" if exists $childwatches->{$pid}; if( HAVE_SIGNALS and !$self->{childwatch_sigid} ) { $self->{childwatch_sigid} = $self->attach_signal( CHLD => sub { _reap_children( $childwatches ) } ); # There's a chance the child has already exited my $zid = waitpid( $pid, WNOHANG ); if( defined $zid and $zid > 0 ) { my $exitstatus = $?; $self->later( sub { $code->( $pid, $exitstatus ) } ); return; } } $childwatches->{$pid} = $code; } # Old name sub watch_child { shift->watch_process( @_ ) } =head2 unwatch_process $loop->unwatch_process( $pid ); This method removes a watch on an existing child process PID. =cut sub unwatch_process { my $self = shift; my ( $pid ) = @_; if( $self->API_VERSION < 0.76 and ( $self->can( "unwatch_child" ) // 0 ) != \&unwatch_child ) { # Invoke legacy loop API return $self->unwatch_child( @_ ); } my $childwatches = $self->{childwatches}; delete $childwatches->{$pid}; if( HAVE_SIGNALS and !keys %$childwatches ) { $self->detach_signal( CHLD => delete $self->{childwatch_sigid} ); } } # Old name sub unwatch_child { shift->unwatch_process( @_ ) } =head1 METHODS FOR SUBCLASSES The following methods are provided to access internal features which are required by specific subclasses to implement the loop functionality. The use cases of each will be documented in the above section. =cut =head2 _adjust_timeout $loop->_adjust_timeout( \$timeout ); Shortens the timeout value passed in the scalar reference if it is longer in seconds than the time until the next queued event on the timer queue. If there are pending idle handlers, the timeout is reduced to zero. =cut sub _adjust_timeout { my $self = shift; my ( $timeref, %params ) = @_; $$timeref = 0, return if @{ $self->{deferrals} }; if( defined $self->{sigproxy} and !$params{no_sigwait} ) { $$timeref = $MAX_SIGWAIT_TIME if !defined $$timeref or $$timeref > $MAX_SIGWAIT_TIME; } if( !HAVE_SIGNALS and keys %{ $self->{childwatches} } ) { $$timeref = $MAX_CHILDWAIT_TIME if !defined $$timeref or $$timeref > $MAX_CHILDWAIT_TIME; } my $timequeue = $self->{timequeue}; return unless defined $timequeue; my $nexttime = $timequeue->next_time; return unless defined $nexttime; my $now = exists $params{now} ? $params{now} : $self->time; my $timer_delay = $nexttime - $now; if( $timer_delay < 0 ) { $$timeref = 0; } elsif( !defined $$timeref or $timer_delay < $$timeref ) { $$timeref = $timer_delay; } } =head2 _manage_queues $loop->_manage_queues; Checks the timer queue for callbacks that should have been invoked by now, and runs them all, removing them from the queue. It also invokes all of the pending idle handlers. Any new idle handlers installed by these are not invoked yet; they will wait for the next time this method is called. =cut sub _manage_queues { my $self = shift; my $count = 0; my $timequeue = $self->{timequeue}; $count += $timequeue->fire if $timequeue; my $deferrals = $self->{deferrals}; $self->{deferrals} = []; foreach my $code ( @$deferrals ) { $code->(); $count++; } my $childwatches = $self->{childwatches}; if( !HAVE_SIGNALS and keys %$childwatches ) { _reap_children( $childwatches ); } return $count; } =head1 EXTENSIONS An Extension is a Perl module that provides extra methods in the C or other packages. They are intended to provide extra functionality that easily integrates with the rest of the code. Certain base methods take an C parameter; an ARRAY reference containing a list of extension names. If such a list is passed to a method, it will immediately call a method whose name is that of the base method, prefixed by the first extension name in the list, separated by C<_>. If the C list contains more extension names, it will be passed the remaining ones in another C parameter. For example, $loop->connect( extensions => [qw( FOO BAR )], %args ); will become $loop->FOO_connect( extensions => [qw( BAR )], %args ); This is provided so that extension modules, such as L can easily be invoked indirectly, by passing extra arguments to C methods or similar, without needing every module to be aware of the C extension. This functionality is generic and not limited to C; other extensions may also use it. The following methods take an C parameter: $loop->connect $loop->listen If an extension C method is invoked, it will be passed a C parameter even if one was not provided to the original C<< $loop->listen >> call, and it will not receive any of the C event callbacks. It should use the C parameter on the C object. =cut =head1 STALL WATCHDOG A well-behaved L program should spend almost all of its time blocked on input using the underlying C instance. The stall watchdog is an optional debugging feature to help detect CPU spinlocks and other bugs, where control is not returned to the loop every so often. If the watchdog is enabled and an event handler consumes more than a given amount of real time before returning to the event loop, it will be interrupted by printing a stack trace and terminating the program. The watchdog is only in effect while the loop itself is not blocking; it won't fail simply because the loop instance is waiting for input or timers. It is implemented using C, so if enabled, this signal will no longer be available to user code. (Though in any case, most uses of C and C are better served by one of the L subclasses). The following environment variables control its behaviour. =over 4 =item IO_ASYNC_WATCHDOG => BOOL Enables the stall watchdog if set to a non-zero value. =item IO_ASYNC_WATCHDOG_INTERVAL => INT Watchdog interval, in seconds, to pass to the C call. Defaults to 10 seconds. =item IO_ASYNC_WATCHDOG_SIGABRT => BOOL If enabled, the watchdog signal handler will raise a C, which usually has the effect of breaking out of a running program in debuggers such as F. If not set then the process is terminated by throwing an exception with C. =back =cut =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/LoopTests.pm000444001750001750 5477515001742754 16460 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2009-2025 -- leonerd@leonerd.org.uk package IO::Async::LoopTests 0.804; use v5.14; use warnings; use Exporter 'import'; our @EXPORT = qw( run_tests ); use Test2::V0 0.000149; use Test::Metrics::Any; use IO::Async::Test qw(); use IO::Async::OS; use IO::File; use Fcntl qw( SEEK_SET ); use POSIX qw( SIGTERM ); use Socket qw( sockaddr_family AF_UNIX ); use Time::HiRes qw( time ); # Abstract Units of Time use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1; # The loop under test. We keep it in a single lexical here, so we can use # is_oneref tests in the individual test suite functions my $loop; END { undef $loop } =head1 NAME C - acceptance testing for L subclasses =head1 SYNOPSIS use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Shiney', 'io' ); =head1 DESCRIPTION This module contains a collection of test functions for running acceptance tests on L subclasses. It is provided as a facility for authors of such subclasses to ensure that the code conforms to the Loop API required by L. =head1 TIMING Certain tests require the use of timers or timed delays. Normally these are counted in units of seconds. By setting the environment variable C to some true value, these timers run 10 times quicker, being measured in units of 0.1 seconds instead. This value may be useful when running the tests interactively, to avoid them taking too long. The slower timers are preferred on automated smoke-testing machines, to help guard against false negatives reported simply because of scheduling delays or high system load while testing. $ TEST_QUICK_TIMERS=1 ./Build test =cut =head1 FUNCTIONS =cut =head2 run_tests run_tests( $class, @tests ); Runs a test or collection of tests against the loop subclass given. The class being tested is loaded by this function; the containing script does not need to C or C it first. This function runs C to output its expected test count; the containing script should not do this. =cut sub run_tests { my ( $testclass, @tests ) = @_; ( my $file = "$testclass.pm" ) =~ s{::}{/}g; eval { require $file }; if( $@ ) { BAIL_OUT( "Unable to load $testclass - $@" ); } foreach my $test ( @tests ) { $loop = $testclass->new; isa_ok( $loop, [ $testclass ], '$loop' ); is( IO::Async::Loop->new, $loop, 'magic constructor yields $loop' ); # Kill the reference in $ONE_TRUE_LOOP so as not to upset the refcounts # and to ensure we get a new one each time undef $IO::Async::Loop::ONE_TRUE_LOOP; is_oneref( $loop, '$loop has refcount 1' ); __PACKAGE__->can( "run_tests_$test" )->(); is_oneref( $loop, '$loop has refcount 1 finally' ); } done_testing; } sub wait_for(&) { # Bounce via here so we don't upset refcount tests by having loop # permanently set in IO::Async::Test IO::Async::Test::testing_loop( $loop ); # Override prototype - I know what I'm doing &IO::Async::Test::wait_for( @_ ); IO::Async::Test::testing_loop( undef ); } sub time_between(&$$$) { my ( $code, $lower, $upper, $name ) = @_; my $start = time; $code->(); my $took = ( time - $start ) / AUT; cmp_ok( $took, '>=', $lower, "$name took at least $lower seconds" ) if defined $lower; cmp_ok( $took, '<=', $upper * 3, "$name took no more than $upper seconds" ) if defined $upper; if( $took > $upper and $took <= $upper * 3 ) { diag( "$name took longer than $upper seconds - this may just be an indication of a busy testing machine rather than a bug" ); } } =head1 TEST SUITES The following test suite names exist, to be passed as a name in the C<@tests> argument to C: =cut =head2 io Tests the Loop's ability to watch filehandles for IO readiness =cut sub run_tests_io { { my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!"; $_->blocking( 0 ) for $S1, $S2; my $readready = 0; my $writeready = 0; $loop->watch_io( handle => $S1, on_read_ready => sub { $readready = 1 }, ); is_oneref( $loop, '$loop has refcount 1 after watch_io on_read_ready' ); is( $readready, 0, '$readready still 0 before ->loop_once' ); $loop->loop_once( 0.1 ); is( $readready, 0, '$readready when idle' ); $S2->syswrite( "data\n" ); # We should still wait a little while even thought we expect to be ready # immediately, because talking to ourself with 0 poll timeout is a race # condition - we can still race with the kernel. $loop->loop_once( 0.1 ); is( $readready, 1, '$readready after loop_once' ); # Ready $S1 to clear the data $S1->getline; # ignore return $loop->unwatch_io( handle => $S1, on_read_ready => 1, ); $loop->watch_io( handle => $S1, on_read_ready => sub { $readready = 1 }, ); $readready = 0; $S2->syswrite( "more data\n" ); $loop->loop_once( 0.1 ); is( $readready, 1, '$readready after ->unwatch_io/->watch_io' ); $S1->getline; # ignore return $loop->watch_io( handle => $S1, on_write_ready => sub { $writeready = 1 }, ); is_oneref( $loop, '$loop has refcount 1 after watch_io on_write_ready' ); $loop->loop_once( 0.1 ); is( $writeready, 1, '$writeready after loop_once' ); $loop->unwatch_io( handle => $S1, on_write_ready => 1, ); $readready = 0; $loop->loop_once( 0.1 ); is( $readready, 0, '$readready before HUP' ); $S2->close; $readready = 0; $loop->loop_once( 0.1 ); is( $readready, 1, '$readready after HUP' ); $loop->unwatch_io( handle => $S1, on_read_ready => 1, ); } # HUP of pipe - can be different to sockets on some architectures { my ( $Prd, $Pwr ) = IO::Async::OS->pipepair or die "Cannot pipepair - $!"; $_->blocking( 0 ) for $Prd, $Pwr; my $readready = 0; $loop->watch_io( handle => $Prd, on_read_ready => sub { $readready = 1 }, ); $loop->loop_once( 0.1 ); is( $readready, 0, '$readready before pipe HUP' ); $Pwr->close; $readready = 0; $loop->loop_once( 0.1 ); is( $readready, 1, '$readready after pipe HUP' ); $loop->unwatch_io( handle => $Prd, on_read_ready => 1, ); } SKIP: { $loop->_CAN_ON_HANGUP or skip "Loop cannot watch_io for on_hangup", 2; SKIP: { my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!"; $_->blocking( 0 ) for $S1, $S2; sockaddr_family( $S1->sockname ) == AF_UNIX or skip "Cannot reliably detect hangup condition on non AF_UNIX sockets", 1; my $hangup = 0; $loop->watch_io( handle => $S1, on_hangup => sub { $hangup = 1 }, ); $S2->close; $loop->loop_once( 0.1 ); is( $hangup, 1, '$hangup after socket close' ); $loop->unwatch_io( handle => $S1, on_hangup => 1, ); } my ( $Prd, $Pwr ) = IO::Async::OS->pipepair or die "Cannot pipepair - $!"; $_->blocking( 0 ) for $Prd, $Pwr; my $hangup = 0; $loop->watch_io( handle => $Pwr, on_hangup => sub { $hangup = 1 }, ); $Prd->close; $loop->loop_once( 0.1 ); is( $hangup, 1, '$hangup after pipe close for writing' ); $loop->unwatch_io( handle => $Pwr, on_hangup => 1, ); } # Check that combined read/write handlers can cancel each other { my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!"; $_->blocking( 0 ) for $S1, $S2; my $callcount = 0; $loop->watch_io( handle => $S1, on_read_ready => sub { $callcount++; $loop->unwatch_io( handle => $S1, on_read_ready => 1, on_write_ready => 1 ); }, on_write_ready => sub { $callcount++; $loop->unwatch_io( handle => $S1, on_read_ready => 1, on_write_ready => 1 ); }, ); $S2->close; $loop->loop_once( 0.1 ); is( $callcount, 1, 'read/write_ready can cancel each other' ); } # Check that cross-connected handlers can cancel each other { my ( $SA1, $SA2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!"; my ( $SB1, $SB2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!"; $_->blocking( 0 ) for $SA1, $SA2, $SB1, $SB2; my @handles = ( $SA1, $SB1 ); my $callcount = 0; $loop->watch_io( handle => $_, on_write_ready => sub { $callcount++; $loop->unwatch_io( handle => $_, on_write_ready => 1 ) for @handles; }, ) for @handles; $loop->loop_once( 0.1 ); is( $callcount, 1, 'write_ready on crosslinked handles can cancel each other' ); } # Check that error conditions that aren't true read/write-ability are still # invoked SKIP: { skip "cygwin does not indicate read-ready on exceptional sockets", 1 if $^O eq "cygwin"; my ( $S1, $S2 ) = IO::Async::OS->socketpair( 'inet', 'dgram' ) or die "Cannot create AF_INET/SOCK_DGRAM connected pair - $!"; $_->blocking( 0 ) for $S1, $S2; $S2->close; my $readready = 0; $loop->watch_io( handle => $S1, on_read_ready => sub { $readready = 1 }, ); $S1->syswrite( "Boo!" ); $loop->loop_once( 0.1 ); is( $readready, 1, 'exceptional socket invokes on_read_ready' ); $loop->unwatch_io( handle => $S1, on_read_ready => 1, ); } # Check that regular files still report read/writereadiness { my $F = IO::File->new_tmpfile or die "Cannot create temporary file - $!"; $F->print( "Here's some content\n" ); $F->seek( 0, SEEK_SET ); my $readready = 0; my $writeready = 0; $loop->watch_io( handle => $F, on_read_ready => sub { $readready = 1 }, on_write_ready => sub { $writeready = 1 }, ); $loop->loop_once( 0.1 ); is( $readready, 1, 'regular file is readready' ); is( $writeready, 1, 'regular file is writeready' ); $loop->unwatch_io( handle => $F, on_read_ready => 1, on_write_ready => 1, ); } { my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create AF_INET/SOCK_DGRAM connected pair - $!"; $_->blocking( 0 ) for $S1, $S2; my $readready = 0; $loop->watch_io( handle => $S1, on_read_ready => sub { $readready = 1 }, ); $loop->post_fork; $S2->syswrite( "Boo!" ); $loop->loop_once( 0.1 ); is( $readready, 1, 'socket invokes on_read_ready' ); } } =head2 timer Tests the Loop's ability to handle timer events =cut sub run_tests_timer { # New watch/unwatch API cmp_ok( abs( $loop->time - time ), "<", 0.1, '$loop->time gives the current time' ); # ->watch_time after { my $done; $loop->watch_time( after => 2 * AUT, code => sub { $done = 1; } ); is_oneref( $loop, '$loop has refcount 1 after watch_time' ); time_between { my $now = time; $loop->loop_once( 5 * AUT ); # poll might have returned just a little early, such that the TimerQueue # doesn't think anything is ready yet. We need to handle that case. while( !$done ) { die "It should have been ready by now" if( time - $now > 5 * AUT ); $loop->loop_once( 0.1 * AUT ); } } 1.5, 2.5, 'loop_once(5) while waiting for watch_time after'; } # ->watch_time at { my $done; $loop->watch_time( at => time + 2 * AUT, code => sub { $done = 1; } ); time_between { my $now = time; $loop->loop_once( 5 * AUT ); # poll might have returned just a little early, such that the TimerQueue # doesn't think anything is ready yet. We need to handle that case. while( !$done ) { die "It should have been ready by now" if( time - $now > 5 * AUT ); $loop->loop_once( 0.1 * AUT ); } } 1.5, 2.5, 'loop_once(5) while waiting for watch_time at'; } # cancelled timer { my $cancelled_fired = 0; my $id = $loop->watch_time( after => 1 * AUT, code => sub { $cancelled_fired = 1 } ); $loop->unwatch_time( $id ); undef $id; $loop->loop_once( 2 * AUT ); ok( !$cancelled_fired, 'unwatched watch_time does not fire' ); } # ->watch_after negative time { my $done; $loop->watch_time( after => -1, code => sub { $done = 1 } ); time_between { $loop->loop_once while !$done; } 0, 0.1, 'loop_once while waiting for negative interval timer'; } # self-cancellation { my $done; my $id; $id = $loop->watch_time( after => 1 * AUT, code => sub { $loop->unwatch_time( $id ); undef $id; }); $loop->watch_time( after => 1.1 * AUT, code => sub { $done++; }); wait_for { $done }; is( $done, 1, 'Other timers still fire after self-cancelling one' ); } SKIP: { skip "Unable to handle sub-second timers accurately", 3 unless $loop->_CAN_SUBSECOND_ACCURATELY; # Check that short delays are achievable in one ->loop_once call foreach my $delay ( 0.001, 0.01, 0.1 ) { my $done; my $count = 0; my $start = time; $loop->watch_timer( delay => $delay, code => sub { $done++ } ); while( !$done ) { $loop->loop_once( 1 ); $count++; last if time - $start > 5; # bailout } is( $count, 1, "One ->loop_once(1) sufficient for a single $delay second timer" ); } } # ->watch_time after post_fork { my $done; $loop->watch_time( after => 2 * AUT, code => sub { $done = 1; } ); $loop->post_fork; time_between { my $now = time; $loop->loop_once( 5 * AUT ); # poll might have returned just a little early, such that the TimerQueue # doesn't think anything is ready yet. We need to handle that case. while( !$done ) { die "It should have been ready by now" if( time - $now > 5 * AUT ); $loop->loop_once( 0.1 * AUT ); } } 1.5, 2.5, 'loop_once(5) while waiting for watch_time after'; } } =head2 signal Tests the Loop's ability to watch POSIX signals =cut sub run_tests_signal { unless( IO::Async::OS->HAVE_SIGNALS ) { SKIP: { skip "This OS does not have signals", 14; } return; } my $caught = 0; $loop->watch_signal( TERM => sub { $caught++ } ); is_oneref( $loop, '$loop has refcount 1 after watch_signal' ); $loop->loop_once( 0.1 ); is( $caught, 0, '$caught idling' ); kill SIGTERM, $$; is( $caught, 0, '$caught before ->loop_once' ); $loop->loop_once( 0.1 ); is( $caught, 1, '$caught after ->loop_once' ); kill SIGTERM, $$; is( $caught, 1, 'second raise is still deferred' ); $loop->loop_once( 0.1 ); is( $caught, 2, '$caught after second ->loop_once' ); is_oneref( $loop, '$loop has refcount 1 before unwatch_signal' ); $loop->unwatch_signal( 'TERM' ); is_oneref( $loop, '$loop has refcount 1 after unwatch_signal' ); my ( $cA, $cB ); my $idA = $loop->attach_signal( TERM => sub { $cA = 1 } ); my $idB = $loop->attach_signal( TERM => sub { $cB = 1 } ); is_oneref( $loop, '$loop has refcount 1 after 2 * attach_signal' ); kill SIGTERM, $$; $loop->loop_once( 0.1 ); is( $cA, 1, '$cA after raise' ); is( $cB, 1, '$cB after raise' ); $loop->detach_signal( 'TERM', $idA ); undef $cA; undef $cB; kill SIGTERM, $$; $loop->loop_once( 0.1 ); is( $cA, undef, '$cA after raise' ); is( $cB, 1, '$cB after raise' ); $loop->detach_signal( 'TERM', $idB ); ok( dies { $loop->attach_signal( 'this signal name does not exist', sub {} ) }, 'Bad signal name fails' ); undef $caught; $loop->attach_signal( TERM => sub { $caught++ } ); $loop->post_fork; kill SIGTERM, $$; $loop->loop_once( 0.1 ); is( $caught, 1, '$caught SIGTERM after ->post_fork' ); } =head2 idle Tests the Loop's support for idle handlers =cut sub run_tests_idle { my $called = 0; my $id = $loop->watch_idle( when => 'later', code => sub { $called = 1 } ); ok( defined $id, 'idle watcher id is defined' ); is( $called, 0, 'deferred sub not yet invoked' ); time_between { $loop->loop_once( 3 * AUT ) } undef, 1.0, 'loop_once(3) with deferred sub'; is( $called, 1, 'deferred sub called after loop_once' ); $loop->watch_idle( when => 'later', code => sub { $loop->watch_idle( when => 'later', code => sub { $called = 2 } ) } ); $loop->loop_once( 1 ); is( $called, 1, 'inner deferral not yet invoked' ); $loop->loop_once( 1 ); is( $called, 2, 'inner deferral now invoked' ); $called = 2; # set it anyway in case previous test fails $id = $loop->watch_idle( when => 'later', code => sub { $called = 20 } ); $loop->unwatch_idle( $id ); # Some loop types (e.g. UV) need to clear a pending queue first and thus the # first loop_once will take zero time $loop->loop_once( 0 ); time_between { $loop->loop_once( 1 * AUT ) } 0.5, 1.5, 'loop_once(1) with unwatched deferral'; is( $called, 2, 'unwatched deferral not called' ); $id = $loop->watch_idle( when => 'later', code => sub { $called = 3 } ); my $timer_id = $loop->watch_time( after => 5, code => sub {} ); $loop->loop_once( 1 ); is( $called, 3, '$loop->later still invoked with enqueued timer' ); $loop->unwatch_time( $timer_id ); $loop->later( sub { $called = 4 } ); $loop->loop_once( 1 ); is( $called, 4, '$loop->later shortcut works' ); } =head2 process Tests the Loop's support for watching child processes by PID (Previously called C) =cut sub run_in_child(&) { my $kid = fork; defined $kid or die "Cannot fork() - $!"; return $kid if $kid; shift->(); die "Fell out of run_in_child!\n"; } sub run_tests_process { my $kid = run_in_child { exit( 3 ); }; my $exitcode; $loop->watch_process( $kid => sub { ( undef, $exitcode ) = @_; } ); is_oneref( $loop, '$loop has refcount 1 after watch_process' ); ok( !defined $exitcode, '$exitcode not defined before ->loop_once' ); undef $exitcode; wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after child exit' ); is( ($exitcode >> 8), 3, 'WEXITSTATUS($exitcode) after child exit' ); SKIP: { skip "This OS does not have signals", 1 unless IO::Async::OS->HAVE_SIGNALS; # We require that SIGTERM perform its default action; i.e. terminate the # process. Ensure this definitely happens, in case the test harness has it # ignored or handled elsewhere. local $SIG{TERM} = "DEFAULT"; $kid = run_in_child { sleep( 10 ); # Just in case the parent died already and didn't kill us exit( 0 ); }; $loop->watch_process( $kid => sub { ( undef, $exitcode ) = @_; } ); kill SIGTERM, $kid; undef $exitcode; wait_for { defined $exitcode }; is( ($exitcode & 0x7f), SIGTERM, 'WTERMSIG($exitcode) after SIGTERM' ); } SKIP: { my %kids; $loop->_CAN_WATCH_ALL_PIDS or skip "Loop cannot watch_process for all PIDs", 2; $loop->watch_process( 0 => sub { my ( $kid ) = @_; delete $kids{$kid} } ); %kids = map { run_in_child { exit 0 } => 1 } 1 .. 3; is( scalar keys %kids, 3, 'Waiting for 3 child processes' ); wait_for { !keys %kids }; ok( !keys %kids, 'All child processes reclaimed' ); } # Legacy API name $kid = run_in_child { exit 2 }; undef $exitcode; $loop->watch_child( $kid => sub { ( undef, $exitcode ) = @_; } ); wait_for { defined $exitcode }; is( ($exitcode >> 8), 2, '$exitcode after child exit from legacy ->watch_child' ); } *run_tests_child = \&run_tests_process; # old name =head2 control Tests that the C, C, C and C methods behave correctly =cut sub run_tests_control { time_between { $loop->loop_once( 0 ) } 0, 0.1, 'loop_once(0) when idle'; time_between { $loop->loop_once( 2 * AUT ) } 1.5, 2.5, 'loop_once(2) when idle'; $loop->watch_time( after => 0.1, code => sub { $loop->stop( result => "here" ) } ); local $SIG{ALRM} = sub { die "Test timed out before ->stop" }; alarm( 1 ); my @result = $loop->run; alarm( 0 ); is( \@result, [ result => "here" ], '->stop arguments returned by ->run' ); $loop->watch_time( after => 0.1, code => sub { $loop->stop( result => "here" ) } ); my $result = $loop->run; is( $result, "result", 'First ->stop argument returned by ->run in scalar context' ); $loop->watch_time( after => 0.1, code => sub { SKIP: { unless( $loop->can( 'is_running' ) ) { diag "Unsupported \$loop->is_running"; skip "Unsupported \$loop->is_running", 1; } ok( $loop->is_running, '$loop->is_running' ); } $loop->watch_time( after => 0.1, code => sub { $loop->stop( "inner" ) } ); my @result = $loop->run; $loop->stop( @result, "outer" ); } ); @result = $loop->run; is( \@result, [ "inner", "outer" ], '->run can be nested properly' ); $loop->watch_time( after => 0.1, code => sub { $loop->loop_stop } ); local $SIG{ALRM} = sub { die "Test timed out before ->loop_stop" }; alarm( 1 ); $loop->loop_forever; alarm( 0 ); ok( 1, '$loop->loop_forever interruptable by ->loop_stop' ); } =head2 metrics Tests that metrics are generated appropriately using L. =cut sub run_tests_metrics { my $loopclass = ref $loop; return unless $IO::Async::Metrics::METRICS; # We should already at least have the loop-type metric is_metrics( { "io_async_loops class:$loopclass" => 1, }, 'Constructing the loop creates a loop type metric' ); # The very first call won't create timing metrics because it isn't armed yet. $loop->loop_once( 0 ); is_metrics_from( sub { $loop->loop_once( 0.1 ) }, { io_async_processing_count => 1, io_async_processing_total => Test::Metrics::Any::positive, }, 'loop_once(0) creates timing metrics' ); } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Metrics.pm000444001750001750 744515001742754 16102 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2020-2024 -- leonerd@leonerd.org.uk package IO::Async::Metrics 0.804; use v5.14; use warnings; # Metrics support is entirely optional our $METRICS; eval { require Metrics::Any and Metrics::Any->VERSION( '0.05' ) and Metrics::Any->import( '$METRICS', name_prefix => [qw( io_async )], ); }; =head1 NAME C - report metrics about C to C =head1 DESCRIPTION This module contains the implementation of metrics-reporting code from C to provide information about its operation into L. =cut sub import { my $class = shift; my $caller = caller; my ( $varname ) = @_; $varname =~ s/^\$//; no strict 'refs'; *{"${caller}::${varname}"} = \$METRICS; } =head1 METRICS The following metrics are reported: =head2 io_async_forks A counter giving the number of times that C has been called by the L. =head2 io_async_notifiers A gauge giving the number of L currently registered with the Loop. =head2 io_async_processing A time distribution giving the amount of time spent processing IO events. This time does not include the time spent blocking on the underlying kernel system call to wait for IO events, but only the time spent in userland afterwards to handle them. =head2 io_async_resolver_lookups A labelled counter giving the number of attempted lookups by the L. This metric has one label, C, containing the type of lookup; e.g. C. =head2 io_async_resolver_failures A labelled counter giving the number of Resolver lookups that failed. This is labelled as for C. =head2 io_async_stream_read A counter giving the number of bytes read by L instances. Note that for SSL connections, this will only be able to count bytes of plaintext, not ciphertext, and thus will be a slight under-estimate in this case. =head2 io_async_stream_written A counter giving the number of bytes written by Stream instances. Note again for SSL connections this will only be able to count bytes of plaintext. =cut if( defined $METRICS ) { # Loop metrics $METRICS->make_gauge( notifiers => description => "Number of IO::Async::Notifiers registered with the Loop", ); $METRICS->make_counter( forks => description => "Number of times IO::Async has fork()ed a process", ); $METRICS->make_timer( processing_time => name => [qw( processing )], description => "Time spent by IO::Async:Loop processing IO", # Override bucket generation bucket_min => 0.001, bucket_max => 1, # 1msec to 1sec buckets_per_decade => [qw( 1 2.5 5 )], ); $METRICS->make_gauge( loops => description => "Count of IO::Async::Loop instances by class", labels => [qw( class )], ); # Resolver metrics $METRICS->make_counter( resolver_lookups => name => [qw( resolver lookups )], description => "Number of IO::Async::Resolver lookups by type", labels => [qw( type )], ); $METRICS->make_counter( resolver_failures => name => [qw( resolver failures )], description => "Number of IO::Async::Resolver lookups that failed by type", labels => [qw( type )], ); # Stream metrics $METRICS->make_counter( stream_written => name => [qw( stream written )], description => "Bytes written by IO::Async::Streams", units => "bytes", ); $METRICS->make_counter( stream_read => name => [qw( stream read )], description => "Bytes read by IO::Async::Streams", units => "bytes", ); } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Notifier.pm000444001750001750 6202115001742754 16262 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2006-2024 -- leonerd@leonerd.org.uk package IO::Async::Notifier 0.804; use v5.14; use warnings; use Carp; use Scalar::Util qw( weaken ); use Future 0.26; # ->is_failed use IO::Async::Debug; # Perl 5.8.4 cannot do trampolines by modiying @_ then goto &$code use constant HAS_BROKEN_TRAMPOLINES => ( $] == "5.008004" ); =head1 NAME C - base class for L event objects =head1 SYNOPSIS Usually not directly used by a program, but one valid use case may be: use IO::Async::Notifier; use IO::Async::Stream; use IO::Async::Signal; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $notifier = IO::Async::Notifier->new; $notifier->add_child( IO::Async::Stream->new_for_stdin( on_read => sub { my $self = shift; my ( $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*)\n// ) { print "You said $1\n"; } return 0; }, ) ); $notifier->add_child( IO::Async::Signal->new( name => 'INT', on_receipt => sub { print "Goodbye!\n"; $loop->stop; }, ) ); $loop->add( $notifier ); $loop->run; =head1 DESCRIPTION This object class forms the basis for all the other event objects that an L program uses. It provides the lowest level of integration with a L container, and a facility to collect Notifiers together, in a tree structure, where any Notifier can contain a collection of children. Normally, objects in this class would not be directly used by an end program, as it performs no actual IO work, and generates no actual events. These are all left to the various subclasses, such as: =over 4 =item * L - event callbacks for a non-blocking file descriptor =item * L - event callbacks and write bufering for a stream filehandle =item * L - event callbacks and send buffering for a socket filehandle =item * L - base class for Notifiers that use timed delays =item * L - event callback on receipt of a POSIX signal =item * L - event callback on exit of a child process =item * L - start and manage a child process =back For more detail, see the SYNOPSIS section in one of the above. One case where this object class would be used, is when a library wishes to provide a sub-component which consists of multiple other C subclasses, such as Cs and C, but no particular object is suitable to be the root of a tree. In this case, a plain C object can be used as the tree root, and all the other notifiers added as children of it. =cut =head1 AS A MIXIN Rather than being used as a subclass this package also supports being used as a non-principle superclass for an object, as a mix-in. It still provides methods and satisfies an C test, even though the constructor is not directly called. This simply requires that the object be based on a normal blessed hash reference and include C somewhere in its C<@ISA> list. The methods in this class all use only keys in the hash prefixed by C<"IO_Async_Notifier__"> for namespace purposes. This is intended mainly for defining a subclass of some other object that is also an C, suitable to be added to an L. package SomeEventSource::Async; use base qw( SomeEventSource IO::Async::Notifier ); sub _add_to_loop { my $self = shift; my ( $loop ) = @_; # Code here to set up event handling on $loop that may be required } sub _remove_from_loop { my $self = shift; my ( $loop ) = @_; # Code here to undo the event handling set up above } Since all the methods documented here will be available, the implementation may wish to use the C and C or C methods to implement its own event callbacks. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_error $message, $name, @details Invoked by C. =cut =head1 PARAMETERS A specific subclass of C defines named parameters that control its behaviour. These may be passed to the C constructor, or to the C method. The documentation on each specific subclass will give details on the parameters that exist, and their uses. Some parameters may only support being set once at construction time, or only support being changed if the object is in a particular state. The following parameters are supported by all Notifiers: =over 8 =item on_error => CODE CODE reference for event handler. =item notifier_name => STRING Optional string used to identify this particular Notifier. This value will be returned by the C method. =back =cut =head1 CONSTRUCTOR =cut =head2 new $notifier = IO::Async::Notifier->new( %params ); This function returns a new instance of a C object with the given initial values of the named parameters. Up until L version 0.19, this module used to implement the IO handle features now found in the L subclass. Code that needs to use any of C, C, C, C or C should use L instead. =cut sub new { my $class = shift; my %params = @_; my $self = bless {}, $class; $self->_init( \%params ); $self->configure( %params ); return $self; } =head1 METHODS =cut =head2 configure $notifier->configure( %params ); Adjust the named parameters of the C as given by the C<%params> hash. =cut # for subclasses to override and call down to sub configure { my $self = shift; my %params = @_; foreach (qw( notifier_name on_error )) { $self->{"IO_Async_Notifier__$_"} = delete $params{$_} if exists $params{$_}; } $self->configure_unknown( %params ) if keys %params; } sub configure_unknown { my $self = shift; my %params = @_; my $class = ref $self; croak "Unrecognised configuration keys for $class - " . join( " ", keys %params ); } =head2 loop $loop = $notifier->loop; Returns the L that this Notifier is a member of. =cut sub loop { my $self = shift; return $self->{IO_Async_Notifier__loop} } *get_loop = \&loop; # Only called by IO::Async::Loop, not external interface sub __set_loop { my $self = shift; my ( $loop ) = @_; # early exit if no change return if !$loop and !$self->loop or $loop and $self->loop and $loop == $self->loop; $self->_remove_from_loop( $self->loop ) if $self->loop; $self->{IO_Async_Notifier__loop} = $loop; weaken( $self->{IO_Async_Notifier__loop} ); # To avoid a cycle $self->_add_to_loop( $self->loop ) if $self->loop; } =head2 notifier_name $name = $notifier->notifier_name; Returns the name to identify this Notifier. If a has not been set, it will return the empty string. Subclasses may wish to override this behaviour to return some more useful information, perhaps from configured parameters. =cut sub notifier_name { my $self = shift; return $self->{IO_Async_Notifier__notifier_name} || ""; } =head2 adopt_future $f = $notifier->adopt_future( $f ); Stores a reference to the L instance within the notifier itself, so the reference doesn't get lost. This reference will be dropped when the future becomes ready (either by success or failure). Additionally, if the future failed the notifier's C method will be informed. This means that if the notifier does not provide an C handler, nor is there one anywhere in the parent chain, this will be fatal to the caller of C<< $f->fail >>. To avoid this being fatal if the failure is handled elsewhere, use the C method on the future to obtain a sequence one that never fails. $notifier->adopt_future( $f->else_done() ); The future itself is returned. =cut sub adopt_future { my $self = shift; my ( $f ) = @_; my $fkey = "$f"; # stable stringification $self->{IO_Async_Notifier__futures}{$fkey} = $f; $f->on_ready( $self->_capture_weakself( sub { my $self = shift; my ( $f ) = @_; delete $self->{IO_Async_Notifier__futures}{$fkey}; $self->invoke_error( $f->failure ) if $f->is_failed; })); return $f; } =head2 adopted_futures @f = $notifier->adopted_futures; I Returns a list of all the adopted and still-pending futures, in no particular order. =cut sub adopted_futures { my $self = shift; return values %{ $self->{IO_Async_Notifier__futures} }; } =head1 CHILD NOTIFIERS During the execution of a program, it may be the case that certain IO handles cause other handles to be created; for example, new sockets that have been Ced from a listening socket. To facilitate these, a notifier may contain child notifier objects, that are automatically added to or removed from the L that manages their parent. =cut =head2 parent $parent = $notifier->parent; Returns the parent of the notifier, or C if does not have one. =cut sub parent { my $self = shift; return $self->{IO_Async_Notifier__parent}; } =head2 children @children = $notifier->children; Returns a list of the child notifiers contained within this one. =cut sub children { my $self = shift; return unless $self->{IO_Async_Notifier__children}; return @{ $self->{IO_Async_Notifier__children} }; } =head2 add_child $notifier->add_child( $child ); Adds a child notifier. This notifier will be added to the containing loop, if the parent has one. Only a notifier that does not currently have a parent and is not currently a member of any loop may be added as a child. If the child itself has grandchildren, these will be recursively added to the containing loop. =cut sub add_child { my $self = shift; my ( $child ) = @_; croak "Cannot add a child that already has a parent" if defined $child->{IO_Async_Notifier__parent}; croak "Cannot add a child that is already a member of a loop" if defined $child->loop; if( defined( my $loop = $self->loop ) ) { $loop->add( $child ); } push @{ $self->{IO_Async_Notifier__children} }, $child; $child->{IO_Async_Notifier__parent} = $self; weaken( $child->{IO_Async_Notifier__parent} ); return; } =head2 remove_child $notifier->remove_child( $child ); Removes a child notifier. The child will be removed from the containing loop, if the parent has one. If the child itself has grandchildren, these will be recurively removed from the loop. =cut sub remove_child { my $self = shift; my ( $child ) = @_; LOOP: { my $childrenref = $self->{IO_Async_Notifier__children}; for my $i ( 0 .. $#$childrenref ) { no warnings 'uninitialized'; next unless $childrenref->[$i] == $child; splice @$childrenref, $i, 1, (); last LOOP; } croak "Cannot remove child from a parent that doesn't contain it"; } undef $child->{IO_Async_Notifier__parent}; if( defined( my $loop = $self->loop ) ) { $loop->remove( $child ); } } =head2 remove_from_parent $notifier->remove_from_parent; Removes this notifier object from its parent (either another notifier object or the containing loop) if it has one. If the notifier is not a child of another notifier nor a member of a loop, this method does nothing. =cut sub remove_from_parent { my $self = shift; if( my $parent = $self->parent ) { $parent->remove_child( $self ); } elsif( my $loop = $self->loop ) { $loop->remove( $self ); } } =head1 SUBCLASS METHODS C is a base class provided so that specific subclasses of it provide more specific behaviour. The base class provides a number of methods that subclasses may wish to override. If a subclass implements any of these, be sure to invoke the superclass method at some point within the code. =cut =head2 _init $notifier->_init( $paramsref ); This method is called by the constructor just before calling C. It is passed a reference to the HASH storing the constructor arguments. This method may initialise internal details of the Notifier as required, possibly by using parameters from the HASH. If any parameters are construction-only they should be Cd from the hash. =cut sub _init { # empty default } =head2 configure $notifier->configure( %params ); This method is called by the constructor to set the initial values of named parameters, and by users of the object to adjust the values once constructed. This method should C from the C<%params> hash any keys it has dealt with, then pass the remaining ones to the C. The base class implementation will throw an exception if there are any unrecognised keys remaining. =cut =head2 configure_unknown $notifier->configure_unknown( %params ); This method is called by the base class C method, for any remaining parameters that are not recognised. The default implementation throws an exception using C that lists the unrecognised keys. This method is provided to allow subclasses to override the behaviour, perhaps to store unrecognised keys, or to otherwise inspect the left-over arguments for some other purpose. =cut =head2 _add_to_loop $notifier->_add_to_loop( $loop ); This method is called when the Notifier has been added to a Loop; either directly, or indirectly through being a child of a Notifer already in a loop. This method may be used to perform any initial startup activity required for the Notifier to be fully functional but which requires a Loop to do so. =cut sub _add_to_loop { # empty default } =head2 _remove_from_loop $notifier->_remove_from_loop( $loop ); This method is called when the Notifier has been removed from a Loop; either directly, or indirectly through being a child of a Notifier removed from the loop. This method may be used to undo the effects of any setup that the C<_add_to_loop> method had originally done. =cut sub _remove_from_loop { # empty default } =head1 UTILITY METHODS =cut =head2 _capture_weakself $mref = $notifier->_capture_weakself( $code ); Returns a new CODE ref which, when invoked, will invoke the originally-passed ref, with additionally a reference to the Notifier as its first argument. The Notifier reference is stored weakly in C<$mref>, so this CODE ref may be stored in the Notifier itself without creating a cycle. For example, my $mref = $notifier->_capture_weakself( sub { my ( $notifier, $arg ) = @_; print "Notifier $notifier got argument $arg\n"; } ); $mref->( 123 ); This is provided as a utility for Notifier subclasses to use to build a callback CODEref to pass to a Loop method, but which may also want to store the CODE ref internally for efficiency. The C<$code> argument may also be a plain string, which will be used as a method name; the returned CODE ref will then invoke that method on the object. In this case the method name is stored symbolically in the returned CODE reference, and dynamically dispatched each time the reference is invoked. This allows it to follow code reloading, dynamic replacement of class methods, or other similar techniques. If the C<$mref> CODE reference is being stored in some object other than the one it refers to, remember that since the Notifier is only weakly captured, it is possible that it has been destroyed by the time the code runs, and so the reference will be passed as C. This should be protected against by the code body. $other_object->{on_event} = $notifier->_capture_weakself( sub { my $notifier = shift or return; my ( @event_args ) = @_; ... } ); For stand-alone generic implementation of this behaviour, see also L and C. =cut sub _capture_weakself { my $self = shift; my ( $code ) = @_; # actually bare method names work too if( !ref $code ) { my $class = ref $self; # Don't save this coderef, or it will break dynamic method dispatch, # which means code reloading, dynamic replacement, or other funky # techniques stop working $self->can( $code ) or croak qq(Can't locate object method "$code" via package "$class"); } weaken $self; return sub { my $cv = ref( $code ) ? $code : $self->can( $code ); if( HAS_BROKEN_TRAMPOLINES ) { return $cv->( $self, @_ ); } else { unshift @_, $self; goto &$cv; } }; } =head2 _replace_weakself $mref = $notifier->_replace_weakself( $code ); Returns a new CODE ref which, when invoked, will invoke the originally-passed ref, with a reference to the Notifier replacing its first argument. The Notifier reference is stored weakly in C<$mref>, so this CODE ref may be stored in the Notifier itself without creating a cycle. For example, my $mref = $notifier->_replace_weakself( sub { my ( $notifier, $arg ) = @_; print "Notifier $notifier got argument $arg\n"; } ); $mref->( $object, 123 ); This is provided as a utility for Notifier subclasses to use for event callbacks on other objects, where the delegated object is passed in the function's arguments. The C<$code> argument may also be a plain string, which will be used as a method name; the returned CODE ref will then invoke that method on the object. As with C<_capture_weakself> this is stored symbolically. As with C<_capture_weakself>, care should be taken against Notifier destruction if the C<$mref> CODE reference is stored in some other object. =cut sub _replace_weakself { my $self = shift; my ( $code ) = @_; # actually bare method names work too if( !ref $code ) { # Don't save this coderef, see _capture_weakself for why my $class = ref $self; $self->can( $code ) or croak qq(Can't locate object method "$code" via package "$class"); } weaken $self; return sub { my $cv = ref( $code ) ? $code : $self->can( $code ); if( HAS_BROKEN_TRAMPOLINES ) { return $cv->( $self, @_[1..$#_] ); } else { # Don't assign to $_[0] directly or we will change caller's first argument shift @_; unshift @_, $self; goto &$cv; } }; } =head2 can_event $code = $notifier->can_event( $event_name ); Returns a C reference if the object can perform the given event name, either by a configured C reference parameter, or by implementing a method. If the object is unable to handle this event, C is returned. =cut sub can_event { my $self = shift; my ( $event_name ) = @_; return $self->{$event_name} || $self->can( $event_name ); } =head2 make_event_cb $callback = $notifier->make_event_cb( $event_name ); Returns a C reference which, when invoked, will execute the given event handler. Event handlers may either be subclass methods, or parameters given to the C or C method. The event handler can be passed extra arguments by giving them to the C reference; the first parameter received will be a reference to the notifier itself. This is stored weakly in the closure, so it is safe to store the resulting C reference in the object itself without causing a reference cycle. =cut sub make_event_cb { my $self = shift; my ( $event_name ) = @_; my $code = $self->can_event( $event_name ) or croak "$self cannot handle $event_name event"; my $caller = caller; return $self->_capture_weakself( !$IO::Async::Debug::DEBUG ? $code : sub { my $self = $_[0]; $self->_debug_printf_event( $caller, $event_name ); goto &$code; } ); } =head2 maybe_make_event_cb $callback = $notifier->maybe_make_event_cb( $event_name ); Similar to C but will return C if the object cannot handle the named event, rather than throwing an exception. =cut sub maybe_make_event_cb { my $self = shift; my ( $event_name ) = @_; my $code = $self->can_event( $event_name ) or return undef; my $caller = caller; return $self->_capture_weakself( !$IO::Async::Debug::DEBUG ? $code : sub { my $self = $_[0]; $self->_debug_printf_event( $caller, $event_name ); goto &$code; } ); } =head2 invoke_event @ret = $notifier->invoke_event( $event_name, @args ); Invokes the given event handler, passing in the given arguments. Event handlers may either be subclass methods, or parameters given to the C or C method. Returns whatever the underlying method or CODE reference returned. =cut sub invoke_event { my $self = shift; my ( $event_name, @args ) = @_; my $code = $self->can_event( $event_name ) or croak "$self cannot handle $event_name event"; $self->_debug_printf_event( scalar caller, $event_name ) if $IO::Async::Debug::DEBUG; return $code->( $self, @args ); } =head2 maybe_invoke_event $retref = $notifier->maybe_invoke_event( $event_name, @args ); Similar to C but will return C if the object cannot handle the name event, rather than throwing an exception. In order to distinguish this from an event-handling function that simply returned C, if the object does handle the event, the list that it returns will be returned in an ARRAY reference. =cut sub maybe_invoke_event { my $self = shift; my ( $event_name, @args ) = @_; my $code = $self->can_event( $event_name ) or return undef; $self->_debug_printf_event( scalar caller, $event_name ) if $IO::Async::Debug::DEBUG; return [ $code->( $self, @args ) ]; } =head1 DEBUGGING SUPPORT =cut =head2 debug_printf $notifier->debug_printf( $format, @args ); Conditionally print a debugging message to C if debugging is enabled. If such a message is printed, it will be printed using C using the given format and arguments. The message will be prefixed with a string, in square brackets, to help identify the C<$notifier> instance. This string will be the class name of the notifier, and any parent notifiers it is contained by, joined by an arrow C<< <- >>. To ensure this string does not grow too long, certain prefixes are abbreviated: IO::Async::Protocol:: => IaP: IO::Async:: => Ia: Net::Async:: => Na: Finally, each notifier that has a name defined using the C parameter has that name appended in braces. For example, invoking $stream->debug_printf( "EVENT on_read" ); On an L instance reading and writing a file descriptor whose C is 4, which is a child of an L, will produce a line of output: [Ia:Stream{rw=4}<-IaP:Stream] EVENT on_read =cut sub debug_printf { $IO::Async::Debug::DEBUG or return; my $self = shift; my ( $format, @args ) = @_; my @id; while( $self ) { push @id, ref $self; my $name = $self->notifier_name; $id[-1] .= "{$name}" if defined $name and length $name; $self = $self->parent; } s/^IO::Async::Protocol::/IaP:/, s/^IO::Async::/Ia:/, s/^Net::Async::/Na:/ for @id; IO::Async::Debug::logf "[%s] $format\n", join("<-", @id), @args; } sub _debug_printf_event { my $self = shift; my ( $caller, $event_name ) = @_; my $class = ref $self; if( $IO::Async::Debug::DEBUG > 1 or $class eq $caller ) { s/^IO::Async::Protocol::/IaP:/, s/^IO::Async::/Ia:/, s/^Net::Async::/Na:/ for my $str_caller = $caller; $self->debug_printf( "EVENT %s", ( $class eq $caller ? $event_name : "${str_caller}::$event_name" ) ); } } =head2 invoke_error $notifier->invoke_error( $message, $name, @details ); Invokes the stored C event handler, passing in the given arguments. If no handler is defined, it will be passed up to the containing parent notifier, if one exists. If no parent exists, the error message will be thrown as an exception by using C and this method will not return. If a handler is found to handle this error, the method will return as normal. However, as the expected use-case is to handle "fatal" errors that now render the notifier unsuitable to continue, code should be careful not to perform any further work after invoking it. Specifically, sockets may become disconnected, or the entire notifier may now be removed from its containing loop. The C<$name> and C<@details> list should follow similar semantics to L failures. That is, the C<$name> should be a string giving a category of failure, and the C<@details> list should contain additional arguments that relate to that kind of failure. =cut sub invoke_error { my $self = shift; my ( $message, $name, @details ) = @_; if( my $code = $self->{IO_Async_Notifier__on_error} || $self->can( "on_error" ) ) { return $code->( $self, $message, $name, @details ); } if( my $parent = $self->parent ) { return $parent->invoke_error( @_ ); } die "$message\n"; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/OS.pm000444001750001750 4550015001742754 15027 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2012-2024 -- leonerd@leonerd.org.uk package IO::Async::OS 0.804; use v5.14; use warnings; our @ISA = qw( IO::Async::OS::_Base ); if( eval { require "IO/Async/OS/$^O.pm" } ) { @ISA = "IO::Async::OS::$^O"; } package # hide from CPAN IO::Async::OS::_Base; use Carp; use Socket 1.95 qw( AF_INET AF_INET6 AF_UNIX INADDR_LOOPBACK SOCK_DGRAM SOCK_RAW SOCK_STREAM pack_sockaddr_in inet_aton pack_sockaddr_in6 inet_pton pack_sockaddr_un ); use POSIX qw( sysconf _SC_OPEN_MAX ); # Win32 [and maybe other places] don't have an _SC_OPEN_MAX. About the best we # can do really is just make up some largeish number and hope for the best. use constant OPEN_MAX_FD => eval { sysconf(_SC_OPEN_MAX) } || 1024; # Some constants that define features of the OS use constant HAVE_SOCKADDR_IN6 => defined eval { pack_sockaddr_in6 0, inet_pton( AF_INET6, "2001::1" ) }; use constant HAVE_SOCKADDR_UN => defined eval { pack_sockaddr_un "/foo" }; # Do we have to fake S_ISREG() files read/write-ready in select()? use constant HAVE_FAKE_ISREG_READY => 0; # Do we have to select() for for evec to get connect() failures use constant HAVE_SELECT_CONNECT_EVEC => 0; # Ditto; do we have to poll() for POLLPRI to get connect() failures use constant HAVE_POLL_CONNECT_POLLPRI => 0; # Does connect() yield EWOULDBLOCK for nonblocking in progress? use constant HAVE_CONNECT_EWOULDBLOCK => 0; # Can we rename() files that are open? use constant HAVE_RENAME_OPEN_FILES => 1; # Can we reliably watch for POSIX signals, including SIGCHLD to reliably # inform us that a fork()ed child has exit()ed? use constant HAVE_SIGNALS => 1; # Do we support POSIX-style true fork()ed processes at all? use constant HAVE_POSIX_FORK => !$ENV{IO_ASYNC_NO_FORK}; # Can we potentially support threads? (would still need to 'require threads') use constant HAVE_THREADS => !$ENV{IO_ASYNC_NO_THREADS} && eval { require Config && $Config::Config{useithreads} }; # Preferred trial order for built-in Loop classes use constant LOOP_BUILTIN_CLASSES => qw( Poll Select ); # Should there be any other Loop classes we try before the builtin ones? use constant LOOP_PREFER_CLASSES => (); =head1 NAME C - operating system abstractions for C =head1 DESCRIPTION This module acts as a class to provide a number of utility methods whose exact behaviour may depend on the type of OS it is running on. It is provided as a class so that specific kinds of operating system can override methods in it. As well as these support functions it also provides a number of constants, all with names beginning C which describe various features that may or may not be available on the OS or perl build. Most of these are either hard-coded per OS, or detected at runtime. The following constants may be overridden by environment variables. =over 4 =item * HAVE_POSIX_FORK True if the C call has full POSIX semantics (full process separation). This is true on most OSes but false on MSWin32. This may be overridden to be false by setting the environment variable C. =item * HAVE_THREADS True if C are available, meaning that the C module can be used. This depends on whether perl was built with threading support. This may be overridable to be false by setting the environment variable C. =back =cut =head2 getfamilybyname $family = IO::Async::OS->getfamilybyname( $name ) Return a protocol family value based on the given name. If C<$name> looks like a number it will be returned as-is. The string values C, C and C will be converted to the appropriate C constant. =cut sub getfamilybyname { shift; my ( $name ) = @_; return undef unless defined $name; return $name if $name =~ m/^\d+$/; return AF_INET if $name eq "inet"; return AF_INET6() if $name eq "inet6" and defined &AF_INET6; return AF_UNIX if $name eq "unix"; croak "Unrecognised socket family name '$name'"; } =head2 getsocktypebyname $socktype = IO::Async::OS->getsocktypebyname( $name ); Return a socket type value based on the given name. If C<$name> looks like a number it will be returned as-is. The string values C, C and C will be converted to the appropriate C constant. =cut sub getsocktypebyname { shift; my ( $name ) = @_; return undef unless defined $name; return $name if $name =~ m/^\d+$/; return SOCK_STREAM if $name eq "stream"; return SOCK_DGRAM if $name eq "dgram"; return SOCK_RAW if $name eq "raw"; croak "Unrecognised socktype name '$name'"; } # This one isn't documented because it's not really overridable. It's largely # here just for completeness my $HAVE_IO_SOCKET_IP; sub socket { my $self = shift; my ( $family, $socktype, $proto ) = @_; require IO::Socket; defined $HAVE_IO_SOCKET_IP or $HAVE_IO_SOCKET_IP = defined eval { require IO::Socket::IP }; croak "Cannot create a new socket without a family" unless $family; # PF_UNSPEC and undef are both false $family = $self->getfamilybyname( $family ) || AF_UNIX; # SOCK_STREAM is the most likely $socktype = $self->getsocktypebyname( $socktype ) || SOCK_STREAM; $proto //= 0; if( $HAVE_IO_SOCKET_IP and ( $family == AF_INET || $family == AF_INET6() ) ) { return IO::Socket::IP->new->socket( $family, $socktype, $proto ); } my $sock = eval { IO::Socket->new( Domain => $family, Type => $socktype, Proto => $proto, ); }; return $sock if $sock; # That failed. Most likely because the Domain was unrecognised. This # usually happens if getaddrinfo returns an AF_INET6 address but we don't # have a suitable class loaded. In this case we'll return a generic one. # It won't be in the specific subclass but that's the best we can do. And # it will still work as a generic socket. return IO::Socket->new->socket( $family, $socktype, $proto ); } =head2 socketpair ( $S1, $S2 ) = IO::Async::OS->socketpair( $family, $socktype, $proto ); An abstraction of the C syscall, where any argument may be missing (or given as C). If C<$family> is not provided, a suitable value will be provided by the OS (likely C on POSIX-based platforms). If C<$socktype> is not provided, then C will be used. Additionally, this method supports building connected C or C pairs in the C family even if the underlying platform's C does not, by connecting two normal sockets together. C<$family> and C<$socktype> may also be given symbolically as defined by C and C. =cut sub socketpair { my $self = shift; my ( $family, $socktype, $proto ) = @_; require IO::Socket; # PF_UNSPEC and undef are both false $family = $self->getfamilybyname( $family ) || AF_UNIX; # SOCK_STREAM is the most likely $socktype = $self->getsocktypebyname( $socktype ) || SOCK_STREAM; $proto ||= 0; my ( $S1, $S2 ) = IO::Socket->new->socketpair( $family, $socktype, $proto ); return ( $S1, $S2 ) if defined $S1; return unless $family == AF_INET and ( $socktype == SOCK_STREAM or $socktype == SOCK_DGRAM ); # Now lets emulate an AF_INET socketpair call my $Stmp = IO::Async::OS->socket( $family, $socktype ) or return; $Stmp->bind( pack_sockaddr_in( 0, INADDR_LOOPBACK ) ) or return; $S1 = IO::Async::OS->socket( $family, $socktype ) or return; if( $socktype == SOCK_STREAM ) { $Stmp->listen( 1 ) or return; $S1->connect( getsockname $Stmp ) or return; $S2 = $Stmp->accept or return; # There's a bug in IO::Socket here, in that $S2 's ->socktype won't # yet be set. We can apply a horribly hacky fix here # defined $S2->socktype and $S2->socktype == $socktype or # ${*$S2}{io_socket_type} = $socktype; # But for now we'll skip the test for it instead } else { $S2 = $Stmp; $S1->connect( getsockname $S2 ) or return; $S2->connect( getsockname $S1 ) or return; } return ( $S1, $S2 ); } =head2 pipepair ( $rd, $wr ) = IO::Async::OS->pipepair; An abstraction of the C syscall, which returns the two new handles. =cut sub pipepair { my $self = shift; pipe( my ( $rd, $wr ) ) or return; return ( $rd, $wr ); } =head2 pipequad ( $rdA, $wrA, $rdB, $wrB ) = IO::Async::OS->pipequad; This method is intended for creating two pairs of filehandles that are linked together, suitable for passing as the STDIN/STDOUT pair to a child process. After this function returns, C<$rdA> and C<$wrA> will be a linked pair, as will C<$rdB> and C<$wrB>. On platforms that support C, this implementation will be preferred, in which case C<$rdA> and C<$wrB> will actually be the same filehandle, as will C<$rdB> and C<$wrA>. This saves a file descriptor in the parent process. When creating a L or subclass of it, the C and C parameters should always be used. my ( $childRd, $myWr, $myRd, $childWr ) = IO::Async::OS->pipequad; $loop->open_process( stdin => $childRd, stdout => $childWr, ... ); my $str = IO::Async::Stream->new( read_handle => $myRd, write_handle => $myWr, ... ); $loop->add( $str ); =cut sub pipequad { my $self = shift; # Prefer socketpair if( my ( $S1, $S2 ) = $self->socketpair ) { return ( $S1, $S2, $S2, $S1 ); } # Can't do that, fallback on pipes my ( $rdA, $wrA ) = $self->pipepair or return; my ( $rdB, $wrB ) = $self->pipepair or return; return ( $rdA, $wrA, $rdB, $wrB ); } =head2 signame2num $signum = IO::Async::OS->signame2num( $signame ); This utility method converts a signal name (such as "TERM") into its system- specific signal number. This may be useful to pass to C or use in other places which use numbers instead of symbolic names. =head2 signum2name $signame = IO::Async::OS->signum2name( $signum ); The inverse of L; this method convers signal numbers into readable names. =cut my %sig_name2num; my %sig_num2name; sub _init_signum { my $self = shift; require Config; $Config::Config{sig_name} and $Config::Config{sig_num} or die "No signals found"; my @names = split ' ', $Config::Config{sig_name}; my @nums = split ' ', $Config::Config{sig_num}; @sig_name2num{ @names } = @nums; # Only take the first of each name, in case of aliased names @sig_num2name{ $sig_name2num{$_} } //= $_ for @names; } sub signame2num { my $self = shift; my ( $signame ) = @_; %sig_name2num or $self->_init_signum; return $sig_name2num{$signame}; } sub signum2name { my $self = shift; my ( $signum ) = @_; %sig_num2name or $self->_init_signum; return $sig_num2name{$signum}; } =head2 extract_addrinfo ( $family, $socktype, $protocol, $addr ) = IO::Async::OS->extract_addrinfo( $ai ); Given an ARRAY or HASH reference value containing an addrinfo, returns a family, socktype and protocol argument suitable for a C call and an address suitable for C or C. If given an ARRAY it should be in the following form: [ $family, $socktype, $protocol, $addr ] If given a HASH it should contain the following keys: family socktype protocol addr Each field in the result will be initialised to 0 (or empty string for the address) if not defined in the C<$ai> value. The family type may also be given as a symbolic string as defined by C. The socktype may also be given as a symbolic string; C, C or C; this will be converted to the appropriate C constant. Note that the C field, if provided, must be a packed socket address, such as returned by C or C. If the HASH form is used, rather than passing a packed socket address in the C field, certain other hash keys may be used instead for convenience on certain named families. =over 4 =cut use constant ADDRINFO_FAMILY => 0; use constant ADDRINFO_SOCKTYPE => 1; use constant ADDRINFO_PROTOCOL => 2; use constant ADDRINFO_ADDR => 3; sub extract_addrinfo { my $self = shift; my ( $ai, $argname ) = @_; $argname ||= "addr"; my @ai; if( ref $ai eq "ARRAY" ) { @ai = @$ai; } elsif( ref $ai eq "HASH" ) { $ai = { %$ai }; # copy so we can delete from it @ai = delete @{$ai}{qw( family socktype protocol addr )}; if( defined $ai[ADDRINFO_FAMILY] and !defined $ai[ADDRINFO_ADDR] ) { my $family = $ai[ADDRINFO_FAMILY]; my $method = "_extract_addrinfo_$family"; my $code = $self->can( $method ) or croak "Cannot determine addr for extract_addrinfo on family='$family'"; $ai[ADDRINFO_ADDR] = $code->( $self, $ai ); keys %$ai and croak "Unrecognised '$family' addrinfo keys: " . join( ", ", keys %$ai ); } } else { croak "Expected '$argname' to be an ARRAY or HASH reference"; } $ai[ADDRINFO_FAMILY] = $self->getfamilybyname( $ai[ADDRINFO_FAMILY] ); $ai[ADDRINFO_SOCKTYPE] = $self->getsocktypebyname( $ai[ADDRINFO_SOCKTYPE] ); # Make sure all fields are defined $ai[$_] ||= 0 for ADDRINFO_FAMILY, ADDRINFO_SOCKTYPE, ADDRINFO_PROTOCOL; $ai[ADDRINFO_ADDR] = "" if !defined $ai[ADDRINFO_ADDR]; return @ai; } =item family => 'inet' Will pack an IP address and port number from keys called C and C. If C is missing it will be set to "0.0.0.0". If C is missing it will be set to 0. =cut sub _extract_addrinfo_inet { my $self = shift; my ( $ai ) = @_; my $port = delete $ai->{port} || 0; my $ip = delete $ai->{ip} || "0.0.0.0"; return pack_sockaddr_in( $port, inet_aton( $ip ) ); } =item family => 'inet6' Will pack an IP address and port number from keys called C and C. If C is missing it will be set to "::". If C is missing it will be set to 0. Optionally will also include values from C and C keys if provided. This will only work if a C function can be found in C =cut sub _extract_addrinfo_inet6 { my $self = shift; my ( $ai ) = @_; my $port = delete $ai->{port} || 0; my $ip = delete $ai->{ip} || "::"; my $scopeid = delete $ai->{scopeid} || 0; my $flowinfo = delete $ai->{flowinfo} || 0; if( HAVE_SOCKADDR_IN6 ) { return pack_sockaddr_in6( $port, inet_pton( AF_INET6, $ip ), $scopeid, $flowinfo ); } else { croak "Cannot pack_sockaddr_in6"; } } =item family => 'unix' Will pack a UNIX socket path from a key called C. =cut sub _extract_addrinfo_unix { my $self = shift; my ( $ai ) = @_; defined( my $path = delete $ai->{path} ) or croak "Expected 'path' for extract_addrinfo on family='unix'"; return pack_sockaddr_un( $path ); } =pod =back =cut =head2 make_addr_for_peer $connectaddr = IO::Async::OS->make_addr_for_peer( $family, $listenaddr ); Given the C and C of a listening socket. creates an address suitable to C to it. This method will handle specially any C address bound to C or any C address bound to C, as some OSes do not allow Cing to those and would instead insist on receiving C or C respectively. This method is used by the C<< ->connect( peer => $sock ) >> parameter of handle and loop connect methods. =cut sub make_addr_for_peer { shift; my ( $p_family, $p_addr ) = @_; if( $p_family == Socket::AF_INET ) { my @params = Socket::unpack_sockaddr_in $p_addr; $params[1] = Socket::INADDR_LOOPBACK if $params[1] eq Socket::INADDR_ANY; return Socket::pack_sockaddr_in @params; } if( HAVE_SOCKADDR_IN6 and $p_family == Socket::AF_INET6 ) { my @params = Socket::unpack_sockaddr_in6 $p_addr; $params[1] = Socket::IN6ADDR_LOOPBACK if $params[1] eq Socket::IN6ADDR_ANY; return Socket::pack_sockaddr_in6 @params; } # Most other cases should be fine return $p_addr; } =head1 LOOP IMPLEMENTATION METHODS The following methods are provided on C because they are likely to require OS-specific implementations, but are used by L to implement its functionality. It can use the HASH reference C<< $loop->{os} >> to store other data it requires. =cut =head2 loop_watch_signal =head2 loop_unwatch_signal IO::Async::OS->loop_watch_signal( $loop, $signal, $code ); IO::Async::OS->loop_unwatch_signal( $loop, $signal ); Used to implement the C / C Loop pair. =cut sub _setup_sigpipe { my $self = shift; my ( $loop ) = @_; require IO::Async::Handle; my ( $reader, $sigpipe ) = $self->pipepair or croak "Cannot pipe() - $!"; $_->blocking( 0 ) for $reader, $sigpipe; $loop->{os}{sigpipe} = $sigpipe; my $sigwatch = $loop->{os}{sigwatch}; $loop->add( $loop->{os}{sigpipe_reader} = IO::Async::Handle->new( notifier_name => "sigpipe", read_handle => $reader, on_read_ready => sub { sysread $reader, my $buffer, 8192 or return; foreach my $signum ( unpack "I*", $buffer ) { $sigwatch->{$signum}->() if $sigwatch->{$signum}; } }, ) ); return $sigpipe; } sub loop_watch_signal { my $self = shift; my ( $loop, $signal, $code ) = @_; exists $SIG{$signal} or croak "Unrecognised signal name $signal"; ref $code or croak 'Expected $code as a reference'; my $signum = $self->signame2num( $signal ); my $sigwatch = $loop->{os}{sigwatch} ||= {}; # {$num} = $code my $sigpipe = $loop->{os}{sigpipe} // $self->_setup_sigpipe( $loop ); my $signum_str = pack "I", $signum; $SIG{$signal} = sub { syswrite $sigpipe, $signum_str }; $sigwatch->{$signum} = $code; } sub loop_unwatch_signal { my $self = shift; my ( $loop, $signal ) = @_; my $signum = $self->signame2num( $signal ); my $sigwatch = $loop->{os}{sigwatch} or return; delete $sigwatch->{$signum}; undef $SIG{$signal}; } =head2 potentially_open_fds @fds = IO::Async::OS->potentially_open_fds; Returns a list of filedescriptors which might need closing. By default this will return C<0 .. _SC_OPEN_MAX>. OS-specific subclasses may have a better guess. =cut sub potentially_open_fds { return 0 .. OPEN_MAX_FD; } sub post_fork { my $self = shift; my ( $loop ) = @_; if( $loop->{os}{sigpipe} ) { $loop->remove( $loop->{os}{sigpipe_reader} ); undef $loop->{os}{sigpipe}; my $sigwatch = $loop->{os}{sigwatch}; foreach my $signal ( keys %SIG ) { my $signum = $self->signame2num( $signal ) or next; my $code = $sigwatch->{$signum} or next; $self->loop_watch_signal( $loop, $signal, $code ); } } } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/PID.pm000444001750001750 717315001742754 15106 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2024 -- leonerd@leonerd.org.uk package IO::Async::PID 0.804; use v5.14; use warnings; use base qw( IO::Async::Notifier ); use Carp; =head1 NAME C - event callback on exit of a child process =head1 SYNOPSIS use IO::Async::PID; use POSIX qw( WEXITSTATUS ); use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $kid = $loop->fork( code => sub { print "Child sleeping..\n"; sleep 10; print "Child exiting\n"; return 20; }, ); print "Child process $kid started\n"; my $pid = IO::Async::PID->new( pid => $kid, on_exit => sub { my ( $self, $exitcode ) = @_; printf "Child process %d exited with status %d\n", $self->pid, WEXITSTATUS($exitcode); }, ); $loop->add( $pid ); $loop->run; =head1 DESCRIPTION This subclass of L invokes its callback when a process exits. For most use cases, a L object provides more control of setting up the process, connecting filehandles to it, sending data to and receiving data from it. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_exit $exitcode Invoked when the watched process exits. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 pid => INT The process ID to watch. Must be given before the object has been added to the containing L object. =head2 on_exit => CODE CODE reference for the C event. Once the C continuation has been invoked, the C object is removed from the containing L object. =cut sub configure { my $self = shift; my %params = @_; if( exists $params{pid} ) { $self->loop and croak "Cannot configure 'pid' after adding to Loop"; $self->{pid} = delete $params{pid}; } if( exists $params{on_exit} ) { $self->{on_exit} = delete $params{on_exit}; undef $self->{cb}; if( my $loop = $self->loop ) { $self->_remove_from_loop( $loop ); $self->_add_to_loop( $loop ); } } $self->SUPER::configure( %params ); } sub _add_to_loop { my $self = shift; my ( $loop ) = @_; $self->pid or croak "Require a 'pid' in $self"; $self->SUPER::_add_to_loop( @_ ); # on_exit continuation gets passed PID value; need to replace that with # $self $self->{cb} ||= $self->_replace_weakself( sub { my $self = shift or return; my ( $exitcode ) = @_; $self->invoke_event( on_exit => $exitcode ); # Since this is a oneshot, we'll have to remove it from the loop or # parent Notifier $self->remove_from_parent; } ); $loop->watch_process( $self->pid, $self->{cb} ); } sub _remove_from_loop { my $self = shift; my ( $loop ) = @_; $loop->unwatch_process( $self->pid ); } sub notifier_name { my $self = shift; if( length( my $name = $self->SUPER::notifier_name ) ) { return $name; } return $self->{pid}; } =head1 METHODS =cut =head2 pid $process_id = $pid->pid; Returns the underlying process ID =cut sub pid { my $self = shift; return $self->{pid}; } =head2 kill $pid->kill( $signal ); Sends a signal to the process =cut sub kill { my $self = shift; my ( $signal ) = @_; kill $signal, $self->pid or croak "Cannot kill() - $!"; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Process.pm000444001750001750 6304315001742754 16126 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2024 -- leonerd@leonerd.org.uk package IO::Async::Process 0.804; use v5.14; use warnings; use base qw( IO::Async::Notifier ); use Carp; use Socket qw( SOCK_STREAM ); use Future; use IO::Async::OS; =head1 NAME C - start and manage a child process =head1 SYNOPSIS use IO::Async::Process; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $process = IO::Async::Process->new( command => [ "tr", "a-z", "n-za-m" ], stdin => { from => "hello world\n", }, stdout => { on_read => sub { my ( $stream, $buffref ) = @_; while( $$buffref =~ s/^(.*)\n// ) { print "Rot13 of 'hello world' is '$1'\n"; } return 0; }, }, on_finish => sub { $loop->stop; }, ); $loop->add( $process ); $loop->run; Also accessible via the L method: $loop->open_process( command => [ "/bin/ping", "-c4", "some.host" ], stdout => { on_read => sub { my ( $stream, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*)\n// ) { print "PING wrote: $1\n"; } return 0; }, }, on_finish => sub { my $process = shift; my ( $exitcode ) = @_; my $status = ( $exitcode >> 8 ); ... }, ); =head1 DESCRIPTION This subclass of L starts a child process, and invokes a callback when it exits. The child process can either execute a given block of code (via C), or a command. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_finish $exitcode Invoked after the process has exited by normal means (i.e. an C syscall from a process, or Cing from the code block), and has closed all its file descriptors. =head2 on_exception $exception, $errno, $exitcode Invoked when the process exits by an exception from C, or by failing to C the given command. C<$errno> will be a dualvar, containing both number and string values. After a successful C call, this condition can no longer happen. Note that this has a different name and a different argument order from C<< Loop->open_process >>'s C. If this is not provided and the process exits with an exception, then C is invoked instead, being passed just the exit code. Since this is just the results of the underlying C<< $loop->spawn_child >> C handler in a different order it is possible that the C<$exception> field will be an empty string. It will however always be defined. This can be used to distinguish the two cases: on_exception => sub { my $self = shift; my ( $exception, $errno, $exitcode ) = @_; if( length $exception ) { print STDERR "The process died with the exception $exception " . "(errno was $errno)\n"; } elsif( ( my $status = W_EXITSTATUS($exitcode) ) == 255 ) { print STDERR "The process failed to exec() - $errno\n"; } else { print STDERR "The process exited with exit status $status\n"; } } =cut =head1 CONSTRUCTOR =cut =head2 new $process = IO::Async::Process->new( %args ); Constructs a new C object and returns it. Once constructed, the C will need to be added to the C before the child process is started. =cut sub _init { my $self = shift; $self->SUPER::_init( @_ ); $self->{to_close} = {}; $self->{finish_futures} = []; } =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 on_finish => CODE =head2 on_exception => CODE CODE reference for the event handlers. Once the C continuation has been invoked, the C object is removed from the containing L object. The following parameters may be passed to C, or to C before the process has been started (i.e. before it has been added to the C). Once the process is running these cannot be changed. =head2 command => ARRAY or STRING Either a reference to an array containing the command and its arguments, or a plain string containing the command. This value is passed into perl's C function. =head2 code => CODE A block of code to execute in the child process. It will be called in scalar context inside an C block. =head2 setup => ARRAY Optional reference to an array to pass to the underlying C C method. =head2 fdI => HASH A hash describing how to set up file descriptor I. The hash may contain the following keys: =over 4 =item via => STRING Configures how this file descriptor will be configured for the child process. Must be given one of the following mode names: =over 4 =item pipe_read The child will be given the writing end of a C; the parent may read from the other. =item pipe_write The child will be given the reading end of a C; the parent may write to the other. Since an EOF condition of this kind of handle cannot reliably be detected, C will not wait for this type of pipe to be closed. =item pipe_rdwr Only valid on the C filehandle. The child will be given the reading end of one C on STDIN and the writing end of another on STDOUT. A single Stream object will be created in the parent configured for both filehandles. =item socketpair The child will be given one end of a C; the parent will be given the other. The family of this socket may be given by the extra key called C; defaulting to C. The socktype of this socket may be given by the extra key called C; defaulting to C. If the type is not C then a L object will be constructed for the parent side of the handle, rather than L. =back Once the filehandle is set up, the C method (or its shortcuts of C, C or C) may be used to access the L-subclassed object wrapped around it. The value of this argument is implied by any of the following alternatives. =item on_read => CODE The child will be given the writing end of a pipe. The reading end will be wrapped by an L using this C callback function. =item into => SCALAR The child will be given the writing end of a pipe. The referenced scalar will be filled by data read from the child process. This data may not be available until the pipe has been closed by the child. =item from => STRING The child will be given the reading end of a pipe. The string given by the C parameter will be written to the child. When all of the data has been written the pipe will be closed. =item prefork => CODE Only valid for handles with a C of C. The code block runs after the C is created, but before the child is forked. This is handy for when you adjust both ends of the created socket (for example, to use C) from the controlling parent, before the child code runs. The arguments passed in are the L objects for the parent and child ends of the socket. $prefork->( $localfd, $childfd ); =back =head2 stdin => ... =head2 stdout => ... =head2 stderr => ... Shortcuts for C, C and C respectively. =head2 stdio => ... Special filehandle to affect STDIN and STDOUT at the same time. This filehandle supports being configured for both reading and writing at the same time. =cut sub configure { my $self = shift; my %params = @_; foreach (qw( on_finish on_exception )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } # All these parameters can only be configured while the process isn't # running my %setup_params; foreach (qw( code command setup stdin stdout stderr stdio ), grep { m/^fd\d+$/ } keys %params ) { $setup_params{$_} = delete $params{$_} if exists $params{$_}; } if( $self->is_running ) { keys %setup_params and croak "Cannot configure a running Process with " . join ", ", keys %setup_params; } defined( exists $setup_params{code} ? $setup_params{code} : $self->{code} ) + defined( exists $setup_params{command} ? $setup_params{command} : $self->{command} ) <= 1 or croak "Cannot have both 'code' and 'command'"; foreach (qw( code command setup )) { $self->{$_} = delete $setup_params{$_} if exists $setup_params{$_}; } $self->configure_fd( 0, %{ delete $setup_params{stdin} } ) if $setup_params{stdin}; $self->configure_fd( 1, %{ delete $setup_params{stdout} } ) if $setup_params{stdout}; $self->configure_fd( 2, %{ delete $setup_params{stderr} } ) if $setup_params{stderr}; $self->configure_fd( 'io', %{ delete $setup_params{stdio} } ) if $setup_params{stdio}; # All the rest are fd\d+ foreach ( keys %setup_params ) { my ( $fd ) = m/^fd(\d+)$/ or croak "Expected 'fd\\d+'"; $self->configure_fd( $fd, %{ $setup_params{$_} } ); } $self->SUPER::configure( %params ); } # These are from the perspective of the parent use constant FD_VIA_PIPEREAD => 1; use constant FD_VIA_PIPEWRITE => 2; use constant FD_VIA_PIPERDWR => 3; # Only valid for stdio pseudo-fd use constant FD_VIA_SOCKETPAIR => 4; my %via_names = ( pipe_read => FD_VIA_PIPEREAD, pipe_write => FD_VIA_PIPEWRITE, pipe_rdwr => FD_VIA_PIPERDWR, socketpair => FD_VIA_SOCKETPAIR, ); sub configure_fd { my $self = shift; my ( $fd, %args ) = @_; $self->is_running and croak "Cannot configure fd $fd in a running Process"; if( $fd eq "io" ) { exists $self->{fd_opts}{$_} and croak "Cannot configure stdio since fd$_ is already defined" for 0 .. 1; } elsif( $fd == 0 or $fd == 1 ) { exists $self->{fd_opts}{io} and croak "Cannot configure fd$fd since stdio is already defined"; } my $opts = $self->{fd_opts}{$fd} ||= {}; my $via = $opts->{via}; my ( $wants_read, $wants_write ); if( my $via_name = delete $args{via} ) { defined $via and croak "Cannot change the 'via' mode of fd$fd now that it is already configured"; $via = $via_names{$via_name} or croak "Unrecognised 'via' name of '$via_name'"; } if( my $on_read = delete $args{on_read} ) { $opts->{handle}{on_read} = $on_read; $wants_read++; } elsif( my $into = delete $args{into} ) { $opts->{handle}{on_read} = sub { my ( undef, $buffref, $eof ) = @_; $$into .= $$buffref if $eof; return 0; }; $wants_read++; } if( defined( my $from = delete $args{from} ) ) { $opts->{from} = $from; $wants_write++; } if( defined $via and $via == FD_VIA_SOCKETPAIR ) { $self->{fd_opts}{$fd}{$_} = delete $args{$_} for qw( family socktype prefork ); } keys %args and croak "Unexpected extra keys for fd $fd - " . join ", ", keys %args; if( !defined $via ) { $via = FD_VIA_PIPEREAD if $wants_read and !$wants_write; $via = FD_VIA_PIPEWRITE if !$wants_read and $wants_write; $via = FD_VIA_PIPERDWR if $wants_read and $wants_write; } elsif( $via == FD_VIA_PIPEREAD ) { $wants_write and $via = FD_VIA_PIPERDWR; } elsif( $via == FD_VIA_PIPEWRITE ) { $wants_read and $via = FD_VIA_PIPERDWR; } elsif( $via == FD_VIA_PIPERDWR or $via == FD_VIA_SOCKETPAIR ) { # Fine } else { die "Need to check fd_via{$fd}\n"; } $via == FD_VIA_PIPERDWR and $fd ne "io" and croak "Cannot both read and write simultaneously on fd$fd"; defined $via and $opts->{via} = $via; } sub _prepare_fds { my $self = shift; my ( $loop ) = @_; my $fd_handle = $self->{fd_handle}; my $fd_opts = $self->{fd_opts}; my $finish_futures = $self->{finish_futures}; my @setup; foreach my $fd ( keys %$fd_opts ) { my $opts = $fd_opts->{$fd}; my $via = $opts->{via}; my $handle = $self->fd( $fd ); my $key = $fd eq "io" ? "stdio" : "fd$fd"; my $write_only; if( $via == FD_VIA_PIPEREAD ) { my ( $myfd, $childfd ) = IO::Async::OS->pipepair or croak "Unable to pipe() - $!"; $myfd->blocking( 0 ); $handle->configure( read_handle => $myfd ); push @setup, $key => [ dup => $childfd ]; $self->{to_close}{$childfd->fileno} = $childfd; } elsif( $via == FD_VIA_PIPEWRITE ) { my ( $childfd, $myfd ) = IO::Async::OS->pipepair or croak "Unable to pipe() - $!"; $myfd->blocking( 0 ); $write_only++; $handle->configure( write_handle => $myfd ); push @setup, $key => [ dup => $childfd ]; $self->{to_close}{$childfd->fileno} = $childfd; } elsif( $via == FD_VIA_PIPERDWR ) { $key eq "stdio" or croak "Oops - should only be FD_VIA_PIPERDWR on stdio"; # Can't use pipequad here for now because we need separate FDs so we # can ->close them properly my ( $myread, $childwrite ) = IO::Async::OS->pipepair or croak "Unable to pipe() - $!"; my ( $childread, $mywrite ) = IO::Async::OS->pipepair or croak "Unable to pipe() - $!"; $_->blocking( 0 ) for $myread, $mywrite; $handle->configure( read_handle => $myread, write_handle => $mywrite ); push @setup, stdin => [ dup => $childread ], stdout => [ dup => $childwrite ]; $self->{to_close}{$childread->fileno} = $childread; $self->{to_close}{$childwrite->fileno} = $childwrite; } elsif( $via == FD_VIA_SOCKETPAIR ) { my ( $myfd, $childfd ) = IO::Async::OS->socketpair( $opts->{family}, $opts->{socktype} ) or croak "Unable to socketpair() - $!"; $myfd->blocking( 0 ); $opts->{prefork}->( $myfd, $childfd ) if $opts->{prefork}; $handle->configure( handle => $myfd ); if( $key eq "stdio" ) { push @setup, stdin => [ dup => $childfd ], stdout => [ dup => $childfd ]; } else { push @setup, $key => [ dup => $childfd ]; } $self->{to_close}{$childfd->fileno} = $childfd; } else { croak "Unsure what to do with fd_via==$via"; } $self->add_child( $handle ); unless( $write_only ) { push @$finish_futures, $handle->new_close_future; } } return @setup; } sub _add_to_loop { my $self = shift; my ( $loop ) = @_; $self->{code} or $self->{command} or croak "Require either 'code' or 'command' in $self"; $self->can_event( "on_finish" ) or croak "Expected either an on_finish callback or to be able to ->on_finish"; my @setup; push @setup, @{ $self->{setup} } if $self->{setup}; push @setup, $self->_prepare_fds( $loop ); my $finish_futures = delete $self->{finish_futures}; my ( $exitcode, $dollarbang, $dollarat ); push @$finish_futures, my $exit_future = $loop->new_future; $self->{pid} = $loop->spawn_child( code => $self->{code}, command => $self->{command}, setup => \@setup, on_exit => $self->_capture_weakself( sub { ( my $self, undef, $exitcode, $dollarbang, $dollarat ) = @_; $self->debug_printf( "EXIT status=0x%04x", $exitcode ) if $self; $exit_future->done unless $exit_future->is_cancelled; } ), ); $self->{running} = 1; $self->SUPER::_add_to_loop( @_ ); $_->close for values %{ delete $self->{to_close} }; my $is_code = defined $self->{code}; my $f = $self->finish_future; $self->{_finish_future} = Future->needs_all( @$finish_futures ) ->on_done( $self->_capture_weakself( sub { my $self = shift or return; $self->debug_printf( "FINISH status=0x%04x%s", $exitcode, join " ", '', ( $dollarbang ? '$!' : '' ), ( $dollarat ? '$@' : '' ) ); $self->{exitcode} = $exitcode; $self->{dollarbang} = $dollarbang; $self->{dollarat} = $dollarat; undef $self->{running}; if( $is_code ? $dollarat eq "" : $dollarbang == 0 ) { $self->invoke_event( on_finish => $exitcode ); } else { $self->maybe_invoke_event( on_exception => $dollarat, $dollarbang, $exitcode ) or # Don't have a way to report dollarbang/dollarat $self->invoke_event( on_finish => $exitcode ); } $f->done( $exitcode ); $self->remove_from_parent; } ), ); } sub DESTROY { my $self = shift; $self->{_finish_future}->cancel if $self->{_finish_future}; } sub notifier_name { my $self = shift; if( length( my $name = $self->SUPER::notifier_name ) ) { return $name; } return "nopid" unless my $pid = $self->pid; return "[$pid]" unless $self->is_running; return "$pid"; } =head1 METHODS =cut =head2 finish_future $f = $process->finish_future; I Returns a L that completes when the process finishes. It will yield the exit code from the process. =cut sub finish_future { my $self = shift; return $self->{finish_future} //= $self->loop->new_future; } =head2 pid $pid = $process->pid; Returns the process ID of the process, if it has been started, or C if not. Its value is preserved after the process exits, so it may be inspected during the C or C events. =cut sub pid { my $self = shift; return $self->{pid}; } =head2 kill $process->kill( $signal ); Sends a signal to the process =cut sub kill { my $self = shift; my ( $signal ) = @_; kill $signal, $self->pid or croak "Cannot kill() - $!"; } =head2 is_running $running = $process->is_running; Returns true if the Process has been started, and has not yet finished. =cut sub is_running { my $self = shift; return $self->{running}; } =head2 is_exited $exited = $process->is_exited; Returns true if the Process has finished running, and finished due to normal C. =cut sub is_exited { my $self = shift; return defined $self->{exitcode} ? ( $self->{exitcode} & 0x7f ) == 0 : undef; } =head2 exitstatus $status = $process->exitstatus; If the process exited due to normal C, returns the value that was passed to C. Otherwise, returns C. =cut sub exitstatus { my $self = shift; return defined $self->{exitcode} ? ( $self->{exitcode} >> 8 ) : undef; } =head2 exception $exception = $process->exception; If the process exited due to an exception, returns the exception that was thrown. Otherwise, returns C. =cut sub exception { my $self = shift; return $self->{dollarat}; } =head2 errno $errno = $process->errno; If the process exited due to an exception, returns the numerical value of C<$!> at the time the exception was thrown. Otherwise, returns C. =cut sub errno { my $self = shift; return $self->{dollarbang}+0; } =head2 errstr $errstr = $process->errstr; If the process exited due to an exception, returns the string value of C<$!> at the time the exception was thrown. Otherwise, returns C. =cut sub errstr { my $self = shift; return $self->{dollarbang}.""; } =head2 fd $stream = $process->fd( $fd ); Returns the L or L associated with the given FD number. This must have been set up by a C argument prior to adding the C object to the C. The returned object have its read or write handle set to the other end of a pipe or socket connected to that FD number in the child process. Typically, this will be used to call the C method on, to write more data into the child, or to set an C handler to read data out of the child. The C event for these streams must not be changed, or it will break the close detection used by the C object and the C event will not be invoked. =cut sub fd { my $self = shift; my ( $fd ) = @_; return $self->{fd_handle}{$fd} ||= do { my $opts = $self->{fd_opts}{$fd} or croak "$self does not have an fd Stream for $fd"; my $handle_class; if( defined $opts->{socktype} && IO::Async::OS->getsocktypebyname( $opts->{socktype} ) != SOCK_STREAM ) { require IO::Async::Socket; $handle_class = "IO::Async::Socket"; } else { require IO::Async::Stream; $handle_class = "IO::Async::Stream"; } my $handle = $handle_class->new( notifier_name => $fd eq "0" ? "stdin" : $fd eq "1" ? "stdout" : $fd eq "2" ? "stderr" : $fd eq "io" ? "stdio" : "fd$fd", %{ $opts->{handle} }, ); if( defined $opts->{from} ) { $handle->write( $opts->{from}, on_flush => sub { my ( $handle ) = @_; $handle->close_write; }, ); } $handle }; } =head2 stdin =head2 stdout =head2 stderr =head2 stdio $stream = $process->stdin; $stream = $process->stdout; $stream = $process->stderr; $stream = $process->stdio; Shortcuts for calling C with 0, 1, 2 or C respectively, to obtain the L representing the standard input, output, error, or combined input/output streams of the child process. =cut sub stdin { shift->fd( 0 ) } sub stdout { shift->fd( 1 ) } sub stderr { shift->fd( 2 ) } sub stdio { shift->fd( 'io' ) } =head1 EXAMPLES =head2 Capturing the STDOUT stream of a process By configuring the C filehandle of the process using the C key, data written by the process can be captured. my $stdout; my $process = IO::Async::Process->new( command => [ "writing-program", "arguments" ], stdout => { into => \$stdout }, on_finish => sub { my $process = shift; my ( $exitcode ) = @_; print "Process has exited with code $exitcode, and wrote:\n"; print $stdout; } ); $loop->add( $process ); Note that until C is invoked, no guarantees are made about how much of the data actually written by the process is yet in the C<$stdout> scalar. See also the C method of L. To handle data more interactively as it arrives, the C key can instead be used, to provide a callback function to invoke whenever more data is available from the process. my $process = IO::Async::Process->new( command => [ "writing-program", "arguments" ], stdout => { on_read => sub { my ( $stream, $buffref ) = @_; while( $$buffref =~ s/^(.*)\n// ) { print "The process wrote a line: $1\n"; } return 0; }, }, on_finish => sub { print "The process has finished\n"; } ); $loop->add( $process ); If the code to handle data read from the process isn't available yet when the object is constructed, it can be supplied later by using the C method on the C filestream at some point before it gets added to the Loop. In this case, C should be configured using C in the C key. my $process = IO::Async::Process->new( command => [ "writing-program", "arguments" ], stdout => { via => "pipe_read" }, on_finish => sub { print "The process has finished\n"; } ); $process->stdout->configure( on_read => sub { my ( $stream, $buffref ) = @_; while( $$buffref =~ s/^(.*)\n// ) { print "The process wrote a line: $1\n"; } return 0; }, ); $loop->add( $process ); =head2 Sending data to STDIN of a process By configuring the C filehandle of the process using the C key, data can be written into the C stream of the process. my $process = IO::Async::Process->new( command => [ "reading-program", "arguments" ], stdin => { from => "Here is the data to send\n" }, on_finish => sub { print "The process has finished\n"; } ); $loop->add( $process ); The data in this scalar will be written until it is all consumed, then the handle will be closed. This may be useful if the program waits for EOF on C before it exits. To have the ability to write more data into the process once it has started. the C method on the C stream can be used, when it is configured using the C value for C: my $process = IO::Async::Process->new( command => [ "reading-program", "arguments" ], stdin => { via => "pipe_write" }, on_finish => sub { print "The process has finished\n"; } ); $loop->add( $process ); $process->stdin->write( "Here is some more data\n" ); =head2 Setting socket options By using the C code block you can change the socket receive buffer size at both ends of the socket before the child is forked (at which point it would be too late for the parent to be able to change the child end of the socket). use Socket qw( SOL_SOCKET SO_RCVBUF ); my $process = IO::Async::Process->new( command => [ "command-to-read-from-and-write-to", "arguments" ], stdio => { via => "socketpair", prefork => sub { my ( $parentfd, $childfd ) = @_; # Set parent end of socket receive buffer to 3 MB $parentfd->setsockopt(SOL_SOCKET, SO_RCVBUF, 3 * 1024 * 1024); # Set child end of socket receive buffer to 3 MB $childfd ->setsockopt(SOL_SOCKET, SO_RCVBUF, 3 * 1024 * 1024); }, }, ); $loop->add( $process ); =cut =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Protocol.pm000444001750001750 1326615001742754 16313 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2024 -- leonerd@leonerd.org.uk package IO::Async::Protocol 0.804; use v5.14; use warnings; use base qw( IO::Async::Notifier ); use Carp; =head1 NAME C - base class for transport-based protocols =head1 DESCRIPTION This subclass of L provides storage for a L object, to act as a transport for some protocol. It contains an instance of the transport object, which it adds as a child notifier, allowing a level of independence from the actual transport being used. For example, a stream may actually be an L to allow the protocol to be used over SSL. This class is not intended to be used directly, instead, see one of the subclasses =over 4 =item L - base class for stream-based protocols =back =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_closed Optional. Invoked when the transport handle becomes closed. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 transport => IO::Async::Handle The L to delegate communications to. =head2 on_closed => CODE CODE reference for the C event. When a new C object is given, it will be configured by calling the C method, then added as a child notifier. If a different transport object was already configured, this will first be removed and deconfigured using the C. =cut sub configure { my $self = shift; my %params = @_; for (qw( on_closed )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } if( exists $params{transport} ) { my $transport = delete $params{transport}; if( $self->{transport} ) { $self->remove_child( $self->transport ); $self->teardown_transport( $self->transport ); } $self->{transport} = $transport; if( $transport ) { $self->setup_transport( $self->transport ); $self->add_child( $self->transport ); } } $self->SUPER::configure( %params ); } =head1 METHODS =cut =head2 transport $transport = $protocol->transport; Returns the stored transport object =cut sub transport { my $self = shift; return $self->{transport}; } =head2 connect $protocol->connect( %args ); Sets up a connection to a peer, and configures the underlying C for the Protocol. Takes the following named arguments: =over 8 =item socktype => STRING or INT Required. Identifies the socket type, and the type of continuation that will be used. If this value is C<"stream"> or C then C continuation will be used; otherwise C will be used. =item on_connected => CODE Optional. If supplied, will be invoked once the connection has been established. $on_connected->( $protocol ); =item transport => IO::Async::Handle Optional. If this is provided, it will immediately be configured as the transport (by calling C), and the C callback will be invoked. This is provided as a convenient shortcut. =back Other arguments will be passed to the underlying L C call. =cut sub connect { my $self = shift; my %args = @_; my $on_connected = delete $args{on_connected}; if( my $transport = $args{transport} ) { $self->configure( transport => $transport ); $on_connected->( $self ) if $on_connected; return; } my $socktype = $args{socktype} or croak "Expected socktype"; my $on_transport = do { no warnings 'numeric'; $socktype eq "stream" || $socktype == Socket::SOCK_STREAM() } ? "on_stream" : "on_socket"; my $loop = $self->loop or croak "Cannot ->connect a ".ref($self)." that is not in a Loop"; $loop->connect( %args, socktype => "stream", $on_transport => sub { my ( $transport ) = @_; $self->configure( transport => $transport ); $on_connected->( $self ) if $on_connected; }, ); } =head1 TRANSPORT DELEGATION The following methods are delegated to the transport object close =cut sub close { shift->transport->close } =head1 SUBCLASS METHODS C is a base class provided so that specific subclasses of it provide more specific behaviour. The base class provides a number of methods that subclasses may wish to override. If a subclass implements any of these, be sure to invoke the superclass method at some point within the code. =cut =head2 setup_transport $protocol->setup_transport( $transport ); Called by C when a new C object is given, this method should perform whatever setup is required to wire the new transport object into the protocol object; typically by setting up event handlers. =cut sub setup_transport { my $self = shift; my ( $transport ) = @_; $transport->configure( on_closed => $self->_capture_weakself( sub { my $self = shift or return; my ( $transport ) = @_; $self->maybe_invoke_event( on_closed => ); $self->configure( transport => undef ); } ), ); } =head2 teardown_transport $protocol->teardown_transport( $transport ); The reverse of C; called by C when a previously set-up transport object is about to be replaced. =cut sub teardown_transport { my $self = shift; my ( $transport ) = @_; $transport->configure( on_closed => undef, ); } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Resolver.pm000444001750001750 5226215001742754 16312 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2007-2024 -- leonerd@leonerd.org.uk package IO::Async::Resolver 0.804; use v5.14; use warnings; use base qw( IO::Async::Function ); # Socket 2.006 fails to getaddrinfo() AI_NUMERICHOST properly on MSWin32 use Socket 2.007 qw( AI_NUMERICHOST AI_PASSIVE NI_NUMERICHOST NI_NUMERICSERV NI_DGRAM EAI_NONAME ); use IO::Async::Metrics '$METRICS'; use IO::Async::OS; # Try to use HiRes alarm, but we don't strictly need it. # MSWin32 doesn't implement it BEGIN { require Time::HiRes; eval { Time::HiRes::alarm(0) } and Time::HiRes->import( qw( alarm ) ); } use Carp; my $started = 0; my %METHODS; =head1 NAME C - performing name resolutions asynchronously =head1 SYNOPSIS This object is used indirectly via an L: use Future::AsyncAwait; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my @results = await $loop->resolver->getaddrinfo( host => "www.example.com", service => "http", ); foreach my $addr ( @results ) { printf "http://www.example.com can be reached at " . "socket(%d,%d,%d) + connect('%v02x')\n", @{$addr}{qw( family socktype protocol addr )}; } my @pwent = await $loop->resolve( type => 'getpwuid', data => [ $< ] ); print "My passwd ent: " . join( "|", @pwent ) . "\n"; =head1 DESCRIPTION This module extends an L to use the system's name resolver functions asynchronously. It provides a number of named resolvers, each one providing an asynchronous wrapper around a single resolver function. Because the system may not provide asynchronous versions of its resolver functions, this class is implemented using a L object that wraps the normal (blocking) functions. In this case, name resolutions will be performed asynchronously from the rest of the program, but will likely be done by a single background worker process, so will be processed in the order they were requested; a single slow lookup will hold up the queue of other requests behind it. To mitigate this, multiple worker processes can be used; see the C argument to the constructor. The C parameter for the underlying L object is set to a default of 30 seconds, and C is set to 0. This ensures that there are no spare processes sitting idle during the common case of no outstanding requests. =cut sub _init { my $self = shift; my ( $params ) = @_; $self->SUPER::_init( @_ ); $params->{module} = __PACKAGE__; $params->{func} = "_resolve"; $params->{idle_timeout} = 30; $params->{min_workers} = 0; $started = 1; } sub _resolve { my ( $type, $timeout, @data ) = @_; if( my $code = $METHODS{$type} ) { local $SIG{ALRM} = sub { die "Timed out\n" }; alarm( $timeout ); my @ret = eval { $code->( @data ) }; alarm( 0 ); die $@ if $@; return @ret; } else { die "Unrecognised resolver request '$type'"; } } sub debug_printf_call { my $self = shift; my ( $type, undef, @data ) = @_; my $arg0; if( $type eq "getaddrinfo" ) { my %args = @data; $arg0 = sprintf "%s:%s", @args{qw( host service )}; } elsif( $type eq "getnameinfo" ) { # cheat $arg0 = sprintf "%s:%s", ( Socket::getnameinfo( $data[0], NI_NUMERICHOST|NI_NUMERICSERV ) )[1,2]; } else { $arg0 = $data[0]; } $self->debug_printf( "CALL $type $arg0" ); } sub debug_printf_result { my $self = shift; my ( @result ) = @_; $self->debug_printf( "RESULT n=" . scalar @result ); } =head1 METHODS The following methods documented in C expressions return L instances. =cut =head2 resolve @result = await $loop->resolve( %params ); Performs a single name resolution operation, as given by the keys in the hash. The C<%params> hash keys the following keys: =over 8 =item type => STRING Name of the resolution operation to perform. See BUILT-IN RESOLVERS for the list of available operations. =item data => ARRAY Arguments to pass to the resolver function. Exact meaning depends on the specific function chosen by the C; see BUILT-IN RESOLVERS. =item timeout => NUMBER Optional. Timeout in seconds, after which the resolver operation will abort with a timeout exception. If not supplied, a default of 10 seconds will apply. =back On failure, the fail category name is C; the details give the individual resolver function name (e.g. C), followed by other error details specific to the resolver in question. ->fail( $message, resolve => $type => @details ) =head2 resolve (void) $resolver->resolve( %params ); When not returning a future, additional parameters can be given containing the continuations to invoke on success or failure: =over 8 =item on_resolved => CODE A continuation that is invoked when the resolver function returns a successful result. It will be passed the array returned by the resolver function. $on_resolved->( @result ) =item on_error => CODE A continuation that is invoked when the resolver function fails. It will be passed the exception thrown by the function. =back =cut sub resolve { my $self = shift; my %args = @_; my $type = $args{type}; defined $type or croak "Expected 'type'"; if( $type eq "getaddrinfo_hash" ) { $type = "getaddrinfo"; } exists $METHODS{$type} or croak "Expected 'type' to be an existing resolver method, got '$type'"; my $on_resolved; if( $on_resolved = $args{on_resolved} ) { ref $on_resolved or croak "Expected 'on_resolved' to be a reference"; } elsif( !defined wantarray ) { croak "Expected 'on_resolved' or to return a Future"; } my $on_error; if( $on_error = $args{on_error} ) { ref $on_error or croak "Expected 'on_error' to be a reference"; } elsif( !defined wantarray ) { croak "Expected 'on_error' or to return a Future"; } my $timeout = $args{timeout} || 10; $METRICS and $METRICS->inc_counter( resolver_lookups => [ type => $type ] ); my $future = $self->call( args => [ $type, $timeout, @{$args{data}} ], )->else( sub { my ( $message, @detail ) = @_; $METRICS and $METRICS->inc_counter( resolver_failures => [ type => $type ] ); Future->fail( $message, resolve => $type => @detail ); }); $future->on_done( $on_resolved ) if $on_resolved; $future->on_fail( $on_error ) if $on_error; return $future if defined wantarray; # Caller is not going to keep hold of the Future, so we have to ensure it # stays alive somehow $self->adopt_future( $future->else( sub { Future->done } ) ); } =head2 getaddrinfo @addrs = await $resolver->getaddrinfo( %args ); A shortcut wrapper around the C resolver, taking its arguments in a more convenient form. =over 8 =item host => STRING =item service => STRING The host and service names to look up. At least one must be provided. =item family => INT or STRING =item socktype => INT or STRING =item protocol => INT Hint values used to filter the results. =item flags => INT Flags to control the C function. See the C constants in L's C function for more detail. =item passive => BOOL If true, sets the C flag. This is provided as a convenience to avoid the caller from having to import the C constant from C. =item timeout => NUMBER Time in seconds after which to abort the lookup with a C exception =back On success, the future will yield the result as a list of HASH references; each containing one result. Each result will contain fields called C, C, C and C. If requested by C then the C field will also be present. On failure, the detail field will give the error number, which should match one of the C constants. ->fail( $message, resolve => getaddrinfo => $eai_errno ) As a specific optimisation, this method will try to perform a lookup of numeric values synchronously, rather than asynchronously, if it looks likely to succeed. Specifically, if the service name is entirely numeric, and the hostname looks like an IPv4 or IPv6 string, a synchronous lookup will first be performed using the C flag. If this gives an C error, then the lookup is performed asynchronously instead. =head2 getaddrinfo (void) $resolver->getaddrinfo( %args ); When not returning a future, additional parameters can be given containing the continuations to invoke on success or failure: =over 8 =item on_resolved => CODE Callback which is invoked after a successful lookup. $on_resolved->( @addrs ); =item on_error => CODE Callback which is invoked after a failed lookup, including for a timeout. $on_error->( $exception ); =back =cut sub getaddrinfo { my $self = shift; my %args = @_; $args{on_resolved} or defined wantarray or croak "Expected 'on_resolved' or to return a Future"; $args{on_error} or defined wantarray or croak "Expected 'on_error' or to return a Future"; my $host = $args{host} || ""; my $service = $args{service} // ""; my $flags = $args{flags} || 0; $flags |= AI_PASSIVE if $args{passive}; $args{family} = IO::Async::OS->getfamilybyname( $args{family} ) if defined $args{family}; $args{socktype} = IO::Async::OS->getsocktypebyname( $args{socktype} ) if defined $args{socktype}; # Clear any other existing but undefined hints defined $args{$_} or delete $args{$_} for keys %args; # It's likely this will succeed with AI_NUMERICHOST if host contains only # [\d.] (IPv4) or [[:xdigit:]:] (IPv6) # Technically we should pass AI_NUMERICSERV but not all platforms support # it, but since we're checking service contains only \d we should be fine. # These address tests don't have to be perfect as if it fails we'll get # EAI_NONAME and just try it asynchronously anyway if( ( $host =~ m/^[\d.]+$/ or $host =~ m/^[[:xdigit:]:]$/ or $host eq "" ) and $service =~ m/^\d*$/ ) { my ( $err, @results ) = Socket::getaddrinfo( $host, $service, { %args, flags => $flags | AI_NUMERICHOST } ); if( !$err ) { my $future = $self->loop->new_future->done( @results ); $future->on_done( $args{on_resolved} ) if $args{on_resolved}; return $future; } elsif( $err == EAI_NONAME ) { # fallthrough to async case } else { my $future = $self->loop->new_future->fail( $err, resolve => getaddrinfo => $err+0 ); $future->on_fail( $args{on_error} ) if $args{on_error}; return $future; } } my $future = $self->resolve( type => "getaddrinfo", data => [ host => $host, service => $service, flags => $flags, map { exists $args{$_} ? ( $_ => $args{$_} ) : () } qw( family socktype protocol ), ], timeout => $args{timeout}, ); $future->on_done( $args{on_resolved} ) if $args{on_resolved}; $future->on_fail( $args{on_error} ) if $args{on_error}; return $future if defined wantarray; # Caller is not going to keep hold of the Future, so we have to ensure it # stays alive somehow $self->adopt_future( $future->else( sub { Future->done } ) ); } =head2 getnameinfo ( $host, $service ) = await $resolver->getnameinfo( %args ); A shortcut wrapper around the C resolver, taking its arguments in a more convenient form. =over 8 =item addr => STRING The packed socket address to look up. =item flags => INT Flags to control the C function. See the C constants in L's C for more detail. =item numerichost => BOOL =item numericserv => BOOL =item dgram => BOOL If true, set the C, C or C flags. =item numeric => BOOL If true, sets both C and C flags. =item timeout => NUMBER Time in seconds after which to abort the lookup with a C exception =back On failure, the detail field will give the error number, which should match one of the C constants. ->fail( $message, resolve => getnameinfo => $eai_errno ) As a specific optimisation, this method will try to perform a lookup of numeric values synchronously, rather than asynchronously, if both the C and C flags are given. =head2 getnameinfo (void) $resolver->getnameinfo( %args ); When not returning a future, additional parameters can be given containing the continuations to invoke on success or failure: =over 8 =item on_resolved => CODE Callback which is invoked after a successful lookup. $on_resolved->( $host, $service ); =item on_error => CODE Callback which is invoked after a failed lookup, including for a timeout. $on_error->( $exception ); =back =cut sub getnameinfo { my $self = shift; my %args = @_; $args{on_resolved} or defined wantarray or croak "Expected 'on_resolved' or to return a Future"; $args{on_error} or defined wantarray or croak "Expected 'on_error' or to return a Future"; my $flags = $args{flags} || 0; $flags |= NI_NUMERICHOST if $args{numerichost}; $flags |= NI_NUMERICSERV if $args{numericserv}; $flags |= NI_DGRAM if $args{dgram}; $flags |= NI_NUMERICHOST|NI_NUMERICSERV if $args{numeric}; if( $flags & (NI_NUMERICHOST|NI_NUMERICSERV) ) { # This is a numeric-only lookup that can be done synchronously my ( $err, $host, $service ) = Socket::getnameinfo( $args{addr}, $flags ); if( $err ) { my $future = $self->loop->new_future->fail( $err, resolve => getnameinfo => $err+0 ); $future->on_fail( $args{on_error} ) if $args{on_error}; return $future; } else { my $future = $self->loop->new_future->done( $host, $service ); $future->on_done( $args{on_resolved} ) if $args{on_resolved}; return $future; } } my $future = $self->resolve( type => "getnameinfo", data => [ $args{addr}, $flags ], timeout => $args{timeout}, )->transform( done => sub { @{ $_[0] } }, # unpack the ARRAY ref ); $future->on_done( $args{on_resolved} ) if $args{on_resolved}; $future->on_fail( $args{on_error} ) if $args{on_error}; return $future if defined wantarray; # Caller is not going to keep hold of the Future, so we have to ensure it # stays alive somehow $self->adopt_future( $future->else( sub { Future->done } ) ); } =head1 FUNCTIONS =cut =head2 register_resolver register_resolver( $name, $code ); Registers a new named resolver function that can be called by the C method. All named resolvers must be registered before the object is constructed. =over 8 =item $name The name of the resolver function; must be a plain string. This name will be used by the C argument to the C method, to identify it. =item $code A CODE reference to the resolver function body. It will be called in list context, being passed the list of arguments given in the C argument to the C method. The returned list will be passed to the C callback. If the code throws an exception at call time, it will be passed to the C continuation. If it returns normally, the list of values it returns will be passed to C. =back =cut # Plain function, not a method sub register_resolver { my ( $name, $code ) = @_; croak "Cannot register new resolver methods once the resolver has been started" if $started; croak "Already have a resolver method called '$name'" if exists $METHODS{$name}; $METHODS{$name} = $code; } =head1 BUILT-IN RESOLVERS The following resolver names are implemented by the same-named perl function, taking and returning a list of values exactly as the perl function does: getpwnam getpwuid getgrnam getgrgid getservbyname getservbyport gethostbyname gethostbyaddr getnetbyname getnetbyaddr getprotobyname getprotobynumber =cut # Now register the inbuilt methods register_resolver getpwnam => sub { my @r = getpwnam( $_[0] ) or die "$!\n"; @r }; register_resolver getpwuid => sub { my @r = getpwuid( $_[0] ) or die "$!\n"; @r }; register_resolver getgrnam => sub { my @r = getgrnam( $_[0] ) or die "$!\n"; @r }; register_resolver getgrgid => sub { my @r = getgrgid( $_[0] ) or die "$!\n"; @r }; register_resolver getservbyname => sub { my @r = getservbyname( $_[0], $_[1] ) or die "$!\n"; @r }; register_resolver getservbyport => sub { my @r = getservbyport( $_[0], $_[1] ) or die "$!\n"; @r }; register_resolver gethostbyname => sub { my @r = gethostbyname( $_[0] ) or die "$!\n"; @r }; register_resolver gethostbyaddr => sub { my @r = gethostbyaddr( $_[0], $_[1] ) or die "$!\n"; @r }; register_resolver getnetbyname => sub { my @r = getnetbyname( $_[0] ) or die "$!\n"; @r }; register_resolver getnetbyaddr => sub { my @r = getnetbyaddr( $_[0], $_[1] ) or die "$!\n"; @r }; register_resolver getprotobyname => sub { my @r = getprotobyname( $_[0] ) or die "$!\n"; @r }; register_resolver getprotobynumber => sub { my @r = getprotobynumber( $_[0] ) or die "$!\n"; @r }; =pod The following three resolver names are implemented using the L module. getaddrinfo getaddrinfo_array getnameinfo The C resolver takes arguments in a hash of name/value pairs and returns a list of hash structures, as the C function does. For neatness it takes all its arguments as named values; taking the host and service names from arguments called C and C respectively; all the remaining arguments are passed into the hints hash. This name is also aliased as simply C. The C resolver behaves more like the C version of the function. It takes hints in a flat list, and mangles the result of the function, so that the returned value is more useful to the caller. It splits up the list of 5-tuples into a list of ARRAY refs, where each referenced array contains one of the tuples of 5 values. As an extra convenience to the caller, both resolvers will also accept plain string names for the C argument, converting C and possibly C into the appropriate C value, and for the C argument, converting C, C or C into the appropriate C value. The C resolver returns its result in the same form as C. Because this module simply uses the system's C resolver, it will be fully IPv6-aware if the underlying platform's resolver is. This allows programs to be fully IPv6-capable. =cut register_resolver getaddrinfo => sub { my %args = @_; my $host = delete $args{host}; my $service = delete $args{service}; $args{family} = IO::Async::OS->getfamilybyname( $args{family} ) if defined $args{family}; $args{socktype} = IO::Async::OS->getsocktypebyname( $args{socktype} ) if defined $args{socktype}; # Clear any other existing but undefined hints defined $args{$_} or delete $args{$_} for keys %args; my ( $err, @addrs ) = Socket::getaddrinfo( $host, $service, \%args ); die [ "$err", $err+0 ] if $err; return @addrs; }; register_resolver getaddrinfo_array => sub { my ( $host, $service, $family, $socktype, $protocol, $flags ) = @_; $family = IO::Async::OS->getfamilybyname( $family ); $socktype = IO::Async::OS->getsocktypebyname( $socktype ); my %hints; $hints{family} = $family if defined $family; $hints{socktype} = $socktype if defined $socktype; $hints{protocol} = $protocol if defined $protocol; $hints{flags} = $flags if defined $flags; my ( $err, @addrs ) = Socket::getaddrinfo( $host, $service, \%hints ); die [ "$err", $err+0 ] if $err; # Convert the @addrs list into a list of ARRAY refs of 5 values each return map { [ $_->{family}, $_->{socktype}, $_->{protocol}, $_->{addr}, $_->{canonname} ] } @addrs; }; register_resolver getnameinfo => sub { my ( $addr, $flags ) = @_; my ( $err, $host, $service ) = Socket::getnameinfo( $addr, $flags || 0 ); die [ "$err", $err+0 ] if $err; return [ $host, $service ]; }; =head1 EXAMPLES The following somewhat contrieved example shows how to implement a new resolver function. This example just uses in-memory data, but a real function would likely make calls to OS functions to provide an answer. In traditional Unix style, a pair of functions are provided that each look up the entity by either type of key, where both functions return the same type of list. This is purely a convention, and is in no way required or enforced by the L itself. @numbers = qw( zero one two three four five six seven eight nine ); register_resolver getnumberbyindex => sub { my ( $index ) = @_; die "Bad index $index" unless $index >= 0 and $index < @numbers; return ( $index, $numbers[$index] ); }; register_resolver getnumberbyname => sub { my ( $name ) = @_; foreach my $index ( 0 .. $#numbers ) { return ( $index, $name ) if $numbers[$index] eq $name; } die "Bad name $name"; }; =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Routine.pm000444001750001750 4100415001742754 16126 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2012-2024 -- leonerd@leonerd.org.uk package IO::Async::Routine 0.804; use v5.14; use warnings; use base qw( IO::Async::Notifier ); use Carp; use IO::Async::OS; use IO::Async::Process; use Struct::Dumb qw( readonly_struct ); =head1 NAME C - execute code in an independent sub-process or thread =head1 SYNOPSIS use IO::Async::Routine; use IO::Async::Channel; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $nums_ch = IO::Async::Channel->new; my $ret_ch = IO::Async::Channel->new; my $routine = IO::Async::Routine->new( channels_in => [ $nums_ch ], channels_out => [ $ret_ch ], code => sub { my @nums = @{ $nums_ch->recv }; my $ret = 0; $ret += $_ for @nums; # Can only send references $ret_ch->send( \$ret ); }, on_finish => sub { say "The routine aborted early - $_[-1]"; $loop->stop; }, ); $loop->add( $routine ); $nums_ch->send( [ 10, 20, 30 ] ); $ret_ch->recv( on_recv => sub { my ( $ch, $totalref ) = @_; say "The total of 10, 20, 30 is: $$totalref"; $loop->stop; } ); $loop->run; =head1 DESCRIPTION This L contains a body of code and executes it in a sub-process or thread, allowing it to act independently of the main program. Once set up, all communication with the code happens by values passed into or out of the Routine via L objects. The code contained within the Routine is free to make blocking calls without stalling the rest of the program. This makes it useful for using existing code which has no option not to block within an L-based program. To create asynchronous wrappers of functions that return a value based only on their arguments, and do not generally maintain state within the process it may be more convenient to use an L instead, which uses an C to contain the body of the function and manages the Channels itself. =head2 Models A choice of detachment model is available. Each has various advantages and disadvantages. Not all of them may be available on a particular system. =head3 The C model The code in this model runs within its own process, created by calling C from the main process. It is isolated from the rest of the program in terms of memory, CPU time, and other resources. Because it is started using C, the initial process state is a clone of the main process. This model performs well on UNIX-like operating systems which possess a true native C system call, but is not available on C for example, because the operating system does not provide full fork-like semantics. =head3 The C model The code in this model runs inside a separate thread within the main process. It therefore shares memory and other resources such as open filehandles with the main thread. As with the C model, the initial thread state is cloned from the main controlling thread. This model is only available on perls built to support threading. =head3 The C model I The code in this model runs within its own freshly-created process running another copy of the perl interpreter. Similar to the C model it therefore has its own memory, CPU time, and other resources. However, since it is started freshly rather than by cloning the main process, it starts up in a clean state, without any shared resources from its parent. Since this model creates a new fresh process rather than sharing existing state, it cannot use the C argument to specify the routine body; it must instead use only the C and C arguments. In the current implementation this model requires exactly one input channel and exactly one output channel; both must be present, and there cannot be more than one of either. =cut =head1 EVENTS =head2 on_finish $exitcode For C-based Routines, this is invoked after the process has exited and is passed the raw exitcode status. =head2 on_finish $type, @result For thread-based Routines, this is invoked after the thread has returned from its code block and is passed the C result. As the behaviour of these events differs per model, it may be more convenient to use C and C instead. =head2 on_return $result Invoked if the code block returns normally. Note that C-based Routines can only transport an integer result between 0 and 255, as this is the actual C value. =head2 on_die $exception Invoked if the code block fails with an exception. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 model => "fork" | "thread" | "spawn" Optional. Defines how the routine will detach itself from the main process. See the L section above for more detail. If the model is not specified, the environment variable C is used to pick a default. If that isn't defined, C is preferred if it is available, otherwise C. =head2 channels_in => ARRAY of IO::Async::Channel ARRAY reference of L objects to set up for passing values in to the Routine. =head2 channels_out => ARRAY of IO::Async::Channel ARRAY reference of L objects to set up for passing values out of the Routine. =head2 code => CODE CODE reference to the body of the Routine, to execute once the channels are set up. When using the C model, this is not permitted; you must use C and C instead. =head2 module => STRING =head2 func => STRING I An alternative to the C argument, which names a module to load and a function to call within it. C should give a perl module name (i.e. C, not a filename like F), and C should give the basename of a function within that module (i.e. without the module name prefixed). It will be invoked as the main code body of the object, and passed in a list of all the channels; first the input ones then the output ones. module::func( @channels_in, @channels_out ); =head2 setup => ARRAY Optional. For C-based Routines, gives a reference to an array to pass to the underlying C C method. Ignored for thread-based Routines. =cut use constant PREFERRED_MODEL => IO::Async::OS->HAVE_POSIX_FORK ? "fork" : IO::Async::OS->HAVE_THREADS ? "thread" : die "No viable Routine models"; sub _init { my $self = shift; my ( $params ) = @_; $params->{model} ||= $ENV{IO_ASYNC_ROUTINE_MODEL} || PREFERRED_MODEL; $self->SUPER::_init( @_ ); } my %SETUP_CODE; sub configure { my $self = shift; my %params = @_; # TODO: Can only reconfigure when not running foreach (qw( channels_in channels_out code module func setup on_finish on_return on_die )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } defined $self->{code} and defined $self->{func} and croak "Cannot ->configure both 'code' and 'func'"; defined $self->{func} and !defined $self->{module} and croak "'func' parameter requires a 'module' as well"; if( defined( my $model = delete $params{model} ) ) { ( $SETUP_CODE{$model} ||= $self->can( "_setup_$model" ) ) or die "Unrecognised Routine model $model"; # TODO: optional plugin "configure" check here? $model eq "fork" and !IO::Async::OS->HAVE_POSIX_FORK and croak "Cannot use 'fork' model as fork() is not available"; $model eq "thread" and !IO::Async::OS->HAVE_THREADS and croak "Cannot use 'thread' model as threads are not available"; $self->{model} = $model; } $self->SUPER::configure( %params ); } sub _add_to_loop { my $self = shift; my ( $loop ) = @_; $self->SUPER::_add_to_loop( $loop ); my $model = $self->{model}; my $code = ( $SETUP_CODE{$model} ||= $self->can( "_setup_$model" ) ) or die "Unrecognised Routine model $model"; $self->$code(); } readonly_struct ChannelSetup => [qw( chan myfd otherfd )]; sub _create_channels_in { my $self = shift; my @channels_in; foreach my $ch ( @{ $self->{channels_in} || [] } ) { my ( $rd, $wr ); unless( $rd = $ch->_extract_read_handle ) { ( $rd, $wr ) = IO::Async::OS->pipepair; } push @channels_in, ChannelSetup( $ch, $wr, $rd ); } return @channels_in; } sub _create_channels_out { my $self = shift; my @channels_out; foreach my $ch ( @{ $self->{channels_out} || [] } ) { my ( $rd, $wr ); unless( $wr = $ch->_extract_write_handle ) { ( $rd, $wr ) = IO::Async::OS->pipepair; } push @channels_out, ChannelSetup( $ch, $rd, $wr ); } return @channels_out; } sub _adopt_channels_in { my $self = shift; my ( @channels_in ) = @_; foreach ( @channels_in ) { my $ch = $_->chan; $ch->setup_async_mode( write_handle => $_->myfd ); $self->add_child( $ch ) unless $ch->parent; } } sub _adopt_channels_out { my $self = shift; my ( @channels_out ) = @_; foreach ( @channels_out ) { my $ch = $_->chan; $ch->setup_async_mode( read_handle => $_->myfd ); $self->add_child( $ch ) unless $ch->parent; } } sub _setup_fork { my $self = shift; my @channels_in = $self->_create_channels_in; my @channels_out = $self->_create_channels_out; my $code = $self->{code}; my $module = $self->{module}; my $func = $self->{func}; my @setup = map { $_->otherfd => "keep" } @channels_in, @channels_out; my $setup = $self->{setup}; push @setup, @$setup if $setup; my $process = IO::Async::Process->new( setup => \@setup, code => sub { foreach ( @channels_in, @channels_out ) { $_->chan->setup_sync_mode( $_->otherfd ); } if( defined $module ) { ( my $file = "$module.pm" ) =~ s{::}{/}g; require $file; $code = $module->can( $func ) or die "Module '$module' has no '$func'\n"; } my $ret = $code->( map { $_->chan } @channels_in, @channels_out ); foreach ( @channels_in, @channels_out ) { $_->chan->close; } return $ret; }, on_finish => $self->_replace_weakself( sub { my $self = shift or return; my ( $exitcode ) = @_; $self->maybe_invoke_event( on_finish => $exitcode ); unless( $exitcode & 0x7f ) { $self->maybe_invoke_event( on_return => ($exitcode >> 8) ); $self->result_future->done( $exitcode >> 8 ); } }), on_exception => $self->_replace_weakself( sub { my $self = shift or return; my ( $exception, $errno, $exitcode ) = @_; $self->maybe_invoke_event( on_die => $exception ); $self->result_future->fail( $exception, routine => ); }), ); $self->_adopt_channels_in ( @channels_in ); $self->_adopt_channels_out( @channels_out ); $self->add_child( $self->{process} = $process ); $self->{id} = "P" . $process->pid; $_->otherfd->close for @channels_in, @channels_out; } sub _setup_thread { my $self = shift; my @channels_in = $self->_create_channels_in; my @channels_out = $self->_create_channels_out; my $code = $self->{code}; my $module = $self->{module}; my $func = $self->{func}; my $tid = $self->loop->create_thread( code => sub { foreach ( @channels_in, @channels_out ) { $_->chan->setup_sync_mode( $_->otherfd ); defined and $_->close for $_->myfd; } if( defined $func ) { ( my $file = "$module.pm" ) =~ s{::}{/}g; require $file; $code = $module->can( $func ) or die "Module '$module' has no '$func'\n"; } my $ret = $code->( map { $_->chan } @channels_in, @channels_out ); foreach ( @channels_in, @channels_out ) { $_->chan->close; } return $ret; }, on_joined => $self->_capture_weakself( sub { my $self = shift or return; my ( $ev, @result ) = @_; $self->maybe_invoke_event( on_finish => @_ ); if( $ev eq "return" ) { $self->maybe_invoke_event( on_return => @result ); $self->result_future->done( @result ); } if( $ev eq "died" ) { $self->maybe_invoke_event( on_die => $result[0] ); $self->result_future->fail( $result[0], routine => ); } delete $self->{tid}; }), ); $self->{tid} = $tid; $self->{id} = "T" . $tid; $self->_adopt_channels_in ( @channels_in ); $self->_adopt_channels_out( @channels_out ); $_->otherfd->close for @channels_in, @channels_out; } # The injected program that goes into spawn mode use constant PERL_RUNNER => <<'EOF'; ( my ( $module, $func ), @INC ) = @ARGV; ( my $file = "$module.pm" ) =~ s{::}{/}g; require $file; my $code = $module->can( $func ) or die "Module '$module' has no '$func'\n"; require IO::Async::Channel; exit $code->( IO::Async::Channel->new_stdin, IO::Async::Channel->new_stdout ); EOF sub _setup_spawn { my $self = shift; $self->{code} and die "Cannot run IO::Async::Routine in 'spawn' with code\n"; @{ $self->{channels_in} } == 1 or die "IO::Async::Routine in 'spawn' mode requires exactly one input channel\n"; @{ $self->{channels_out} } == 1 or die "IO::Async::Routine in 'spawn' mode requires exactly one output channel\n"; my @channels_in = $self->_create_channels_in; my @channels_out = $self->_create_channels_out; my $module = $self->{module}; my $func = $self->{func}; my $process = IO::Async::Process->new( setup => [ stdin => $channels_in[0]->otherfd, stdout => $channels_out[0]->otherfd, ], command => [ $^X, "-E", PERL_RUNNER, $module, $func, grep { !ref } @INC ], on_finish => $self->_replace_weakself( sub { my $self = shift or return; my ( $exitcode ) = @_; $self->maybe_invoke_event( on_finish => $exitcode ); unless( $exitcode & 0x7f ) { $self->maybe_invoke_event( on_return => ($exitcode >> 8) ); $self->result_future->done( $exitcode >> 8 ); } }), on_exception => $self->_replace_weakself( sub { my $self = shift or return; my ( $exception, $errno, $exitcode ) = @_; $self->maybe_invoke_event( on_die => $exception ); $self->result_future->fail( $exception, routine => ); }), ); $self->_adopt_channels_in ( @channels_in ); $self->_adopt_channels_out( @channels_out ); $self->add_child( $self->{process} = $process ); $self->{id} = "P" . $process->pid; $_->otherfd->close for @channels_in, @channels_out; } =head1 METHODS =cut =head2 id $id = $routine->id; Returns an ID string that uniquely identifies the Routine out of all the currently-running ones. (The ID of already-exited Routines may be reused, however.) =cut sub id { my $self = shift; return $self->{id}; } =head2 model $model = $routine->model; Returns the detachment model in use by the Routine. =cut sub model { my $self = shift; return $self->{model}; } =head2 kill $routine->kill( $signal ); Sends the specified signal to the routine code. This is either implemented by C or C as required. Note that in the thread case this has the usual limits of signal delivery to threads; namely, that it works at the Perl interpreter level, and cannot actually interrupt blocking system calls. =cut sub kill { my $self = shift; my ( $signal ) = @_; $self->{process}->kill( $signal ) if $self->{model} eq "fork"; threads->object( $self->{tid} )->kill( $signal ) if $self->{model} eq "thread"; } =head2 result_future $f = $routine->result_future; I Returns a new C which will complete with the eventual return value or exception when the routine finishes. If the routine finishes with a successful result then this will be the C result of the future. If the routine fails with an exception then this will be the C result. =cut sub result_future { my $self = shift; return $self->{result_future} //= do { my $f = $self->loop->new_future; # This future needs to strongly retain $self to ensure it definitely gets # notified $f->on_ready( sub { undef $self } ); $f; }; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Signal.pm000444001750001750 544715001742754 15711 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2009-2024 -- leonerd@leonerd.org.uk package IO::Async::Signal 0.804; use v5.14; use warnings; use base qw( IO::Async::Notifier ); use Carp; =head1 NAME C - event callback on receipt of a POSIX signal =head1 SYNOPSIS use IO::Async::Signal; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $signal = IO::Async::Signal->new( name => "HUP", on_receipt => sub { print "I caught SIGHUP\n"; }, ); $loop->add( $signal ); $loop->run; =head1 DESCRIPTION This subclass of L invokes its callback when a particular POSIX signal is received. Multiple objects can be added to a C that all watch for the same signal. The callback functions will all be invoked, in no particular order. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_receipt Invoked when the signal is received. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 name => STRING The name of the signal to watch. This should be a bare name like C. Can only be given at construction time. =head2 on_receipt => CODE CODE reference for the C event. Once constructed, the C will need to be added to the C before it will work. =cut sub _init { my $self = shift; my ( $params ) = @_; my $name = delete $params->{name} or croak "Expected 'name'"; $name =~ s/^SIG//; # Trim a leading "SIG" $self->{name} = $name; $self->SUPER::_init( $params ); } sub configure { my $self = shift; my %params = @_; if( exists $params{on_receipt} ) { $self->{on_receipt} = delete $params{on_receipt}; undef $self->{cb}; # Will be lazily constructed when needed if( my $loop = $self->loop ) { $self->_remove_from_loop( $loop ); $self->_add_to_loop( $loop ); } } unless( $self->can_event( 'on_receipt' ) ) { croak 'Expected either a on_receipt callback or an ->on_receipt method'; } $self->SUPER::configure( %params ); } sub _add_to_loop { my $self = shift; my ( $loop ) = @_; $self->{cb} ||= $self->make_event_cb( 'on_receipt' ); $self->{id} = $loop->attach_signal( $self->{name}, $self->{cb} ); } sub _remove_from_loop { my $self = shift; my ( $loop ) = @_; $loop->detach_signal( $self->{name}, $self->{id} ); undef $self->{id}; } sub notifier_name { my $self = shift; if( length( my $name = $self->SUPER::notifier_name ) ) { return $name; } return $self->{name}; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Socket.pm000444001750001750 2124515001742754 15736 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2024 -- leonerd@leonerd.org.uk package IO::Async::Socket 0.804; use v5.14; use warnings; use base qw( IO::Async::Handle ); use Errno qw( EAGAIN EWOULDBLOCK EINTR ); use Carp; =head1 NAME C - event callbacks and send buffering for a socket filehandle =head1 SYNOPSIS use Future::AsyncAwait; use IO::Async::Socket; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $socket = IO::Async::Socket->new( on_recv => sub { my ( $self, $dgram, $addr ) = @_; print "Received reply: $dgram\n", $loop->stop; }, on_recv_error => sub { my ( $self, $errno ) = @_; die "Cannot recv - $errno\n"; }, ); $loop->add( $socket ); await $socket->connect( host => "some.host.here", service => "echo", socktype => 'dgram', ); $socket->send( "A TEST DATAGRAM" ); $loop->run; =head1 DESCRIPTION This subclass of L contains a socket filehandle. It provides a queue of outgoing data. It invokes the C handler when new data is received from the filehandle. Data may be sent to the filehandle by calling the C method. It is primarily intended for C or C sockets (such as UDP or packet-capture); for C sockets (such as TCP) an instance of L is more appropriate. =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_recv $data, $addr Invoke on receipt of a packet, datagram, or stream segment. The C handler is invoked once for each packet, datagram, or stream segment that is received. It is passed the data itself, and the sender's address. =head2 on_recv_error $errno Optional. Invoked when the C method on the receiving handle fails. =head2 on_send_error $errno Optional. Invoked when the C method on the sending handle fails. The C and C handlers are passed the value of C<$!> at the time the error occurred. (The C<$!> variable itself, by its nature, may have changed from the original error by the time this handler runs so it should always use the value passed in). If an error occurs when the corresponding error callback is not supplied, and there is not a subclass method for it, then the C method is called instead. =head2 on_outgoing_empty Optional. Invoked when the sending data buffer becomes empty. =cut sub _init { my $self = shift; $self->{recv_len} = 65536; $self->SUPER::_init( @_ ); } =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 read_handle => IO The IO handle to receive from. Must implement C and C methods. =head2 write_handle => IO The IO handle to send to. Must implement C and C methods. =head2 handle => IO Shortcut to specifying the same IO handle for both of the above. =head2 on_recv => CODE =head2 on_recv_error => CODE =head2 on_outgoing_empty => CODE =head2 on_send_error => CODE =head2 autoflush => BOOL Optional. If true, the C method will atempt to send data to the operating system immediately, without waiting for the loop to indicate the filehandle is write-ready. =head2 recv_len => INT Optional. Sets the buffer size for C calls. Defaults to 64 KiB. =head2 recv_all => BOOL Optional. If true, repeatedly call C when the receiving handle first becomes read-ready. By default this is turned off, meaning at most one fixed-size buffer is received. If there is still more data in the kernel's buffer, the handle will stil be readable, and will be received from again. This behaviour allows multiple streams and sockets to be multiplexed simultaneously, meaning that a large bulk transfer on one cannot starve other filehandles of processing time. Turning this option on may improve bulk data transfer rate, at the risk of delaying or stalling processing on other filehandles. =head2 send_all => INT Optional. Analogous to the C option, but for sending. When C is enabled, this option only affects deferred sending if the initial attempt failed. The condition requiring an C handler is checked at the time the object is added to a Loop; it is allowed to create a C object with a read handle but without a C handler, provided that one is later given using C before the stream is added to its containing Loop, either directly or by being a child of another Notifier already in a Loop, or added to one. =cut sub configure { my $self = shift; my %params = @_; for (qw( on_recv on_outgoing_empty on_recv_error on_send_error recv_len recv_all send_all autoflush )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } $self->SUPER::configure( %params ); if( $self->loop and defined $self->read_handle ) { $self->can_event( "on_recv" ) or croak 'Expected either an on_recv callback or to be able to ->on_recv'; } } sub _add_to_loop { my $self = shift; if( defined $self->read_handle ) { $self->can_event( "on_recv" ) or croak 'Expected either an on_recv callback or to be able to ->on_recv'; } $self->SUPER::_add_to_loop( @_ ); } =head1 METHODS =cut =head2 send $socket->send( $data, $flags, $addr ); This method adds a segment of data to be sent, or sends it immediately, according to the C parameter. C<$flags> and C<$addr> are optional. If the C option is set, this method will try immediately to send the data to the underlying filehandle, optionally using the given flags and destination address. If this completes successfully then it will have been sent by the time this method returns. If it fails to send, then the data is queued as if C were not set, and will be flushed as normal. =cut sub send { my $self = shift; my ( $data, $flags, $addr ) = @_; croak "Cannot send data to a Socket with no write_handle" unless my $handle = $self->write_handle; my $sendqueue = $self->{sendqueue} ||= []; push @$sendqueue, [ $data, $flags, $addr ]; if( $self->{autoflush} ) { while( @$sendqueue ) { my ( $data, $flags, $addr ) = @{ $sendqueue->[0] }; my $len = $handle->send( $data, $flags, $addr ); last if !$len; # stop on any errors and defer back to the non-autoflush path shift @$sendqueue; } if( !@$sendqueue ) { $self->want_writeready( 0 ); return; } } $self->want_writeready( 1 ); } sub on_read_ready { my $self = shift; my $handle = $self->read_handle; while(1) { my $addr = $handle->recv( my $data, $self->{recv_len} ); if( !defined $addr ) { return if $! == EAGAIN || $! == EWOULDBLOCK || $! == EINTR; my $errno = $!; $self->maybe_invoke_event( on_recv_error => $errno ) or $self->close; return; } if( !length $data ) { $self->close; return; } $self->invoke_event( on_recv => $data, $addr ); last unless $self->{recv_all}; } } sub on_write_ready { my $self = shift; my $handle = $self->write_handle; my $sendqueue = $self->{sendqueue}; while( $sendqueue and @$sendqueue ) { my ( $data, $flags, $addr ) = @{ shift @$sendqueue }; my $len = $handle->send( $data, $flags, $addr ); if( !defined $len ) { return if $! == EAGAIN || $! == EWOULDBLOCK || $! == EINTR; my $errno = $!; $self->maybe_invoke_event( on_send_error => $errno ) or $self->close; return; } if( $len == 0 ) { $self->close; return; } last unless $self->{send_all}; } if( !$sendqueue or !@$sendqueue ) { $self->want_writeready( 0 ); $self->maybe_invoke_event( on_outgoing_empty => ); } } =head1 EXAMPLES =head2 Send-first on a UDP Socket C is carried by the C socket type, for which the string C<'dgram'> is a convenient shortcut: await $socket->connect( host => $hostname, service => $service, socktype => 'dgram', ... ); =head2 Receive-first on a UDP Socket A typical server pattern with C involves binding a well-known port number instead of connecting to one, and waiting on incoming packets. await $socket->bind( service => 12345, socktype => 'dgram', ); =head1 SEE ALSO =over 4 =item * L - Supply object methods for I/O handles =back =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Stream.pm000444001750001750 12756415001742754 15774 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2006-2024 -- leonerd@leonerd.org.uk package IO::Async::Stream 0.804; use v5.14; use warnings; use base qw( IO::Async::Handle ); use Errno qw( EAGAIN EWOULDBLOCK EINTR EPIPE ); use Carp; use Encode 2.11 qw( find_encoding STOP_AT_PARTIAL ); use Scalar::Util qw( blessed ); use Future 0.44; # ->result use IO::Async::Debug; use IO::Async::Metrics '$METRICS'; # Tuneable from outside # Not yet documented our $READLEN = 8192; our $WRITELEN = 8192; use Struct::Dumb; # Element of the writequeue struct Writer => [qw( data writelen on_write on_flush on_error watching )]; # Element of the readqueue struct Reader => [qw( on_read future )]; # Bitfields in the want flags use constant WANT_READ_FOR_READ => 0x01; use constant WANT_READ_FOR_WRITE => 0x02; use constant WANT_WRITE_FOR_READ => 0x04; use constant WANT_WRITE_FOR_WRITE => 0x08; use constant WANT_ANY_READ => WANT_READ_FOR_READ |WANT_READ_FOR_WRITE; use constant WANT_ANY_WRITE => WANT_WRITE_FOR_READ|WANT_WRITE_FOR_WRITE; =head1 NAME C - event callbacks and write bufering for a stream filehandle =head1 SYNOPSIS use IO::Async::Stream; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $stream = IO::Async::Stream->new( read_handle => \*STDIN, write_handle => \*STDOUT, on_read => sub { my ( $self, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*\n)// ) { print "Received a line $1"; } if( $eof ) { print "EOF; last partial line is $$buffref\n"; } return 0; } ); $loop->add( $stream ); $stream->write( "An initial line here\n" ); =head1 DESCRIPTION This subclass of L contains a filehandle that represents a byte-stream. It provides buffering for both incoming and outgoing data. It invokes the C handler when new data is read from the filehandle. Data may be written to the filehandle by calling the C method. This class is suitable for any kind of filehandle that provides a possibly-bidirectional reliable byte stream, such as a pipe, TTY, or C socket (such as TCP or a byte-oriented UNIX local socket). For datagram or raw message-based sockets (such as UDP) see instead L. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 $ret = on_read \$buffer, $eof Invoked when more data is available in the internal receiving buffer. The first argument is a reference to a plain perl string. The code should inspect and remove any data it likes, but is not required to remove all, or indeed any of the data. Any data remaining in the buffer will be preserved for the next call, the next time more data is received from the handle. In this way, it is easy to implement code that reads records of some form when completed, but ignores partially-received records, until all the data is present. If the handler wishes to be immediately invoke a second time, to have another attempt at consuming more content, it should return C<1>. Otherwise, it should return C<0>, and the handler will next be invoked when more data has arrived from the underlying read handle and appended to the buffer. This makes it easy to implement code that handles multiple incoming records at the same time. Alternatively, if the handler function already attempts to consume as much as possible from the buffer, it will have no need to return C<1> at all. See the examples at the end of this documentation for more detail. The second argument is a scalar indicating whether the stream has reported an end-of-file (EOF) condition. A reference to the buffer is passed to the handler in the usual way, so it may inspect data contained in it. Once the handler returns a false value, it will not be called again, as the handle is now at EOF and no more data can arrive. The C code may also dynamically replace itself with a new callback by returning a CODE reference instead of C<0> or C<1>. The original callback or method that the object first started with may be restored by returning C. Whenever the callback is changed in this way, the new code is called again; even if the read buffer is currently empty. See the examples at the end of this documentation for more detail. The C method can be used to insert new, temporary handlers that take precedence over the global C handler. This event is only used if there are no further pending handlers created by C. =head2 on_read_eof Optional. Invoked when the read handle indicates an end-of-file (EOF) condition. If there is any data in the buffer still to be processed, the C event will be invoked first, before this one. =head2 on_write_eof Optional. Invoked when the write handle indicates an end-of-file (EOF) condition. Note that this condition can only be detected after a C syscall returns the C error. If there is no data pending to be written then it will not be detected yet. =head2 on_read_error $errno Optional. Invoked when the C method on the read handle fails. =head2 on_write_error $errno Optional. Invoked when the C method on the write handle fails. The C and C handlers are passed the value of C<$!> at the time the error occurred. (The C<$!> variable itself, by its nature, may have changed from the original error by the time this handler runs so it should always use the value passed in). If an error occurs when the corresponding error callback is not supplied, and there is not a handler for it, then the C method is called instead. =head2 on_read_high_watermark $length =head2 on_read_low_watermark $length Optional. Invoked when the read buffer grows larger than the high watermark or smaller than the low watermark respectively. These are edge-triggered events; they will only be triggered once per crossing, not continuously while the buffer remains above or below the given limit. If these event handlers are not defined, the default behaviour is to disable read-ready notifications if the read buffer grows larger than the high watermark (so as to avoid it growing arbitrarily if nothing is consuming it), and re-enable notifications again once something has read enough to cause it to drop. If these events are overridden, the overriding code will have to perform this behaviour if required, by using $self->want_readready_for_read(...); =head2 on_outgoing_empty Optional. Invoked when the writing data buffer becomes empty. =head2 on_writeable_start =head2 on_writeable_stop Optional. These two events inform when the filehandle becomes writeable, and when it stops being writeable. C is invoked by the C event if previously it was known to be not writeable. C is invoked after a C operation fails with C or C. These two events track the writeability state, and ensure that only state change cause events to be invoked. A stream starts off being presumed writeable, so the first of these events to be observed will be C. =cut sub _init { my $self = shift; $self->{writequeue} = []; # Queue of Writers $self->{readqueue} = []; # Queue of Readers $self->{writeable} = 1; # "innocent until proven guilty" (by means of EAGAIN) $self->{readbuff} = ""; $self->{reader} = "_sysread"; $self->{writer} = "_syswrite"; $self->{read_len} = $READLEN; $self->{write_len} = $WRITELEN; $self->{want} = WANT_READ_FOR_READ; $self->{close_on_read_eof} = 1; } =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 read_handle => IO The IO handle to read from. Must implement C and C methods. =head2 write_handle => IO The IO handle to write to. Must implement C and C methods. =head2 handle => IO Shortcut to specifying the same IO handle for both of the above. =head2 on_read => CODE =head2 on_read_error => CODE =head2 on_outgoing_empty => CODE =head2 on_write_error => CODE =head2 on_writeable_start => CODE =head2 on_writeable_stop => CODE CODE references for event handlers. =head2 autoflush => BOOL Optional. If true, the C method will attempt to write data to the operating system immediately, without waiting for the loop to indicate the filehandle is write-ready. This is useful, for example, on streams that should contain up-to-date logging or console information. It currently defaults to false for any file handle, but future versions of L may enable this by default on STDOUT and STDERR. =head2 read_len => INT Optional. Sets the buffer size for C calls. Defaults to 8 KiBytes. =head2 read_all => BOOL Optional. If true, attempt to read as much data from the kernel as possible when the handle becomes readable. By default this is turned off, meaning at most one fixed-size buffer is read. If there is still more data in the kernel's buffer, the handle will still be readable, and will be read from again. This behaviour allows multiple streams and sockets to be multiplexed simultaneously, meaning that a large bulk transfer on one cannot starve other filehandles of processing time. Turning this option on may improve bulk data transfer rate, at the risk of delaying or stalling processing on other filehandles. =head2 write_len => INT Optional. Sets the buffer size for C calls. Defaults to 8 KiBytes. =head2 write_all => BOOL Optional. Analogous to the C option, but for writing. When C is enabled, this option only affects deferred writing if the initial attempt failed due to buffer space. =head2 read_high_watermark => INT =head2 read_low_watermark => INT Optional. If defined, gives a way to implement flow control or other behaviours that depend on the size of Stream's read buffer. If after more data is read from the underlying filehandle the read buffer is now larger than the high watermark, the C event is triggered (which, by default, will disable read-ready notifications and pause reading from the filehandle). If after data is consumed by an C handler the read buffer is now smaller than the low watermark, the C event is triggered (which, by default, will re-enable read-ready notifications and resume reading from the filehandle). For to be possible, the read handler would have to be one added by the C method or one of the Future-returning C methods. By default these options are not defined, so this behaviour will not happen. C may not be set to a larger value than C, but it may be set to a smaller value, creating a hysteresis region. If either option is defined then both must be. If these options are used with the default event handlers, be careful not to cause deadlocks by having a high watermark sufficiently low that a single C invocation might not consider it finished yet. =head2 reader => STRING|CODE =head2 writer => STRING|CODE Optional. If defined, gives the name of a method or a CODE reference to use to implement the actual reading from or writing to the filehandle. These will be invoked as $stream->reader( $read_handle, $buffer, $len ); $stream->writer( $write_handle, $buffer, $len ); Each is expected to modify the passed buffer; C by appending to it, C by removing a prefix from it. Each is expected to return a true value on success, zero on EOF, or C with C<$!> set for errors. If not provided, they will be substituted by implenentations using C and C on the underlying handle, respectively. =head2 close_on_read_eof => BOOL Optional. Usually true, but if set to a false value then the stream will not be Cd when an EOF condition occurs on read. This is normally not useful as at that point the underlying stream filehandle is no longer useable, but it may be useful for reading regular files, or interacting with TTY devices. =head2 encoding => STRING If supplied, sets the name of encoding of the underlying stream. If an encoding is set, then the C method will expect to receive Unicode strings and encodes them into bytes, and incoming bytes will be decoded into Unicode strings for the C event. If an encoding is not supplied then C and C will work in byte strings. I in order to handle reads of UTF-8 content or other multibyte encodings, the code implementing the C event uses a feature of L; the C flag. While this flag has existed for a while and is used by the C<:encoding> PerlIO layer itself for similar purposes, the flag is not officially documented by the C module. In principle this undocumented feature could be subject to change, in practice I believe it to be reasonably stable. This note applies only to the C event; data written using the C method does not rely on any undocumented features of C. If a read handle is given, it is required that either an C callback reference is configured, or that the object provides an C method. It is optional whether either is true for C; if neither is supplied then no action will be taken when the writing buffer becomes empty. An C handler may be supplied even if no read handle is yet given, to be used when a read handle is eventually provided by the C method. This condition is checked at the time the object is added to a Loop; it is allowed to create a C object with a read handle but without a C handler, provided that one is later given using C before the stream is added to its containing Loop, either directly or by being a child of another Notifier already in a Loop, or added to one. =cut sub configure { my $self = shift; my %params = @_; for (qw( on_read on_outgoing_empty on_read_eof on_write_eof on_read_error on_write_error on_writeable_start on_writeable_stop autoflush read_len read_all write_len write_all on_read_high_watermark on_read_low_watermark reader writer close_on_read_eof )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } if( exists $params{read_high_watermark} or exists $params{read_low_watermark} ) { my $high = delete $params{read_high_watermark} // $self->{read_high_watermark}; my $low = delete $params{read_low_watermark} // $self->{read_low_watermark}; croak "Cannot set read_low_watermark without read_high_watermark" if defined $low and !defined $high; croak "Cannot set read_high_watermark without read_low_watermark" if defined $high and !defined $low; croak "Cannot set read_low_watermark higher than read_high_watermark" if defined $low and defined $high and $low > $high; $self->{read_high_watermark} = $high; $self->{read_low_watermark} = $low; # TODO: reassert levels if we've moved them } if( exists $params{encoding} ) { my $encoding = delete $params{encoding}; my $obj = find_encoding( $encoding ); defined $obj or croak "Cannot handle an encoding of '$encoding'"; $self->{encoding} = $obj; } $self->SUPER::configure( %params ); if( $self->loop and $self->read_handle ) { $self->can_event( "on_read" ) or croak 'Expected either an on_read callback or to be able to ->on_read'; } if( $self->{autoflush} and my $write_handle = $self->write_handle ) { carp "An IO::Async::Stream with autoflush needs an O_NONBLOCK write handle" if $write_handle->blocking; } } sub _add_to_loop { my $self = shift; if( defined $self->read_handle ) { $self->can_event( "on_read" ) or croak 'Expected either an on_read callback or to be able to ->on_read'; } $self->SUPER::_add_to_loop( @_ ); if( !$self->_is_empty ) { $self->want_writeready_for_write( 1 ); } } =head1 METHODS The following methods documented in C expressions return L instances. =cut =head2 want_readready_for_read =head2 want_readready_for_write $stream->want_readready_for_read( $set ); $stream->want_readready_for_write( $set ); Mutators for the C property on L, which control whether the C or C behaviour should be continued once the filehandle becomes ready for read. Normally, C is always true (though the read watermark behaviour can modify it), and C is not used. However, if a custom C function is provided, it may find this useful for being invoked again if it cannot proceed with a write operation until the filehandle becomes readable (such as during transport negotiation or SSL key management, for example). =cut sub want_readready_for_read { my $self = shift; my ( $set ) = @_; $set ? ( $self->{want} |= WANT_READ_FOR_READ ) : ( $self->{want} &= ~WANT_READ_FOR_READ ); $self->want_readready( $self->{want} & WANT_ANY_READ ) if $self->read_handle; } sub want_readready_for_write { my $self = shift; my ( $set ) = @_; $set ? ( $self->{want} |= WANT_READ_FOR_WRITE ) : ( $self->{want} &= ~WANT_READ_FOR_WRITE ); $self->want_readready( $self->{want} & WANT_ANY_READ ) if $self->read_handle; } =head2 want_writeready_for_read =head2 want_writeready_for_write $stream->want_writeready_for_write( $set ); $stream->want_writeready_for_read( $set ); Mutators for the C property on L, which control whether the C or C behaviour should be continued once the filehandle becomes ready for write. Normally, C is managed by the C method and associated flushing, and C is not used. However, if a custom C function is provided, it may find this useful for being invoked again if it cannot proceed with a read operation until the filehandle becomes writable (such as during transport negotiation or SSL key management, for example). =cut sub want_writeready_for_write { my $self = shift; my ( $set ) = @_; $set ? ( $self->{want} |= WANT_WRITE_FOR_WRITE ) : ( $self->{want} &= ~WANT_WRITE_FOR_WRITE ); $self->want_writeready( $self->{want} & WANT_ANY_WRITE ) if $self->write_handle; } sub want_writeready_for_read { my $self = shift; my ( $set ) = @_; $set ? ( $self->{want} |= WANT_WRITE_FOR_READ ) : ( $self->{want} &= ~WANT_WRITE_FOR_READ ); $self->want_writeready( $self->{want} & WANT_ANY_WRITE ) if $self->write_handle; } # FUNCTION not method sub _nonfatal_error { my ( $errno ) = @_; return $errno == EAGAIN || $errno == EWOULDBLOCK || $errno == EINTR; } sub _is_empty { my $self = shift; return !@{ $self->{writequeue} }; } =head2 close $stream->close; A synonym for C. This should not be used when the deferred wait behaviour is required, as the behaviour of C may change in a future version of L. Instead, call C directly. =cut sub close { my $self = shift; $self->close_when_empty; } =head2 close_when_empty $stream->close_when_empty; If the write buffer is empty, this method calls C on the underlying IO handles, and removes the stream from its containing loop. If the write buffer still contains data, then this is deferred until the buffer is empty. This is intended for "write-then-close" one-shot streams. $stream->write( "Here is my final data\n" ); $stream->close_when_empty; Because of this deferred nature, it may not be suitable for error handling. See instead the C method. =cut sub close_when_empty { my $self = shift; return $self->SUPER::close if $self->_is_empty; $self->{stream_closing} = 1; } =head2 close_now $stream->close_now; This method immediately closes the underlying IO handles and removes the stream from the containing loop. It will not wait to flush the remaining data in the write buffer. =cut sub close_now { my $self = shift; foreach ( @{ $self->{writequeue} } ) { $_->on_error->( $self, "stream closing" ) if $_->on_error; } undef @{ $self->{writequeue} }; undef $self->{stream_closing}; $self->SUPER::close; } =head2 is_read_eof =head2 is_write_eof $eof = $stream->is_read_eof; $eof = $stream->is_write_eof; Returns true after an EOF condition is reported on either the read or the write handle, respectively. =cut sub is_read_eof { my $self = shift; return $self->{read_eof}; } sub is_write_eof { my $self = shift; return $self->{write_eof}; } =head2 write $stream->write( $data, %params ); This method adds data to the outgoing data queue, or writes it immediately, according to the C parameter. If the C option is set, this method will try immediately to write the data to the underlying filehandle. If this completes successfully then it will have been written by the time this method returns. If it fails to write completely, then the data is queued as if C were not set, and will be flushed as normal. C<$data> can either be a plain string, a L, or a CODE reference. If it is a plain string it is written immediately. If it is not, its value will be used to generate more C<$data> values, eventually leading to strings to be written. If C<$data> is a C, the Stream will wait until it is ready, and take the single value it yields. If C<$data> is a CODE reference, it will be repeatedly invoked to generate new values. Each time the filehandle is ready to write more data to it, the function is invoked. Once the function has finished generating data it should return undef. The function is passed the Stream object as its first argument. It is allowed that Cs yield CODE references, or CODE references return Cs, as well as plain strings. For example, to stream the contents of an existing opened filehandle: open my $fileh, "<", $path or die "Cannot open $path - $!"; $stream->write( sub { my ( $stream ) = @_; sysread $fileh, my $buffer, 8192 or return; return $buffer; } ); Takes the following optional named parameters in C<%params>: =over 8 =item write_len => INT Overrides the C parameter for the data written by this call. =item on_write => CODE A CODE reference which will be invoked after every successful C operation on the underlying filehandle. It will be passed the number of bytes that were written by this call, which may not be the entire length of the buffer - if it takes more than one C operation to empty the buffer then this callback will be invoked multiple times. $on_write->( $stream, $len ); =item on_flush => CODE A CODE reference which will be invoked once the data queued by this C call has been flushed. This will be invoked even if the buffer itself is not yet empty; if more data has been queued since the call. $on_flush->( $stream ); =item on_error => CODE A CODE reference which will be invoked if a C error happens while performing this write. Invoked as for the C's C event. $on_error->( $stream, $errno ); =back If the object is not yet a member of a loop and doesn't yet have a C, then calls to the C method will simply queue the data and return. It will be flushed when the object is added to the loop. If C<$data> is a defined but empty string, the write is still queued, and the C continuation will be invoked, if supplied. This can be used to obtain a marker, to invoke some code once the output queue has been flushed up to this point. =head2 write (scalar) await $stream->write( ... ); If called in non-void context, this method returns a L which will complete (with no value) when the write operation has been flushed. This may be used as an alternative to, or combined with, the C callback. =cut sub _syswrite { my $self = shift; my ( $handle, undef, $len ) = @_; my $written = $handle->syswrite( $_[1], $len ); return $written if !$written; # zero or undef substr( $_[1], 0, $written ) = ""; return $written; } sub _flush_one_write { my $self = shift; my $writequeue = $self->{writequeue}; my $head; while( $head = $writequeue->[0] and ref $head->data ) { if( ref $head->data eq "CODE" ) { my $data = $head->data->( $self ); if( !defined $data ) { $head->on_flush->( $self ) if $head->on_flush; shift @$writequeue; return 1; } if( !ref $data and my $encoding = $self->{encoding} ) { $data = $encoding->encode( $data ); } unshift @$writequeue, my $new = Writer( $data, $head->writelen, $head->on_write, undef, undef, 0 ); next; } elsif( blessed $head->data and $head->data->isa( "Future" ) ) { my $f = $head->data; if( !$f->is_ready ) { return 0 if $head->watching; $f->on_ready( sub { $self->_flush_one_write } ); $head->watching++; return 0; } my $data = $f->result; if( !ref $data and my $encoding = $self->{encoding} ) { $data = $encoding->encode( $data ); } $head->data = $data; next; } else { die "Unsure what to do with reference ".ref($head->data)." in write queue"; } } my $second; while( $second = $writequeue->[1] and !ref $second->data and $head->writelen == $second->writelen and !$head->on_write and !$second->on_write and !$head->on_flush ) { $head->data .= $second->data; $head->on_write = $second->on_write; $head->on_flush = $second->on_flush; splice @$writequeue, 1, 1, (); } die "TODO: head data does not contain a plain string" if ref $head->data; if( $IO::Async::Debug::DEBUG > 1 ) { my $data = substr $head->data, 0, $head->writelen; $self->debug_printf( "WRITE len=%d", length $data ); IO::Async::Debug::log_hexdump( $data ) if $IO::Async::Debug::DEBUG_FLAGS{Sw}; } my $writer = $self->{writer}; my $len = $self->$writer( $self->write_handle, $head->data, $head->writelen ); if( !defined $len ) { my $errno = $!; if( $errno == EAGAIN or $errno == EWOULDBLOCK ) { $self->maybe_invoke_event( on_writeable_stop => ) if $self->{writeable}; $self->{writeable} = 0; } return 0 if _nonfatal_error( $errno ); $self->debug_printf( "WRITE err=%d/%s", $errno, $errno ) if $IO::Async::Debug::DEBUG > 1; if( $errno == EPIPE ) { $self->debug_printf( "WRITE-EOF" ); $self->{write_eof} = 1; $self->maybe_invoke_event( on_write_eof => ); } $head->on_error->( $self, $errno ) if $head->on_error; $self->maybe_invoke_event( on_write_error => $errno ) or $self->close_now; return 0; } $METRICS and $METRICS->inc_counter_by( stream_written => $len ) if $len; if( my $on_write = $head->on_write ) { $on_write->( $self, $len ); } if( !length $head->data ) { $head->on_flush->( $self ) if $head->on_flush; shift @{ $self->{writequeue} }; } return 1; } sub write { my $self = shift; my ( $data, %params ) = @_; carp "Cannot write data to a Stream that is closing" and return if $self->{stream_closing}; # Allow writes without a filehandle if we're not yet in a Loop, just don't # try to flush them my $handle = $self->write_handle; croak "Cannot write data to a Stream with no write_handle" if !$handle and $self->loop; if( !ref $data and my $encoding = $self->{encoding} ) { $data = $encoding->encode( $data ); } my $on_write = delete $params{on_write}; my $on_flush = delete $params{on_flush}; my $on_error = delete $params{on_error}; my $f; if( defined wantarray ) { my $orig_on_flush = $on_flush; my $orig_on_error = $on_error; my $loop = $self->loop or croak "Cannot ->write data returning a Future to a Stream not in a Loop"; $f = $loop->new_future; $on_flush = sub { $f->done; $orig_on_flush->( @_ ) if $orig_on_flush; }; $on_error = sub { my $self = shift; my ( $errno ) = @_; $f->fail( "write failed: $errno", syswrite => $errno ) unless $f->is_ready; $orig_on_error->( $self, @_ ) if $orig_on_error; }; } my $write_len = $params{write_len} // $self->{write_len}; push @{ $self->{writequeue} }, Writer( $data, $write_len, $on_write, $on_flush, $on_error, 0 ); keys %params and croak "Unrecognised keys for ->write - " . join( ", ", keys %params ); return $f unless $handle; if( $self->{autoflush} ) { 1 while !$self->_is_empty and $self->_flush_one_write; if( $self->_is_empty ) { $self->want_writeready_for_write( 0 ); return $f; } } $self->want_writeready_for_write( 1 ); return $f; } sub on_write_ready { my $self = shift; if( !$self->{writeable} ) { $self->maybe_invoke_event( on_writeable_start => ); $self->{writeable} = 1; } $self->_do_write if $self->{want} & WANT_WRITE_FOR_WRITE; $self->_do_read if $self->{want} & WANT_WRITE_FOR_READ; } sub _do_write { my $self = shift; 1 while !$self->_is_empty and $self->_flush_one_write and $self->{write_all}; # All data successfully flushed if( $self->_is_empty ) { $self->want_writeready_for_write( 0 ); $self->maybe_invoke_event( on_outgoing_empty => ); $self->close_now if $self->{stream_closing}; } } sub _flush_one_read { my $self = shift; my ( $eof ) = @_; local $self->{flushing_read} = 1; my $readqueue = $self->{readqueue}; my $ret; if( $readqueue->[0] and my $on_read = $readqueue->[0]->on_read ) { $ret = $on_read->( $self, \$self->{readbuff}, $eof ); } else { $ret = $self->invoke_event( on_read => \$self->{readbuff}, $eof ); } if( defined $self->{read_low_watermark} and $self->{at_read_high_watermark} and length $self->{readbuff} < $self->{read_low_watermark} ) { undef $self->{at_read_high_watermark}; $self->invoke_event( on_read_low_watermark => length $self->{readbuff} ); } if( ref $ret eq "CODE" ) { # Replace the top CODE, or add it if there was none $readqueue->[0] = Reader( $ret, undef ); return 1; } elsif( @$readqueue and !defined $ret ) { shift @$readqueue; return 1; } else { return $ret && ( length( $self->{readbuff} ) > 0 || $eof ); } } sub _sysread { my $self = shift; my ( $handle, undef, $len ) = @_; return $handle->sysread( $_[1], $len ); } sub on_read_ready { my $self = shift; $self->_do_read if $self->{want} & WANT_READ_FOR_READ; $self->_do_write if $self->{want} & WANT_READ_FOR_WRITE; } sub _do_read { my $self = shift; my $handle = $self->read_handle; my $reader = $self->{reader}; while(1) { my $data; my $len = $self->$reader( $handle, $data, $self->{read_len} ); if( !defined $len ) { my $errno = $!; return if _nonfatal_error( $errno ); $self->debug_printf( "READ err=%d/%s", $errno, $errno ) if $IO::Async::Debug::DEBUG > 1; $self->maybe_invoke_event( on_read_error => $errno ) or $self->close_now; foreach ( @{ $self->{readqueue} } ) { $_->future->fail( "read failed: $errno", sysread => $errno ) if $_->future; } undef @{ $self->{readqueue} }; return; } if( $IO::Async::Debug::DEBUG > 1 ) { $self->debug_printf( "READ len=%d", $len ); IO::Async::Debug::log_hexdump( $data ) if $IO::Async::Debug::DEBUG_FLAGS{Sr}; } $METRICS and $METRICS->inc_counter_by( stream_read => $len ) if $len; my $eof = $self->{read_eof} = ( $len == 0 ); if( my $encoding = $self->{encoding} ) { my $bytes = defined $self->{bytes_remaining} ? $self->{bytes_remaining} . $data : $data; $data = $encoding->decode( $bytes, STOP_AT_PARTIAL ); $self->{bytes_remaining} = $bytes; } $self->{readbuff} .= $data if !$eof; 1 while $self->_flush_one_read( $eof ); if( $eof ) { $self->debug_printf( "READ-EOF" ); $self->maybe_invoke_event( on_read_eof => ); $self->close_now if $self->{close_on_read_eof}; foreach ( @{ $self->{readqueue} } ) { $_->future->done( undef ) if $_->future; } undef @{ $self->{readqueue} }; return; } last unless $self->{read_all}; } if( defined $self->{read_high_watermark} and length $self->{readbuff} >= $self->{read_high_watermark} ) { $self->{at_read_high_watermark} or $self->invoke_event( on_read_high_watermark => length $self->{readbuff} ); $self->{at_read_high_watermark} = 1; } } sub on_read_high_watermark { my $self = shift; $self->want_readready_for_read( 0 ); } sub on_read_low_watermark { my $self = shift; $self->want_readready_for_read( 1 ); } =head2 push_on_read $stream->push_on_read( $on_read ); Pushes a new temporary C handler to the end of the queue. This queue, if non-empty, is used to provide C event handling code in preference to using the object's main event handler or method. New handlers can be supplied at any time, and they will be used in first-in first-out (FIFO) order. As with the main C event handler, each can return a (defined) boolean to indicate if they wish to be invoked again or not, another C reference to replace themself with, or C to indicate it is now complete and should be removed. When a temporary handler returns C it is shifted from the queue and the next one, if present, is invoked instead. If there are no more then the object's main handler is invoked instead. =cut sub push_on_read { my $self = shift; my ( $on_read, %args ) = @_; # %args undocumented for internal use push @{ $self->{readqueue} }, Reader( $on_read, $args{future} ); # TODO: Should this always defer? return if $self->{flushing_read}; 1 while length $self->{readbuff} and $self->_flush_one_read( 0 ); } =head1 FUTURE-RETURNING READ METHODS The following methods all return a L which will become ready when enough data has been read by the Stream into its buffer. At this point, the data is removed from the buffer and given to the C object to complete it. my $string = await $stream->read_... Unlike the C event handlers, these methods don't allow for access to "partial" results; they only provide the final result once it is ready. If a C is cancelled before it completes it is removed from the read queue without consuming any data; i.e. each C atomically either completes or is cancelled. Since it is possible to use a readable C entirely using these C-returning methods instead of the C event, it may be useful to configure a trivial return-false event handler to keep it from consuming any input, and to allow it to be added to a C in the first place. my $stream = IO::Async::Stream->new( on_read => sub { 0 }, ... ); $loop->add( $stream ); my $f = $stream->read_... If a read EOF or error condition happens while there are read Cs pending, they are all completed. In the case of a read EOF, they are done with C; in the case of a read error they are failed using the C<$!> error value as the failure. $f->fail( $message, sysread => $! ) If a read EOF condition happens to the currently-processing read C, it will return a partial result. The calling code can detect this by the fact that the returned data is not complete according to the specification (too short in C's case, or lacking the ending pattern in C's case). Additionally, each C will yield the C<$eof> value in its results. my ( $string, $eof ) = await ...; =cut sub _read_future { my $self = shift; my $f = $self->loop->new_future; $f->on_cancel( $self->_capture_weakself( sub { my $self = shift or return; 1 while $self->_flush_one_read; })); return $f; } =head2 read_atmost =head2 read_exactly ( $string, $eof ) = await $stream->read_atmost( $len ); ( $string, $eof ) = await $stream->read_exactly( $len ); Completes the C when the read buffer contains C<$len> or more characters of input. C will also complete after the first invocation of C, even if fewer characters are available, whereas C will wait until at least C<$len> are available. =cut sub read_atmost { my $self = shift; my ( $len ) = @_; my $f = $self->_read_future; $self->push_on_read( sub { my ( undef, $buffref, $eof ) = @_; return undef if $f->is_cancelled; $f->done( substr( $$buffref, 0, $len, "" ), $eof ); return undef; }, future => $f ); return $f; } sub read_exactly { my $self = shift; my ( $len ) = @_; my $f = $self->_read_future; $self->push_on_read( sub { my ( undef, $buffref, $eof ) = @_; return undef if $f->is_cancelled; return 0 unless $eof or length $$buffref >= $len; $f->done( substr( $$buffref, 0, $len, "" ), $eof ); return undef; }, future => $f ); return $f; } =head2 read_until ( $string, $eof ) = await $stream->read_until( $end ); Completes the C when the read buffer contains a match for C<$end>, which may either be a plain string or a compiled C reference. Yields the prefix of the buffer up to and including this match. =cut sub read_until { my $self = shift; my ( $until ) = @_; ref $until or $until = qr/\Q$until\E/; my $f = $self->_read_future; $self->push_on_read( sub { my ( undef, $buffref, $eof ) = @_; return undef if $f->is_cancelled; if( $$buffref =~ $until ) { $f->done( substr( $$buffref, 0, $+[0], "" ), $eof ); return undef; } elsif( $eof ) { $f->done( $$buffref, $eof ); $$buffref = ""; return undef; } else { return 0; } }, future => $f ); return $f; } =head2 read_until_eof ( $string, $eof ) = await $stream->read_until_eof; Completes the C when the stream is eventually closed at EOF, and yields all of the data that was available. =cut sub read_until_eof { my $self = shift; my $f = $self->_read_future; $self->push_on_read( sub { my ( undef, $buffref, $eof ) = @_; return undef if $f->is_cancelled; return 0 unless $eof; $f->done( $$buffref, $eof ); $$buffref = ""; return undef; }, future => $f ); return $f; } =head1 UTILITY CONSTRUCTORS =cut =head2 new_for_stdin =head2 new_for_stdout =head2 new_for_stdio $stream = IO::Async::Stream->new_for_stdin; $stream = IO::Async::Stream->new_for_stdout; $stream = IO::Async::Stream->new_for_stdio; Return a C object preconfigured with the correct C, C or both. =cut sub new_for_stdin { shift->new( read_handle => \*STDIN, @_ ) } sub new_for_stdout { shift->new( write_handle => \*STDOUT, @_ ) } sub new_for_stdio { shift->new( read_handle => \*STDIN, write_handle => \*STDOUT, @_ ) } =head2 connect $future = $stream->connect( %args ); A convenient wrapper for calling the C method on the underlying L object, passing the C hint as C if not otherwise supplied. =cut sub connect { my $self = shift; return $self->SUPER::connect( socktype => "stream", @_ ); } =head1 DEBUGGING FLAGS The following flags in C enable extra logging: =over 4 =item C Log byte buffers as data is read from a Stream =item C Log byte buffers as data is written to a Stream =back =cut =head1 EXAMPLES =head2 A line-based C method The following C method accepts incoming C<\n>-terminated lines and prints them to the program's C stream. sub on_read { my $self = shift; my ( $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*\n)// ) { print "Received a line: $1"; } return 0; } Because a reference to the buffer itself is passed, it is simple to use a C regular expression on the scalar it points at, to both check if data is ready (i.e. a whole line), and to remove it from the buffer. Since it always removes as many complete lines as possible, it doesn't need invoking again when it has finished, so it can return a constant C<0>. =head2 Reading binary data This C method accepts incoming records in 16-byte chunks, printing each one. sub on_read { my ( $self, $buffref, $eof ) = @_; if( length $$buffref >= 16 ) { my $record = substr( $$buffref, 0, 16, "" ); print "Received a 16-byte record: $record\n"; return 1; } if( $eof and length $$buffref ) { print "EOF: a partial record still exists\n"; } return 0; } This time, rather than a C loop we have decided to have the handler just process one record, and use the C mechanism to ask that the handler be invoked again if there still remains data that might contain another record; only stopping with C when we know we can't find one. The 4-argument form of C extracts the 16-byte record from the buffer and assigns it to the C<$record> variable, if there was enough data in the buffer to extract it. A lot of protocols use a fixed-size header, followed by a variable-sized body of data, whose size is given by one of the fields of the header. The following C method extracts messages in such a protocol. sub on_read { my ( $self, $buffref, $eof ) = @_; return 0 unless length $$buffref >= 8; # "N n n" consumes 8 bytes my ( $len, $x, $y ) = unpack "N n n", $$buffref; return 0 unless length $$buffref >= 8 + $len; substr( $$buffref, 0, 8, "" ); my $data = substr( $$buffref, 0, $len, "" ); print "A record with values x=$x y=$y\n"; return 1; } In this example, the header is Ced first, to extract the body length, and then the body is extracted. If the buffer does not have enough data yet for a complete message then C<0> is returned, and the buffer is left unmodified for next time. Only when there are enough bytes in total does it use C to remove them. =head2 Dynamic replacement of C Consider the following protocol (inspired by IMAP), which consists of C<\n>-terminated lines that may have an optional data block attached. The presence of such a data block, as well as its size, is indicated by the line prefix. sub on_read { my $self = shift; my ( $buffref, $eof ) = @_; if( $$buffref =~ s/^DATA (\d+):(.*)\n// ) { my $length = $1; my $line = $2; return sub { my $self = shift; my ( $buffref, $eof ) = @_; return 0 unless length $$buffref >= $length; # Take and remove the data from the buffer my $data = substr( $$buffref, 0, $length, "" ); print "Received a line $line with some data ($data)\n"; return undef; # Restore the original method } } elsif( $$buffref =~ s/^LINE:(.*)\n// ) { my $line = $1; print "Received a line $line with no data\n"; return 1; } else { print STDERR "Unrecognised input\n"; # Handle it somehow } } In the case where trailing data is supplied, a new temporary C callback is provided in a closure. This closure captures the C<$length> variable so it knows how much data to expect. It also captures the C<$line> variable so it can use it in the event report. When this method has finished reading the data, it reports the event, then restores the original method by returning C. =head1 SEE ALSO =over 4 =item * L - Supply object methods for I/O handles =back =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Test.pm000444001750001750 1206015001742754 15420 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2007-2024 -- leonerd@leonerd.org.uk package IO::Async::Test 0.804; use v5.14; use warnings; use Exporter 'import'; our @EXPORT = qw( testing_loop wait_for wait_for_stream wait_for_future ); =head1 NAME C - utility functions for use in test scripts =head1 SYNOPSIS use Test2::V0; use Future::AsyncAwait; use IO::Async::Test; use IO::Async::Loop; my $loop = IO::Async::Loop->new; testing_loop( $loop ); my $result; $loop->do_something( some => args, on_done => sub { $result = the_outcome; } ); wait_for { defined $result }; is( $result, what_we_expected, 'The event happened' ); ... my $buffer = ""; my $handle = IO::Handle-> ... wait_for_stream { length $buffer >= 10 } $handle => $buffer; is( substr( $buffer, 0, 10, "" ), "0123456789", 'Buffer was correct' ); my $result = await wait_for_future( $stream->read_until( "\n" ) ); done_testing; =head1 DESCRIPTION This module provides utility functions that may be useful when writing test scripts for code which uses L (as well as being used in the L test scripts themselves). Test scripts are often synchronous by nature; they are a linear sequence of actions to perform, interspersed with assertions which check for given conditions. This goes against the very nature of L which, being an asynchronisation framework, does not provide a linear stepped way of working. In order to write a test, the C function provides a way of synchronising the code, so that a given condition is known to hold, which would typically signify that some event has occurred, the outcome of which can now be tested using the usual testing primitives. Because the primary purpose of L is to provide IO operations on filehandles, a great many tests will likely be based around connected pipes or socket handles. The C function provides a convenient way to wait for some content to be written through such a connected stream. =cut my $loop; END { undef $loop } =head1 FUNCTIONS =cut =head2 testing_loop testing_loop( $loop ); Set the L object which the C function will loop on. =cut sub testing_loop { $loop = shift; } =head2 wait_for wait_for { COND } OPTS; Repeatedly call the C method on the underlying loop (given to the C function), until the given condition function callback returns true. To guard against stalled scripts, if the loop indicates a timeout for (a default of) 10 consequentive seconds, then an error is thrown. Takes the following named options: =over 4 =item timeout => NUM The time in seconds to wait before giving up the test as being stalled. Defaults to 10 seconds. =back =cut our $Level = 0; sub wait_for(&@) { my ( $cond, %opts ) = @_; my ( undef, $callerfile, $callerline ) = caller( $Level ); my $timedout = 0; my $timerid = $loop->watch_time( after => $opts{timeout} // 10, code => sub { $timedout = 1 }, ); $loop->loop_once( 1 ) while !$cond->() and !$timedout; if( $timedout ) { die "Nothing was ready after 10 second wait; called at $callerfile line $callerline\n"; } else { $loop->unwatch_time( $timerid ); } } =head2 wait_for_stream wait_for_stream { COND } $handle, $buffer; As C, but will also watch the given IO handle for readability, and whenever it is readable will read bytes in from it into the given buffer. The buffer is NOT initialised when the function is entered, in case data remains from a previous call. C<$buffer> can also be a CODE reference, in which case it will be invoked being passed data read from the handle, whenever it is readable. =cut sub wait_for_stream(&$$) { my ( $cond, $handle, undef ) = @_; my $on_read; if( ref $_[2] eq "CODE" ) { $on_read = $_[2]; } else { my $varref = \$_[2]; $on_read = sub { $$varref .= $_[0] }; } $loop->watch_io( handle => $handle, on_read_ready => sub { my $ret = $handle->sysread( my $buffer, 8192 ); if( !defined $ret ) { die "Read failed on $handle - $!\n"; } elsif( $ret == 0 ) { die "Read returned EOF on $handle\n"; } $on_read->( $buffer ); } ); local $Level = $Level + 1; # Have to defeat the prototype... grr I hate these &wait_for( $cond ); $loop->unwatch_io( handle => $handle, on_read_ready => 1, ); } =head2 wait_for_future $future = wait_for_future $future; I A handy wrapper around using C to wait for a L to become ready. The future instance itself is returned, allowing neater code. =cut sub wait_for_future { my ( $future ) = @_; local $Level = $Level + 1; wait_for { $future->is_ready }; return $future; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Timer.pm000444001750001750 710615001742754 15546 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2009-2024 -- leonerd@leonerd.org.uk package IO::Async::Timer 0.804; use v5.14; use warnings; use base qw( IO::Async::Notifier ); use Carp; =head1 NAME C - base class for Notifiers that use timed delays =head1 DESCRIPTION This module provides a subclass of L for implementing notifiers that use timed delays. For specific implementations, see one of the subclasses: =over 8 =item * L - event callback at a fixed future time =item * L - event callback after a fixed delay =item * L - event callback at regular intervals =back =cut =head1 CONSTRUCTOR =cut =head2 new $timer = IO::Async::Timer->new( %args ); Constructs a particular subclass of C object, and returns it. This constructor is provided for backward compatibility to older code which doesn't use the subclasses. New code should directly construct a subclass instead. =over 8 =item mode => STRING The type of timer to create. Currently the only allowed mode is C but more types may be added in the future. =back Once constructed, the C will need to be added to the C before it will work. It will also need to be started by the C method. =cut sub new { my $class = shift; my %args = @_; if( my $mode = delete $args{mode} ) { # Might define some other modes later $mode eq "countdown" or croak "Expected 'mode' to be 'countdown'"; require IO::Async::Timer::Countdown; return IO::Async::Timer::Countdown->new( %args ); } return $class->SUPER::new( %args ); } sub _add_to_loop { my $self = shift; $self->start if delete $self->{pending}; } sub _remove_from_loop { my $self = shift; $self->stop; } =head1 METHODS =cut =head2 is_running $running = $timer->is_running; Returns true if the Timer has been started, and has not yet expired, or been stopped. =cut sub is_running { my $self = shift; defined $self->{id}; } =head2 start $timer->start; Starts the Timer. Throws an error if it was already running. If the Timer is not yet in a Loop, the actual start will be deferred until it is added. Once added, it will be running, and will expire at the given duration after the time it was added. As a convenience, C<$timer> is returned. This may be useful for starting timers at construction time: $loop->add( IO::Async::Timer->new( ... )->start ); =cut sub start { my $self = shift; my $loop = $self->loop; if( !defined $loop ) { $self->{pending} = 1; return $self; } defined $self->{id} and croak "Cannot start a Timer that is already running"; if( !$self->{cb} ) { $self->{cb} = $self->_make_cb; } $self->{id} = $loop->watch_time( $self->_make_enqueueargs, code => $self->{cb}, ); return $self; } =head2 stop $timer->stop; Stops the Timer if it is running. If it has not yet been added to the C but there is a start pending, this will cancel it. =cut sub stop { my $self = shift; if( $self->{pending} ) { delete $self->{pending}; return; } return if !$self->is_running; my $loop = $self->loop or croak "Cannot stop a Timer that is not in a Loop"; defined $self->{id} or return; # nothing to do but no error $loop->unwatch_time( $self->{id} ); undef $self->{id}; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Internals000755001750001750 015001742754 15726 5ustar00leoleo000000000000IO-Async-0.804/lib/IO/Async/Internals/ChildManager.pm000444001750001750 2721315001742754 20764 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2007-2024 -- leonerd@leonerd.org.uk package IO::Async::Internals::ChildManager 0.804; use v5.14; use warnings; # Not a notifier use IO::Async::Stream; use IO::Async::OS; use Carp; use Scalar::Util qw( weaken ); use POSIX qw( _exit dup dup2 nice ); use constant LENGTH_OF_I => length( pack( "I", 0 ) ); # Writing to variables of $> and $) have tricky ways to obtain error results sub setuid { my ( $uid ) = @_; $> = $uid; my $saved_errno = $!; $> == $uid and return 1; $! = $saved_errno; return undef; } sub setgid { my ( $gid ) = @_; $) = $gid; my $saved_errno = $!; $) == $gid and return 1; $! = $saved_errno; return undef; } sub setgroups { my @groups = @_; my $gid = $)+0; # Put the primary GID as the first group in the supplementary list, because # some operating systems ignore this position, expecting it to indeed be # the primary GID. # See # https://rt.cpan.org/Ticket/Display.html?id=65127 @groups = grep { $_ != $gid } @groups; $) = "$gid $gid " . join " ", @groups; my $saved_errno = $!; # No easy way to detect success or failure. Just check that we have all and # only the right groups my %gotgroups = map { $_ => 1 } split ' ', "$)"; $! = $saved_errno; $gotgroups{$_}-- or return undef for @groups; keys %gotgroups or return undef; return 1; } # Internal constructor sub new { my $class = shift; my ( %params ) = @_; my $loop = delete $params{loop} or croak "Expected a 'loop'"; my $self = bless { loop => $loop, }, $class; weaken( $self->{loop} ); return $self; } sub spawn_child { my $self = shift; my %params = @_; my $command = delete $params{command}; my $code = delete $params{code}; my $setup = delete $params{setup}; my $on_exit = delete $params{on_exit}; if( %params ) { croak "Unrecognised options to spawn: " . join( ",", keys %params ); } defined $command and defined $code and croak "Cannot pass both 'command' and 'code' to spawn"; defined $command or defined $code or croak "Must pass one of 'command' or 'code' to spawn"; my @setup = defined $setup ? $self->_check_setup_and_canonicise( $setup ) : (); my $loop = $self->{loop}; my ( $readpipe, $writepipe ); { # Ensure it's FD_CLOEXEC - this is a bit more portable than manually # fiddling with F_GETFL and F_SETFL (e.g. MSWin32) local $^F = -1; ( $readpipe, $writepipe ) = IO::Async::OS->pipepair or croak "Cannot pipe() - $!"; $readpipe->blocking( 0 ); } if( defined $command ) { my @command = ref( $command ) ? @$command : ( $command ); $code = sub { no warnings; exec( @command ); return; }; } my $kid = $loop->fork( code => sub { # Child close( $readpipe ); $self->_spawn_in_child( $writepipe, $code, \@setup ); }, ); # Parent close( $writepipe ); return $self->_spawn_in_parent( $readpipe, $kid, $on_exit ); } sub _check_setup_and_canonicise { my $self = shift; my ( $setup ) = @_; ref $setup eq "ARRAY" or croak "'setup' must be an ARRAY reference"; return () if !@$setup; my @setup; my $has_setgroups; foreach my $i ( 0 .. $#$setup / 2 ) { my ( $key, $value ) = @$setup[$i*2, $i*2 + 1]; # Rewrite stdin/stdout/stderr $key eq "stdin" and $key = "fd0"; $key eq "stdout" and $key = "fd1"; $key eq "stderr" and $key = "fd2"; # Rewrite other filehandles ref $key and eval { $key->fileno; 1 } and $key = "fd" . $key->fileno; if( $key =~ m/^fd(\d+)$/ ) { my $fd = $1; my $ref = ref $value; if( !$ref ) { $value = [ $value ]; } elsif( $ref eq "ARRAY" ) { # Already OK } elsif( $ref eq "GLOB" or eval { $value->isa( "IO::Handle" ) } ) { $value = [ 'dup', $value ]; } else { croak "Unrecognised reference type '$ref' for file descriptor $fd"; } my $operation = $value->[0]; grep { $_ eq $operation } qw( open close dup keep ) or croak "Unrecognised operation '$operation' for file descriptor $fd"; } elsif( $key eq "env" ) { ref $value eq "HASH" or croak "Expected HASH reference for 'env' setup key"; } elsif( $key eq "nice" ) { $value =~ m/^\d+$/ or croak "Expected integer for 'nice' setup key"; } elsif( $key eq "chdir" ) { # This isn't a purely watertight test, but it does guard against # silly things like passing a reference - directories such as # ARRAY(0x12345) are unlikely to exist -d $value or croak "Working directory '$value' does not exist"; } elsif( $key eq "setuid" ) { $value =~ m/^\d+$/ or croak "Expected integer for 'setuid' setup key"; } elsif( $key eq "setgid" ) { $value =~ m/^\d+$/ or croak "Expected integer for 'setgid' setup key"; $has_setgroups and carp "It is suggested to 'setgid' before 'setgroups'"; } elsif( $key eq "setgroups" ) { ref $value eq "ARRAY" or croak "Expected ARRAY reference for 'setgroups' setup key"; m/^\d+$/ or croak "Expected integer in 'setgroups' array" for @$value; $has_setgroups = 1; } else { croak "Unrecognised setup operation '$key'"; } push @setup, $key => $value; } return @setup; } sub _spawn_in_parent { my $self = shift; my ( $readpipe, $kid, $on_exit ) = @_; my $loop = $self->{loop}; # We need to wait for both the errno pipe to close, and for waitpid # to give us an exit code. We'll form two closures over these two # variables so we can cope with those happening in either order my $dollarbang; my ( $dollarat, $length_dollarat ); my $exitcode; my $pipeclosed = 0; $loop->add( IO::Async::Stream->new( notifier_name => "statuspipe,kid=$kid", read_handle => $readpipe, on_read => sub { my ( $self, $buffref, $eof ) = @_; if( !defined $dollarbang ) { if( length( $$buffref ) >= 2 * LENGTH_OF_I ) { ( $dollarbang, $length_dollarat ) = unpack( "II", $$buffref ); substr( $$buffref, 0, 2 * LENGTH_OF_I, "" ); return 1; } } elsif( !defined $dollarat ) { if( length( $$buffref ) >= $length_dollarat ) { $dollarat = substr( $$buffref, 0, $length_dollarat, "" ); return 1; } } if( $eof ) { $dollarbang = 0 if !defined $dollarbang; if( !defined $length_dollarat ) { $length_dollarat = 0; $dollarat = ""; } $pipeclosed = 1; if( defined $exitcode ) { local $! = $dollarbang; $on_exit->( $kid, $exitcode, $!, $dollarat ); } } return 0; } ) ); $loop->watch_process( $kid => sub { ( my $kid, $exitcode ) = @_; if( $pipeclosed ) { local $! = $dollarbang; $on_exit->( $kid, $exitcode, $!, $dollarat ); } } ); return $kid; } sub _spawn_in_child { my $self = shift; my ( $writepipe, $code, $setup ) = @_; my $exitvalue = eval { # Map of which handles will be in use by the end my %fd_in_use = ( 0 => 1, 1 => 1, 2 => 1 ); # Keep STDIN, STDOUT, STDERR # Count of how many times we'll need to use the current handles. my %fds_refcount = %fd_in_use; # To dup2() without clashes we might need to temporarily move some handles my %dup_from; my $max_fd = 0; my $writepipe_clashes = 0; if( @$setup ) { # The writepipe might be in the way of a setup filedescriptor. If it # is we'll have to dup2 it out of the way then close the original. foreach my $i ( 0 .. $#$setup/2 ) { my ( $key, $value ) = @$setup[$i*2, $i*2 + 1]; $key =~ m/^fd(\d+)$/ or next; my $fd = $1; $max_fd = $fd if $fd > $max_fd; $writepipe_clashes = 1 if $fd == fileno $writepipe; my ( $operation, @params ) = @$value; $operation eq "close" and do { delete $fd_in_use{$fd}; delete $fds_refcount{$fd}; }; $operation eq "dup" and do { $fd_in_use{$fd} = 1; my $fileno = fileno $params[0]; # Keep a count of how many times it will be dup'ed from so we # can close it once we've finished $fds_refcount{$fileno}++; $dup_from{$fileno} = $fileno; }; $operation eq "keep" and do { $fds_refcount{$fd} = 1; }; } } foreach ( IO::Async::OS->potentially_open_fds ) { next if $fds_refcount{$_}; next if $_ == fileno $writepipe; POSIX::close( $_ ); } if( @$setup ) { if( $writepipe_clashes ) { $max_fd++; dup2( fileno $writepipe, $max_fd ) or die "Cannot dup2(writepipe to $max_fd) - $!\n"; undef $writepipe; open( $writepipe, ">&=$max_fd" ) or die "Cannot fdopen($max_fd) as writepipe - $!\n"; } foreach my $i ( 0 .. $#$setup/2 ) { my ( $key, $value ) = @$setup[$i*2, $i*2 + 1]; if( $key =~ m/^fd(\d+)$/ ) { my $fd = $1; my( $operation, @params ) = @$value; $operation eq "dup" and do { my $from = fileno $params[0]; if( $from != $fd ) { if( exists $dup_from{$fd} ) { defined( $dup_from{$fd} = dup( $fd ) ) or die "Cannot dup($fd) - $!"; } my $real_from = $dup_from{$from}; POSIX::close( $fd ); dup2( $real_from, $fd ) or die "Cannot dup2($real_from to $fd) - $!\n"; } $fds_refcount{$from}--; if( !$fds_refcount{$from} and !$fd_in_use{$from} ) { POSIX::close( $from ); delete $dup_from{$from}; } }; $operation eq "open" and do { my ( $mode, $filename ) = @params; open( my $fh, $mode, $filename ) or die "Cannot open('$mode', '$filename') - $!\n"; my $from = fileno $fh; dup2( $from, $fd ) or die "Cannot dup2($from to $fd) - $!\n"; close $fh; }; } elsif( $key eq "env" ) { %ENV = %$value; } elsif( $key eq "nice" ) { nice( $value ) or die "Cannot nice($value) - $!"; } elsif( $key eq "chdir" ) { chdir( $value ) or die "Cannot chdir('$value') - $!"; } elsif( $key eq "setuid" ) { setuid( $value ) or die "Cannot setuid('$value') - $!"; } elsif( $key eq "setgid" ) { setgid( $value ) or die "Cannot setgid('$value') - $!"; } elsif( $key eq "setgroups" ) { setgroups( @$value ) or die "Cannot setgroups() - $!"; } } } $code->(); }; my $writebuffer = ""; $writebuffer .= pack( "I", $!+0 ); $writebuffer .= pack( "I", length( $@ ) ) . $@; syswrite( $writepipe, $writebuffer ); return $exitvalue; } 0x55AA; IO-Async-0.804/lib/IO/Async/Internals/Connector.pm000444001750001750 2050115001742754 20371 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2008-2024 -- leonerd@leonerd.org.uk package # hide from CPAN IO::Async::Internals::Connector 0.802; use v5.14; use warnings; use Scalar::Util qw( weaken blessed ); use POSIX qw( EINPROGRESS ); use Socket qw( SOL_SOCKET SO_ERROR ); use Future 0.44; # ->result use Future::Utils 0.18 qw( try_repeat_until_success ); use IO::Async::OS; use Carp; use constant { CONNECT_EWOULDLBOCK => IO::Async::OS->HAVE_CONNECT_EWOULDBLOCK, HAVE_SOCKADDR_IN6 => IO::Async::OS->HAVE_SOCKADDR_IN6, }; # Internal constructor sub new { my $class = shift; my ( %params ) = @_; my $loop = delete $params{loop} or croak "Expected a 'loop'"; my $self = bless {}, $class; weaken( $self->{loop} = $loop ); return $self; } ## Utility function sub _get_sock_err { my ( $sock ) = @_; my $err = $sock->getsockopt( SOL_SOCKET, SO_ERROR ); if( defined $err ) { # 0 means no error, but is still defined return undef if !$err; $! = $err; return $!; } # It seems we can't call getsockopt to query SO_ERROR. We'll try getpeername if( defined getpeername( $sock ) ) { return undef; } my $peername_errno = $!+0; my $peername_errstr = "$!"; # Not connected so we know this ought to fail if( read( $sock, my $buff, 1 ) ) { # That was most unexpected. getpeername fails because we're not # connected, yet read succeeds. warn "getpeername fails with $peername_errno ($peername_errstr) but read is successful\n"; warn "Please see http://rt.cpan.org/Ticket/Display.html?id=38382\n"; $! = $peername_errno; return $!; } return $!; } sub _connect_addresses { my $self = shift; my ( $addrlist, $on_fail ) = @_; my $loop = $self->{loop}; my ( $connecterr, $binderr, $socketerr ); my $future = try_repeat_until_success { my $addr = shift; my ( $family, $socktype, $protocol, $localaddr, $peeraddr ) = @{$addr}{qw( family socktype protocol localaddr peeraddr )}; my $sock = IO::Async::OS->socket( $family, $socktype, $protocol ); if( !$sock ) { $socketerr = $!; $on_fail->( "socket", $family, $socktype, $protocol, $! ) if $on_fail; return Future->fail( 1 ); } if( $localaddr and not $sock->bind( $localaddr ) ) { $binderr = $!; $on_fail->( "bind", $sock, $localaddr, $! ) if $on_fail; return Future->fail( 1 ); } $sock->blocking( 0 ); # TODO: $sock->connect returns success masking EINPROGRESS my $ret = connect( $sock, $peeraddr ); if( $ret ) { # Succeeded already? Dubious, but OK. Can happen e.g. with connections to # localhost, or UNIX sockets, or something like that. return Future->done( $sock ); } elsif( $! != EINPROGRESS and !CONNECT_EWOULDLBOCK || $! != POSIX::EWOULDBLOCK ) { $connecterr = $!; $on_fail->( "connect", $sock, $peeraddr, $! ) if $on_fail; return Future->fail( 1 ); } # Else my $f = $loop->new_future; $loop->watch_io( handle => $sock, on_write_ready => sub { $loop->unwatch_io( handle => $sock, on_write_ready => 1 ); my $err = _get_sock_err( $sock ); return $f->done( $sock ) if !$err; $connecterr = $!; $on_fail->( "connect", $sock, $peeraddr, $err ) if $on_fail; return $f->fail( 1 ); }, ); $f->on_cancel( sub { $loop->unwatch_io( handle => $sock, on_write_ready => 1 ); } ); return $f; } foreach => $addrlist; return $future->else_with_f( sub { my $f = shift; return $future->new->fail( "connect: $connecterr", connect => connect => $connecterr ) if $connecterr; return $future->new->fail( "bind: $binderr", connect => bind => $binderr ) if $binderr; return $future->new->fail( "socket: $socketerr", connect => socket => $socketerr ) if $socketerr; # If it gets this far then something went wrong return $f; } ); } sub connect { my $self = shift; my ( %params ) = @_; my $loop = $self->{loop}; my $on_fail = $params{on_fail}; my %gai_hints; exists $params{$_} and $gai_hints{$_} = $params{$_} for qw( family socktype protocol flags ); if( exists $params{host} or exists $params{local_host} or exists $params{local_port} ) { # We'll be making a ->getaddrinfo call defined $gai_hints{socktype} or defined $gai_hints{protocol} or carp "Attempting to ->connect without either 'socktype' or 'protocol' hint is not portable"; } my $peeraddrfuture; if( exists $params{host} and exists $params{service} ) { my $host = $params{host} or croak "Expected 'host'"; my $service = $params{service} or croak "Expected 'service'"; $peeraddrfuture = $loop->resolver->getaddrinfo( host => $host, service => $service, %gai_hints, ); } elsif( exists $params{addrs} or exists $params{addr} ) { my @addrs = exists $params{addrs} ? @{ $params{addrs} } : ( $params{addr} ); # Warn about some common mistakes foreach my $peer ( @addrs ) { my ( $p_family, undef, undef, $p_addr ) = IO::Async::OS->extract_addrinfo( $peer ); local our @CARP_NOT = qw( IO::Async::Loop IO::Async::Handle ); if( $p_family == Socket::AF_INET ) { carp "Connecting to 0.0.0.0 is non-portable and ill-advised" if ( Socket::unpack_sockaddr_in $p_addr )[1] eq Socket::INADDR_ANY; } elsif( HAVE_SOCKADDR_IN6 and $p_family == Socket::AF_INET6 ) { carp "Connecting to :: is non-portable and ill-advised" if ( Socket::unpack_sockaddr_in6 $p_addr )[1] eq Socket::IN6ADDR_ANY; } } $peeraddrfuture = $loop->new_future->done( @addrs ); } elsif( exists $params{peer} ) { my $peer = delete $params{peer}; croak "Expected 'peer' to be an IO::Socket or subclass" unless blessed $peer and $peer->isa( "IO::Socket" ); my $p_family = $peer->sockdomain; $peeraddrfuture = $loop->new_future->done( [ $p_family, $peer->socktype, $peer->protocol, IO::Async::OS->make_addr_for_peer( $p_family, $peer->sockname ) ] ); } else { croak "Expected 'host' and 'service' or 'addrs' or 'addr' arguments"; } my $localaddrfuture; if( defined $params{local_host} or defined $params{local_service} ) { # Empty is fine on either of these my $host = $params{local_host}; my $service = $params{local_service}; $localaddrfuture = $loop->resolver->getaddrinfo( host => $host, service => $service, %gai_hints, ); } elsif( exists $params{local_addrs} or exists $params{local_addr} ) { $localaddrfuture = $loop->new_future->done( exists $params{local_addrs} ? @{ $params{local_addrs} } : ( $params{local_addr} ) ); } else { $localaddrfuture = $loop->new_future->done( {} ); } return Future->needs_all( $peeraddrfuture, $localaddrfuture ) ->then( sub { my @peeraddrs = $peeraddrfuture->result; my @localaddrs = $localaddrfuture->result; my @addrs; foreach my $local ( @localaddrs ) { my ( $l_family, $l_socktype, $l_protocol, $l_addr ) = IO::Async::OS->extract_addrinfo( $local, 'local_addr' ); foreach my $peer ( @peeraddrs ) { my ( $p_family, $p_socktype, $p_protocol, $p_addr ) = IO::Async::OS->extract_addrinfo( $peer ); next if $l_family and $p_family and $l_family != $p_family; next if $l_socktype and $p_socktype and $l_socktype != $p_socktype; next if $l_protocol and $p_protocol and $l_protocol != $p_protocol; push @addrs, { family => $l_family || $p_family, socktype => $l_socktype || $p_socktype, protocol => $l_protocol || $p_protocol, localaddr => $l_addr, peeraddr => $p_addr, }; } } return $self->_connect_addresses( \@addrs, $on_fail ); } ); } 0x55AA; IO-Async-0.804/lib/IO/Async/Internals/FunctionWorker.pm000444001750001750 310515001742754 21377 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2024 -- leonerd@leonerd.org.uk package IO::Async::Internals::FunctionWorker 0.804; use v5.14; use warnings; # Called directly by IO::Async::Function::Worker when used in "code" mode, # or by run_worker() below. sub runloop { my ( $code, $arg_channel, $ret_channel ) = @_; while( my $args = $arg_channel->recv ) { my @ret; my $ok = eval { @ret = $code->( @$args ); 1 }; if( $ok ) { $ret_channel->send( [ r => @ret ] ); } elsif( ref $@ ) { # Presume that $@ is an ARRAYref of error results $ret_channel->send( [ e => @{ $@ } ] ); } else { chomp( my $e = "$@" ); $ret_channel->send( [ e => $e, error => ] ); } } } # Called by IO::Async::Function::Worker via the module+func arguments to its # IO::Async::Routine superclass when used in "module+func" mode sub run_worker { my ( $arg_channel, $ret_channel ) = @_; # Setup args my ( $module, $func, $init_func, @init_args ) = @{ $arg_channel->recv }; ( my $file = "$module.pm" ) =~ s{::}{/}g; require $file; my $code = $module->can( $func ) or die "Module $module does not provide a function called $func\n"; if( defined $init_func ) { my $init = $module->can( $init_func ) or die "Module $module does not provide a function called $init_func\n"; $init->( @init_args ); } runloop( $code, $arg_channel, $ret_channel ); } 0x55AA; IO-Async-0.804/lib/IO/Async/Internals/TimeQueue.pm000444001750001750 630715001742754 20332 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2006-2024 -- leonerd@leonerd.org.uk package # hide from CPAN IO::Async::Internals::TimeQueue 0.802; use v5.14; use warnings; use Carp; use Time::HiRes qw( time ); BEGIN { my @methods = qw( next_time _enqueue cancel _fire ); if( eval { require Heap::Fibonacci } ) { unshift our @ISA, "Heap::Fibonacci"; require Heap::Elem; no strict 'refs'; *$_ = \&{"HEAP_$_"} for @methods; } else { no strict 'refs'; *$_ = \&{"ARRAY_$_"} for "new", @methods; } } # High-level methods sub enqueue { my $self = shift; my ( %params ) = @_; my $code = delete $params{code}; ref $code or croak "Expected 'code' to be a reference"; defined $params{time} or croak "Expected 'time'"; my $time = $params{time}; $self->_enqueue( $time, $code ); } sub fire { my $self = shift; my ( %params ) = @_; my $now = exists $params{now} ? $params{now} : time; $self->_fire( $now ); } # Implementation using a Perl array use constant { TIME => 0, CODE => 1, }; sub ARRAY_new { my $class = shift; return bless [], $class; } sub ARRAY_next_time { my $self = shift; return @$self ? $self->[0]->[TIME] : undef; } sub ARRAY__enqueue { my $self = shift; my ( $time, $code ) = @_; # TODO: This could be more efficient maybe using a binary search my $idx = 0; $idx++ while $idx < @$self and $self->[$idx][TIME] <= $time; splice @$self, $idx, 0, ( my $elem = [ $time, $code ]); return $elem; } sub ARRAY_cancel { my $self = shift; my ( $id ) = @_; @$self = grep { $_ != $id } @$self; } sub ARRAY__fire { my $self = shift; my ( $now ) = @_; my $count = 0; while( @$self ) { last if( $self->[0]->[TIME] > $now ); my $top = shift @$self; $top->[CODE]->(); $count++; } return $count; } # Implementation using Heap::Fibonacci sub HEAP_next_time { my $self = shift; my $top = $self->top; return defined $top ? $top->time : undef; } sub HEAP__enqueue { my $self = shift; my ( $time, $code ) = @_; my $elem = IO::Async::Internals::TimeQueue::Elem->new( $time, $code ); $self->add( $elem ); return $elem; } sub HEAP_cancel { my $self = shift; my ( $id ) = @_; $self->delete( $id ); } sub HEAP__fire { my $self = shift; my ( $now ) = @_; my $count = 0; while( defined( my $top = $self->top ) ) { last if( $top->time > $now ); $self->extract_top; $top->code->(); $count++; } return $count; } package # hide from CPAN IO::Async::Internals::TimeQueue::Elem; our @ISA = qw( Heap::Elem ); sub new { my $self = shift; my $class = ref $self || $self; my ( $time, $code ) = @_; my $new = $class->SUPER::new( time => $time, code => $code, ); return $new; } sub time { my $self = shift; return $self->val->{time}; } sub code { my $self = shift; return $self->val->{code}; } # This only uses methods so is transparent to HASH or ARRAY sub cmp { my $self = shift; my $other = shift; $self->time <=> $other->time; } 0x55AA; IO-Async-0.804/lib/IO/Async/Loop000755001750001750 015001742754 14700 5ustar00leoleo000000000000IO-Async-0.804/lib/IO/Async/Loop/Poll.pm000444001750001750 2317015001742754 16324 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2007-2024 -- leonerd@leonerd.org.uk package IO::Async::Loop::Poll 0.804; use v5.14; use warnings; use constant API_VERSION => '0.49'; use base qw( IO::Async::Loop ); use Carp; use IO::Poll qw( POLLIN POLLOUT POLLPRI POLLHUP POLLERR ); use Errno qw( EINTR ); use Fcntl qw( S_ISREG ); # Only Linux, or FreeBSD 8.0 and above, are known always to be able to report # EOF conditions on filehandles using POLLHUP use constant _CAN_ON_HANGUP => ( $^O eq "linux" ) || ( $^O eq "freebsd" and do { no warnings 'numeric'; (POSIX::uname)[2] >= 8.0 } ); # poll() on most platforms claims that ISREG files are always read- and # write-ready, but not on MSWin32. We need to fake this use constant FAKE_ISREG_READY => IO::Async::OS->HAVE_FAKE_ISREG_READY; # poll() on most platforms indicates POLLOUT when connect() fails, but not on # MSWin32. Have to poll also for POLLPRI in that case use constant POLL_CONNECT_POLLPRI => IO::Async::OS->HAVE_POLL_CONNECT_POLLPRI; use constant _CAN_WATCHDOG => 1; use constant WATCHDOG_ENABLE => IO::Async::Loop->WATCHDOG_ENABLE; =head1 NAME C - use C with C =head1 SYNOPSIS Normally an instance of this class would not be directly constructed by a program. It may however, be useful for runinng L with an existing program already using an C object. use IO::Poll; use IO::Async::Loop::Poll; my $poll = IO::Poll->new; my $loop = IO::Async::Loop::Poll->new( poll => $poll ); $loop->add( ... ); while(1) { my $timeout = ... my $ret = $poll->poll( $timeout ); $loop->post_poll; } =head1 DESCRIPTION This subclass of L uses the C system call to perform read-ready and write-ready tests. By default, this loop will use the underlying C system call directly, bypassing the usual L object wrapper around it because of a number of bugs and design flaws in that class; namely =over 2 =item * L - IO::Poll relies on stable stringification of IO handles =item * L - IO::Poll->poll() with no handles always returns immediately =back However, to integrate with existing code that uses an C object, a C can be called immediately after the C method that C object. The appropriate mask bits are maintained on the C object when notifiers are added or removed from the loop, or when they change their C status. The C method inspects the result bits and invokes the C or C methods on the notifiers. =cut =head1 CONSTRUCTOR =cut =head2 new $loop = IO::Async::Loop::Poll->new( %args ); This function returns a new instance of a C object. It takes the following named arguments: =over 8 =item C The C object to use for notification. Optional; if a value is not given, the underlying C function is invoked directly, outside of the object wrapping. =back =cut sub new { my $class = shift; my ( %args ) = @_; my $poll = delete $args{poll}; my $self = $class->__new( %args ); $self->{poll} = $poll; $self->{pollmask} = {}; return $self; } =head1 METHODS =cut =head2 post_poll $count = $loop->post_poll; This method checks the returned event list from a C call, and calls any of the notification methods or callbacks that are appropriate. It returns the total number of callbacks that were invoked; that is, the total number of C and C callbacks for C, and C event callbacks. =cut sub post_poll { my $self = shift; my $iowatches = $self->{iowatches}; my $poll = $self->{poll}; my $count = 0; alarm( IO::Async::Loop->WATCHDOG_INTERVAL ) if WATCHDOG_ENABLE; foreach my $fd ( keys %$iowatches ) { my $watch = $iowatches->{$fd} or next; my $events = $poll ? $poll->events( $watch->[0] ) : $self->{pollevents}{$fd}; if( FAKE_ISREG_READY and $self->{fake_isreg}{$fd} ) { $events |= $self->{fake_isreg}{$fd} & ( POLLIN|POLLOUT ); } # We have to test separately because kernel doesn't report POLLIN when # a pipe gets closed. if( $events & (POLLIN|POLLHUP|POLLERR) ) { $count++, $watch->[1]->() if defined $watch->[1]; } if( $events & (POLLOUT|POLLPRI|POLLHUP|POLLERR) ) { $count++, $watch->[2]->() if defined $watch->[2]; } if( $events & (POLLHUP|POLLERR) ) { $count++, $watch->[3]->() if defined $watch->[3]; } } # Since we have no way to know if the timeout occurred, we'll have to # attempt to fire any waiting timeout events anyway $count += $self->_manage_queues; alarm( 0 ) if WATCHDOG_ENABLE; return $count; } sub is_running { my $self = shift; return $self->{running}; } =head2 loop_once $count = $loop->loop_once( $timeout ); This method calls the C method on the stored C object, passing in the value of C<$timeout>, and then runs the C method on itself. It returns the total number of callbacks invoked by the C method, or C if the underlying C method returned an error. =cut sub loop_once { my $self = shift; my ( $timeout ) = @_; $self->_adjust_timeout( \$timeout ); $timeout = 0 if FAKE_ISREG_READY and keys %{ $self->{fake_isreg} }; # Round up to nearest millisecond if( $timeout ) { my $mils = $timeout * 1000; my $fraction = $mils - int $mils; $timeout += ( 1 - $fraction ) / 1000 if $fraction; } if( my $poll = $self->{poll} ) { my $pollret; $self->pre_wait; # There is a bug in IO::Poll at least version 0.07, where poll with no # registered masks returns immediately, rather than waiting for a timeout # This has been reported: # http://rt.cpan.org/Ticket/Display.html?id=25049 if( $poll->handles ) { $pollret = $poll->poll( $timeout ); if( ( $pollret == -1 and $! == EINTR ) or $pollret == 0 and defined $self->{sigproxy} ) { # A signal occurred and we have a sigproxy. Allow one more poll # call with zero timeout. If it finds something, keep that result. # If it finds nothing, keep -1 # Preserve $! whatever happens local $!; my $secondattempt = $poll->poll( 0 ); $pollret = $secondattempt if $secondattempt > 0; } } else { # Workaround - we'll use select to fake a millisecond-accurate sleep $pollret = select( undef, undef, undef, $timeout ); } $self->post_wait; return undef unless defined $pollret; return $self->post_poll; } else { my @pollmasks = %{ $self->{pollmask} }; $self->pre_wait; # Perl 5.8.x's IO::Poll::_poll gets confused with no masks my $pollret; if( @pollmasks ) { my $msec = defined $timeout ? $timeout * 1000 : -1; $pollret = IO::Poll::_poll( $msec, @pollmasks ); if( $pollret == -1 and $! == EINTR or $pollret == 0 and $self->{sigproxy} ) { local $!; @pollmasks = %{ $self->{pollmask} }; my $secondattempt = IO::Poll::_poll( $msec, @pollmasks ); $pollret = $secondattempt if $secondattempt > 0; } } else { # Workaround - we'll use select to fake a millisecond-accurate sleep $pollret = select( undef, undef, undef, $timeout ); } $self->post_wait; return undef unless defined $pollret; $self->{pollevents} = { @pollmasks }; return $self->post_poll; } } sub watch_io { my $self = shift; my %params = @_; $self->__watch_io( %params ); my $poll = $self->{poll}; my $handle = $params{handle}; my $fileno = $handle->fileno; my $curmask = $poll ? $poll->mask( $handle ) : $self->{pollmask}{$fileno}; $curmask ||= 0; my $mask = $curmask; $params{on_read_ready} and $mask |= POLLIN; $params{on_write_ready} and $mask |= POLLOUT | (POLL_CONNECT_POLLPRI ? POLLPRI : 0); $params{on_hangup} and $mask |= POLLHUP; if( FAKE_ISREG_READY and S_ISREG +(stat $handle)[2] ) { $self->{fake_isreg}{$fileno} = $mask; } return if $mask == $curmask; if( $poll ) { $poll->mask( $handle, $mask ); } else { $self->{pollmask}{$fileno} = $mask; } } sub unwatch_io { my $self = shift; my %params = @_; $self->__unwatch_io( %params ); my $poll = $self->{poll}; my $handle = $params{handle}; my $fileno = $handle->fileno; my $curmask = $poll ? $poll->mask( $handle ) : $self->{pollmask}{$fileno}; $curmask ||= 0; my $mask = $curmask; $params{on_read_ready} and $mask &= ~POLLIN; $params{on_write_ready} and $mask &= ~(POLLOUT | (POLL_CONNECT_POLLPRI ? POLLPRI : 0)); $params{on_hangup} and $mask &= ~POLLHUP; if( FAKE_ISREG_READY and S_ISREG +(stat $handle)[2] ) { if( $mask ) { $self->{fake_isreg}{$handle->fileno} = $mask; } else { delete $self->{fake_isreg}{$handle->fileno}; } } return if $mask == $curmask; if( $poll ) { $poll->mask( $handle, $mask ); } else { $mask ? ( $self->{pollmask}{$fileno} = $mask ) : ( delete $self->{pollmask}{$fileno} ); } } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Loop/Select.pm000444001750001750 1610515001742754 16635 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2007-2024 -- leonerd@leonerd.org.uk package IO::Async::Loop::Select 0.804; use v5.14; use warnings; use constant API_VERSION => '0.49'; use base qw( IO::Async::Loop ); use IO::Async::OS; use Carp; # select() on most platforms claims that ISREG files are always read- and # write-ready, but not on MSWin32. We need to fake this use constant FAKE_ISREG_READY => IO::Async::OS->HAVE_FAKE_ISREG_READY; # select() on most platforms indicates write-ready when connect() fails, but # not on MSWin32. Have to pull from evec in that case use constant SELECT_CONNECT_EVEC => IO::Async::OS->HAVE_SELECT_CONNECT_EVEC; use constant _CAN_WATCHDOG => 1; use constant WATCHDOG_ENABLE => IO::Async::Loop->WATCHDOG_ENABLE; =head1 NAME C - use L with C =head1 SYNOPSIS Normally an instance of this class would not be directly constructed by a program. It may however, be useful for runinng L with an existing program already using a C-based event loop, a pair of methods C and C can be called immediately before and after a C call, setting the bits that the Loop is interested in. It will also adjust the C<$timeout> value if appropriate, reducing it if the next event timeout the Loop requires is sooner than the current value. =over 8 =item \$readvec =item \$writevec =item \$exceptvec Scalar references to the reading, writing and exception bitvectors =item \$timeout Scalar reference to the timeout value =back =cut sub pre_select { my $self = shift; my ( $readref, $writeref, $exceptref, $timeref ) = @_; # BITWISE operations $$readref |= $self->{rvec}; $$writeref |= $self->{wvec}; $$exceptref |= $self->{evec}; $self->_adjust_timeout( $timeref ); $$timeref = 0 if FAKE_ISREG_READY and length $self->{avec}; # Round up to nearest millisecond if( $$timeref ) { my $mils = $$timeref * 1000; my $fraction = $mils - int $mils; $$timeref += ( 1 - $fraction ) / 1000 if $fraction; } return; } =head2 post_select $loop->post_select( $readvec, $writevec, $exceptvec ); This method checks the returned bitvectors from a C syscall, performs it, then calls C to process the result. It returns the total number of callbacks invoked by the C method, or C if the underlying C syscall returned an error. =cut sub loop_once { my $self = shift; my ( $timeout ) = @_; my ( $rvec, $wvec, $evec ) = ('') x 3; $self->pre_select( \$rvec, \$wvec, \$evec, \$timeout ); $self->pre_wait; my $ret = select( $rvec, $wvec, $evec, $timeout ); $self->post_wait; if( $ret < 0 ) { # r/w/e vec can't be trusted $rvec = $wvec = $evec = ''; } { local $!; $self->post_select( $rvec, $wvec, $evec ); } return $ret; } sub watch_io { my $self = shift; my %params = @_; $self->__watch_io( %params ); my $fileno = $params{handle}->fileno; vec( $self->{rvec}, $fileno, 1 ) = 1 if $params{on_read_ready}; vec( $self->{wvec}, $fileno, 1 ) = 1 if $params{on_write_ready}; # MSWin32 does not indicate writeready for connect() errors, HUPs, etc # but it does indicate exceptional vec( $self->{evec}, $fileno, 1 ) = 1 if SELECT_CONNECT_EVEC and $params{on_write_ready}; vec( $self->{avec}, $fileno, 1 ) = 1 if FAKE_ISREG_READY and stat( $params{handle} ) and -f _; } sub unwatch_io { my $self = shift; my %params = @_; $self->__unwatch_io( %params ); my $fileno = $params{handle}->fileno; vec( $self->{rvec}, $fileno, 1 ) = 0 if $params{on_read_ready}; vec( $self->{wvec}, $fileno, 1 ) = 0 if $params{on_write_ready}; vec( $self->{evec}, $fileno, 1 ) = 0 if SELECT_CONNECT_EVEC and $params{on_write_ready}; vec( $self->{avec}, $fileno, 1 ) = 0 if FAKE_ISREG_READY and stat( $params{handle} ) and -f _; # vec will grow a bit vector as needed, but never shrink it. We'll trim # trailing null bytes $_ =~s/\0+\z// for $self->{rvec}, $self->{wvec}, $self->{evec}, $self->{avec}; } =head1 SEE ALSO =over 4 =item * L - OO interface to select system call =back =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/OS000755001750001750 015001742754 14310 5ustar00leoleo000000000000IO-Async-0.804/lib/IO/Async/OS/MSWin32.pm000444001750001750 540615001742754 16152 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2012-2013 -- leonerd@leonerd.org.uk package IO::Async::OS::MSWin32 0.804; use v5.14; use warnings; our @ISA = qw( IO::Async::OS::_Base ); use Carp; use Socket qw( AF_INET SOCK_STREAM SOCK_DGRAM INADDR_LOOPBACK pack_sockaddr_in ); use IO::Socket (); # empty import use constant HAVE_FAKE_ISREG_READY => 1; # Also select() only reports connect() failures by evec, not wvec use constant HAVE_SELECT_CONNECT_EVEC => 1; use constant HAVE_POLL_CONNECT_POLLPRI => 1; use constant HAVE_CONNECT_EWOULDBLOCK => 1; use constant HAVE_RENAME_OPEN_FILES => 0; # poll(2) on Windows is emulated by wrapping select(2) anyway, so we might as # well try the Select loop first use constant LOOP_BUILTIN_CLASSES => qw( Select Poll ); # CORE::fork() does not provide full POSIX semantics use constant HAVE_POSIX_FORK => 0; # Windows does not have signals, and SIGCHLD is not available use constant HAVE_SIGNALS => 0; =head1 NAME C - operating system abstractions on C for C =head1 DESCRIPTION This module contains OS support code for C. See instead L. =cut # Win32's pipes don't actually work with select(). We'll have to create # sockets instead sub pipepair { shift->socketpair( 'inet', 'stream' ); } # Win32 doesn't have a socketpair(). We'll fake one up sub socketpair { my $self = shift; my ( $family, $socktype, $proto ) = @_; $family = $self->getfamilybyname( $family ) || AF_INET; # SOCK_STREAM is the most likely $socktype = $self->getsocktypebyname( $socktype ) || SOCK_STREAM; $proto ||= 0; $family == AF_INET or croak "Cannot emulate ->socketpair except on AF_INET"; my $Stmp = $self->socket( $family, $socktype ) or return; $Stmp->bind( pack_sockaddr_in( 0, INADDR_LOOPBACK ) ) or return; my $S1 = $self->socket( $family, $socktype ) or return; my $S2; if( $socktype == SOCK_STREAM ) { $Stmp->listen( 1 ) or return; $S1->connect( getsockname $Stmp ) or return; $S2 = $Stmp->accept or return; # There's a bug in IO::Socket here, in that $S2 's ->socktype won't # yet be set. We can apply a horribly hacky fix here # defined $S2->socktype and $S2->socktype == $socktype or # ${*$S2}{io_socket_type} = $socktype; # But for now we'll skip the test for it instead } elsif( $socktype == SOCK_DGRAM ) { $S2 = $Stmp; $S1->connect( getsockname $S2 ) or return; $S2->connect( getsockname $S1 ) or return; } else { croak "Unrecognised socktype $socktype"; } return ( $S1, $S2 ); }; =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/OS/cygwin.pm000444001750001750 154615001742754 16311 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2013-2024 -- leonerd@leonerd.org.uk package IO::Async::OS::cygwin 0.804; use v5.14; use warnings; our @ISA = qw( IO::Async::OS::_Base ); # Cygwin almost needs no hinting above the POSIX-like base, except that its # emulation of poll() isn't quite perfect. It needs POLLPRI use constant HAVE_POLL_CONNECT_POLLPRI => 1; # Also select() only reports connect() failures by evec, not wvec use constant HAVE_SELECT_CONNECT_EVEC => 1; =head1 NAME C - operating system abstractions on C for C =head1 DESCRIPTION This module contains OS support code for C. See instead L. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/OS/linux.pm000444001750001750 267315001742754 16152 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2014-2024 -- leonerd@leonerd.org.uk package IO::Async::OS::linux 0.804; use v5.14; use warnings; our @ISA = qw( IO::Async::OS::_Base ); =head1 NAME C - operating system abstractions on C for L =head1 DESCRIPTION This module contains OS support code for C. See instead L. =cut # Suggest either Epoll or Ppoll loops first if they are installed use constant LOOP_PREFER_CLASSES => qw( Epoll Ppoll ); # Try to use /proc/pid/fd to get the list of actually-open file descriptors # for our process. Saves a bit of time when running with high ulimit -n / # fileno counts. sub potentially_open_fds { my $class = shift; opendir my $fd_path, "/proc/$$/fd" or do { warn "Cannot open /proc/$$/fd, falling back to generic method - $!"; return $class->SUPER::potentially_open_fds }; # Skip ., .., our directory handle itself and any other cruft # except fileno() isn't available for the handle so we'll # end up with that in the output anyway. As long as we're # called just before the relevant close() loop, this # should be harmless enough. my @fd = map { m/^([0-9]+)$/ ? $1 : () } readdir $fd_path; closedir $fd_path; return @fd; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Protocol000755001750001750 015001742754 15570 5ustar00leoleo000000000000IO-Async-0.804/lib/IO/Async/Protocol/LineStream.pm000444001750001750 470715001742754 20336 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2024 -- leonerd@leonerd.org.uk package IO::Async::Protocol::LineStream 0.804; use v5.14; use warnings; use base qw( IO::Async::Protocol::Stream ); use Carp; =head1 NAME C - stream-based protocols using lines of text =head1 SYNOPSIS Most likely this class will be subclassed to implement a particular network protocol. package Net::Async::HelloWorld; use strict; use warnings; use base qw( IO::Async::Protocol::LineStream ); sub on_read_line { my $self = shift; my ( $line ) = @_; if( $line =~ m/^HELLO (.*)/ ) { my $name = $1; $self->invoke_event( on_hello => $name ); } } sub send_hello { my $self = shift; my ( $name ) = @_; $self->write_line( "HELLO $name" ); } This small example elides such details as error handling, which a real protocol implementation would be likely to contain. =head1 DESCRIPTION =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_read_line $line Invoked when a new complete line of input is received. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 on_read_line => CODE CODE reference for the C event. =cut sub _init { my $self = shift; $self->SUPER::_init; $self->{eol} = "\x0d\x0a"; $self->{eol_pattern} = qr/\x0d?\x0a/; } sub configure { my $self = shift; my %params = @_; foreach (qw( on_read_line )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } $self->SUPER::configure( %params ); } sub on_read { my $self = shift; my ( $buffref, $eof ) = @_; # Easiest to run each event individually, in case it returns a CODE ref $$buffref =~ s/^(.*?)$self->{eol_pattern}// or return 0; return $self->invoke_event( on_read_line => $1 ) || 1; } =head1 METHODS =cut =head2 write_line $lineprotocol->write_line( $text ); Writes a line of text to the transport stream. The text will have the end-of-line marker appended to it; C<$text> should not end with it. =cut sub write_line { my $self = shift; my ( $line, @args ) = @_; $self->write( "$line$self->{eol}", @args ); } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Protocol/Stream.pm000444001750001750 1243315001742754 17541 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2024 -- leonerd@leonerd.org.uk package IO::Async::Protocol::Stream 0.804; use v5.14; use warnings; use base qw( IO::Async::Protocol ); use Carp; =head1 NAME C - base class for stream-based protocols =head1 SYNOPSIS Most likely this class will be subclassed to implement a particular network protocol. package Net::Async::HelloWorld; use strict; use warnings; use base qw( IO::Async::Protocol::Stream ); sub on_read { my $self = shift; my ( $buffref, $eof ) = @_; return 0 unless $$buffref =~ s/^(.*)\n//; my $line = $1; if( $line =~ m/^HELLO (.*)/ ) { my $name = $1; $self->invoke_event( on_hello => $name ); } return 1; } sub send_hello { my $self = shift; my ( $name ) = @_; $self->write( "HELLO $name\n" ); } This small example elides such details as error handling, which a real protocol implementation would be likely to contain. =head1 DESCRIPTION This subclass of L is intended to stand as a base class for implementing stream-based protocols. It provides an interface similar to L, primarily, a C method and an C event handler. It contains an instance of an L object which it uses for actual communication, rather than being a subclass of it, allowing a level of independence from the actual stream being used. For example, the stream may actually be an L to allow the protocol to be used over SSL. As with L, it is required that by the time the protocol object is added to a Loop, that it either has an C method, or has been configured with an C callback handler. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 $ret = on_read \$buffer, $eof =head2 on_read_eof =head2 on_write_eof The event handlers are invoked identically to L. =head2 on_closed The C handler is optional, but if provided, will be invoked after the stream is closed by either side (either because the C method has been invoked on it, or on an incoming EOF). =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 on_read => CODE =head2 on_read_eof => CODE =head2 on_write_eof => CODE CODE references for the events. =head2 handle => IO A shortcut for the common case where the transport only needs to be a plain L object. If this argument is provided without a C object, a new L object will be built around the given IO handle, and used as the transport. =cut sub configure { my $self = shift; my %params = @_; for (qw( on_read on_read_eof on_write_eof )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } if( !exists $params{transport} and my $handle = delete $params{handle} ) { require IO::Async::Stream; $params{transport} = IO::Async::Stream->new( handle => $handle ); } $self->SUPER::configure( %params ); if( $self->loop ) { $self->can_event( "on_read" ) or croak 'Expected either an on_read callback or to be able to ->on_read'; } } sub _add_to_loop { my $self = shift; $self->can_event( "on_read" ) or croak 'Expected either an on_read callback or to be able to ->on_read'; } sub setup_transport { my $self = shift; my ( $transport ) = @_; $self->SUPER::setup_transport( $transport ); $transport->configure( on_read => $self->_replace_weakself( sub { my $self = shift or return; $self->invoke_event( on_read => @_ ); } ), on_read_eof => $self->_replace_weakself( sub { my $self = shift or return; $self->maybe_invoke_event( on_read_eof => @_ ); } ), on_write_eof => $self->_replace_weakself( sub { my $self = shift or return; $self->maybe_invoke_event( on_write_eof => @_ ); } ), ); } sub teardown_transport { my $self = shift; my ( $transport ) = @_; $transport->configure( on_read => undef, ); $self->SUPER::teardown_transport( $transport ); } =head1 METHODS =cut =head2 write $protocol->write( $data ); Writes the given data by calling the C method on the contained transport stream. =cut sub write { my $self = shift; my ( $data, %args ) = @_; if( ref $data eq "CODE" ) { $data = $self->_replace_weakself( $data ); } if( $args{on_flush} ) { $args{on_flush} = $self->_replace_weakself( $args{on_flush} ); } my $transport = $self->transport or croak "Attempted to ->write to a ".ref($self)." with no transport"; $transport->write( $data, %args ); } =head2 connect $protocol->connect( %args ); Sets up a connection to a peer, and configures the underlying C for the Protocol. Calls L C with C set to C<"stream">. =cut sub connect { my $self = shift; $self->SUPER::connect( @_, socktype => "stream", ); } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Timer000755001750001750 015001742754 15047 5ustar00leoleo000000000000IO-Async-0.804/lib/IO/Async/Timer/Absolute.pm000444001750001750 542015001742754 17321 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2024 -- leonerd@leonerd.org.uk package IO::Async::Timer::Absolute 0.804; use v5.14; use warnings; use base qw( IO::Async::Timer ); use Carp; =head1 NAME C - event callback at a fixed future time =head1 SYNOPSIS use IO::Async::Timer::Absolute; use POSIX qw( mktime ); use IO::Async::Loop; my $loop = IO::Async::Loop->new; my @time = gmtime; my $timer = IO::Async::Timer::Absolute->new( time => mktime( 0, 0, 0, $time[3]+1, $time[4], $time[5] ), on_expire => sub { print "It's midnight\n"; $loop->stop; }, ); $loop->add( $timer ); $loop->run; =head1 DESCRIPTION This subclass of L implements one-shot events at a fixed time in the future. The object waits for a given timestamp, and invokes its callback at that point in the future. For a C object that waits for a delay relative to the time it is started, see instead L. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_expire Invoked when the timer expires. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 on_expire => CODE CODE reference for the C event. =head2 time => NUM The epoch time at which the timer will expire. Once constructed, the timer object will need to be added to the C before it will work. Unlike other timers, it does not make sense to C this object, because its expiry time is absolute, and not relative to the time it is started. =cut sub configure { my $self = shift; my %params = @_; if( exists $params{on_expire} ) { my $on_expire = delete $params{on_expire}; ref $on_expire or croak "Expected 'on_expire' as a reference"; $self->{on_expire} = $on_expire; undef $self->{cb}; # Will be lazily constructed when needed } if( exists $params{time} ) { my $time = delete $params{time}; $self->stop if $self->is_running; $self->{time} = $time; $self->start if !$self->is_running; } unless( $self->can_event( 'on_expire' ) ) { croak 'Expected either a on_expire callback or an ->on_expire method'; } $self->SUPER::configure( %params ); } sub _make_cb { my $self = shift; return $self->_capture_weakself( sub { my $self = shift or return; undef $self->{id}; $self->invoke_event( "on_expire" ); } ); } sub _make_enqueueargs { my $self = shift; return at => $self->{time}; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Timer/Countdown.pm000444001750001750 1476515001742754 17557 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2009-2012 -- leonerd@leonerd.org.uk package IO::Async::Timer::Countdown 0.804; use v5.14; use warnings; use base qw( IO::Async::Timer ); use Carp; =head1 NAME C - event callback after a fixed delay =head1 SYNOPSIS use IO::Async::Timer::Countdown; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $timer = IO::Async::Timer::Countdown->new( delay => 10, on_expire => sub { print "Sorry, your time's up\n"; $loop->stop; }, ); $timer->start; $loop->add( $timer ); $loop->run; =head1 DESCRIPTION This subclass of L implements one-shot fixed delays. The object implements a countdown timer, which invokes its callback after the given period from when it was started. After it has expired the Timer may be started again, when it will wait the same period then invoke the callback again. A timer that is currently running may be stopped or reset. For a C object that repeatedly runs a callback at regular intervals, see instead L. For a C that invokes its callback at a fixed time in the future, see L. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_expire Invoked when the timer expires. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 on_expire => CODE CODE reference for the C event. =head2 delay => NUM The delay in seconds after starting the timer until it expires. Cannot be changed if the timer is running. A timer with a zero delay expires "immediately". =head2 remove_on_expire => BOOL Optional. If true, remove this timer object from its parent notifier or containing loop when it expires. Defaults to false. Once constructed, the timer object will need to be added to the C before it will work. It will also need to be started by the C method. =cut sub configure { my $self = shift; my %params = @_; foreach (qw( remove_on_expire )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } if( exists $params{on_expire} ) { my $on_expire = delete $params{on_expire}; ref $on_expire or croak "Expected 'on_expire' as a reference"; $self->{on_expire} = $on_expire; undef $self->{cb}; # Will be lazily constructed when needed } if( exists $params{delay} ) { $self->is_running and croak "Cannot configure 'delay' of a running timer\n"; my $delay = delete $params{delay}; $delay >= 0 or croak "Expected a 'delay' as a non-negative number"; $self->{delay} = $delay; } unless( $self->can_event( 'on_expire' ) ) { croak 'Expected either a on_expire callback or an ->on_expire method'; } $self->SUPER::configure( %params ); } =head1 METHODS =cut =head2 is_expired $expired = $timer->is_expired; Returns true if the Timer has already expired. =cut sub is_expired { my $self = shift; return $self->{expired}; } sub _make_cb { my $self = shift; return $self->_capture_weakself( sub { my $self = shift or return; undef $self->{id}; $self->{expired} = 1; $self->remove_from_parent if $self->{remove_on_expire}; $self->invoke_event( "on_expire" ); } ); } sub _make_enqueueargs { my $self = shift; undef $self->{expired}; return after => $self->{delay}; } =head2 reset $timer->reset; If the timer is running, restart the countdown period from now. If the timer is not running, this method has no effect. =cut sub reset { my $self = shift; my $loop = $self->loop or croak "Cannot reset a Timer that is not in a Loop"; return if !$self->is_running; $self->stop; $self->start; } =head1 EXAMPLES =head2 Watchdog Timer Because the C method restarts a running countdown timer back to its full period, it can be used to implement a watchdog timer. This is a timer which will not expire provided the method is called at least as often as it is configured. If the method fails to be called, the timer will eventually expire and run its callback. For example, to expire an accepted connection after 30 seconds of inactivity: ... on_accept => sub { my ( $newclient ) = @_; my $watchdog = IO::Async::Timer::Countdown->new( delay => 30, on_expire => sub { my $self = shift; my $stream = $self->parent; $stream->close; }, ); my $stream = IO::Async::Stream->new( handle => $newclient, on_read => sub { my ( $self, $buffref, $eof ) = @_; $watchdog->reset; ... }, on_closed => sub { $watchdog->stop; }, ) ); $stream->add_child( $watchdog ); $watchdog->start; $loop->add( $watchdog ); } Rather than setting up a lexical variable to store the Stream so that the Timer's C closure can call C on it, the parent/child relationship between the two Notifier objects is used. At the time the Timer C closure is invoked, it will have been added as a child notifier of the Stream; this means the Timer's C method will return the Stream Notifier. This enables it to call C without needing to capture a lexical variable, which would create a cyclic reference. =head2 Fixed-Delay Repeating Timer The C event fires a fixed delay after the C method has begun the countdown. The C method can be invoked again at some point during the C handling code, to create a timer that invokes its code regularly a fixed delay after the previous invocation has finished. This creates an arrangement similar to an L, except that it will wait until the previous invocation has indicated it is finished, before starting the countdown for the next call. my $timer = IO::Async::Timer::Countdown->new( delay => 60, on_expire => sub { my $self = shift; start_some_operation( on_complete => sub { $self->start }, ); }, ); $timer->start; $loop->add( $timer ); This example invokes the C function 60 seconds after the previous iteration has indicated it has finished. =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/lib/IO/Async/Timer/Periodic.pm000444001750001750 1452315001742754 17325 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2009-2024 -- leonerd@leonerd.org.uk package IO::Async::Timer::Periodic 0.804; use v5.14; use warnings; use base qw( IO::Async::Timer ); use Carp; =head1 NAME C - event callback at regular intervals =head1 SYNOPSIS use IO::Async::Timer::Periodic; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $timer = IO::Async::Timer::Periodic->new( interval => 60, on_tick => sub { print "You've had a minute\n"; }, ); $timer->start; $loop->add( $timer ); $loop->run; =head1 DESCRIPTION This subclass of L implements repeating events at regular clock intervals. The timing may or may not be subject to how long it takes the callback to execute. Iterations may be rescheduled runs at fixed regular intervals beginning at the time the timer was started, or by a fixed delay after the previous code has finished executing. For a C object that only runs a callback once, after a given delay, see instead L. A Countdown timer can also be used to create repeating events that fire at a fixed delay after the previous event has finished processing. See als the examples in C. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_tick Invoked on each interval of the timer. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =head2 on_tick => CODE CODE reference for the C event. =head2 interval => NUM The interval in seconds between invocations of the callback or method. Cannot be changed if the timer is running. =head2 first_interval => NUM Optional. If defined, the interval in seconds after calling the C method before the first invocation of the callback or method. Thereafter, the regular C will be used. If not supplied, the first interval will be the same as the others. Even if this value is zero, the first invocation will be made asynchronously, by the containing C object, and not synchronously by the C method itself. =head2 reschedule => STRING Optional. Must be one of C, C or C. Defines the algorithm used to reschedule the next invocation. C schedules each iteration at the fixed interval from the previous iteration's schedule time, ensuring a regular repeating event. C schedules similarly to C, but skips over times that have already passed. This matters if the duration is particularly short and there's a possibility that times may be missed, or if the entire process is stopped and resumed by C or similar. C schedules each iteration at the fixed interval from the time that the previous iteration's event handler returns. This allows it to slowly drift over time and become desynchronised with other events of the same interval or multiples/fractions of it. Once constructed, the timer object will need to be added to the C before it will work. It will also need to be started by the C method. =cut sub _init { my $self = shift; $self->SUPER::_init( @_ ); $self->{reschedule} = "hard"; } sub configure { my $self = shift; my %params = @_; if( exists $params{on_tick} ) { my $on_tick = delete $params{on_tick}; ref $on_tick or croak "Expected 'on_tick' as a reference"; $self->{on_tick} = $on_tick; undef $self->{cb}; # Will be lazily constructed when needed } if( exists $params{interval} ) { $self->is_running and croak "Cannot configure 'interval' of a running timer\n"; my $interval = delete $params{interval}; $interval > 0 or croak "Expected a 'interval' as a positive number"; $self->{interval} = $interval; } if( exists $params{first_interval} ) { $self->is_running and croak "Cannot configure 'first_interval' of a running timer\n"; my $first_interval = delete $params{first_interval}; $first_interval >= 0 or croak "Expected a 'first_interval' as a non-negative number"; $self->{first_interval} = $first_interval; } if( exists $params{reschedule} ) { my $resched = delete $params{reschedule} || "hard"; grep { $_ eq $resched } qw( hard skip drift ) or croak "Expected 'reschedule' to be one of hard, skip, drift"; $self->{reschedule} = $resched; } unless( $self->can_event( 'on_tick' ) ) { croak 'Expected either a on_tick callback or an ->on_tick method'; } $self->SUPER::configure( %params ); } sub _reschedule { my $self = shift; my $now = $self->loop->time; my $resched = $self->{reschedule}; my $next_interval = $self->{is_first} && defined $self->{first_interval} ? $self->{first_interval} : $self->{interval}; delete $self->{is_first}; if( !defined $self->{next_time} ) { $self->{next_time} = $now + $next_interval; } elsif( $resched eq "hard" ) { $self->{next_time} += $next_interval; } elsif( $resched eq "skip" ) { # How many ticks are needed? my $ticks = POSIX::ceil( ( $now - $self->{next_time} ) / $next_interval ); # $self->{last_ticks} = $ticks; $self->{next_time} += $next_interval * $ticks; } elsif( $resched eq "drift" ) { $self->{next_time} = $now + $next_interval; } $self->SUPER::start; } sub start { my $self = shift; $self->{is_first} = 1; # Only actually define a time if we've got a loop; otherwise it'll just # become start-pending. We'll calculate it properly when it gets added to # the Loop if( $self->loop ) { $self->_reschedule; } else { $self->SUPER::start; } } sub stop { my $self = shift; $self->SUPER::stop; undef $self->{next_time}; } sub _make_cb { my $self = shift; return $self->_capture_weakself( sub { my $self = shift or return; undef $self->{id}; my $ok = eval { $self->invoke_event( on_tick => ); 1 } or my $e = $@; # detect ->stop $self->_reschedule if defined $self->{next_time}; die $e if !$ok; } ); } sub _make_enqueueargs { my $self = shift; return at => $self->{next_time}; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.804/t000755001750001750 015001742754 12100 5ustar00leoleo000000000000IO-Async-0.804/t/00use.t000444001750001750 134315001742754 13357 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; require IO::Async::Notifier; require IO::Async::Handle; require IO::Async::Stream; require IO::Async::Timer; require IO::Async::Timer::Absolute; require IO::Async::Timer::Countdown; require IO::Async::Timer::Periodic; require IO::Async::Signal; require IO::Async::Listener; require IO::Async::Socket; require IO::Async::File; require IO::Async::FileStream; require IO::Async::OS; require IO::Async::Loop::Select; require IO::Async::Loop::Poll; require IO::Async::Test; require IO::Async::Function; require IO::Async::Resolver; require IO::Async::Protocol; require IO::Async::Protocol::Stream; require IO::Async::Protocol::LineStream; pass( 'Modules loaded' ); done_testing; IO-Async-0.804/t/01timequeue.t000444001750001750 516615001742754 14576 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::Internals::TimeQueue; my $queue = IO::Async::Internals::TimeQueue->new; ok( defined $queue, '$queue defined' ); isa_ok( $queue, [ "IO::Async::Internals::TimeQueue" ], '$queue isa IO::Async::Internals::TimeQueue' ); is( $queue->next_time, undef, '->next_time when empty is undef' ); ok( dies { $queue->enqueue( code => sub { "DUMMY" } ) }, 'enqueue no time fails' ); ok( dies { $queue->enqueue( time => 123 ) }, 'enqueue no code fails' ); ok( dies { $queue->enqueue( time => 123, code => 'HELLO' ) }, 'enqueue code not CODE ref fails' ); $queue->enqueue( time => 1000, code => sub { "DUMMY" } ); is( $queue->next_time, 1000, '->next_time after single enqueue' ); my $fired = 0; $queue->enqueue( time => 500, code => sub { $fired = 1; } ); is( $queue->next_time, 500, '->next_time after second enqueue' ); my $count = $queue->fire( now => 700 ); is( $fired, 1, '$fired after fire at time 700' ); is( $count, 1, '$count after fire at time 700' ); is( $queue->next_time, 1000, '->next_time after fire at time 700' ); $count = $queue->fire( now => 900 ); is( $count, 0, '$count after fire at time 900' ); is( $queue->next_time, 1000, '->next_time after fire at time 900' ); $count = $queue->fire( now => 1200 ); is( $count, 1, '$count after fire at time 1200' ); is( $queue->next_time, undef, '->next_time after fire at time 1200' ); $queue->enqueue( time => 1300, code => sub{ $fired++; } ); $queue->enqueue( time => 1301, code => sub{ $fired++; } ); $count = $queue->fire( now => 1400 ); is( $fired, 3, '$fired after fire at time 1400' ); is( $count, 2, '$count after fire at time 1400' ); is( $queue->next_time, undef, '->next_time after fire at time 1400' ); my $id = $queue->enqueue( time => 1500, code => sub { $fired++ } ); $queue->enqueue( time => 1505, code => sub { $fired++ } ); is( $queue->next_time, 1500, '->next_time before cancel' ); $queue->cancel( $id ); is( $queue->next_time, 1505, '->next_time after cancel' ); $fired = 0; $count = $queue->fire( now => 1501 ); is( $fired, 0, '$fired after fire at time 1501' ); is( $count, 0, '$count after fire at time 1501' ); $count = $queue->fire( now => 1510 ); is( $fired, 1, '$fired after fire at time 1510' ); is( $count, 1, '$count after fire at time 1510' ); # Performance for large collections { foreach my $t ( 2000 .. 2100 ) { $queue->enqueue( time => $t, code => sub {} ); } foreach my $t ( 2000 .. 2100 ) { $queue->next_time == $t or fail( "Failed for large collection - expected $t" ), last; $queue->fire( now => $t ); } ok( "Large collection" ); } done_testing; IO-Async-0.804/t/02os.t000444001750001750 1733215001742754 13233 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::OS; use Socket qw( SOCK_STREAM SOCK_DGRAM SO_TYPE AF_INET pack_sockaddr_in unpack_sockaddr_in AF_INET6 pack_sockaddr_in6 unpack_sockaddr_in6 AF_UNIX pack_sockaddr_un unpack_sockaddr_un inet_aton inet_pton inet_ntoa inet_ntop INADDR_ANY ); use POSIX qw( SIGTERM ); SKIP: { skip "No IO::Socket::IP", 2 unless eval { require IO::Socket::IP }; my $S_inet = IO::Async::OS->socket( "inet", "stream" ); isa_ok( $S_inet, [ "IO::Socket::IP" ], 'IO::Async::OS->socket("inet") isa IO::Socket::IP' ); SKIP: { skip "No AF_INET6", 1 unless eval { socket( my $fh, AF_INET6, SOCK_STREAM, 0 ) }; my $S_inet6 = IO::Async::OS->socket( "inet6", "stream" ); isa_ok( $S_inet6, [ "IO::Socket::IP" ], 'IO::Async::OS->socket("inet6") isa IO::Socket::IP' ); } } foreach my $family ( undef, "inet" ) { my ( $S1, $S2 ) = IO::Async::OS->socketpair( $family, "stream" ) or die "Could not socketpair - $!"; isa_ok( $S1, [ "IO::Socket" ], '$S1 isa IO::Socket' ); isa_ok( $S2, [ "IO::Socket" ], '$S2 isa IO::Socket' ); # Due to a bug in IO::Socket, ->socktype may not be set is( $S1->sockopt(SO_TYPE), SOCK_STREAM, 'SO_TYPE of $S1 is SOCK_STREAM' ); is( $S2->sockopt(SO_TYPE), SOCK_STREAM, 'SO_TYPE of $S2 is SOCK_STREAM' ); $S1->syswrite( "Hello" ); is( do { my $b; $S2->sysread( $b, 8192 ); $b }, "Hello", '$S1 --writes-> $S2' ); $S2->syswrite( "Goodbye" ); is( do { my $b; $S1->sysread( $b, 8192 ); $b }, "Goodbye", '$S2 --writes-> $S1' ); ( $S1, $S2 ) = IO::Async::OS->socketpair( $family, "dgram" ) or die "Could not socketpair - $!"; isa_ok( $S1, [ "IO::Socket" ], '$S1 isa IO::Socket' ); isa_ok( $S2, [ "IO::Socket" ], '$S2 isa IO::Socket' ); is( $S1->socktype, SOCK_DGRAM, '$S1->socktype is SOCK_DGRAM' ); is( $S2->socktype, SOCK_DGRAM, '$S2->socktype is SOCK_DGRAM' ); $S1->syswrite( "Hello" ); is( do { my $b; $S2->sysread( $b, 8192 ); $b }, "Hello", '$S1 --writes-> $S2' ); $S2->syswrite( "Goodbye" ); is( do { my $b; $S1->sysread( $b, 8192 ); $b }, "Goodbye", '$S2 --writes-> $S1' ); } { my ( $Prd, $Pwr ) = IO::Async::OS->pipepair or die "Could not pipepair - $!"; $Pwr->syswrite( "Hello" ); is( do { my $b; $Prd->sysread( $b, 8192 ); $b }, "Hello", '$Pwr --writes-> $Prd' ); # Writing to $Prd _may_ fail, but some systems might implement this as a # socketpair instead. We won't test it just in case } { my ( $rdA, $wrA, $rdB, $wrB ) = IO::Async::OS->pipequad or die "Could not pipequad - $!"; $wrA->syswrite( "Hello" ); is( do { my $b; $rdA->sysread( $b, 8192 ); $b }, "Hello", '$wrA --writes-> $rdA' ); $wrB->syswrite( "Goodbye" ); is( do { my $b; $rdB->sysread( $b, 8192 ); $b }, "Goodbye", '$wrB --writes-> $rdB' ); } is( IO::Async::OS->signame2num( 'TERM' ), SIGTERM, 'signame2num' ); is( IO::Async::OS->signum2name( SIGTERM ), "TERM", 'signum2name' ); # RT145759 is( IO::Async::OS->signum2name( IO::Async::OS->signame2num( "ABRT" ) ), "ABRT", 'signum2name gives correct result for aliased signals' ); is( IO::Async::OS->getfamilybyname( "inet" ), AF_INET, 'getfamilybyname "inet"' ); is( IO::Async::OS->getfamilybyname( AF_INET ), AF_INET, 'getfamilybyname AF_INET' ); is( IO::Async::OS->getsocktypebyname( "stream" ), SOCK_STREAM, 'getsocktypebyname "stream"' ); is( IO::Async::OS->getsocktypebyname( SOCK_STREAM ), SOCK_STREAM, 'getsocktypebyname SOCK_STREAM' ); { my $sinaddr = pack_sockaddr_in( 56, inet_aton( "1.2.3.4" ) ); is( [ IO::Async::OS->extract_addrinfo( [ "inet", "stream", 0, $sinaddr ] ) ], [ AF_INET, SOCK_STREAM, 0, $sinaddr ], 'extract_addrinfo( ARRAY )' ); is( [ IO::Async::OS->extract_addrinfo( { family => "inet", socktype => "stream", addr => $sinaddr } ) ], [ AF_INET, SOCK_STREAM, 0, $sinaddr ], 'extract_addrinfo( HASH )' ); is( [ IO::Async::OS->extract_addrinfo( { family => "inet", socktype => "stream", ip => "1.2.3.4", port => "56", } ) ], [ AF_INET, SOCK_STREAM, 0, $sinaddr ], 'extract_addrinfo( HASH ) with inet, ip+port' ); is( [ IO::Async::OS->extract_addrinfo( { family => "inet", socktype => "stream", port => "56", } ) ], [ AF_INET, SOCK_STREAM, 0, pack_sockaddr_in( 56, INADDR_ANY ) ], 'extract_addrinfo( HASH ) with inet, port' ); is( [ IO::Async::OS->extract_addrinfo( { family => "inet", socktype => "stream", } ) ], [ AF_INET, SOCK_STREAM, 0, pack_sockaddr_in( 0, INADDR_ANY ) ], 'extract_addrinfo( HASH ) with inet only' ); ok( dies { IO::Async::OS->extract_addrinfo( { family => "inet", host => "foobar.com", } ) }, 'extract_addrinfo for inet complains about unrecognised key' ); # ->make_addr_for_peer should rewrite 0.0.0.0 to 127.0.0.1 my ( $port, $host ) = unpack_sockaddr_in( IO::Async::OS->make_addr_for_peer( AF_INET, pack_sockaddr_in( 567, inet_aton( "0.0.0.0" ) ) ) ); is( $port, 567, 'make_addr_for_peer preserves AF_INET port' ); is( inet_ntoa( $host ), "127.0.0.1", 'make_addr_for_peer rewrites INADDR_ANY to _LOCALHOST' ); ( undef, $host ) = unpack_sockaddr_in( IO::Async::OS->make_addr_for_peer( AF_INET, pack_sockaddr_in( 567, inet_aton( "1.2.3.4" ) ) ) ); is( inet_ntoa( $host ), "1.2.3.4", 'make_addr_for_peer preserves AF_INET other host' ); } SKIP: { my $sin6addr = eval { Socket::pack_sockaddr_in6( 1234, inet_pton( AF_INET6, "fe80::5678" ) ) }; skip "No pack_sockaddr_in6", 1 unless defined $sin6addr; is( [ IO::Async::OS->extract_addrinfo( { family => "inet6", socktype => "stream", ip => "fe80::5678", port => "1234", } ) ], [ AF_INET6, SOCK_STREAM, 0, $sin6addr ], 'extract_addrinfo( HASH ) with inet6, ip+port' ); # ->make_addr_for_peer should rewrite :: to ::1 my ( $port, $host ) = unpack_sockaddr_in6( IO::Async::OS->make_addr_for_peer( AF_INET6, pack_sockaddr_in6( 567, inet_pton( AF_INET6, "::" ) ) ) ); is( $port, 567, 'make_addr_for_peer preserves AF_INET6 port' ); is( inet_ntop( AF_INET6, $host ), "::1", 'make_addr_for_peer rewrites IN6ADDR_ANY to _LOCALHOST' ); ( undef, $host ) = unpack_sockaddr_in6( IO::Async::OS->make_addr_for_peer( AF_INET6, pack_sockaddr_in6( 567, inet_pton( AF_INET6, "fe80::1234" ) ) ) ); is( inet_ntop( AF_INET6, $host ), "fe80::1234", 'make_addr_for_peer preserves AF_INET6 other host' ); } SKIP: { skip "No pack_sockaddr_un", 1 unless IO::Async::OS->HAVE_SOCKADDR_UN; my $sunaddr = pack_sockaddr_un( "foo.sock" ); is( [ IO::Async::OS->extract_addrinfo( { family => "unix", socktype => "stream", path => "foo.sock", } ) ], [ AF_UNIX, SOCK_STREAM, 0, $sunaddr ], 'extract_addrinfo( HASH ) with unix, path' ); # ->make_addr_for_peer should leave address undisturbed my ( $path ) = unpack_sockaddr_un( IO::Async::OS->make_addr_for_peer( AF_UNIX, pack_sockaddr_un( "/tmp/mysock" ) ) ); is( $path, "/tmp/mysock", 'make_addr_for_peer preserves AF_UNIX path' ); } ok( dies { IO::Async::OS->extract_addrinfo( { family => "hohum" } ) }, 'extract_addrinfo on unrecognised family complains' ); done_testing; IO-Async-0.804/t/03loop-magic.t000444001750001750 230515001742754 14614 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use lib "."; # for t::StupidLoop use IO::Async::Loop; $IO::Async::Loop::LOOP_NO_OS = 1; delete $ENV{IO_ASYNC_LOOP}; # Just in case it was already set my $loop; my $LOOPCLASS = "IO::Async::Loop::" . ( IO::Async::OS->LOOP_BUILTIN_CLASSES )[0]; $loop = IO::Async::Loop->new; isa_ok( $loop, [ $LOOPCLASS ], 'Magic constructor in default mode' ) or diag( 'ref($loop) is ' . ref $loop ); is( IO::Async::Loop->new, $loop, 'IO::Async::Loop->new again yields same loop' ); { local $ENV{IO_ASYNC_LOOP} = "t::StupidLoop"; undef $IO::Async::Loop::ONE_TRUE_LOOP; $loop = IO::Async::Loop->new; isa_ok( $loop, [ "t::StupidLoop" ], 'Magic constructor obeys $ENV{IO_ASYNC_LOOP}' ); } { local $IO::Async::Loop::LOOP = "t::StupidLoop"; undef $IO::Async::Loop::ONE_TRUE_LOOP; $loop = IO::Async::Loop->new; isa_ok( $loop, [ "t::StupidLoop" ], 'Magic constructor obeys $IO::Async::Loop::LOOP' ); } { local $IO::Async::Loop::LOOP = "Select"; undef $IO::Async::Loop::ONE_TRUE_LOOP; $loop = IO::Async::Loop->new; isa_ok( $loop, [ "IO::Async::Loop::Select" ], 'Magic constructor expands unqualified package names' ); } done_testing; IO-Async-0.804/t/04notifier.t000444001750001750 1265415001742754 14435 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000149; use IO::Async::Notifier; { my $notifier = IO::Async::Notifier->new( notifier_name => "test1", ); ok( defined $notifier, '$notifier defined' ); isa_ok( $notifier, [ "IO::Async::Notifier" ], '$notifier isa IO::Async::Notifier' ); is_oneref( $notifier, '$notifier has refcount 1 initially' ); is( $notifier->notifier_name, "test1", '$notifier->notifier_name' ); ok( !dies { $notifier->configure; }, '$notifier->configure no params succeeds' ); ok( dies { $notifier->configure( oranges => 1 ) }, '$notifier->configure an unknown parameter fails' ); my %other; no warnings 'redefine'; local *IO::Async::Notifier::configure_unknown = sub { shift; %other = @_; }; ok( !dies { $notifier->configure( oranges => 3 ) }, '$notifier->configure with configure_unknown succeeds' ); is( \%other, { oranges => 3 }, '%other after configure_unknown' ); } # weaseling { my $notifier = IO::Async::Notifier->new; my @args; my $mref = $notifier->_capture_weakself( sub { @args = @_ } ); is_oneref( $notifier, '$notifier has refcount 1 after _capture_weakself' ); $mref->( 123 ); is( \@args, [ $notifier, 123 ], '@args after invoking $mref' ); my @callstack; $notifier->_capture_weakself( sub { my $level = 0; push @callstack, [ (caller $level++)[0,3] ] while defined caller $level; } )->(); is( \@callstack, [ [ "main", "main::__ANON__" ] ], 'trampoline does not appear in _capture_weakself callstack' ); undef @args; $mref = $notifier->_replace_weakself( sub { @args = @_ } ); is_oneref( $notifier, '$notifier has refcount 1 after _replace_weakself' ); my $outerself = bless [], "OtherClass"; $mref->( $outerself, 456 ); is( \@args, [ $notifier, 456 ], '@args after invoking replacer $mref' ); isa_ok( $outerself, [ "OtherClass" ], '$outerself unchanged' ); ok( dies { $notifier->_capture_weakself( 'cannotdo' ) }, '$notifier->_capture_weakself on unknown method name fails' ); } # Subclass { my @subargs; { package TestNotifier; use base qw( IO::Async::Notifier ); sub frobnicate { @subargs = @_ } } my $subn = TestNotifier->new; my $mref = $subn->_capture_weakself( 'frobnicate' ); is_oneref( $subn, '$subn has refcount 1 after _capture_weakself on named method' ); $mref->( 456 ); is( \@subargs, [ $subn, 456 ], '@subargs after invoking $mref on named method' ); undef @subargs; # Method capture { my @newargs; no warnings 'redefine'; local *TestNotifier::frobnicate = sub { @newargs = @_; }; $mref->( 321 ); is( \@subargs, [], '@subargs empty after TestNotifier::frobnicate replacement' ); is( \@newargs, [ $subn, 321 ], '@newargs after TestNotifier::frobnicate replacement' ); } undef @subargs; $subn->invoke_event( 'frobnicate', 78 ); is( \@subargs, [ $subn, 78 ], '@subargs after ->invoke_event' ); undef @subargs; is( $subn->maybe_invoke_event( 'frobnicate', 'a'..'c' ), [ $subn, 'a'..'c' ], 'return value from ->maybe_invoke_event' ); is( $subn->maybe_invoke_event( 'mangle' ), undef, 'return value from ->maybe_invoke_event on missing event' ); undef @subargs; my $cb = $subn->make_event_cb( 'frobnicate' ); is( ref $cb, "CODE", '->make_event_cb returns a CODE reference' ); is_oneref( $subn, '$subn has refcount 1 after ->make_event_cb' ); $cb->( 90 ); is( \@subargs, [ $subn, 90 ], '@subargs after ->make_event_cb->()' ); is( ref $subn->maybe_make_event_cb( 'frobnicate' ), "CODE", '->maybe_make_event_cb yields CODE ref' ); is( $subn->maybe_make_event_cb( 'mangle' ), undef, '->maybe_make_event_cb on missing event yields undef' ); undef @subargs; is_oneref( $subn, '$subn has refcount 1 finally' ); } # parent/child { my $parent = IO::Async::Notifier->new; my $child = IO::Async::Notifier->new; is_oneref( $parent, '$parent has refcount 1 initially' ); is_oneref( $child, '$child has refcount 1 initially' ); $parent->add_child( $child ); ref_is( $child->parent, $parent, '$child->parent is $parent' ); is( [ $parent->children ], [ exact_ref($child) ], '$parent->children' ); is_oneref( $parent, '$parent has refcount 1 after add_child' ); is_refcount( $child, 2, '$child has refcount 2 after add_child' ); ok( dies { $parent->add_child( $child ) }, 'Adding child again fails' ); $parent->remove_child( $child ); is_oneref( $child, '$child has refcount 1 after remove_child' ); is( [ $parent->children ], [], '$parent->children now empty' ); } # invoke_error { my $parent = IO::Async::Notifier->new; my $child = IO::Async::Notifier->new; $parent->add_child( $child ); # invoke_error no handler ok( dies { $parent->invoke_error( "It went wrong", wrong => ) }, 'Exception thrown from ->invoke_error with no handler' ); # invoke_error handler my $err; $parent->configure( on_error => sub { $err = $_[1] } ); ok( !dies { $parent->invoke_error( "It's still wrong", wrong => ) }, 'Exception not thrown from ->invoke_error with handler' ); is( $err, "It's still wrong", '$message to on_error' ); ok( !dies { $child->invoke_error( "Wrong on child", wrong => ) }, 'Exception not thrown from ->invoke_error on child' ); is( $err, "Wrong on child", '$message to parent on_error' ); } done_testing; IO-Async-0.804/t/05notifier-loop.t000444001750001750 707515001742754 15366 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000149; use Test::Metrics::Any; use IO::Async::Notifier; use IO::Async::Loop; my $loop = IO::Async::Loop->new; is_refcount( $loop, 2, '$loop has refcount 2 initially' ); { package TestNotifier; use base qw( IO::Async::Notifier ); sub new { my $self = shift->SUPER::new; ( $self->{varref} ) = @_; return $self; } sub _add_to_loop { my $self = shift; ${ $self->{varref} } = 1; } sub _remove_from_loop { my $self = shift; ${ $self->{varref} } = 0; } } # $loop->add { my $notifier = TestNotifier->new( \my $in_loop ); is( [ $loop->notifiers ], [], '$loop->notifiers empty' ); is( $notifier->loop, undef, 'loop undef' ); $loop->add( $notifier ); is_refcount( $loop, 2, '$loop has refcount 2 adding Notifier' ); is_refcount( $notifier, 2, '$notifier has refcount 2 after adding to Loop' ); ref_is( $notifier->loop, $loop, 'loop $loop' ); is( [ $loop->notifiers ], [ exact_ref($notifier) ], '$loop->notifiers contains new Notifier' ); ok( $in_loop, '_add_to_loop called' ); ok( dies { $loop->add( $notifier ) }, 'adding again produces error' ); $loop->remove( $notifier ); is( $notifier->loop, undef, '$notifier->loop is undef' ); is( [ $loop->notifiers ], [], '$loop->notifiers empty once more' ); ok( !$in_loop, '_remove_from_loop called' ); is_oneref( $notifier, '$notifier has refcount 1 finally' ); } # parent/child in Loop { my $parent = TestNotifier->new( \my $parent_in_loop ); my $child = TestNotifier->new( \my $child_in_loop ); $loop->add( $parent ); $parent->add_child( $child ); is_refcount( $child, 3, '$child has refcount 3 after add_child within loop' ); ref_is( $parent->loop, $loop, '$parent->loop is $loop' ); ref_is( $child->loop, $loop, '$child->loop is $loop' ); ok( $parent_in_loop, '$parent now in loop' ); ok( $child_in_loop, '$child now in loop' ); ok( dies { $loop->remove( $child ) }, 'Directly removing a child from the loop fails' ); $loop->remove( $parent ); is( [ $parent->children ], [ exact_ref($child) ], '$parent->children after $loop->remove' ); is_oneref( $parent, '$parent has refcount 1 after removal from loop' ); is_refcount( $child, 2, '$child has refcount 2 after removal of parent from loop' ); is( $parent->loop, undef, '$parent->loop is undef' ); is( $child->loop, undef, '$child->loop is undef' ); ok( !$parent_in_loop, '$parent no longer in loop' ); ok( !$child_in_loop, '$child no longer in loop' ); ok( dies { $loop->add( $child ) }, 'Directly adding a child to the loop fails' ); $loop->add( $parent ); ref_is( $child->loop, $loop, '$child->loop is $loop after remove/add parent' ); ok( $parent_in_loop, '$parent now in loop' ); ok( $child_in_loop, '$child now in loop' ); $loop->remove( $parent ); $parent->remove_child( $child ); is_oneref( $parent, '$parent has refcount 1 finally' ); is_oneref( $child, '$child has refcount 1 finally' ); } # Metrics SKIP: { skip "Metrics are unavailable" unless $IO::Async::Metrics::METRICS; my $notifier = TestNotifier->new( \my $tmp ); $loop->add( $notifier ); is_metrics( { io_async_notifiers => 1 }, '$loop->add increments notifiers count' ); $loop->remove( $notifier ); is_metrics( { io_async_notifiers => 0 }, '$loop->remove decrements notifiers count' ); } is_refcount( $loop, 2, '$loop has refcount 2 finally' ); done_testing; IO-Async-0.804/t/06notifier-mixin.t000444001750001750 211615001742754 15531 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000149; use IO::Async::Loop; my $loop = IO::Async::Loop->new; is_refcount( $loop, 2, '$loop has refcount 2 initially' ); my $notifier = SomeEventSource::Async->new; my $in_loop; isa_ok( $notifier, [ "SomeEventSource" ], '$notifier isa SomeEventSource' ); isa_ok( $notifier, [ "IO::Async::Notifier" ], '$notifier isa IO::Async::Notifier' ); $loop->add( $notifier ); is_refcount( $loop, 2, '$loop has refcount 2 adding Notifier' ); is_refcount( $notifier, 2, '$notifier has refcount 2 after adding to Loop' ); ref_is( $notifier->loop, $loop, 'loop $loop' ); ok( $in_loop, 'SomeEventSource::Async added to Loop' ); $loop->remove( $notifier ); is( $notifier->loop, undef, '$notifier->loop is undef' ); ok( !$in_loop, 'SomeEventSource::Async removed from Loop' ); done_testing; package SomeEventSource; sub new { my $class = shift; return bless {}, $class; } package SomeEventSource::Async; use base qw( SomeEventSource IO::Async::Notifier ); sub _add_to_loop { $in_loop = 1 } sub _remove_from_loop { $in_loop = 0 } IO-Async-0.804/t/07notifier-future.t000444001750001750 253115001742754 15721 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000149; use IO::Async::Notifier; use Future; my ( $err, $name, @detail ); my $notifier = IO::Async::Notifier->new( on_error => sub { ( undef, $err, $name, @detail ) = @_; }, ); # done { my $f = Future->new; is( [ $notifier->adopted_futures ], [], '->adopted_futures initially' ); $notifier->adopt_future( $f ); is_refcount( $f, 2, '$f has refcount 2 after ->adopt_future' ); is_oneref( $notifier, '$notifier still has refcount 1 after ->adopt_future' ); is( [ $notifier->adopted_futures ], [ $f ], '->adopted_futures after adoption' ); $f->done( "result" ); is_refcount( $f, 1, '$f has refcount 1 after $f->done' ); is( [ $notifier->adopted_futures ], [], '->adopted_futures finally' ); } # fail { my $f = Future->new; $notifier->adopt_future( $f ); $f->fail( "It failed", name => 1, 2, 3 ); is( $err, "It failed", '$err after $f->fail' ); is( $name, "name", '$name after $f->fail' ); is( \@detail, [ 1, 2, 3 ], '@detail after $f->fail' ); is_refcount( $f, 1, '$f has refcount 1 after $f->fail' ); undef $err; $f = Future->new; $notifier->adopt_future( $f->else_done() ); $f->fail( "Not captured" ); ok( !defined $err, '$err not defined after ->else_done suppressed failure' ); } done_testing; IO-Async-0.804/t/10loop-poll-io.t000444001750001750 20015001742754 15055 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Poll', 'io' ); IO-Async-0.804/t/10loop-select-io.t000444001750001750 20215001742754 15370 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Select', 'io' ); IO-Async-0.804/t/11loop-poll-timer.t000444001750001750 20315001742754 15572 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Poll', 'timer' ); IO-Async-0.804/t/11loop-select-timer.t000444001750001750 20515001742754 16105 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Select', 'timer' ); IO-Async-0.804/t/12loop-poll-signal.t000444001750001750 33215001742754 15733 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::LoopTests; plan skip_all => "This OS does not have signals" unless IO::Async::OS->HAVE_SIGNALS; run_tests( 'IO::Async::Loop::Poll', 'signal' ); IO-Async-0.804/t/12loop-select-signal.t000444001750001750 33415001742754 16246 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::LoopTests; plan skip_all => "This OS does not have signals" unless IO::Async::OS->HAVE_SIGNALS; run_tests( 'IO::Async::Loop::Select', 'signal' ); IO-Async-0.804/t/13loop-poll-idle.t000444001750001750 20215001742754 15370 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Poll', 'idle' ); IO-Async-0.804/t/13loop-select-idle.t000444001750001750 20415001742754 15703 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Select', 'idle' ); IO-Async-0.804/t/14loop-poll-process.t000444001750001750 20515001742754 16135 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Poll', 'process' ); IO-Async-0.804/t/14loop-select-process.t000444001750001750 20715001742754 16450 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Select', 'process' ); IO-Async-0.804/t/15loop-poll-control.t000444001750001750 20515001742754 16140 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Poll', 'control' ); IO-Async-0.804/t/15loop-select-control.t000444001750001750 20715001742754 16453 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Select', 'control' ); IO-Async-0.804/t/16loop-poll-metrics.t000444001750001750 20515001742754 16127 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Poll', 'metrics' ); IO-Async-0.804/t/16loop-select-metrics.t000444001750001750 20715001742754 16442 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Select', 'metrics' ); IO-Async-0.804/t/18loop-poll-legacy.t000444001750001750 435515001742754 15761 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use IO::Poll; use IO::Async::OS; use IO::Async::Loop::Poll; my $poll = IO::Poll->new; my $loop = IO::Async::Loop::Poll->new( poll => $poll ); my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!"; # Need sockets in nonblocking mode $S1->blocking( 0 ); $S2->blocking( 0 ); # Empty is( [ $poll->handles ], [], '$poll->handles empty initially' ); # watch_io my $readready = 0; $loop->watch_io( handle => $S1, on_read_ready => sub { $readready = 1 }, ); is( [ $poll->handles ], [ $S1 ], '$poll->handles after watch_io read_ready' ); $S2->syswrite( "data\n" ); # We should still wait a little while even thought we expect to be ready # immediately, because talking to ourself with 0 poll timeout is a race # condition - we can still race with the kernel. $poll->poll( 0.1 ); is( $readready, 0, '$readready before post_poll' ); $loop->post_poll; is( $readready, 1, '$readready after post_poll' ); # Ready $S1 to clear the data $S1->getline; # ignore return $loop->unwatch_io( handle => $S1, on_read_ready => 1, ); is( [ $poll->handles ], [], '$poll->handles empty after unwatch_io read_ready' ); my $writeready = 0; $loop->watch_io( handle => $S1, on_write_ready => sub { $writeready = 1 }, ); is( [ $poll->handles ], [ $S1 ], '$poll->handles after watch_io write_ready' ); $poll->poll( 0.1 ); is( $writeready, 0, '$writeready before post_poll' ); $loop->post_poll; is( $writeready, 1, '$writeready after post_poll' ); $loop->unwatch_io( handle => $S1, on_write_ready => 1, ); is( [ $poll->handles ], [], '$poll->handles empty after unwatch_io write_ready' ); # Removal is clean (tests for workaround to bug in IO::Poll version 0.05) my ( $P1, $P2 ) = IO::Async::OS->pipepair or die "Cannot pipepair - $!"; $_->blocking( 0 ) for $P1, $P2; # Just to make the loop non-empty $loop->watch_io( handle => $P2, on_read_ready => sub {} ); $loop->watch_io( handle => \*STDOUT, on_write_ready => sub {} ); is( scalar $poll->handles, 2, '$poll->handles before removal in clean removal test' ); $loop->unwatch_io( handle => \*STDOUT, on_write_ready => 1 ); is( scalar $poll->handles, 1, '$poll->handles after removal in clean removal test' ); done_testing; IO-Async-0.804/t/18loop-select-legacy.t000444001750001750 756215001742754 16275 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use Time::HiRes qw( time ); use IO::Async::Loop::Select; use IO::Async::OS; use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1; my $loop = IO::Async::Loop::Select->new; my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!"; # Need sockets in nonblocking mode $S1->blocking( 0 ); $S2->blocking( 0 ); my $testvec = ''; vec( $testvec, $S1->fileno, 1 ) = 1; my ( $rvec, $wvec, $evec ) = ('') x 3; my $timeout; # Empty $loop->pre_select( \$rvec, \$wvec, \$evec, \$timeout ); is( $rvec, '', '$rvec idling pre_select' ); is( $wvec, '', '$wvec idling pre_select' ); is( $evec, '', '$evec idling pre_select' ); is( $timeout, undef, '$timeout idling pre_select' ); # watch_io my $readready = 0; $loop->watch_io( handle => $S1, on_read_ready => sub { $readready = 1 }, ); $loop->pre_select( \$rvec, \$wvec, \$evec, \$timeout ); is( $rvec, $testvec, '$rvec readready pre_select' ); is( $wvec, '', '$wvec readready pre_select' ); is( $evec, '', '$evec readready pre_select' ); is( $timeout, undef, '$timeout readready pre_select' ); is( $readready, 0, '$readready readready pre_select' ); $rvec = $testvec; $wvec = ''; $evec = ''; $loop->post_select( $rvec, $wvec, $evec ); is( $readready, 1, '$readready readready post_select' ); $loop->unwatch_io( handle => $S1, on_read_ready => 1, ); my $writeready = 0; $loop->watch_io( handle => $S1, on_write_ready => sub { $writeready = 1 }, ); $loop->pre_select( \$rvec, \$wvec, \$evec, \$timeout ); is( $rvec, $testvec, '$rvec writeready pre_select' ); is( $wvec, $testvec, '$wvec writeready pre_select' ); is( $evec, IO::Async::OS->HAVE_SELECT_CONNECT_EVEC ? $testvec : '', '$evec writeready pre_select' ); is( $timeout, undef, '$timeout writeready pre_select' ); is( $writeready, 0, '$writeready writeready pre_select' ); $rvec = ''; $wvec = $testvec; $evec = ''; $loop->post_select( $rvec, $wvec, $evec ); is( $writeready, 1, '$writeready writeready post_select' ); $loop->unwatch_io( handle => $S1, on_write_ready => 1, ); # watch_time $rvec = $wvec = $evec = ''; $timeout = 5 * AUT; $loop->pre_select( \$rvec, \$wvec, \$evec, \$timeout ); is( $timeout, 5 * AUT, '$timeout idling pre_select with timeout' ); my $done = 0; $loop->watch_time( after => 2 * AUT, code => sub { $done = 1; } ); $loop->pre_select( \$rvec, \$wvec, \$evec, \$timeout ); cmp_ok( $timeout/AUT, '>', 1.7, '$timeout while timer waiting pre_select at least 1.7' ); cmp_ok( $timeout/AUT, '<', 2.5, '$timeout while timer waiting pre_select at least 2.5' ); my ( $now, $took ); $now = time; select( $rvec, $wvec, $evec, $timeout ); $took = (time - $now) / AUT; cmp_ok( $took, '>', 1.7, 'loop_once(5) while waiting for timer takes at least 1.7 seconds' ); cmp_ok( $took, '<', 10, 'loop_once(5) while waiting for timer no more than 10 seconds' ); if( $took > 2.5 ) { diag( "took more than 2.5 seconds to select(2).\n" . "This is not itself a bug, and may just be an indication of a busy testing machine" ); } $loop->post_select( $rvec, $evec, $wvec ); # select might have returned just a little early, such that the TimerQueue # doesn't think anything is ready yet. We need to handle that case. while( !$done ) { die "It should have been ready by now" if( time - $now > 5 * AUT ); $timeout = 0.1 * AUT; $loop->pre_select( \$rvec, \$wvec, \$evec, \$timeout ); select( $rvec, $wvec, $evec, $timeout ); $loop->post_select( $rvec, $evec, $wvec ); } is( $done, 1, '$done after post_select while waiting for timer' ); my $id = $loop->watch_time( after => 1 * AUT, code => sub { $done = 2; } ); $loop->unwatch_time( $id ); $done = 0; $now = time; $loop->pre_select( \$rvec, \$wvec, \$evec, \$timeout ); select( $rvec, $wvec, $evec, 1.5 * AUT ); $loop->post_select( $rvec, $evec, $wvec ); is( $done, 0, '$done still 0 before cancelled timeout' ); done_testing; IO-Async-0.804/t/19loop-future.t000444001750001750 616215001742754 15062 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; use lib "."; use t::TimeAbout; use IO::Async::Loop; use Future; use IO::Async::Future; use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1; my $loop = IO::Async::Loop->new_builtin; { my $future = Future->new; $loop->later( sub { $future->done( "result" ) } ); my $ret = $loop->await( $future ); ref_is( $ret, $future, '$loop->await( $future ) returns $future' ); is( [ $future->get ], [ "result" ], '$future->get' ); } { my $future = $loop->later; my $cancellable_future = $loop->later; ok( !$future->is_ready, '$loop->later returns a pending Future' ); ok( !$cancellable_future->is_ready, 'another $loop->later also returns a pending Future' ); $cancellable_future->cancel; $loop->loop_once; ok( $future->is_done, '$loop->later Future is resolved after one loop iteration' ); ok( $cancellable_future->is_cancelled, '$loop->later Future cancels cleanly' ); } { my @futures = map { Future->new } 0 .. 2; do { my $id = $_; $loop->later( sub { $futures[$id]->done } ) } for 0 .. 2; $loop->await_all( @futures ); ok( 1, '$loop->await_all' ); ok( $futures[$_]->is_ready, "future $_ ready" ) for 0 .. 2; } { my $future = IO::Async::Future->new( $loop ); ref_is( $future->loop, $loop, '$future->loop yields $loop' ); $loop->later( sub { $future->done( "result" ) } ); is( [ $future->get ], [ "result" ], '$future->get on IO::Async::Future' ); } { my $future = $loop->new_future; $loop->later( sub { $future->done( "result" ) } ); is( [ $future->get ], [ "result" ], '$future->get on IO::Async::Future from $loop->new_future' ); } # done_later { my $future = $loop->new_future; ref_is( $future->done_later( "deferred result" ), $future, '->done_later returns $future' ); ok( !$future->is_ready, '$future not yet ready after ->done_later' ); is( [ $future->get ], [ "deferred result" ], '$future now ready after ->get' ); } # fail_later { my $future = $loop->new_future; ref_is( $future->fail_later( "deferred exception\n" ), $future, '->fail_later returns $future' ); ok( !$future->is_ready, '$future not yet ready after ->fail_later' ); $loop->await( $future ); is( [ $future->failure ], [ "deferred exception\n" ], '$future now ready after $loop->await' ); } # delay_future { my $future = $loop->delay_future( after => 1 * AUT ); time_about( sub { $loop->await( $future ) }, 1, '->delay_future is ready' ); ok( $future->is_ready, '$future is ready from delay_future' ); is( [ $future->get ], [], '$future->get returns empty list on delay_future' ); # Check that ->cancel does not crash $loop->delay_future( after => 1 * AUT )->cancel; } # timeout_future { my $future = $loop->timeout_future( after => 1 * AUT ); time_about( sub { $loop->await( $future ) }, 1, '->timeout_future is ready' ); ok( $future->is_ready, '$future is ready from timeout_future' ); is( scalar $future->failure, "Timeout", '$future failed with "Timeout" for timeout_future' ); # Check that ->cancel does not crash $loop->timeout_future( after => 1 * AUT )->cancel; } done_testing; IO-Async-0.804/t/19test.t000444001750001750 307215001742754 13555 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0 0.000149; use IO::Async::Test; use IO::Async::OS; use IO::Async::Loop; my $loop = IO::Async::Loop->new_builtin; is_refcount( $loop, 2, '$loop has refcount 2 initially' ); testing_loop( $loop ); is_refcount( $loop, 3, '$loop has refcount 3 after adding to IO::Async::Test' ); my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!"; $_->blocking( 0 ) for $S1, $S2; my $readbuffer = ""; $loop->watch_io( handle => $S1, on_read_ready => sub { $S1->sysread( $readbuffer, 8192, length $readbuffer ) or die "Test failed early"; }, ); # This is just a token "does it run once?" test. A test of a test script. # Mmmmmm. Meta-testing. # Coming up with a proper test that would guarantee multiple loop_once # cycles, etc.. is difficult. TODO for later I feel. # In any case, the wait_for function is effectively tested to death in later # test scripts which use it. If it fails to work, they'd notice it. $S2->syswrite( "A line\n" ); wait_for { $readbuffer =~ m/\n/ }; is( $readbuffer, "A line\n", 'Single-wait' ); $loop->unwatch_io( handle => $S1, on_read_ready => 1, ); # Now the automatic version $readbuffer = ""; $S2->syswrite( "Another line\n" ); wait_for_stream { $readbuffer =~ m/\n/ } $S1 => $readbuffer; is( $readbuffer, "Another line\n", 'Automatic stream read wait' ); $readbuffer = ""; $S2->syswrite( "Some dynamic data\n" ); wait_for_stream { $readbuffer =~ m/\n/ } $S1 => sub { $readbuffer .= shift }; is( $readbuffer, "Some dynamic data\n" ); done_testing; IO-Async-0.804/t/20handle.t000444001750001750 2606615001742754 14051 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use IO::Async::Loop; use IO::Async::Handle; use IO::Async::OS; use Socket qw( AF_INET SOCK_STREAM SOCK_DGRAM SO_TYPE unpack_sockaddr_in ); my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); sub mkhandles { my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!"; # Need sockets in nonblocking mode $S1->blocking( 0 ); $S2->blocking( 0 ); return ( $S1, $S2 ); } ok( dies { IO::Async::Handle->new( handle => "Hello" ) }, 'Not a filehandle' ); # Read readiness { my ( $S1, $S2 ) = mkhandles; my $fd1 = $S1->fileno; my $readready = 0; my @rrargs; my $handle = IO::Async::Handle->new( read_handle => $S1, on_read_ready => sub { @rrargs = @_; $readready = 1 }, ); ok( defined $handle, '$handle defined' ); isa_ok( $handle, [ "IO::Async::Handle" ], '$handle isa IO::Async::Handle' ); is( $handle->notifier_name, "r=$fd1", '$handle->notifier_name for read_handle' ); is_oneref( $handle, '$handle has refcount 1 initially' ); is( $handle->read_handle, $S1, '->read_handle returns S1' ); is( $handle->read_fileno, $S1->fileno, '->read_fileno returns fileno(S1)' ); is( $handle->write_handle, undef, '->write_handle returns undef' ); ok( $handle->want_readready, 'want_readready true' ); $loop->add( $handle ); is_refcount( $handle, 2, '$handle has refcount 2 after adding to Loop' ); $loop->loop_once( 0.1 ); # nothing happens is( $readready, 0, '$readready while idle' ); $S2->syswrite( "data\n" ); wait_for { $readready }; is( $readready, 1, '$readready while readable' ); is( \@rrargs, [ exact_ref($handle) ], 'on_read_ready args while readable' ); $S1->getline; # ignore return $readready = 0; my $new_readready = 0; $handle->configure( on_read_ready => sub { $new_readready = 1 } ); $loop->loop_once( 0.1 ); # nothing happens is( $readready, 0, '$readready while idle after on_read_ready replace' ); is( $new_readready, 0, '$new_readready while idle after on_read_ready replace' ); $S2->syswrite( "data\n" ); wait_for { $new_readready }; is( $readready, 0, '$readready while readable after on_read_ready replace' ); is( $new_readready, 1, '$new_readready while readable after on_read_ready replace' ); $S1->getline; # ignore return ok( dies { $handle->want_writeready( 1 ); }, 'setting want_writeready with write_handle == undef dies' ); ok( !$handle->want_writeready, 'wantwriteready write_handle == undef false' ); undef @rrargs; is_refcount( $handle, 2, '$handle has refcount 2 before removing from Loop' ); $loop->remove( $handle ); is_oneref( $handle, '$handle has refcount 1 finally' ); } # Write readiness { my ( $S1, $S2 ) = mkhandles; my $fd1 = $S1->fileno; my $writeready = 0; my @wrargs; my $handle = IO::Async::Handle->new( write_handle => $S1, on_write_ready => sub { @wrargs = @_; $writeready = 1 }, ); ok( defined $handle, '$handle defined' ); isa_ok( $handle, [ "IO::Async::Handle" ], '$handle isa IO::Async::Handle' ); is( $handle->notifier_name, "w=$fd1", '$handle->notifier_name for write_handle' ); is_oneref( $handle, '$handle has refcount 1 initially' ); is( $handle->write_handle, $S1, '->write_handle returns S1' ); is( $handle->write_fileno, $S1->fileno, '->write_fileno returns fileno(S1)' ); is( $handle->read_handle, undef, '->read_handle returns undef' ); ok( !$handle->want_writeready, 'want_writeready false' ); $loop->add( $handle ); is_refcount( $handle, 2, '$handle has refcount 2 after adding to Loop' ); $loop->loop_once( 0.1 ); # nothing happens is( $writeready, 0, '$writeready while idle' ); $handle->want_writeready( 1 ); wait_for { $writeready }; is( $writeready, 1, '$writeready while writeable' ); is( \@wrargs, [ exact_ref($handle) ], 'on_write_ready args while writeable' ); $writeready = 0; my $new_writeready = 0; $handle->configure( on_write_ready => sub { $new_writeready = 1 } ); wait_for { $new_writeready }; is( $writeready, 0, '$writeready while writeable after on_write_ready replace' ); is( $new_writeready, 1, '$new_writeready while writeable after on_write_ready replace' ); undef @wrargs; is_refcount( $handle, 2, '$handle has refcount 2 before removing from Loop' ); $loop->remove( $handle ); is_oneref( $handle, '$handle has refcount 1 finally' ); } # Combined handle { my ( $S1, $S2 ) = mkhandles; my $fd1 = $S1->fileno; my $handle = IO::Async::Handle->new( handle => $S1, on_read_ready => sub {}, on_write_ready => sub {}, ); is( $handle->read_handle, $S1, '->read_handle returns S1' ); is( $handle->write_handle, $S1, '->write_handle returns S1' ); is( $handle->notifier_name, "rw=$fd1", '$handle->notifier_name for handle' ); } # Subclass my $sub_readready = 0; my $sub_writeready = 0; { my ( $S1, $S2 ) = mkhandles; my $handle = TestHandle->new( handle => $S1, ); ok( defined $handle, 'subclass $handle defined' ); isa_ok( $handle, [ "IO::Async::Handle" ], 'subclass $handle isa IO::Async::Handle' ); is_oneref( $handle, 'subclass $handle has refcount 1 initially' ); is( $handle->read_handle, $S1, 'subclass ->read_handle returns S1' ); is( $handle->write_handle, $S1, 'subclass ->write_handle returns S1' ); $loop->add( $handle ); is_refcount( $handle, 2, 'subclass $handle has refcount 2 after adding to Loop' ); $S2->syswrite( "data\n" ); wait_for { $sub_readready }; is( $sub_readready, 1, '$sub_readready while readable' ); is( $sub_writeready, 0, '$sub_writeready while readable' ); $S1->getline; # ignore return $sub_readready = 0; $handle->want_writeready( 1 ); wait_for { $sub_writeready }; is( $sub_readready, 0, '$sub_readready while writeable' ); is( $sub_writeready, 1, '$sub_writeready while writeable' ); $loop->remove( $handle ); } # Close { my ( $S1, $S2 ) = mkhandles; my $closed = 0; my $handle = IO::Async::Handle->new( read_handle => $S1, want_writeready => 0, on_read_ready => sub {}, on_closed => sub { $closed = 1 }, ); $loop->add( $handle ); my $close_future = $handle->new_close_future; my $closed_by_future; $close_future->on_done( sub { $closed_by_future++ } ); $handle->close; is( $closed, 1, '$closed after ->close' ); ok( $close_future->is_ready, '$close_future is now ready' ); is( $closed_by_future, 1, '$closed_by_future after ->close' ); # removed itself } # Close read/write { my ( $Srd1, $Srd2 ) = mkhandles; my ( $Swr1, $Swr2 ) = mkhandles; local $SIG{PIPE} = "IGNORE"; my $readready = 0; my $writeready = 0; my $closed = 0; my $handle = IO::Async::Handle->new( read_handle => $Srd1, write_handle => $Swr1, on_read_ready => sub { $readready++ }, on_write_ready => sub { $writeready++ }, on_closed => sub { $closed++ }, want_writeready => 1, ); $loop->add( $handle ); $handle->close_read; wait_for { $writeready }; is( $writeready, 1, '$writeready after ->close_read' ); $handle->write_handle->syswrite( "Still works\n" ); is( $Swr2->getline, "Still works\n", 'write handle still works' ); is( $closed, 0, 'not $closed after ->close_read' ); ref_is( $handle->loop, $loop, 'Handle still member of Loop after ->close_read' ); ( $Srd1, $Srd2 ) = mkhandles; $handle->configure( read_handle => $Srd1 ); $handle->close_write; $Srd2->syswrite( "Also works\n" ); wait_for { $readready }; is( $readready, 1, '$readready after ->close_write' ); is( $handle->read_handle->getline, "Also works\n", 'read handle still works' ); is( $Swr2->getline, undef, 'sysread from EOF write handle' ); ref_is( $handle->loop, $loop, 'Handle still member of Loop after ->close_write' ); is( $closed, 0, 'not $closed after ->close_read' ); $handle->close_read; is( $closed, 1, '$closed after ->close_read + ->close_write' ); is( $handle->loop, undef, '$handle no longer member of Loop' ); } # Late-binding of handle { my $readready; my $writeready; my $handle = IO::Async::Handle->new( want_writeready => 0, on_read_ready => sub { $readready = 1 }, on_write_ready => sub { $writeready = 1 }, ); ok( defined $handle, '$handle defined' ); ok( !defined $handle->read_handle, '->read_handle not defined' ); ok( !defined $handle->write_handle, '->write_handle not defined' ); is_oneref( $handle, '$handle latebound has refcount 1 initially' ); is( $handle->notifier_name, "", '$handle->notifier_name for late bind before handles' ); $loop->add( $handle ); is_refcount( $handle, 2, '$handle latebound has refcount 2 after $loop->add' ); my ( $S1, $S2 ) = mkhandles; my $fd1 = $S1->fileno; $handle->set_handle( $S1 ); is( $handle->read_handle, $S1, '->read_handle now S1' ); is( $handle->write_handle, $S1, '->write_handle now S1' ); is_refcount( $handle, 2, '$handle latebound still has refcount 2 after set_handle' ); is( $handle->notifier_name, "rw=$fd1", '$handle->notifier_name for late bind after handles' ); $S2->syswrite( "readable" ); wait_for { $readready }; pass( '$handle latebound still invokes on_read_ready' ); $loop->remove( $handle ); } # ->socket and ->bind { my $handle = IO::Async::Handle->new( on_read_ready => sub {}, on_write_ready => sub {} ); $handle->socket( [ 'inet', 'stream', 0 ] ); ok( defined $handle->read_handle, '->socket sets handle' ); is( $handle->read_handle->sockdomain, AF_INET, 'handle->sockdomain is AF_INET' ); is( $handle->read_handle->sockopt(SO_TYPE), SOCK_STREAM, 'handle->socktype is SOCK_STREAM' ); $handle->bind( { family => "inet", socktype => "dgram" } )->get; is( $handle->read_handle->sockopt(SO_TYPE), SOCK_DGRAM, 'handle->socktype is SOCK_DGRAM' ); # Not sure what port number but it should be nonzero ok( ( unpack_sockaddr_in( $handle->read_handle->sockname ) )[0], 'handle->sockname has nonzero port' ); } # Construction of IO::Handle from fileno { my $handle = IO::Async::Handle->new( read_fileno => 0, on_read_ready => sub { }, ); ok( defined $handle->read_handle, '->new with read_fileno creates read_handle' ); is( $handle->read_handle->fileno, 0, '->fileno of read_handle' ); $handle = IO::Async::Handle->new( write_fileno => 1, on_write_ready => sub { }, ); ok( defined $handle->write_handle, '->new with write_fileno creates write_handle' ); is( $handle->write_handle->fileno, 1, '->fileno of write_handle' ); $handle = IO::Async::Handle->new( read_fileno => 2, write_fileno => 2, on_read_ready => sub { }, on_write_ready => sub { }, ); ref_is( $handle->read_handle, $handle->write_handle, '->new with equal read and write fileno only creates one handle' ); } done_testing; package TestHandle; use base qw( IO::Async::Handle ); sub on_read_ready { $sub_readready = 1 } sub on_write_ready { $sub_writeready = 1 } IO-Async-0.804/t/21stream-1read.t000444001750001750 3636415001742754 15106 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use Test::Metrics::Any; use IO::File; use POSIX qw( ECONNRESET ); use IO::Async::Loop; use IO::Async::OS; use IO::Async::Stream; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); sub mkhandles { my ( $rd, $wr ) = IO::Async::OS->pipepair or die "Cannot pipe() - $!"; # Need handles in nonblocking mode $rd->blocking( 0 ); $wr->blocking( 0 ); return ( $rd, $wr ); } { my ( $rd, $wr ) = mkhandles; my @lines; my $stream = IO::Async::Stream->new( read_handle => $rd, on_read => sub { my $self = shift; my ( $buffref, $eof ) = @_; push @lines, $1 while $$buffref =~ s/^(.*\n)//; return 0; }, ); ok( defined $stream, 'reading $stream defined' ); isa_ok( $stream, [ "IO::Async::Stream" ], 'reading $stream isa IO::Async::Stream' ); is_oneref( $stream, 'reading $stream has refcount 1 initially' ); $loop->add( $stream ); is_refcount( $stream, 2, 'reading $stream has refcount 2 after adding to Loop' ); $wr->syswrite( "message\n" ); is( \@lines, [], '@lines before wait' ); wait_for { scalar @lines }; is( \@lines, [ "message\n" ], '@lines after wait' ); undef @lines; $wr->syswrite( "return" ); $loop->loop_once( 0.1 ); # nothing happens is( \@lines, [], '@lines partial still empty' ); $wr->syswrite( "\n" ); wait_for { scalar @lines }; is( \@lines, [ "return\n" ], '@lines partial completed now received' ); undef @lines; $wr->syswrite( "hello\nworld\n" ); wait_for { scalar @lines }; is( \@lines, [ "hello\n", "world\n" ], '@lines two at once' ); undef @lines; my @new_lines; $stream->configure( on_read => sub { my $self = shift; my ( $buffref, $eof ) = @_; push @new_lines, $1 while $$buffref =~ s/^(.*\n)//; return 0; }, ); $wr->syswrite( "new\nlines\n" ); wait_for { scalar @new_lines }; is( scalar @lines, 0, '@lines still empty after on_read replace' ); is( \@new_lines, [ "new\n", "lines\n" ], '@new_lines after on_read replace' ); is_refcount( $stream, 2, 'reading $stream has refcount 2 before removing from Loop' ); $loop->remove( $stream ); is_oneref( $stream, 'reading $stream refcount 1 finally' ); } # Abstract reading with reader function { my ( $rd, $wr ) = mkhandles; my $buffer = "Here is the contents\n"; my @lines; my $stream = IO::Async::Stream->new( read_handle => $rd, reader => sub { my $self = shift; my $more = substr( $buffer, 0, $_[2], "" ); $_[1] .= $more; return length $more; }, on_read => sub { my $self = shift; my ( $buffref, $eof ) = @_; push @lines, $1 while $$buffref =~ s/^(.*\n)//; return 0; }, ); $loop->add( $stream ); # make it readready $wr->syswrite( "1" ); wait_for { scalar @lines }; is( \@lines, [ "Here is the contents\n" ], '@lines from stream with abstract reader' ); $loop->remove( $stream ); } # ->want_readready_for_write { my ( $rd, $wr ) = mkhandles; my $reader_called; my $writer_called; my $stream = IO::Async::Stream->new( handle => $rd, on_read => sub { return 0; }, # ignore reading reader => sub { $reader_called++; sysread( $rd, $_[2], $_[3] ) }, writer => sub { $writer_called++; return 1 }, ); $loop->add( $stream ); # Hacky hack - make the stream want to write, but don't mark the stream write-ready $stream->write( "A" ); $stream->want_writeready_for_write( 0 ); # End hack # make it readready $wr->syswrite( "1" ); wait_for { $reader_called }; ok( !$writer_called, 'writer not yet called before ->want_readready_for_write' ); $stream->want_readready_for_write( 1 ); undef $reader_called; $wr->syswrite( "2" ); wait_for { $reader_called && $writer_called }; ok( $writer_called, 'writer now invoked with ->want_readready_for_write' ); $loop->remove( $stream ); } { my ( $rd, $wr ) = mkhandles; my @chunks; my $stream = IO::Async::Stream->new( read_handle => $rd, read_len => 2, on_read => sub { my ( $self, $buffref, $eof ) = @_; push @chunks, $$buffref; $$buffref = ""; }, ); $loop->add( $stream ); $wr->syswrite( "partial" ); wait_for { scalar @chunks }; is( \@chunks, [ "pa" ], '@lines with read_len=2 without read_all' ); wait_for { @chunks == 4 }; is( \@chunks, [ "pa", "rt", "ia", "l" ], '@lines finally with read_len=2 without read_all' ); undef @chunks; $stream->configure( read_all => 1 ); $wr->syswrite( "partial" ); wait_for { scalar @chunks }; is( \@chunks, [ "pa", "rt", "ia", "l" ], '@lines with read_len=2 with read_all' ); $loop->remove( $stream ); } { my ( $rd, $wr ) = mkhandles; my $no_on_read_stream; ok( !dies { $no_on_read_stream = IO::Async::Stream->new( read_handle => $rd ) }, 'Allowed to construct a Stream without an on_read handler' ); ok( dies { $loop->add( $no_on_read_stream ) }, 'Not allowed to add an on_read-less Stream to a Loop' ); } # Subclass my @sub_lines; { my ( $rd, $wr ) = mkhandles; my $stream = TestStream->new( read_handle => $rd, ); ok( defined $stream, 'reading subclass $stream defined' ); isa_ok( $stream, [ "IO::Async::Stream" ], 'reading $stream isa IO::Async::Stream' ); is_oneref( $stream, 'subclass $stream has refcount 1 initially' ); $loop->add( $stream ); is_refcount( $stream, 2, 'subclass $stream has refcount 2 after adding to Loop' ); $wr->syswrite( "message\n" ); is( \@sub_lines, [], '@sub_lines before wait' ); wait_for { scalar @sub_lines }; is( \@sub_lines, [ "message\n" ], '@sub_lines after wait' ); $loop->remove( $stream ); } # Dynamic on_read chaining { my ( $rd, $wr ) = mkhandles; my $outer_count = 0; my $inner_count = 0; my $record; my $stream = IO::Async::Stream->new( read_handle => $rd, on_read => sub { my ( $self, $buffref, $eof ) = @_; $outer_count++; return 0 unless $$buffref =~ s/^(.*\n)//; my $length = $1; return sub { my ( $self, $buffref, $eof ) = @_; $inner_count++; return 0 unless length $$buffref >= $length; $record = substr( $$buffref, 0, $length, "" ); return undef; } }, ); is_oneref( $stream, 'dynamic reading $stream has refcount 1 initially' ); $loop->add( $stream ); $wr->syswrite( "11" ); # No linefeed yet wait_for { $outer_count > 0 }; is( $outer_count, 1, '$outer_count after idle' ); is( $inner_count, 0, '$inner_count after idle' ); $wr->syswrite( "\n" ); wait_for { $inner_count > 0 }; is( $outer_count, 2, '$outer_count after received length' ); is( $inner_count, 1, '$inner_count after received length' ); $wr->syswrite( "Hello " ); wait_for { $inner_count > 1 }; is( $outer_count, 2, '$outer_count after partial body' ); is( $inner_count, 2, '$inner_count after partial body' ); $wr->syswrite( "world" ); wait_for { $inner_count > 2 }; is( $outer_count, 3, '$outer_count after complete body' ); is( $inner_count, 3, '$inner_count after complete body' ); is( $record, "Hello world", '$record after complete body' ); $loop->remove( $stream ); is_oneref( $stream, 'dynamic reading $stream has refcount 1 finally' ); } # ->push_on_read { my ( $rd, $wr ) = mkhandles; my $base; my $stream = IO::Async::Stream->new( read_handle => $rd, on_read => sub { my ( $self, $buffref ) = @_; $base = $$buffref; $$buffref = ""; return 0; }, ); $loop->add( $stream ); my $firstline; $stream->push_on_read( sub { my ( $stream, $buffref, $eof ) = @_; return 0 unless $$buffref =~ s/(.*)\n//; $firstline = $1; return undef; } ); my $eightbytes; $stream->push_on_read( sub { my ( $stream, $buffref, $eof ) = @_; return 0 unless length $$buffref >= 8; $eightbytes = substr( $$buffref, 0, 8, "" ); return undef; } ); $wr->syswrite( "The first line\nABCDEFGHIJK" ); wait_for { defined $firstline and defined $eightbytes }; is( $firstline, "The first line", '$firstline from ->push_on_read CODE' ); is( $eightbytes, "ABCDEFGH", '$eightbytes from ->push_on_read CODE' ); is( $base, "IJK", '$base from ->push_on_read CODE' ); $loop->remove( $stream ); } # EOF { my ( $rd, $wr ) = mkhandles; my $eof = 0; my $partial; my $stream = IO::Async::Stream->new( read_handle => $rd, on_read => sub { my ( undef, $buffref, $eof ) = @_; $partial = $$buffref if $eof; return 0; }, on_read_eof => sub { $eof++ }, ); $loop->add( $stream ); $wr->syswrite( "Incomplete" ); $wr->close; ok( !$stream->is_read_eof, '$stream ->is_read_eof before wait' ); is( $eof, 0, 'EOF indication before wait' ); wait_for { $eof }; ok( $stream->is_read_eof, '$stream ->is_read_eof after wait' ); is( $eof, 1, 'EOF indication after wait' ); is( $partial, "Incomplete", 'EOF stream retains partial input' ); ok( !defined $stream->loop, 'EOF stream no longer member of Loop' ); ok( !defined $stream->read_handle, 'Stream no longer has a read_handle' ); } # Disabled close_on_read_eof { my ( $rd, $wr ) = mkhandles; my $eof = 0; my $partial; my $stream = IO::Async::Stream->new( read_handle => $rd, on_read => sub { my ( undef, $buffref, $eof ) = @_; $partial = $$buffref if $eof; return 0; }, on_read_eof => sub { $eof++ }, close_on_read_eof => 0, ); $loop->add( $stream ); $wr->syswrite( "Incomplete" ); $wr->close; is( $eof, 0, 'EOF indication before wait' ); wait_for { $eof }; is( $eof, 1, 'EOF indication after wait' ); is( $partial, "Incomplete", 'EOF stream retains partial input' ); ok( defined $stream->loop, 'EOF stream still member of Loop' ); ok( defined $stream->read_handle, 'Stream still has a read_handle' ); } # Close { my ( $rd, $wr ) = mkhandles; my $closed = 0; my $loop_during_closed; my $stream = IO::Async::Stream->new( read_handle => $rd, on_read => sub { }, on_closed => sub { my ( $self ) = @_; $closed = 1; $loop_during_closed = $self->loop; }, ); is_oneref( $stream, 'closing $stream has refcount 1 initially' ); $loop->add( $stream ); is_refcount( $stream, 2, 'closing $stream has refcount 2 after adding to Loop' ); is( $closed, 0, 'closed before close' ); $stream->close; is( $closed, 1, 'closed after close' ); ref_is( $loop_during_closed, $loop, 'loop during closed' ); ok( !defined $stream->loop, 'Stream no longer member of Loop' ); is_oneref( $stream, 'closing $stream refcount 1 finally' ); } # ->read Futures { my ( $rd, $wr ) = mkhandles; my $stream = IO::Async::Stream->new( read_handle => $rd, on_read => sub { my ( $self, $buffref ) = @_; die "Base on_read invoked with data in the buffer" if length $$buffref; return 0; }, ); $loop->add( $stream ); my $f_atmost = $stream->read_atmost( 256 ); $wr->syswrite( "Some data\n" ); wait_for { $f_atmost->is_ready }; is( scalar $f_atmost->get, "Some data\n", '->read_atmost' ); my $f_exactly = $stream->read_exactly( 4 ); my $f_until_qr = $stream->read_until( qr/[A-Z][a-z]*/ ); my $f_until_str = $stream->read_until( "\n" ); $wr->syswrite( "Here is the First line of input\n" ); wait_for { $f_exactly->is_ready and $f_until_qr->is_ready and $f_until_str->is_ready }; is( scalar $f_exactly->get, "Here", '->read_exactly' ); is( scalar $f_until_qr->get, " is the First", '->read_until regexp' ); is( scalar $f_until_str->get, " line of input\n", '->read_until str' ); my $f_first = $stream->read_until( "\n" ); my $f_second = $stream->read_until( "\n" ); $f_first->cancel; $wr->syswrite( "For the second\n" ); wait_for { $f_second->is_ready }; is( scalar $f_second->get, "For the second\n", 'Second ->read_until recieves data after first is ->cancelled' ); my $f_until_eof = $stream->read_until_eof; $wr->syswrite( "And the rest of it" ); $wr->close; wait_for { $f_until_eof->is_ready }; is( scalar $f_until_eof->get, "And the rest of it", '->read_until_eof' ); # No need to remove as ->close did it } # RT101774 { my ( $rd, $wr ) = mkhandles; my $stream = IO::Async::Stream->new( read_handle => $rd, on_read => sub { 0 }, ); $loop->add( $stream ); $wr->syswrite( "lalaLALA" ); my $f = wait_for_future $stream->read_exactly( 4 )->then( sub { $stream->read_exactly( 4 ); }); is( scalar $f->get, "LALA", 'chained ->read_exactly' ); $loop->remove( $stream ); } # watermarks { my ( $rd, $wr ) = mkhandles; my $high_hit = 0; my $low_hit = 0; my $stream = IO::Async::Stream->new( read_handle => $rd, on_read => sub { 0 }, # we'll work by Futures read_high_watermark => 8, read_low_watermark => 4, on_read_high_watermark => sub { $high_hit++ }, on_read_low_watermark => sub { $low_hit++ }, ); $loop->add( $stream ); $wr->syswrite( "1234567890" ); wait_for { $high_hit }; ok( 1, "Reading too much hits high watermark" ); is( $stream->read_exactly( 8 )->get, "12345678", 'Stream->read_exactly yields bytes' ); is( $low_hit, 1, 'Low watermark hit after ->read' ); } # Errors { my ( $rd, $wr ) = mkhandles; $wr->syswrite( "X" ); # ensuring $rd is read-ready no warnings 'redefine'; local *IO::Handle::sysread = sub { $! = ECONNRESET; return undef; }; my $read_errno; my $stream = IO::Async::Stream->new( read_handle => $rd, on_read => sub {}, on_read_error => sub { ( undef, $read_errno ) = @_ }, ); $loop->add( $stream ); wait_for { defined $read_errno }; cmp_ok( $read_errno, "==", ECONNRESET, 'errno after failed read' ); my $f = wait_for_future $stream->read_atmost( 256 ); cmp_ok( ( $f->failure )[-1], "==", ECONNRESET, 'failure from ->read_atmost after failed read' ); $loop->remove( $stream ); } { binmode STDIN; # Avoid harmless warning in case -CS is in effect my $stream = IO::Async::Stream->new_for_stdin; is( $stream->read_handle, \*STDIN, 'Stream->new_for_stdin->read_handle is STDIN' ); } # Metrics SKIP: { skip "Metrics are unavailable" unless $IO::Async::Metrics::METRICS; my ( $rd, $wr ) = mkhandles; my $done; my $stream = IO::Async::Stream->new( read_handle => $rd, on_read => sub { my ( $self, $bufref ) = @_; $done = 1 if length $$bufref == 100; return 0; }, ); $loop->add( $stream ); $wr->syswrite( "X"x100 ); is_metrics_from( sub { wait_for { $done } }, { io_async_stream_read => 100 }, 'Stream reading increments metric' ); $loop->remove( $stream ); } done_testing; package TestStream; use base qw( IO::Async::Stream ); sub on_read { my $self = shift; my ( $buffref, $eof ) = @_; return 0 unless $$buffref =~ s/^(.*\n)//; push @sub_lines, $1; return 1; } IO-Async-0.804/t/21stream-2write.t000444001750001750 2660715001742754 15325 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use Test::Metrics::Any; use Errno qw( EAGAIN EWOULDBLOCK ECONNRESET ); use IO::Async::Loop; use IO::Async::OS; use IO::Async::Stream; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); sub mkhandles { my ( $rd, $wr ) = IO::Async::OS->pipepair or die "Cannot pipe() - $!"; # Need handles in nonblocking mode $rd->blocking( 0 ); $wr->blocking( 0 ); return ( $rd, $wr ); } # useful test function sub read_data { my ( $s ) = @_; my $buffer; my $ret = $s->sysread( $buffer, 8192 ); return $buffer if( defined $ret && $ret > 0 ); die "Socket closed" if( defined $ret && $ret == 0 ); return "" if $! == EAGAIN or $! == EWOULDBLOCK; die "Cannot sysread() - $!"; } { my ( $rd, $wr ) = mkhandles; my $empty; my $stream = IO::Async::Stream->new( write_handle => $wr, on_outgoing_empty => sub { $empty = 1 }, ); ok( defined $stream, 'writing $stream defined' ); isa_ok( $stream, [ "IO::Async::Stream" ], 'writing $stream isa IO::Async::Stream' ); is_oneref( $stream, 'writing $stream has refcount 1 initially' ); $loop->add( $stream ); is_refcount( $stream, 2, 'writing $stream has refcount 2 after adding to Loop' ); ok( !$stream->want_writeready, 'want_writeready before write' ); $stream->write( "message\n" ); ok( $stream->want_writeready, 'want_writeready after write' ); wait_for { $empty }; ok( !$stream->want_writeready, 'want_writeready after wait' ); is( $empty, 1, '$empty after writing buffer' ); is( read_data( $rd ), "message\n", 'data after writing buffer' ); my $written = 0; my $flushed; my $f = $stream->write( "hello again\n", on_write => sub { ref_is( $_[0], $stream, 'on_write $_[0] is $stream' ); $written += $_[1]; }, on_flush => sub { ref_is( $_[0], $stream, 'on_flush $_[0] is $stream' ); $flushed++ }, ); ok( !$f->is_ready, '->write future not yet ready' ); wait_for { $flushed }; ok( $f->is_ready, '->write future is ready after flush' ); is( $written, 12, 'on_write given total write length after flush' ); is( read_data( $rd ), "hello again\n", 'flushed data does get flushed' ); $flushed = 0; $stream->write( "", on_flush => sub { $flushed++ } ); wait_for { $flushed }; ok( 1, "write empty data with on_flush" ); $stream->configure( autoflush => 1 ); $stream->write( "immediate\n" ); ok( !$stream->want_writeready, 'not want_writeready after autoflush write' ); is( read_data( $rd ), "immediate\n", 'data after autoflush write' ); $stream->configure( autoflush => 0 ); $stream->write( "partial " ); $stream->configure( autoflush => 1 ); $stream->write( "data\n" ); ok( !$stream->want_writeready, 'not want_writeready after split autoflush write' ); is( read_data( $rd ), "partial data\n", 'data after split autoflush write' ); is_refcount( $stream, 2, 'writing $stream has refcount 2 before removing from Loop' ); $loop->remove( $stream ); is_oneref( $stream, 'writing $stream refcount 1 finally' ); } # Abstract writing with writer function { my ( $rd, $wr ) = mkhandles; my $buffer; my $stream = IO::Async::Stream->new( write_handle => $wr, writer => sub { my $self = shift; $buffer .= substr( $_[1], 0, $_[2], "" ); return $_[2]; }, ); $loop->add( $stream ); my $flushed; $stream->write( "Some data for abstract buffer\n", on_flush => sub { $flushed++ } ); wait_for { $flushed }; is( $buffer, "Some data for abstract buffer\n", '$buffer after ->write to stream with abstract writer' ); $loop->remove( $stream ); } # ->want_writeready_for_read { my ( $rd, $wr ) = mkhandles; my $reader_called; my $stream = IO::Async::Stream->new( handle => $wr, on_read => sub { return 0; }, # ignore reading reader => sub { $reader_called++; $! = EAGAIN; return undef }, ); $loop->add( $stream ); $loop->loop_once( 0.1 ); # haaaaack ok( !$reader_called, 'reader not yet called before ->want_writeready_for_read' ); $stream->want_writeready_for_read( 1 ); wait_for { $reader_called }; ok( $reader_called, 'reader now invoked with ->want_writeready_for_read' ); $loop->remove( $stream ); } # on_writeable_{start,stop} { my ( $rd, $wr ) = mkhandles; my $buffer; my $writeable; my $unwriteable; my $emulate_writeable = 0; my $stream = IO::Async::Stream->new( write_handle => $wr, writer => sub { my $self = shift; $! = EAGAIN, return undef unless $emulate_writeable; $buffer .= substr( $_[1], 0, $_[2], "" ); return $_[2]; }, on_writeable_start => sub { $writeable++ }, on_writeable_stop => sub { $unwriteable++ }, ); $loop->add( $stream ); $stream->write( "Something" ); wait_for { $unwriteable }; $emulate_writeable = 1; wait_for { $writeable }; is( $buffer, "Something", '$buffer after emulated EAGAIN' ); $loop->remove( $stream ); } { my ( $rd, $wr ) = mkhandles; my $stream = IO::Async::Stream->new( write_handle => $wr, write_len => 2, ); $loop->add( $stream ); $stream->write( "partial" ); $loop->loop_once( 0.1 ); is( read_data( $rd ), "pa", 'data after writing buffer with write_len=2 without write_all'); $loop->loop_once( 0.1 ) for 1 .. 3; is( read_data( $rd ), "rtial", 'data finally after writing buffer with write_len=2 without write_all' ); $stream->configure( write_all => 1 ); $stream->write( "partial" ); $loop->loop_once( 0.1 ); is( read_data( $rd ), "partial", 'data after writing buffer with write_len=2 with write_all'); $loop->remove( $stream ); } # EOF SKIP: { skip "This loop cannot detect hangup condition", 5 unless $loop->_CAN_ON_HANGUP; my ( $rd, $wr ) = mkhandles; local $SIG{PIPE} = "IGNORE"; my $eof = 0; my $stream = IO::Async::Stream->new( write_handle => $wr, on_write_eof => sub { $eof++ }, ); $loop->add( $stream ); my $write_future = $stream->write( "Junk" ); $rd->close; ok( !$stream->is_write_eof, '$stream->is_write_eof before wait' ); is( $eof, 0, 'EOF indication before wait' ); wait_for { $eof }; ok( $stream->is_write_eof, '$stream->is_write_eof after wait' ); is( $eof, 1, 'EOF indication after wait' ); ok( !defined $stream->loop, 'EOF stream no longer member of Loop' ); ok( $write_future->is_ready,'write future ready after stream closed' ); ok( $write_future->is_failed,'write future failed after stream closed' ); } # Close { my ( $rd, $wr ) = mkhandles; my $closed = 0; my $loop_during_closed; my $stream = IO::Async::Stream->new( write_handle => $wr, on_closed => sub { my ( $self ) = @_; $closed = 1; $loop_during_closed = $self->loop; }, ); is_oneref( $stream, 'closing $stream has refcount 1 initially' ); $stream->write( "hello" ); $loop->add( $stream ); is_refcount( $stream, 2, 'closing $stream has refcount 2 after adding to Loop' ); is( $closed, 0, 'closed before close' ); $stream->close_when_empty; is( $closed, 0, 'closed after close' ); wait_for { $closed }; is( $closed, 1, 'closed after wait' ); is( $loop_during_closed, $loop, 'loop during closed' ); ok( !defined $stream->loop, 'Stream no longer member of Loop' ); is_oneref( $stream, 'closing $stream refcount 1 finally' ); } # ->write( Future ) { my ( $rd, $wr ) = mkhandles; my $stream = IO::Async::Stream->new( write_handle => $wr, ); $loop->add( $stream ); my $written = 0; my $flushed; $stream->write( my $future = $loop->new_future, on_write => sub { $written += $_[1] }, on_flush => sub { $flushed++ }, ); $loop->loop_once( 0.1 ); is( read_data( $rd ), "", 'stream idle before Future completes' ); $future->done( "some data to write" ); wait_for { $flushed }; is( $written, 18, 'stream written by Future completion invokes on_write' ); is( read_data( $rd ), "some data to write", 'stream written by Future completion' ); $loop->remove( $stream ); } # ->write( CODE ) { my ( $rd, $wr ) = mkhandles; my $stream = IO::Async::Stream->new( write_handle => $wr, ); $loop->add( $stream ); my $done; my $written = 0; my $flushed; $stream->write( sub { ref_is( $_[0], $stream, 'Writersub $_[0] is $stream' ); return $done++ ? undef : "a lazy message\n"; }, on_write => sub { $written += $_[1] }, on_flush => sub { $flushed++ }, ); $flushed = 0; wait_for { $flushed }; is( $written, 15, 'stream written by generator CODE invokes on_write' ); is( read_data( $rd ), "a lazy message\n", 'lazy data was written' ); my @chunks = ( "some ", "message chunks ", "here\n" ); $stream->write( sub { return shift @chunks; }, on_flush => sub { $flushed++ }, ); $flushed = 0; wait_for { $flushed }; is( read_data( $rd ), "some message chunks here\n", 'multiple lazy data was written' ); $loop->remove( $stream ); } # ->write mixed returns { my ( $rd, $wr ) = mkhandles; my $stream = IO::Async::Stream->new( write_handle => $wr, ); $loop->add( $stream ); my $flushed; $stream->write( my $future = $loop->new_future, on_flush => sub { $flushed++ } ); my $once = 0; $future->done( sub { return $once++ ? undef : ( $future = $loop->new_future ); }); wait_for { $once }; $future->done( "Eventual string" ); wait_for { $flushed }; is( read_data( $rd ), "Eventual string", 'multiple lazy data was written' ); $loop->remove( $stream ); } { my ( $rd, $wr ) = mkhandles; my $stream = IO::Async::Stream->new; my $flushed; $stream->write( "Prequeued data", on_flush => sub { $flushed++ } ); $stream->configure( write_handle => $wr ); $loop->add( $stream ); wait_for { $flushed }; ok( 1, 'prequeued data gets flushed' ); is( read_data( $rd ), "Prequeued data", 'prequeued data gets written' ); $loop->remove( $stream ); } # Errors { my ( $rd, $wr ) = mkhandles; no warnings 'redefine'; local *IO::Handle::syswrite = sub { $! = ECONNRESET; return undef; }; my $write_errno; my $stream = IO::Async::Stream->new( write_handle => $wr, on_write_error => sub { ( undef, $write_errno ) = @_ }, ); $loop->add( $stream ); my $write_future = $stream->write( "hello" ); wait_for { defined $write_errno }; cmp_ok( $write_errno, "==", ECONNRESET, 'errno after failed write' ); ok( $write_future->is_ready,'write future ready after failed write' ); ok( $write_future->is_failed,'write future failed after failed write' ); $loop->remove( $stream ); } { my $stream = IO::Async::Stream->new_for_stdout; is( $stream->write_handle, \*STDOUT, 'Stream->new_for_stdout->write_handle is STDOUT' ); } # Metrics SKIP: { skip "Metrics are unavailable" unless $IO::Async::Metrics::METRICS; my ( $rd, $wr ) = mkhandles; my $done; my $stream = IO::Async::Stream->new( write_handle => $wr, on_outgoing_empty => sub { $done = 1 }, ); $stream->write( "X"x100 ); $loop->add( $stream ); is_metrics_from( sub { wait_for { $done } }, { io_async_stream_written => 100 }, 'Stream reading increments metric' ); $loop->remove( $stream ); } done_testing; IO-Async-0.804/t/21stream-3split.t000444001750001750 1010315001742754 15307 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use IO::File; use Errno qw( EAGAIN EWOULDBLOCK ); use IO::Async::Loop; use IO::Async::OS; use IO::Async::Stream; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!"; my ( $S3, $S4 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!"; # Need sockets in nonblocking mode $_->blocking( 0 ) for $S1, $S2, $S3, $S4; # useful test function sub read_data { my ( $s ) = @_; my $buffer; my $ret = $s->sysread( $buffer, 8192 ); return $buffer if( defined $ret && $ret > 0 ); die "Socket closed" if( defined $ret && $ret == 0 ); return "" if $! == EAGAIN or $! == EWOULDBLOCK; die "Cannot sysread() - $!"; } my @lines; my $stream = IO::Async::Stream->new( read_handle => $S2, write_handle => $S3, on_read => sub { my $self = shift; my ( $buffref, $eof ) = @_; push @lines, $1 while $$buffref =~ s/^(.*\n)//; return 0; }, ); is_oneref( $stream, 'split read/write $stream has refcount 1 initially' ); undef @lines; $loop->add( $stream ); is_refcount( $stream, 2, 'split read/write $stream has refcount 2 after adding to Loop' ); $stream->write( "message\n" ); $loop->loop_once( 0.1 ); is( read_data( $S4 ), "message\n", '$S4 receives data from split stream' ); is( read_data( $S1 ), "", '$S1 empty from split stream' ); $S1->syswrite( "reverse\n" ); $loop->loop_once( 0.1 ); is( \@lines, [ "reverse\n" ], '@lines on response to split stream' ); is_refcount( $stream, 2, 'split read/write $stream has refcount 2 before removing from Loop' ); $loop->remove( $stream ); is_oneref( $stream, 'split read/write $stream refcount 1 finally' ); undef $stream; my $buffer = ""; my $closed; $stream = IO::Async::Stream->new( # No handle yet on_read => sub { my ( $self, $buffref, $eof ) = @_; $buffer .= $$buffref; $$buffref = ""; return 0; }, on_closed => sub { my ( $self ) = @_; $closed = 1; }, ); is_oneref( $stream, 'latehandle $stream has refcount 1 initially' ); $loop->add( $stream ); is_refcount( $stream, 2, 'latehandle $stream has refcount 2 after adding to Loop' ); ok( dies { $stream->write( "some text" ) }, '->write on stream with no IO handle fails' ); $stream->set_handle( $S1 ); is_refcount( $stream, 2, 'latehandle $stream has refcount 2 after setting a handle' ); $stream->write( "some text" ); $loop->loop_once( 0.1 ); my $buffer2; $S2->sysread( $buffer2, 8192 ); is( $buffer2, "some text", 'stream-written text appears' ); $S2->syswrite( "more text" ); wait_for { length $buffer }; is( $buffer, "more text", 'stream-read text appears' ); $stream->close_when_empty; is( $closed, 1, 'closed after close' ); ok( !defined $stream->loop, 'Stream no longer member of Loop' ); is_oneref( $stream, 'latehandle $stream refcount 1 finally' ); # Now try re-opening the stream with a new handle, and check it continues to # work $loop->add( $stream ); $stream->set_handle( $S3 ); $stream->write( "more text" ); $loop->loop_once( 0.1 ); undef $buffer2; $S4->sysread( $buffer2, 8192 ); is( $buffer2, "more text", 'stream-written text appears after reopen' ); $loop->remove( $stream ); undef $stream; ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!"; $_->blocking( 0 ) for $S1, $S2; $stream = IO::Async::Stream->new( handle => $S1, on_read => sub { }, ); $stream->write( "hello" ); $loop->add( $stream ); is_refcount( $stream, 2, '$stream has two references' ); undef $stream; # Only ref is now in the Loop $S2->close; # $S1 should now be both read- and write-ready. ok( !dies { $loop->loop_once }, 'read+write-ready closed Stream doesn\'t die' ); undef $stream; binmode STDIN; # Avoid harmless warning in case -CS is in effect $stream = IO::Async::Stream->new_for_stdio; is( $stream->read_handle, \*STDIN, 'Stream->new_for_stdio->read_handle is STDIN' ); is( $stream->write_handle, \*STDOUT, 'Stream->new_for_stdio->write_handle is STDOUT' ); done_testing; IO-Async-0.804/t/21stream-4encoding.t000444001750001750 612715001742754 15736 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use Errno qw( EAGAIN EWOULDBLOCK ); use IO::Async::Loop; use IO::Async::OS; use IO::Async::Stream; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); sub mkhandles { my ( $rd, $wr ) = IO::Async::OS->pipepair or die "Cannot pipe() - $!"; # Need handles in nonblocking mode $rd->blocking( 0 ); $wr->blocking( 0 ); return ( $rd, $wr ); } # useful test function sub read_data { my ( $s ) = @_; my $buffer; my $ret = $s->sysread( $buffer, 8192 ); return $buffer if( defined $ret && $ret > 0 ); die "Socket closed" if( defined $ret && $ret == 0 ); return "" if $! == EAGAIN or $! == EWOULDBLOCK; die "Cannot sysread() - $!"; } # To test correct multi-byte encoding handling, we'll use a UTF-8 character # that requires multiple bytes. Furthermore we'll use one that doesn't appear # in Latin-1 # # 'ĉ' [U+0109] - LATIN SMALL LETTER C WITH CIRCUMFLEX # :0xc4 0x89 # Read encoding { my ( $rd, $wr ) = mkhandles; my $read = ""; my $stream = IO::Async::Stream->new( read_handle => $rd, encoding => "UTF-8", on_read => sub { $read = ${$_[1]}; ${$_[1]} = ""; return 0; }, ); $loop->add( $stream ); $wr->syswrite( "\xc4\x89" ); wait_for { length $read }; is( $read, "\x{109}", 'Unicode characters read by on_read' ); $wr->syswrite( "\xc4\x8a\xc4" ); $read = ""; wait_for { length $read }; is( $read, "\x{10a}", 'Partial UTF-8 character not yet visible' ); $wr->syswrite( "\x8b" ); $read = ""; wait_for { length $read }; is( $read, "\x{10b}", 'Partial UTF-8 character visible after completion' ); # An invalid sequence $wr->syswrite( "\xc4!" ); $read = ""; wait_for { length $read }; is( $read, "\x{fffd}!", 'Invalid UTF-8 byte yields U+FFFD' ); $loop->remove( $stream ); } # Write encoding { my ( $rd, $wr ) = mkhandles; my $stream = IO::Async::Stream->new( write_handle => $wr, encoding => "UTF-8", ); $loop->add( $stream ); my $flushed; $stream->write( "\x{109}", on_flush => sub { $flushed++ } ); wait_for { $flushed }; is( read_data( $rd ), "\xc4\x89", 'UTF-8 bytes written by ->write string' ); $stream->configure( write_len => 1 ); $stream->write( "\x{109}" ); my $byte; $loop->loop_once while !length( $byte = read_data( $rd ) ); is( $byte, "\xc4", 'First UTF-8 byte written with write_len 1' ); $loop->loop_once while !length( $byte = read_data( $rd ) ); is( $byte, "\x89", 'Remaining UTF-8 byte written with write_len 1' ); $flushed = 0; $stream->write( Future->done( "\x{10a}" ), on_flush => sub { $flushed++ } ); wait_for { $flushed }; is( read_data( $rd ), "\xc4\x8a", 'UTF-8 bytes written by ->write Future' ); $flushed = 0; my $once = 0; $stream->write( sub { $once++ ? undef : "\x{10b}" }, on_flush => sub { $flushed++ } ); wait_for { $flushed }; is( read_data( $rd ), "\xc4\x8b", 'UTF-8 bytes written by ->write CODE' ); $loop->remove( $stream ); } done_testing; IO-Async-0.804/t/22timer-absolute.t000444001750001750 621315001742754 15524 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use lib "."; use t::TimeAbout; use Time::HiRes qw( time ); use IO::Async::Timer::Absolute; use IO::Async::Loop; use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); { my $expired; my @eargs; my $timer = IO::Async::Timer::Absolute->new( time => time + 2 * AUT, on_expire => sub { @eargs = @_; $expired = 1 }, ); ok( defined $timer, '$timer defined' ); isa_ok( $timer, [ "IO::Async::Timer" ], '$timer isa IO::Async::Timer' ); is_oneref( $timer, '$timer has refcount 1 initially' ); $loop->add( $timer ); is_refcount( $timer, 2, '$timer has refcount 2 after adding to Loop' ); ok( $timer->is_running, 'Started Timer is running' ); time_about( sub { wait_for { $expired } }, 2, 'Timer works' ); is( \@eargs, [ exact_ref($timer) ], 'on_expire args' ); ok( !$timer->is_running, 'Expired Timer is no longer running' ); undef @eargs; is_refcount( $timer, 2, '$timer has refcount 2 before removing from Loop' ); $loop->remove( $timer ); is_oneref( $timer, '$timer has refcount 1 after removing from Loop' ); } { my $expired; my $timer = IO::Async::Timer::Absolute->new( time => time + 2 * AUT, on_expire => sub { $expired++ }, ); $loop->add( $timer ); $loop->remove( $timer ); $loop->loop_once( 3 * AUT ); ok( !$expired, "Removed Timer does not expire" ); } { my $expired; my $timer = IO::Async::Timer::Absolute->new( time => time + 5 * AUT, on_expire => sub { $expired++ }, ); $loop->add( $timer ); $timer->configure( time => time + 1 * AUT ); time_about( sub { wait_for { $expired } }, 1, 'Reconfigured timer works' ); $loop->remove( $timer ); } { my $timer = IO::Async::Timer::Absolute->new( time => time + 1 * AUT, on_expire => sub { die "Test failed to replace expiry handler" }, ); $loop->add( $timer ); my $new_expired; $timer->configure( on_expire => sub { $new_expired = 1 } ); time_about( sub { wait_for { $new_expired } }, 1, 'Reconfigured timer on_expire works' ); $loop->remove( $timer ); } ## Subclass my $sub_expired; { my $timer = TestTimer->new( time => time + 2 * AUT, ); ok( defined $timer, 'subclass $timer defined' ); isa_ok( $timer, [ "IO::Async::Timer" ], 'subclass $timer isa IO::Async::Timer' ); is_oneref( $timer, 'subclass $timer has refcount 1 initially' ); $loop->add( $timer ); is_refcount( $timer, 2, 'subclass $timer has refcount 2 after adding to Loop' ); ok( $timer->is_running, 'Started subclass Timer is running' ); time_about( sub { wait_for { $sub_expired } }, 2, 'subclass Timer works' ); ok( !$timer->is_running, 'Expired subclass Timer is no longer running' ); is_refcount( $timer, 2, 'subclass $timer has refcount 2 before removing from Loop' ); $loop->remove( $timer ); is_oneref( $timer, 'subclass $timer has refcount 1 after removing from Loop' ); } done_testing; package TestTimer; use base qw( IO::Async::Timer::Absolute ); sub on_expire { $sub_expired = 1 } IO-Async-0.804/t/22timer-countdown.t000444001750001750 1331715001742754 15751 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use lib "."; use t::TimeAbout; use Time::HiRes qw( time ); use IO::Async::Timer::Countdown; use IO::Async::Loop; use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); { my $expired; my @eargs; my $timer = IO::Async::Timer::Countdown->new( delay => 2 * AUT, on_expire => sub { @eargs = @_; $expired = 1 }, ); ok( defined $timer, '$timer defined' ); isa_ok( $timer, [ "IO::Async::Timer" ], '$timer isa IO::Async::Timer' ); is_oneref( $timer, '$timer has refcount 1 initially' ); $loop->add( $timer ); is_refcount( $timer, 2, '$timer has refcount 2 after adding to Loop' ); ok( !$timer->is_running, 'New Timer is no yet running' ); ok( !$timer->is_expired, 'New Timer is no yet expired' ); ref_is( $timer->start, $timer, '$timer->start returns $timer' ); is_refcount( $timer, 2, '$timer has refcount 2 after starting' ); ok( $timer->is_running, 'Started Timer is running' ); ok( !$timer->is_expired, 'Started Timer not yet expired' ); time_about( sub { wait_for { $expired } }, 2, 'Timer works' ); is( \@eargs, [ exact_ref($timer) ], 'on_expire args' ); ok( !$timer->is_running, 'Expired Timer is no longer running' ); ok( $timer->is_expired, 'Expired Timer now expired' ); undef @eargs; is_refcount( $timer, 2, '$timer has refcount 2 before removing from Loop' ); $loop->remove( $timer ); is_oneref( $timer, '$timer has refcount 1 after removing from Loop' ); undef $expired; is( $timer->start, $timer, '$timer->start out of a Loop returns $timer' ); $loop->add( $timer ); ok( $timer->is_running, 'Re-started Timer is running' ); ok( !$timer->is_expired, 'Re-started Timer not yet expired' ); time_about( sub { wait_for { $expired } }, 2, 'Timer works a second time' ); ok( !$timer->is_running, '2nd-time expired Timer is no longer running' ); ok( $timer->is_expired, '2nd-time expired Timer now expired' ); undef $expired; $timer->start; $loop->loop_once( 1 * AUT ); $timer->stop; $timer->stop; ok( 1, "Timer can be stopped a second time" ); $loop->loop_once( 2 * AUT ); ok( !$expired, "Stopped timer doesn't expire" ); undef $expired; $timer->start; $loop->loop_once( 1 * AUT ); my $now = time; $timer->reset; $loop->loop_once( 1.5 * AUT ); ok( !$expired, "Reset Timer hasn't expired yet" ); wait_for { $expired }; my $took = (time - $now) / AUT; cmp_ok( $took, '>', 1.5, "Timer has now expired took at least 1.5" ); cmp_ok( $took, '<', 2.5, "Timer has now expired took no more than 2.5" ); $loop->remove( $timer ); undef @eargs; is_oneref( $timer, 'Timer has refcount 1 finally' ); } { my $timer = IO::Async::Timer::Countdown->new( delay => 2 * AUT, on_expire => sub { }, ); $loop->add( $timer ); $timer->start; $loop->remove( $timer ); $loop->loop_once( 3 * AUT ); ok( !$timer->is_expired, "Removed Timer does not expire" ); } { my $timer = IO::Async::Timer::Countdown->new( delay => 2 * AUT, on_expire => sub { }, ); $timer->start; $loop->add( $timer ); ok( $timer->is_running, 'Pre-started Timer is running after adding' ); time_about( sub { wait_for { $timer->is_expired } }, 2, 'Pre-started Timer works' ); $loop->remove( $timer ); } { my $timer = IO::Async::Timer::Countdown->new( delay => 2 * AUT, on_expire => sub { }, ); $timer->start; $timer->stop; $loop->add( $timer ); $loop->loop_once( 3 * AUT ); ok( !$timer->is_expired, "start/stopped Timer doesn't expire" ); $loop->remove( $timer ); } { my $timer = IO::Async::Timer::Countdown->new( delay => 2 * AUT, on_expire => sub { }, ); $loop->add( $timer ); $timer->configure( delay => 1 * AUT ); $timer->start; time_about( sub { wait_for { $timer->is_expired } }, 1, 'Reconfigured timer delay works' ); my $expired; $timer->configure( on_expire => sub { $expired = 1 } ); $timer->start; time_about( sub { wait_for { $expired } }, 1, 'Reconfigured timer on_expire works' ); $timer->start; ok( dies { $timer->configure( delay => 5 ); }, 'Configure a running timer fails' ); $loop->remove( $timer ); } { my $timer = IO::Async::Timer::Countdown->new( delay => 1 * AUT, remove_on_expire => 1, on_expire => sub { }, ); $loop->add( $timer ); $timer->start; time_about( sub { wait_for { $timer->is_expired } }, 1, 'remove_on_expire Timer' ); is( $timer->loop, undef, 'remove_on_expire Timer removed from Loop after expire' ); } ## Subclass my $sub_expired; { my $timer = TestTimer->new( delay => 2 * AUT, ); ok( defined $timer, 'subclass $timer defined' ); isa_ok( $timer, [ "IO::Async::Timer" ], 'subclass $timer isa IO::Async::Timer' ); is_oneref( $timer, 'subclass $timer has refcount 1 initially' ); $loop->add( $timer ); is_refcount( $timer, 2, 'subclass $timer has refcount 2 after adding to Loop' ); $timer->start; is_refcount( $timer, 2, 'subclass $timer has refcount 2 after starting' ); ok( $timer->is_running, 'Started subclass Timer is running' ); time_about( sub { wait_for { $sub_expired } }, 2, 'subclass Timer works' ); ok( !$timer->is_running, 'Expired subclass Timer is no longer running' ); is_refcount( $timer, 2, 'subclass $timer has refcount 2 before removing from Loop' ); $loop->remove( $timer ); is_oneref( $timer, 'subclass $timer has refcount 1 after removing from Loop' ); } done_testing; package TestTimer; use base qw( IO::Async::Timer::Countdown ); sub on_expire { $sub_expired = 1 } IO-Async-0.804/t/22timer-periodic.t000444001750001750 1235515001742754 15530 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use lib "."; use t::TimeAbout; use IO::Async::Timer::Periodic; use IO::Async::Loop; use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); { my $tick = 0; my @targs; my $timer = IO::Async::Timer::Periodic->new( interval => 2 * AUT, on_tick => sub { @targs = @_; $tick++ }, ); ok( defined $timer, '$timer defined' ); isa_ok( $timer, [ "IO::Async::Timer" ], '$timer isa IO::Async::Timer' ); is_oneref( $timer, '$timer has refcount 1 initially' ); $loop->add( $timer ); is_refcount( $timer, 2, '$timer has refcount 2 after adding to Loop' ); ref_is( $timer->start, $timer, '$timer->start returns $timer' ); is_refcount( $timer, 2, '$timer has refcount 2 after starting' ); ok( $timer->is_running, 'Started Timer is running' ); time_about( sub { wait_for { $tick == 1 } }, 2, 'Timer works' ); is( \@targs, [ exact_ref($timer) ], 'on_tick args' ); ok( $timer->is_running, 'Timer is still running' ); time_about( sub { wait_for { $tick == 2 } }, 2, 'Timer works a second time' ); $loop->loop_once( 1 * AUT ); $timer->stop; $timer->stop; ok( 1, "Timer can be stopped a second time" ); $loop->loop_once( 2 * AUT ); ok( $tick == 2, "Stopped timer doesn't tick" ); undef @targs; is_refcount( $timer, 2, '$timer has refcount 2 before removing from Loop' ); $loop->remove( $timer ); is_oneref( $timer, '$timer has refcount 1 after removing from Loop' ); ok( !$timer->is_running, 'Removed timer not running' ); $loop->add( $timer ); $timer->configure( interval => 1 * AUT ); $timer->start; time_about( sub { wait_for { $tick == 3 } }, 1, 'Reconfigured timer interval works' ); $timer->stop; $timer->configure( interval => 2 * AUT, first_interval => 0 ); $timer->start; is( $tick, 3, 'Zero first_interval start not invoked yet' ); time_about( sub { wait_for { $tick == 4 } }, 0, 'Zero first_interval invokes callback async' ); time_about( sub { wait_for { $tick == 5 } }, 2, 'Normal interval used after first invocation' ); ok( dies { $timer->configure( interval => 5 ); }, 'Configure a running timer fails' ); $loop->remove( $timer ); undef @targs; is_oneref( $timer, 'Timer has refcount 1 finally' ); } # reschedule => "skip" { my $tick = 0; my $timer = IO::Async::Timer::Periodic->new( interval => 1 * AUT, reschedule => "skip", on_tick => sub { $tick++ }, ); $loop->add( $timer ); $timer->start; time_about( sub { wait_for { $tick == 1 } }, 1, 'skip Timer works' ); ok( $timer->is_running, 'skip Timer is still running' ); time_about( sub { wait_for { $tick == 2 } }, 1, 'skip Timer ticks a second time' ); $loop->remove( $timer ); } # reschedule => "drift" { my $tick = 0; my $timer = IO::Async::Timer::Periodic->new( interval => 1 * AUT, reschedule => "drift", on_tick => sub { $tick++ }, ); $loop->add( $timer ); $timer->start; time_about( sub { wait_for { $tick == 1 } }, 1, 'drift Timer works' ); ok( $timer->is_running, 'drift Timer is still running' ); time_about( sub { wait_for { $tick == 2 } }, 1, 'drift Timer ticks a second time' ); $loop->remove( $timer ); } # Self-stopping { my $count = 0; my $timer = IO::Async::Timer::Periodic->new( interval => 0.1 * AUT, on_tick => sub { $count++; shift->stop if $count >= 5 }, ); $loop->add( $timer ); $timer->start; my $timedout; my $id = $loop->watch_time( after => 1 * AUT, code => sub { $timedout++ } ); wait_for { $timedout }; is( $count, 5, 'Self-stopping timer can stop itself' ); $loop->remove( $timer ); $loop->unwatch_time( $id ); } # Exception in on_tick shouldn't prevent reschedule { my $count = 0; my $timer = IO::Async::Timer::Periodic->new( interval => 0.1 * AUT, on_tick => sub { $count++; die "FAIL $count" }, ); $loop->add( $timer ); $timer->start; like( dies { wait_for { $count > 0 } }, qr/FAIL 1/, 'on_tick death throws exception' ); like( dies { wait_for { $count > 1 } }, qr/FAIL 2/, 'on_tick death rescheduled and runs a second time' ); $loop->remove( $timer ); } ## Subclass my $sub_tick = 0; { my $timer = TestTimer->new( interval => 2 * AUT, ); ok( defined $timer, 'subclass $timer defined' ); isa_ok( $timer, [ "IO::Async::Timer" ], 'subclass $timer isa IO::Async::Timer' ); is_oneref( $timer, 'subclass $timer has refcount 1 initially' ); $loop->add( $timer ); is_refcount( $timer, 2, 'subclass $timer has refcount 2 after adding to Loop' ); $timer->start; is_refcount( $timer, 2, 'subclass $timer has refcount 2 after starting' ); ok( $timer->is_running, 'Started subclass Timer is running' ); time_about( sub { wait_for { $sub_tick == 1 } }, 2, 'subclass Timer works' ); is_refcount( $timer, 2, 'subclass $timer has refcount 2 before removing from Loop' ); $loop->remove( $timer ); is_oneref( $timer, 'subclass $timer has refcount 1 after removing from Loop' ); } done_testing; package TestTimer; use base qw( IO::Async::Timer::Periodic ); sub on_tick { $sub_tick++ } IO-Async-0.804/t/23signal.t000444001750001750 553115001742754 14050 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use POSIX qw( SIGTERM ); use IO::Async::Signal; use IO::Async::Loop; use IO::Async::OS; plan skip_all => "This OS does not have signals" unless IO::Async::OS->HAVE_SIGNALS; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); my $caught = 0; my @rargs; my $signal = IO::Async::Signal->new( name => 'TERM', on_receipt => sub { @rargs = @_; $caught++ }, ); ok( defined $signal, '$signal defined' ); isa_ok( $signal, [ "IO::Async::Signal" ], '$signal isa IO::Async::Signal' ); is_oneref( $signal, '$signal has refcount 1 initially' ); is( $signal->notifier_name, "TERM", '$signal->notifier_name' ); $loop->add( $signal ); is_refcount( $signal, 2, '$signal has refcount 2 after adding to Loop' ); $loop->loop_once( 0.1 ); # nothing happens is( $caught, 0, '$caught idling' ); kill SIGTERM, $$; wait_for { $caught }; is( $caught, 1, '$caught after raise' ); is( \@rargs, [ exact_ref($signal) ], 'on_receipt args after raise' ); my $caught2 = 0; my $signal2 = IO::Async::Signal->new( name => 'TERM', on_receipt => sub { $caught2++ }, ); $loop->add( $signal2 ); undef $caught; kill SIGTERM, $$; wait_for { $caught }; is( $caught, 1, '$caught after raise' ); is( $caught2, 1, '$caught2 after raise' ); $loop->remove( $signal2 ); undef $caught; undef $caught2; kill SIGTERM, $$; wait_for { $caught }; is( $caught, 1, '$caught after raise' ); is( $caught2, undef, '$caught2 after raise' ); undef $caught; my $new_caught; $signal->configure( on_receipt => sub { $new_caught++ } ); kill SIGTERM, $$; wait_for { $new_caught }; is( $caught, undef, '$caught after raise after replace on_receipt' ); is( $new_caught, 1, '$new_caught after raise after replace on_receipt' ); undef @rargs; is_refcount( $signal, 2, '$signal has refcount 2 before removing from Loop' ); $loop->remove( $signal ); is_oneref( $signal, '$signal has refcount 1 finally' ); undef $signal; ## Subclass my $sub_caught = 0; $signal = TestSignal->new( name => 'TERM', ); ok( defined $signal, 'subclass $signal defined' ); isa_ok( $signal, [ "IO::Async::Signal" ], 'subclass $signal isa IO::Async::Signal' ); is_oneref( $signal, 'subclass $signal has refcount 1 initially' ); $loop->add( $signal ); is_refcount( $signal, 2, 'subclass $signal has refcount 2 after adding to Loop' ); $loop->loop_once( 0.1 ); # nothing happens is( $sub_caught, 0, '$sub_caught idling' ); kill SIGTERM, $$; wait_for { $sub_caught }; is( $sub_caught, 1, '$sub_caught after raise' ); ok( dies { my $signal = IO::Async::Signal->new( name => 'this signal name does not exist', on_receipt => sub {}, ); $loop->add( $signal ); }, 'Bad signal name fails' ); done_testing; package TestSignal; use base qw( IO::Async::Signal ); sub on_receipt { $sub_caught++ } IO-Async-0.804/t/24listener.t000444001750001750 2135315001742754 14441 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use IO::Async::Loop; use IO::Socket::INET; use IO::Async::Listener; # Some odd locations like BSD jails might not like INADDR_ANY. We'll establish # a baseline first to test against my $INADDR_ANY = do { my $anysock = IO::Socket::INET->new( LocalPort => 0, Listen => 1 ); $anysock->sockaddr; }; my $INADDR_ANY_HOST = inet_ntoa( $INADDR_ANY ); if( $INADDR_ANY ne INADDR_ANY ) { diag( "Testing with INADDR_ANY=$INADDR_ANY_HOST; this may be because of odd networking" ); } my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); my $listensock; $listensock = IO::Socket::INET->new( LocalAddr => "localhost", Type => SOCK_STREAM, Listen => 1, Blocking => 0, ) or die "Cannot socket() - $!"; { my $newclient; my $listener = IO::Async::Listener->new( handle => $listensock, on_accept => sub { ( undef, $newclient ) = @_ }, ); ok( defined $listener, 'defined $listener' ); isa_ok( $listener, [ "IO::Async::Listener" ], '$listener isa IO::Async::Listener' ); isa_ok( $listener, [ "IO::Async::Notifier" ], '$listener isa IO::Async::Notifier' ); is_oneref( $listener, '$listener has refcount 1 initially' ); ok( $listener->is_listening, '$listener is_listening' ); is( [ unpack_sockaddr_in $listener->sockname ], [ unpack_sockaddr_in $listensock->sockname ], '$listener->sockname' ); is( $listener->family, AF_INET, '$listener->family' ); is( $listener->socktype, SOCK_STREAM, '$listener->sockname' ); $loop->add( $listener ); is_refcount( $listener, 2, '$listener has refcount 2 after adding to Loop' ); my $clientsock = IO::Socket::INET->new( Type => SOCK_STREAM ) or die "Cannot socket() - $!"; $clientsock->connect( $listensock->sockname ) or die "Cannot connect() - $!"; ok( defined $clientsock->peername, '$clientsock is connected' ); wait_for { defined $newclient }; is( [ unpack_sockaddr_in $newclient->peername ], [ unpack_sockaddr_in $clientsock->sockname ], '$newclient peer is correct' ); is_refcount( $listener, 2, '$listener has refcount 2 before removing from Loop' ); $loop->remove( $listener ); is_oneref( $listener, '$listener has refcount 1 after removing from Loop' ); } # on_accept handle constructors { my $accepted; my $listener = IO::Async::Listener->new( handle => $listensock, on_accept => sub { ( undef, $accepted ) = @_ }, ); $loop->add( $listener ); require IO::Async::Stream; # handle_constructor { $listener->configure( handle_constructor => sub { return IO::Async::Stream->new; } ); my $clientsock = IO::Socket::INET->new( Type => SOCK_STREAM ) or die "Cannot socket() - $!"; $clientsock->connect( $listensock->sockname ) or die "Cannot connect() - $!"; wait_for { defined $accepted }; isa_ok( $accepted, [ "IO::Async::Stream" ], '$accepted with handle_constructor' ); undef $accepted; } # handle_class { $listener->configure( handle_class => "IO::Async::Stream" ); my $clientsock = IO::Socket::INET->new( Type => SOCK_STREAM ) or die "Cannot socket() - $!"; $clientsock->connect( $listensock->sockname ) or die "Cannot connect() - $!"; wait_for { defined $accepted }; isa_ok( $accepted, [ "IO::Async::Stream" ], '$accepted with handle_constructor' ); undef $accepted; } $loop->remove( $listener ); } # on_stream { my $newstream; my $listener = IO::Async::Listener->new( handle => $listensock, on_stream => sub { ( undef, $newstream ) = @_ }, ); $loop->add( $listener ); my $clientsock = IO::Socket::INET->new( Type => SOCK_STREAM ) or die "Cannot socket() - $!"; $clientsock->connect( $listensock->sockname ) or die "Cannot connect() - $!"; wait_for { defined $newstream }; isa_ok( $newstream, [ "IO::Async::Stream" ], 'on_stream $newstream isa IO::Async::Stream' ); is( [ unpack_sockaddr_in $newstream->read_handle->peername ], [ unpack_sockaddr_in $clientsock->sockname ], '$newstream sock peer is correct' ); $loop->remove( $listener ); } # on_socket { my $newsocket; my $listener = IO::Async::Listener->new( handle => $listensock, on_socket => sub { ( undef, $newsocket ) = @_ }, ); $loop->add( $listener ); my $clientsock = IO::Socket::INET->new( Type => SOCK_STREAM ) or die "Cannot socket() - $!"; $clientsock->connect( $listensock->sockname ) or die "Cannot connect() - $!"; wait_for { defined $newsocket }; isa_ok( $newsocket, [ "IO::Async::Socket" ], 'on_socket $newsocket isa IO::Async::Socket' ); is( [ unpack_sockaddr_in $newsocket->read_handle->peername ], [ unpack_sockaddr_in $clientsock->sockname ], '$newsocket sock peer is correct' ); $loop->remove( $listener ); } # stop listening { my $listener = IO::Async::Listener->new( handle => $listensock, on_accept => sub {}, ); $loop->add( $listener ); $listener->configure( handle => undef ); is( $listener->read_handle, undef, '$listener has no read handle any more' ); $loop->remove( $listener ); } # Subclass { my $sub_newclient; { package TestListener; use base qw( IO::Async::Listener ); sub on_accept { ( undef, $sub_newclient ) = @_ } } my $listener = TestListener->new( handle => $listensock, ); ok( defined $listener, 'subclass defined $listener' ); isa_ok( $listener, [ "IO::Async::Listener" ], 'subclass $listener isa IO::Async::Listener' ); is_oneref( $listener, 'subclass $listener has refcount 1 initially' ); $loop->add( $listener ); is_refcount( $listener, 2, 'subclass $listener has refcount 2 after adding to Loop' ); my $clientsock = IO::Socket::INET->new( LocalAddr => "127.0.0.1", Type => SOCK_STREAM ) or die "Cannot socket() - $!"; $clientsock->connect( $listensock->sockname ) or die "Cannot connect() - $!"; ok( defined $clientsock->peername, 'subclass $clientsock is connected' ); wait_for { defined $sub_newclient }; is( [ unpack_sockaddr_in $sub_newclient->peername ], [ unpack_sockaddr_in $clientsock->sockname ], '$sub_newclient peer is correct' ); is_refcount( $listener, 2, 'subclass $listener has refcount 2 before removing from Loop' ); $loop->remove( $listener ); is_oneref( $listener, 'subclass $listener has refcount 1 after removing from Loop' ); } # Subclass with handle_constructor { { package TestListener::WithConstructor; use base qw( IO::Async::Listener ); sub handle_constructor { return IO::Async::Stream->new } } my $accepted; my $listener = TestListener::WithConstructor->new( handle => $listensock, on_accept => sub { ( undef, $accepted ) = @_; }, ); $loop->add( $listener ); my $clientsock = IO::Socket::INET->new( Type => SOCK_STREAM ) or die "Cannot socket() - $!"; $clientsock->connect( $listensock->sockname ) or die "Cannot connect() - $!"; wait_for { defined $accepted }; isa_ok( $accepted, [ "IO::Async::Stream" ], '$accepted with handle_constructor method' ); $loop->remove( $listener ); } { my $newclient; my $listener = IO::Async::Listener->new( on_accept => sub { ( undef, $newclient ) = @_ }, ); ok( !$listener->is_listening, '$listener is_listening not yet' ); $loop->add( $listener ); my $listen_self; $listener->listen( addr => { family => "inet", socktype => "stream", addr => pack_sockaddr_in( 0, $INADDR_ANY ) }, on_listen => sub { $listen_self = shift }, on_listen_error => sub { die "Test died early - $_[0] - $_[-1]\n"; }, ); ok( $listener->is_listening, '$listener is_listening' ); my $sockname = $listener->sockname; ok( defined $sockname, 'defined $sockname' ); my ( $port, $sinaddr ) = unpack_sockaddr_in( $sockname ); ok( $port > 0, 'socket listens on some defined port number' ); is( inet_ntoa( $sinaddr ), $INADDR_ANY_HOST, 'socket listens on INADDR_ANY' ); is( $listener->family, AF_INET, '$listener->family' ); is( $listener->socktype, SOCK_STREAM, '$listener->sockname' ); ref_is( $listen_self, $listener, '$listen_self is $listener' ); undef $listen_self; # for refcount my $clientsock = IO::Socket::INET->new( Type => SOCK_STREAM ) or die "Cannot socket() - $!"; $clientsock->connect( pack_sockaddr_in( $port, INADDR_LOOPBACK ) ) or die "Cannot connect() - $!"; ok( defined $clientsock->peername, '$clientsock is connected' ); wait_for { defined $newclient }; is( [ unpack_sockaddr_in $newclient->peername ], [ unpack_sockaddr_in $clientsock->sockname ], '$newclient peer is correct' ); $loop->remove( $listener ); } done_testing; IO-Async-0.804/t/25socket.t000444001750001750 2004515001742754 14102 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use Errno qw( EAGAIN EWOULDBLOCK ECONNRESET ); use Socket qw( unpack_sockaddr_in ); use IO::Async::Loop; use IO::Async::OS; use IO::Async::Socket; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); # useful test function sub recv_data { my ( $s ) = @_; my $buffer; my $ret = $s->recv( $buffer, 8192 ); return $buffer if defined $ret and length $buffer; die "Socket closed" if defined $ret; return "" if $! == EAGAIN or $! == EWOULDBLOCK; die "Cannot recv - $!"; } ok( !dies { IO::Async::Socket->new( write_handle => \*STDOUT ) }, 'Send-only Socket works' ); # Receiving { my ( $S1, $S2 ) = IO::Async::OS->socketpair( "inet", "dgram" ) or die "Cannot socketpair - $!"; my @S2addr = unpack_sockaddr_in $S2->sockname; # Need sockets in nonblocking mode $S1->blocking( 0 ); $S2->blocking( 0 ); my @received; my $socket = IO::Async::Socket->new( handle => $S1, on_recv => sub { my $self = shift; my ( $dgram, $sender ) = @_; push @received, [ $dgram, unpack_sockaddr_in $sender ]; }, ); ok( defined $socket, 'recving $socket defined' ); isa_ok( $socket, [ "IO::Async::Socket" ], 'recving $socket isa IO::Async::Socket' ); is_oneref( $socket, 'recving $socket has refcount 1 initially' ); $loop->add( $socket ); is_refcount( $socket, 2, 'recving $socket has refcount 2 after adding to Loop' ); $S2->send( "message\n" ); is( \@received, [], '@received before wait' ); wait_for { scalar @received }; is( \@received, [ [ "message\n", @S2addr ] ], '@received after wait' ); undef @received; my @new_received; $socket->configure( on_recv => sub { my $self = shift; my ( $dgram, $sender ) = @_; push @new_received, [ $dgram, unpack_sockaddr_in $sender ]; }, ); $S2->send( "another message\n" ); wait_for { scalar @new_received }; is( scalar @received, 0, '@received still empty after on_recv replace' ); is( \@new_received, [ [ "another message\n", @S2addr ] ], '@new_received after on_recv replace' ); is_refcount( $socket, 2, 'receiving $socket has refcount 2 before removing from Loop' ); $loop->remove( $socket ); is_oneref( $socket, 'receiving $socket refcount 1 finally' ); } SKIP: { # Don't bother with an OS constant for this as it's only used by this unit-test skip "This OS cannot safely ->recv with truncation", 3 if $^O eq "MSWin32"; my ( $S1, $S2 ) = IO::Async::OS->socketpair( "inet", "dgram" ) or die "Cannot socketpair - $!"; # Need sockets in nonblocking mode $S1->blocking( 0 ); $S2->blocking( 0 ); my @frags; my $socket = IO::Async::Socket->new( handle => $S1, recv_len => 4, on_recv => sub { my ( $self, $dgram ) = @_; push @frags, $dgram; }, ); $loop->add( $socket ); $S2->send( "A nice long message" ); $S2->send( "another one here" ); $S2->send( "and again" ); wait_for { scalar @frags }; is( \@frags, [ "A ni" ], '@frags with recv_len=4 without recv_all' ); wait_for { @frags == 3 }; is( \@frags, [ "A ni", "anot", "and " ], '@frags finally with recv_len=4 without recv_all' ); undef @frags; $socket->configure( recv_all => 1 ); $S2->send( "Long messages" ); $S2->send( "Repeated" ); $S2->send( "Once more" ); wait_for { scalar @frags }; is( \@frags, [ "Long", "Repe", "Once" ], '@frags with recv_len=4 with recv_all' ); $loop->remove( $socket ); } { my ( $S1, $S2 ) = IO::Async::OS->socketpair( "inet", "dgram" ) or die "Cannot socketpair - $!"; my $no_on_recv_socket; ok( !dies { $no_on_recv_socket = IO::Async::Socket->new( handle => $S1 ) }, 'Allowed to construct a Socket without an on_recv handler' ); ok( dies { $loop->add( $no_on_recv_socket ) }, 'Not allowed to add an on_recv-less Socket to a Loop' ); } # Subclass my @sub_received; { my ( $S1, $S2 ) = IO::Async::OS->socketpair( "inet", "dgram" ) or die "Cannot socketpair - $!"; my @S2addr = unpack_sockaddr_in $S2->sockname; # Need sockets in nonblocking mode $S1->blocking( 0 ); $S2->blocking( 0 ); my $socket = TestSocket->new( handle => $S1, ); ok( defined $socket, 'receiving subclass $socket defined' ); isa_ok( $socket, [ "IO::Async::Socket" ], 'receiving $socket isa IO::Async::Socket' ); is_oneref( $socket, 'subclass $socket has refcount 1 initially' ); $loop->add( $socket ); is_refcount( $socket, 2, 'subclass $socket has refcount 2 after adding to Loop' ); $S2->send( "message\n" ); is( \@sub_received, [], '@sub_received before wait' ); wait_for { scalar @sub_received }; is( \@sub_received, [ [ "message\n", @S2addr ] ], '@sub_received after wait' ); $loop->remove( $socket ); } # Sending { my ( $S1, $S2 ) = IO::Async::OS->socketpair( "inet", "dgram" ) or die "Cannot socketpair - $!"; # Need sockets in nonblocking mode $S1->blocking( 0 ); $S2->blocking( 0 ); my $empty; my $socket = IO::Async::Socket->new( write_handle => $S1, on_outgoing_empty => sub { $empty = 1 }, ); ok( defined $socket, 'sending $socket defined' ); isa_ok( $socket, [ "IO::Async::Socket" ], 'sending $socket isa IO::Async::Socket' ); is_oneref( $socket, 'sending $socket has refcount 1 intially' ); $loop->add( $socket ); is_refcount( $socket, 2, 'sending $socket has refcount 2 after adding to Loop' ); ok( !$socket->want_writeready, 'want_writeready before send' ); $socket->send( "message\n" ); ok( $socket->want_writeready, 'want_writeready after send' ); wait_for { $empty }; ok( !$socket->want_writeready, 'want_writeready after wait' ); is( $empty, 1, '$empty after writing buffer' ); is( recv_data( $S2 ), "message\n", 'data after writing buffer' ); $socket->configure( autoflush => 1 ); $socket->send( "immediate\n" ); ok( !$socket->want_writeready, 'not want_writeready after autoflush send' ); is( recv_data( $S2 ), "immediate\n", 'data after autoflush send' ); $socket->configure( autoflush => 0 ); $socket->send( "First\n" ); $socket->configure( autoflush => 1 ); $socket->send( "Second\n" ); ok( !$socket->want_writeready, 'not want_writeready after split autoflush send' ); is( recv_data( $S2 ), "First\n", 'data[0] after split autoflush send' ); is( recv_data( $S2 ), "Second\n", 'data[1] after split autoflush send' ); is_refcount( $socket, 2, 'sending $socket has refcount 2 before removing from Loop' ); $loop->remove( $socket ); is_oneref( $socket, 'sending $socket has refcount 1 finally' ); } # Socket errors { my ( $ES1, $ES2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!"; $_->blocking( 0 ) for $ES1, $ES2; $ES2->syswrite( "X" ); # ensuring $ES1 is read- and write-ready # cheating and hackery bless $ES1, "ErrorSocket"; $ErrorSocket::errno = ECONNRESET; my $recv_errno; my $send_errno; my $socket = IO::Async::Socket->new( read_handle => $ES1, on_recv => sub {}, on_recv_error => sub { ( undef, $recv_errno ) = @_ }, ); $loop->add( $socket ); wait_for { defined $recv_errno }; cmp_ok( $recv_errno, "==", ECONNRESET, 'errno after failed recv' ); $loop->remove( $socket ); $socket = IO::Async::Socket->new( write_handle => $ES1, on_send_error => sub { ( undef, $send_errno ) = @_ }, ); $loop->add( $socket ); $socket->send( "hello" ); wait_for { defined $send_errno }; cmp_ok( $send_errno, "==", ECONNRESET, 'errno after failed send' ); $loop->remove( $socket ); } done_testing; package TestSocket; use base qw( IO::Async::Socket ); use Socket qw( unpack_sockaddr_in ); sub on_recv { my $self = shift; my ( $dgram, $sender ) = @_; push @sub_received, [ $dgram, unpack_sockaddr_in $sender ]; } package ErrorSocket; use base qw( IO::Socket ); our $errno; sub recv { $! = $errno; undef; } sub send { $! = $errno; undef; } sub close { } IO-Async-0.804/t/26pid.t000444001750001750 362115001742754 13350 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use POSIX qw( SIGTERM ); use IO::Async::PID; use IO::Async::Loop; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); { my $kid = fork; defined $kid or die "Cannot fork() - $!"; if( $kid == 0 ) { # child exit( 3 ); # this exists as a zombie for now, but we'll deal with this later } my $exitcode; my $pid = IO::Async::PID->new( pid => $kid, on_exit => sub { ( undef, $exitcode ) = @_; } ); ok( defined $pid, '$pid defined' ); isa_ok( $pid, [ "IO::Async::PID" ], '$pid isa IO::Async::PID' ); is_oneref( $pid, '$pid has refcount 1 initially' ); is( $pid->pid, $kid, '$pid->pid' ); is( $pid->notifier_name, "$kid", '$pid->notifier_name' ); $loop->add( $pid ); is_refcount( $pid, 2, '$pid has refcount 2 after adding to Loop' ); # reap zombie wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after process exit' ); is( ($exitcode >> 8), 3, 'WEXITSTATUS($exitcode) after process exit' ); } SKIP: { skip "This OS has no signals", 1 unless IO::Async::OS->HAVE_SIGNALS; # We require that SIGTERM perform its default action; i.e. terminate the # process. Ensure this definitely happens, in case the test harness has it # ignored or handled elsewhere. local $SIG{TERM} = "DEFAULT"; my $kid = fork; defined $kid or die "Cannot fork() - $!"; if( $kid == 0 ) { sleep( 10 ); # Just in case the parent died already and didn't kill us exit( 0 ); } my $exitcode; my $pid = IO::Async::PID->new( pid => $kid, on_exit => sub { ( undef, $exitcode ) = @_; } ); $loop->add( $pid ); $pid->kill( SIGTERM ); wait_for { defined $exitcode }; is( ($exitcode & 0x7f), SIGTERM, 'WTERMSIG($exitcode) after SIGTERM' ); } done_testing; IO-Async-0.804/t/27file.t000444001750001750 516315001742754 13517 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use Fcntl qw( SEEK_SET SEEK_END ); use File::Temp qw( tempfile ); use IO::Async::Loop; use IO::Async::OS; use IO::Async::File; use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); sub mkhandles { my ( $rd, $filename ) = tempfile( "tmpfile.XXXXXX", UNLINK => 1 ); open my $wr, ">", $filename or die "Cannot reopen file for writing - $!"; $wr->autoflush( 1 ); return ( $rd, $wr, $filename ); } { my ( $rd, $wr ) = mkhandles; my $size_change; my ( $new_size, $old_size ); my ( $new_stat, $old_stat ); my $file = IO::Async::File->new( interval => 0.1 * AUT, handle => $rd, on_size_changed => sub { ( undef, $new_size, $old_size ) = @_; $size_change++; }, on_stat_changed => sub { ( undef, $new_stat, $old_stat ) = @_; }, ); ok( defined $file, '$file defined' ); isa_ok( $file, [ "IO::Async::File" ], '$file isa IO::Async::File' ); is_oneref( $file, '$file has refcount 1 initially' ); is( $file->handle, $rd, '$file->handle is $rd' ); $loop->add( $file ); is_refcount( $file, 2, '$file has refcount 2 after adding to Loop' ); $wr->syswrite( "message\n" ); wait_for { $size_change }; is( $old_size, 0, '$old_size' ); is( $new_size, 8, '$new_size' ); isa_ok( $old_stat, [ "File::stat" ], '$old_stat isa File::stat' ); isa_ok( $new_stat, [ "File::stat" ], '$new_stat isa File::stat' ); $loop->remove( $file ); } # Follow by name SKIP: { skip "OS is unable to rename open files", 3 unless IO::Async::OS->HAVE_RENAME_OPEN_FILES; my ( undef, $wr, $filename ) = mkhandles; my $devino_changed; my ( $old_stat, $new_stat ); my $file = IO::Async::File->new( interval => 0.1 * AUT, filename => $filename, on_devino_changed => sub { ( undef, $new_stat, $old_stat ) = @_; $devino_changed++; }, ); ok( $file->handle, '$file has a ->handle' ); $loop->add( $file ); close $wr; rename( $filename, "$filename.old" ) or die "Cannot rename $filename - $!"; END { defined $filename and -f $filename and unlink $filename } END { defined $filename and -f "$filename.old" and unlink "$filename.old" } open $wr, ">", $filename or die "Cannot reopen $filename for writing - $!"; wait_for { $devino_changed }; is( $new_stat->dev, (stat $wr)[0], '$new_stat->dev for renamed file' ); is( $new_stat->ino, (stat $wr)[1], '$new_stat->ino for renamed file' ); $loop->remove( $file ); } done_testing; IO-Async-0.804/t/28filestream.t000444001750001750 1653515001742754 14761 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use Fcntl qw( SEEK_SET SEEK_END ); use File::Temp qw( tempfile ); use IO::Async::Loop; use IO::Async::OS; use IO::Async::FileStream; use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); sub mkhandles { my ( $rd, $filename ) = tempfile( "tmpfile.XXXXXX", UNLINK => 1 ); open my $wr, ">", $filename or die "Cannot reopen file for writing - $!"; $wr->autoflush( 1 ); return ( $rd, $wr, $filename ); } { my ( $rd, $wr ) = mkhandles; my @lines; my $initial_size; my $filestream = IO::Async::FileStream->new( interval => 0.1 * AUT, read_handle => $rd, on_read => sub { my $self = shift; my ( $buffref, $eof ) = @_; push @lines, $1 while $$buffref =~ s/^(.*\n)//; return 0; }, on_initial => sub { ( undef, $initial_size ) = @_ }, ); ok( defined $filestream, '$filestream defined' ); isa_ok( $filestream, [ "IO::Async::FileStream" ], '$filestream isa IO::Async::FileStream' ); is_oneref( $filestream, 'reading $filestream has refcount 1 initially' ); $loop->add( $filestream ); is_refcount( $filestream, 2, '$filestream has refcount 2 after adding to Loop' ); is( $initial_size, 0, '$initial_size is 0' ); $wr->syswrite( "message\n" ); is( \@lines, [], '@lines before wait' ); wait_for { scalar @lines }; is( \@lines, [ "message\n" ], '@lines after wait' ); $loop->remove( $filestream ); } # on_initial { my ( $rd, $wr ) = mkhandles; $wr->syswrite( "Some initial content\n" ); my @lines; my $initial_size; my $filestream = IO::Async::FileStream->new( interval => 0.1 * AUT, read_handle => $rd, on_read => sub { my $self = shift; my ( $buffref, $eof ) = @_; push @lines, $1 while $$buffref =~ s/^(.*\n)//; return 0; }, on_initial => sub { ( undef, $initial_size ) = @_ }, ); $loop->add( $filestream ); is( $initial_size, 21, '$initial_size is 21' ); $wr->syswrite( "More content\n" ); wait_for { scalar @lines }; is( \@lines, [ "Some initial content\n", "More content\n" ], 'All content is visible' ); $loop->remove( $filestream ); } # seek_to_last { my ( $rd, $wr ) = mkhandles; $wr->syswrite( "Some skipped content\nWith a partial line" ); my @lines; my $filestream = IO::Async::FileStream->new( interval => 0.1 * AUT, read_handle => $rd, on_read => sub { my $self = shift; my ( $buffref, $eof ) = @_; return 0 unless( $$buffref =~ s/^(.*\n)// ); push @lines, $1; return 1; }, on_initial => sub { my $self = shift; # Give it a tiny block size, forcing it to have to seek harder to find the \n ok( $self->seek_to_last( "\n", blocksize => 8 ), 'FileStream successfully seeks to last \n' ); }, ); $loop->add( $filestream ); $wr->syswrite( " finished here\n" ); wait_for { scalar @lines }; is( \@lines, [ "With a partial line finished here\n" ], 'Partial line completely returned' ); $loop->remove( $filestream ); } # on_initial can skip content { my ( $rd, $wr ) = mkhandles; $wr->syswrite( "Some skipped content\n" ); my @lines; my $filestream = IO::Async::FileStream->new( interval => 0.1 * AUT, read_handle => $rd, on_read => sub { my $self = shift; my ( $buffref, $eof ) = @_; return 0 unless( $$buffref =~ s/^(.*\n)// ); push @lines, $1; return 1; }, on_initial => sub { my $self = shift; $self->seek( 0, SEEK_END ); }, ); $loop->add( $filestream ); $wr->syswrite( "Additional content\n" ); wait_for { scalar @lines }; is( \@lines, [ "Additional content\n" ], 'Initial content is skipped' ); $loop->remove( $filestream ); } # Truncation { my ( $rd, $wr ) = mkhandles; my @lines; my $truncated; my $filestream = IO::Async::FileStream->new( interval => 0.1 * AUT, read_handle => $rd, on_read => sub { my $self = shift; my ( $buffref, $eof ) = @_; return 0 unless( $$buffref =~ s/^(.*\n)// ); push @lines, $1; return 1; }, on_truncated => sub { $truncated++ }, ); $loop->add( $filestream ); $wr->syswrite( "Some original lines\nin the file\n" ); wait_for { scalar @lines }; $wr->truncate( 0 ); sysseek( $wr, 0, SEEK_SET ); $wr->syswrite( "And another\n" ); wait_for { @lines == 3 }; is( $truncated, 1, 'File content truncation detected' ); is( \@lines, [ "Some original lines\n", "in the file\n", "And another\n" ], 'All three lines read' ); $loop->remove( $filestream ); } # Follow by name SKIP: { skip "OS is unable to rename open files", 7 unless IO::Async::OS->HAVE_RENAME_OPEN_FILES; my ( undef, $wr, $filename ) = mkhandles; my @lines; my $filestream = IO::Async::FileStream->new( interval => 0.1 * AUT, filename => $filename, on_read => sub { my $self = shift; my ( $buffref, $eof ) = @_; push @lines, $1 while $$buffref =~ s/^(.*\n)//; return 0; }, ); ok( defined $filestream, '$filestream defined for filenaem' ); isa_ok( $filestream, [ "IO::Async::FileStream" ], '$filestream isa IO::Async::FileStream' ); is_oneref( $filestream, 'reading $filestream has refcount 1 initially' ); $loop->add( $filestream ); is_refcount( $filestream, 2, '$filestream has refcount 2 after adding to Loop' ); $wr->syswrite( "message\n" ); wait_for { scalar @lines }; is( \@lines, [ "message\n" ], '@lines after wait' ); shift @lines; $wr->syswrite( "last line of old file\n" ); close $wr; rename( $filename, "$filename.old" ) or die "Cannot rename $filename - $!"; END { defined $filename and -f $filename and unlink $filename } END { defined $filename and -f "$filename.old" and unlink "$filename.old" } open $wr, ">", $filename or die "Cannot reopen $filename for writing - $!"; $wr->syswrite( "first line of new file\n" ); wait_for { scalar @lines }; is( $lines[0], "last line of old file\n", '@lines sees last line of old file' ); wait_for { scalar @lines >= 2 }; is( $lines[1], "first line of new file\n", '@lines sees first line of new file' ); $loop->remove( $filestream ); } # Subclass my @sub_lines; { my ( $rd, $wr ) = mkhandles; my $filestream = TestStream->new( interval => 0.1 * AUT, read_handle => $rd, ); ok( defined $filestream, 'subclass $filestream defined' ); isa_ok( $filestream, [ "IO::Async::FileStream" ], '$filestream isa IO::Async::FileStream' ); is_oneref( $filestream, 'subclass $filestream has refcount 1 initially' ); $loop->add( $filestream ); is_refcount( $filestream, 2, 'subclass $filestream has refcount 2 after adding to Loop' ); $wr->syswrite( "message\n" ); is( \@sub_lines, [], '@sub_lines before wait' ); wait_for { scalar @sub_lines }; is( \@sub_lines, [ "message\n" ], '@sub_lines after wait' ); $loop->remove( $filestream ); } done_testing; package TestStream; use base qw( IO::Async::FileStream ); sub on_read { my $self = shift; my ( $buffref ) = @_; return 0 unless $$buffref =~ s/^(.*\n)//; push @sub_lines, $1; return 1; } IO-Async-0.804/t/30loop-fork.t000444001750001750 473015001742754 14501 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use Test::Metrics::Any; use POSIX qw( SIGINT ); use IO::Async::Loop; use IO::Async::OS; plan skip_all => "POSIX fork() is not available" unless IO::Async::OS->HAVE_POSIX_FORK; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); { my $exitcode; $loop->fork( code => sub { return 5; }, on_exit => sub { ( undef, $exitcode ) = @_ }, ); wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after child exit' ); is( ($exitcode >> 8), 5, 'WEXITSTATUS($exitcode) after child exit' ); } { my $exitcode; $loop->fork( code => sub { die "error"; }, on_exit => sub { ( undef, $exitcode ) = @_ }, ); wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after child die' ); is( ($exitcode >> 8), 255, 'WEXITSTATUS($exitcode) after child die' ); } SKIP: { skip "This OS does not have signals", 1 unless IO::Async::OS->HAVE_SIGNALS; local $SIG{INT} = sub { exit( 22 ) }; my $exitcode; $loop->fork( code => sub { kill SIGINT, $$ }, on_exit => sub { ( undef, $exitcode ) = @_ }, ); wait_for { defined $exitcode }; is( ($exitcode & 0x7f), SIGINT, 'WTERMSIG($exitcode) after child SIGINT' ); } SKIP: { skip "This OS does not have signals", 2 unless IO::Async::OS->HAVE_SIGNALS; local $SIG{INT} = sub { exit( 22 ) }; my $exitcode; $loop->fork( code => sub { kill SIGINT, $$ }, on_exit => sub { ( undef, $exitcode ) = @_ }, keep_signals => 1, ); wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after child SIGINT with keep_signals' ); is( ($exitcode >> 8), 22, 'WEXITSTATUS($exitcode) after child SIGINT with keep_signals' ); } { my $exitcode; $loop->fork( code => sub { my $innerloop = IO::Async::Loop->new; return 0 if $innerloop != $loop; # success return 1; }, on_exit => sub { ( undef, $exitcode ) = @_ }, ); wait_for { defined $exitcode }; ok( $exitcode == 0, 'IO::Async::Loop->new inside forked process code gets new loop instance' ); } # Metrics SKIP: { skip "Metrics are unavailable" unless $IO::Async::Metrics::METRICS; is_metrics_from( sub { $loop->fork( code => sub {}, on_exit => sub {} ) }, { io_async_forks => 1 }, '$loop->fork increments fork counter' ); } done_testing; IO-Async-0.804/t/31loop-spawnchild.t000444001750001750 1402315001742754 15711 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use POSIX qw( ENOENT EBADF ); use IO::Async::OS; plan skip_all => "POSIX fork() is not available" unless IO::Async::OS->HAVE_POSIX_FORK; use IO::Async::Loop; # Need to look this up, so we don't hardcode the message in the test script # This might cause locale issues use constant ENOENT_MESSAGE => do { local $! = ENOENT; "$!" }; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); ok( dies { $loop->spawn_child( badoption => 1 ); }, 'Bad option to spawn fails' ); ok( dies { $loop->spawn_child( code => sub { 1 }, command => "hello" ); }, 'Both code and command options to spawn fails' ); ok( dies { $loop->spawn_child( on_exit => sub { 1 } ); }, 'Bad option to spawn fails' ); { my ( $exited_pid, $exitcode, $dollarbang, $dollarat ); my $spawned_pid = $loop->spawn_child( code => sub { return 42; }, on_exit => sub { ( $exited_pid, $exitcode, $dollarbang, $dollarat ) = @_; } ); wait_for { defined $exited_pid }; is( $exited_pid, $spawned_pid, '$exited_pid == $spawned_pid after spawn CODE' ); ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after spawn CODE' ); is( ($exitcode >> 8), 42, 'WEXITSTATUS($exitcode) after spawn CODE' ); # dollarbang isn't interesting here is( $dollarat, '', '$dollarat after spawn CODE' ); } my $ENDEXIT = 10; END { exit $ENDEXIT if defined $ENDEXIT; } { my ( $exited_pid, $exitcode, $dollarbang, $dollarat ); my $spawned_pid = $loop->spawn_child( code => sub { return 0; }, on_exit => sub { ( $exited_pid, $exitcode, $dollarbang, $dollarat ) = @_; } ); wait_for { defined $exited_pid }; is( $exited_pid, $spawned_pid, '$exited_pid == $spawned_pid after spawn CODE with END' ); ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after spawn CODE with END' ); # If this comes out as 10 then the END block ran and we fail. is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after spawn CODE with END' ); # dollarbang isn't interesting here is( $dollarat, '', '$dollarat after spawn CODE with END' ); } { my ( $exited_pid, $exitcode, $dollarbang, $dollarat ); my $spawned_pid = $loop->spawn_child( code => sub { die "An exception here\n"; }, on_exit => sub { ( $exited_pid, $exitcode, $dollarbang, $dollarat ) = @_; } ); wait_for { defined $exited_pid }; is( $exited_pid, $spawned_pid, '$exited_pid == $spawned_pid after spawn CODE with die with END' ); ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after spawn CODE with die with END' ); is( ($exitcode >> 8), 255, 'WEXITSTATUS($exitcode) after spawn CODE with die with END' ); # dollarbang isn't interesting here is( $dollarat, "An exception here\n", '$dollarat after spawn CODE with die with END' ); } undef $ENDEXIT; # We need a command that just exits immediately with 0 my $true; foreach (qw( /bin/true /usr/bin/true )) { $true = $_, last if -x $_; } # Didn't find a likely-looking candidate. We'll fake one using perl itself $true = "$^X -e 1" if !defined $true; { my ( $exited_pid, $exitcode, $dollarbang, $dollarat ); my $spawned_pid = $loop->spawn_child( command => $true, on_exit => sub { ( $exited_pid, $exitcode, $dollarbang, $dollarat ) = @_; } ); wait_for { defined $exited_pid }; is( $exited_pid, $spawned_pid, '$exited_pid == $spawned_pid after spawn '.$true ); ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after spawn '.$true ); is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after spawn '.$true ); is( $dollarbang+0, 0, '$dollarbang after spawn '.$true ); is( $dollarat, '', '$dollarat after spawn '.$true ); } # Just be paranoid in case anyone actually has this my $donotexist = "/bin/donotexist"; $donotexist .= "X" while -e $donotexist; { my ( $exited_pid, $exitcode, $dollarbang, $dollarat ); my $spawned_pid = $loop->spawn_child( command => $donotexist, on_exit => sub { ( $exited_pid, $exitcode, $dollarbang, $dollarat ) = @_; } ); wait_for { defined $exited_pid }; is( $exited_pid, $spawned_pid, '$exited_pid == $spawned_pid after spawn donotexist' ); ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after spawn donotexist' ); is( ($exitcode >> 8), 255, 'WEXITSTATUS($exitcode) after spawn donotexist' ); is( $dollarbang+0, ENOENT, '$dollarbang numerically after spawn donotexist' ); is( "$dollarbang", ENOENT_MESSAGE, '$dollarbang string after spawn donotexist' ); is( $dollarat, '', '$dollarat after spawn donotexist' ); } { my ( $exited_pid, $exitcode, $dollarbang, $dollarat ); my $spawned_pid = $loop->spawn_child( command => [ $^X, "-e", "exit 14" ], on_exit => sub { ( $exited_pid, $exitcode, $dollarbang, $dollarat ) = @_; } ); wait_for { defined $exited_pid }; is( $exited_pid, $spawned_pid, '$exited_pid == $spawned_pid after spawn ARRAY' ); ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after spawn ARRAY' ); is( ($exitcode >> 8), 14, 'WEXITSTATUS($exitcode) after spawn ARRAY' ); is( $dollarbang+0, 0, '$dollarbang after spawn ARRAY' ); is( $dollarat, '', '$dollarat after spawn ARRAY' ); } { my( $pipe_r, $pipe_w ) = IO::Async::OS->pipepair or die "Cannot pipepair - $!"; my ( $exited_pid, $exitcode, $dollarbang, $dollarat ); my $spawned_pid = $loop->spawn_child( code => sub { return $pipe_w->syswrite( "test" ); }, on_exit => sub { ( $exited_pid, $exitcode, $dollarbang, $dollarat ) = @_; } ); wait_for { defined $exited_pid }; is( $exited_pid, $spawned_pid, '$exited_pid == $spawned_pid after pipe close test' ); ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after pipe close test' ); is( ($exitcode >> 8), 255, 'WEXITSTATUS($exitcode) after pipe close test' ); is( $dollarbang+0, EBADF, '$dollarbang numerically after pipe close test' ); is( $dollarat, '', '$dollarat after pipe close test' ); } done_testing; IO-Async-0.804/t/32loop-spawnchild-setup.t000444001750001750 2743315001742754 17061 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use File::Temp qw( tmpnam ); use POSIX qw( ENOENT EBADF getcwd ); use IO::Async::Loop; use IO::Async::OS; plan skip_all => "POSIX fork() is not available" unless IO::Async::OS->HAVE_POSIX_FORK; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); ok( dies { $loop->spawn_child( code => sub { 1 }, setup => "hello" ); }, 'Bad setup type fails' ); ok( dies { $loop->spawn_child( code => sub { 1 }, setup => [ 'somerandomthing' => 1 ] ); }, 'Setup with bad key fails' ); # These tests are all very similar looking, with slightly different start and # code values. Easiest to wrap them up in a common testing wrapper. sub TEST { my ( $name, %attr ) = @_; my $exitcode; my $dollarbang; my $dollarat; my ( undef, $callerfile, $callerline ) = caller; $loop->spawn_child( code => $attr{code}, exists $attr{setup} ? ( setup => $attr{setup} ) : (), on_exit => sub { ( undef, $exitcode, $dollarbang, $dollarat ) = @_; }, ); wait_for { defined $exitcode }; if( exists $attr{exitstatus} ) { ok( ($exitcode & 0x7f) == 0, "WIFEXITED(\$exitcode) after $name" ); is( ($exitcode >> 8), $attr{exitstatus}, "WEXITSTATUS(\$exitcode) after $name" ); } if( exists $attr{dollarbang} ) { is( $dollarbang+0, $attr{dollarbang}, "\$dollarbang numerically after $name" ); } if( exists $attr{dollarat} ) { is( $dollarat, $attr{dollarat}, "\$dollarat after $name" ); } } # A useful utility function like blocking read with a timeout sub read_timeout { my ( $fh, undef, $len, $timeout ) = @_; my $rvec = ''; vec( $rvec, fileno $fh, 1 ) = 1; select( $rvec, undef, undef, $timeout ); return undef if !vec( $rvec, fileno $fh, 1 ); return $fh->read( $_[1], $len ); } my $buffer; my $ret; { my( $pipe_r, $pipe_w ) = IO::Async::OS->pipepair or die "Cannot pipepair - $!"; TEST "pipe dup to fd1", setup => [ fd1 => [ 'dup', $pipe_w ] ], code => sub { print "test"; }, exitstatus => 1, dollarat => ''; undef $buffer; $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 ); is( $ret, 4, '$pipe_r->read after pipe dup to fd1' ); is( $buffer, 'test', '$buffer after pipe dup to fd1' ); my $pipe_w_fileno = fileno $pipe_w; TEST "pipe dup to fd1 closes pipe", setup => [ fd1 => [ 'dup', $pipe_w ] ], code => sub { my $f = IO::Handle->new_from_fd( $pipe_w_fileno, "w" ); defined $f and return 1; $! == EBADF or return 1; return 0; }, exitstatus => 0, dollarat => ''; TEST "pipe dup to stdout shortcut", setup => [ stdout => $pipe_w ], code => sub { print "test"; }, exitstatus => 1, dollarat => ''; undef $buffer; $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 ); is( $ret, 4, '$pipe_r->read after pipe dup to stdout shortcut' ); is( $buffer, 'test', '$buffer after pipe dup to stdout shortcut' ); TEST "pipe dup to \\*STDOUT IO reference", setup => [ \*STDOUT => $pipe_w ], code => sub { print "test2"; }, exitstatus => 1, dollarat => ''; undef $buffer; $ret = read_timeout( $pipe_r, $buffer, 5, 0.1 ); is( $ret, 5, '$pipe_r->read after pipe dup to \\*STDOUT IO reference' ); is( $buffer, 'test2', '$buffer after pipe dup to \\*STDOUT IO reference' ); TEST "pipe keep open", setup => [ "fd$pipe_w_fileno" => [ 'keep' ] ], code => sub { $pipe_w->autoflush(1); $pipe_w->print( "test" ) }, exitstatus => 1, dollarat => ''; undef $buffer; $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 ); is( $ret, 4, '$pipe_r->read after keep pipe open' ); is( $buffer, 'test', '$buffer after keep pipe open' ); TEST "pipe keep shortcut", setup => [ "fd$pipe_w_fileno" => 'keep' ], code => sub { $pipe_w->autoflush(1); $pipe_w->print( "test" ) }, exitstatus => 1, dollarat => ''; undef $buffer; $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 ); is( $ret, 4, '$pipe_r->read after keep pipe open' ); is( $buffer, 'test', '$buffer after keep pipe open' ); TEST "pipe dup to stdout", setup => [ stdout => [ 'dup', $pipe_w ] ], code => sub { print "test"; }, exitstatus => 1, dollarat => ''; undef $buffer; $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 ); is( $ret, 4, '$pipe_r->read after pipe dup to stdout' ); is( $buffer, 'test', '$buffer after pipe dup to stdout' ); TEST "pipe dup to fd2", setup => [ fd2 => [ 'dup', $pipe_w ] ], code => sub { print STDERR "test"; }, exitstatus => 1, dollarat => ''; undef $buffer; $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 ); is( $ret, 4, '$pipe_r->read after pipe dup to fd2' ); is( $buffer, 'test', '$buffer after pipe dup to fd2' ); TEST "pipe dup to stderr", setup => [ stderr => [ 'dup', $pipe_w ] ], code => sub { print STDERR "test"; }, exitstatus => 1, dollarat => ''; undef $buffer; $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 ); is( $ret, 4, '$pipe_r->read after pipe dup to stderr' ); is( $buffer, 'test', '$buffer after pipe dup to stderr' ); TEST "pipe dup to other FD", setup => [ fd4 => [ 'dup', $pipe_w ] ], code => sub { close STDOUT; open( STDOUT, ">&=4" ) or die "Cannot open fd4 as stdout - $!"; print "test"; }, exitstatus => 1, dollarat => ''; undef $buffer; $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 ); is( $ret, 4, '$pipe_r->read after pipe dup to other FD' ); is( $buffer, 'test', '$buffer after pipe dup to other FD' ); TEST "pipe dup to its own FD", setup => [ "fd$pipe_w_fileno" => $pipe_w ], code => sub { close STDOUT; open( STDOUT, ">&=$pipe_w_fileno" ) or die "Cannot open fd$pipe_w_fileno as stdout - $!"; print "test"; }, exitstatus => 1, dollarat => ''; undef $buffer; $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 ); is( $ret, 4, '$pipe_r->read after pipe dup to its own FD' ); is( $buffer, 'test', '$buffer after pipe dup to its own FD' ); TEST "other FD close", code => sub { return $pipe_w->syswrite( "test" ); }, exitstatus => 255, dollarbang => EBADF, dollarat => ''; # Try to force a writepipe clash by asking to dup the pipe to lots of FDs TEST "writepipe clash", code => sub { print "test"; }, setup => [ map { +"fd$_" => $pipe_w } ( 1 .. 19 ) ], exitstatus => 1, dollarat => ''; undef $buffer; $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 ); is( $ret, 4, '$pipe_r->read after writepipe clash' ); is( $buffer, 'test', '$buffer after writepipe clash' ); my( $pipe2_r, $pipe2_w ) = IO::Async::OS->pipepair or die "Cannot pipepair - $!"; $pipe2_r->blocking( 0 ); TEST "pipe dup to stdout and stderr", setup => [ stdout => $pipe_w, stderr => $pipe2_w ], code => sub { print "output"; print STDERR "error"; }, exitstatus => 1, dollarat => ''; undef $buffer; $ret = read_timeout( $pipe_r, $buffer, 6, 0.1 ); is( $ret, 6, '$pipe_r->read after pipe dup to stdout and stderr' ); is( $buffer, 'output', '$buffer after pipe dup to stdout and stderr' ); undef $buffer; $ret = read_timeout( $pipe2_r, $buffer, 5, 0.1 ); is( $ret, 5, '$pipe2_r->read after pipe dup to stdout and stderr' ); is( $buffer, 'error', '$buffer after pipe dup to stdout and stderr' ); TEST "pipe dup to stdout and stderr same pipe", setup => [ stdout => $pipe_w, stderr => $pipe_w ], code => sub { print "output"; print STDERR "error"; }, exitstatus => 1, dollarat => ''; undef $buffer; $ret = read_timeout( $pipe_r, $buffer, 11, 0.1 ); is( $ret, 11, '$pipe_r->read after pipe dup to stdout and stderr same pipe' ); is( $buffer, 'outputerror', '$buffer after pipe dup to stdout and stderr same pipe' ); } { my ( $child_r, $my_w, $my_r, $child_w ) = IO::Async::OS->pipequad or die "Cannot pipequad - $!"; $my_w->syswrite( "hello\n" ); TEST "pipe quad to fd0/fd1", setup => [ stdin => $child_r, stdout => $child_w, ], code => sub { print uc scalar ; return 0 }, exitstatus => 0, dollarat => ''; my $buffer; $ret = read_timeout( $my_r, $buffer, 6, 0.1 ); is( $ret, 6, '$my_r->read after pipe quad to fd0/fd1' ); is( $buffer, "HELLO\n", '$buffer after pipe quad to fd0/fd1' ); } { # Try to swap two filehandles and cause a dup2() collision my @fhA = IO::Async::OS->pipepair or die "Cannot pipepair - $!"; my @fhB = IO::Async::OS->pipepair or die "Cannot pipepair - $!"; my $filenoA = $fhA[1]->fileno; my $filenoB = $fhB[1]->fileno; TEST "fd swap", setup => [ "fd$filenoA" => $fhB[1], "fd$filenoB" => $fhA[1], ], code => sub { $fhA[1]->print( "FHA" ); $fhA[1]->autoflush(1); $fhB[1]->print( "FHB" ); $fhB[1]->autoflush(1); return 0; }, exitstatus => 0; my $buffer; read_timeout( $fhA[0], $buffer, 3, 0.1 ); is( $buffer, "FHB", '$buffer [A] after dup2() swap' ); read_timeout( $fhB[0], $buffer, 3, 0.1 ); is( $buffer, "FHA", '$buffer [B] after dup2() swap' ); } TEST "stdout close", setup => [ stdout => [ 'close' ] ], code => sub { print "test"; }, exitstatus => 255, dollarbang => EBADF, dollarat => ''; TEST "stdout close shortcut", setup => [ stdout => 'close' ], code => sub { print "test"; }, exitstatus => 255, dollarbang => EBADF, dollarat => ''; { my $name = tmpnam; END { unlink $name if defined $name and -f $name } TEST "stdout open", setup => [ stdout => [ 'open', '>', $name ] ], code => sub { print "test"; }, exitstatus => 1, dollarat => ''; ok( -f $name, 'tmpnam file exists after stdout open' ); open( my $tmpfh, "<", $name ) or die "Cannot open '$name' for reading - $!"; undef $buffer; $ret = read_timeout( $tmpfh, $buffer, 4, 0.1 ); is( $ret, 4, '$tmpfh->read after stdout open' ); is( $buffer, 'test', '$buffer after stdout open' ); TEST "stdout open append", setup => [ stdout => [ 'open', '>>', $name ] ], code => sub { print "value"; }, exitstatus => 1, dollarat => ''; seek( $tmpfh, 0, 0 ); undef $buffer; $ret = read_timeout( $tmpfh, $buffer, 9, 0.1 ); is( $ret, 9, '$tmpfh->read after stdout open append' ); is( $buffer, 'testvalue', '$buffer after stdout open append' ); } $ENV{TESTKEY} = "parent value"; TEST "environment is preserved", setup => [], code => sub { return $ENV{TESTKEY} eq "parent value" ? 0 : 1 }, exitstatus => 0, dollarat => ''; TEST "environment is overwritten", setup => [ env => { TESTKEY => "child value" } ], code => sub { return $ENV{TESTKEY} eq "child value" ? 0 : 1 }, exitstatus => 0, dollarat => ''; SKIP: { # Some of the CPAN smoke testers might run test scripts under modified nice # anyway. We'd better get our starting value to check for difference, not # absolute my $prio_now = getpriority(0,0); # If it's already quite high, we don't want to hit the limit and be # clamped. Just skip the tests if it's too high before we start. skip "getpriority is already above 15, so I won't try renicing upwards", 3 if $prio_now > 15; TEST "nice works", setup => [ nice => 3 ], code => sub { return getpriority(0,0) == $prio_now + 3 ? 0 : 1 }, exitstatus => 0, dollarat => ''; } TEST "chdir works", setup => [ chdir => "/" ], code => sub { return getcwd eq "/" ? 0 : 1 }, exitstatus => 0, dollarat => ''; done_testing; IO-Async-0.804/t/33process.t000444001750001750 1674215001742754 14300 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use POSIX qw( ENOENT SIGTERM SIGUSR1 ); use constant ENOENT_MESSAGE => do { local $! = ENOENT; "$!" }; use IO::Async::Process; use IO::Async::Loop; use IO::Async::OS; plan skip_all => "POSIX fork() is not available" unless IO::Async::OS->HAVE_POSIX_FORK; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); { my ( $invocant, $exitcode ); my $process = IO::Async::Process->new( code => sub { return 0 }, on_finish => sub { ( $invocant, $exitcode ) = @_; }, ); is_oneref( $process, '$process has refcount 1 before $loop->add' ); is( $process->notifier_name, "nopid", '$process->notifier_name before $loop->add' ); ok( !$process->is_running, '$process is not yet running' ); ok( !defined $process->pid, '$process has no PID yet' ); $loop->add( $process ); is_refcount( $process, 2, '$process has refcount 2 after $loop->add' ); my $pid = $process->pid; ok( $process->is_running, '$process is running' ); ok( defined $pid, '$process now has a PID' ); is( $process->notifier_name, "$pid", '$process->notifier_name after $loop->add' ); wait_for { defined $exitcode }; ref_is( $invocant, $process, '$_[0] in on_finish is $process' ); undef $invocant; # refcount ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after sub { 0 }' ); is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after sub { 0 }' ); ok( !$process->is_running, '$process no longer running' ); ok( defined $process->pid, '$process still has PID after exit' ); is( $process->notifier_name, "[$pid]", '$process->notifier_name after exit' ); ok( $process->is_exited, '$process->is_exited after sub { 0 }' ); is( $process->exitstatus, 0, '$process->exitstatus after sub { 0 }' ); ok( !defined $process->loop, '$process no longer in Loop' ); my $f = $process->finish_future; ok( $f->is_ready, '$process->finish_future is ready' ); is( $f->get, 0, '$process->finish_future->get' ); is_oneref( $process, '$process has refcount 1 before EOS' ); } # Exit only via ->finish_future { my $process = IO::Async::Process->new( code => sub { return 2 }, on_finish => sub {}, ); $loop->add( $process ); my $exitcode = wait_for_future( $process->finish_future )->get; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after sub { 2 }' ); is( ($exitcode >> 8), 2, 'WEXITSTATUS($exitcode) after sub { 2 }' ); } { my $process = IO::Async::Process->new( code => sub { return 3 }, on_finish => sub { }, ); $loop->add( $process ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after sub { 3 }' ); is( $process->exitstatus, 3, '$process->exitstatus after sub { 3 }' ); } { my ( $invocant, $exception, $exitcode ); my $process = IO::Async::Process->new( code => sub { die "An exception\n" }, on_finish => sub { die "Test failed early\n" }, on_exception => sub { ( $invocant, $exception, undef, $exitcode ) = @_ }, ); is_oneref( $process, '$process has refcount 1 before $loop->add' ); $loop->add( $process ); is_refcount( $process, 2, '$process has refcount 2 after $loop->add' ); wait_for { defined $exitcode }; ref_is( $invocant, $process, '$_[0] in on_exception is $process' ); undef $invocant; # refcount ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after sub { die }' ); is( ($exitcode >> 8), 255, 'WEXITSTATUS($exitcode) after sub { die }' ); is( $exception, "An exception\n", '$exception after sub { die }' ); ok( $process->is_exited, '$process->is_exited after sub { die }' ); is( $process->exitstatus, 255, '$process->exitstatus after sub { die }' ); is( $process->exception, "An exception\n", '$process->exception after sub { die }' ); is_oneref( $process, '$process has refcount 1 before EOS' ); } { my $exitcode; my $process = IO::Async::Process->new( code => sub { die "An exception\n" }, on_finish => sub { ( undef, $exitcode ) = @_ }, ); $loop->add( $process ); wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after sub { die } on_finish' ); is( ($exitcode >> 8), 255, 'WEXITSTATUS($exitcode) after sub { die } on_finish' ); ok( $process->is_exited, '$process->is_exited after sub { die } on_finish' ); is( $process->exitstatus, 255, '$process->exitstatus after sub { die } on_finish' ); is( $process->exception, "An exception\n", '$process->exception after sub { die } on_finish' ); } { my $process = IO::Async::Process->new( command => [ $^X, "-e", '1' ], on_finish => sub { }, ); $loop->add( $process ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after perl -e 1' ); is( $process->exitstatus, 0, '$process->exitstatus after perl -e 1' ); } { my $process = IO::Async::Process->new( command => [ $^X, "-e", 'exit 5' ], on_finish => sub { }, ); $loop->add( $process ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after perl -e exit 5' ); is( $process->exitstatus, 5, '$process->exitstatus after perl -e exit 5' ); } { # Just be paranoid in case anyone actually has this my $donotexist = "/bin/donotexist"; $donotexist .= "X" while -e $donotexist; my ( $exception, $errno ); my $process = IO::Async::Process->new( command => $donotexist, on_finish => sub { die "Test failed early\n" }, on_exception => sub { ( undef, $exception, $errno ) = @_ }, ); $loop->add( $process ); wait_for { !$process->is_running }; is( $errno+0, ENOENT, '$errno number after donotexist' ); is( "$errno", ENOENT_MESSAGE, '$errno string after donotexist' ); ok( $process->is_exited, '$process->is_exited after donotexist' ); is( $process->exitstatus, 255, '$process->exitstatus after donotexist' ); is( $process->errno, ENOENT, '$process->errno number after donotexist' ); is( $process->errstr, ENOENT_MESSAGE, '$process->errno string after donotexist' ); is( $process->exception, "", '$process->exception after donotexist' ); } { $ENV{TEST_KEY} = "foo"; my $process = IO::Async::Process->new( code => sub { $ENV{TEST_KEY} eq "bar" ? 0 : 1 }, setup => [ env => { TEST_KEY => "bar" }, ], on_finish => sub { }, ); $loop->add( $process ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after %ENV test' ); is( $process->exitstatus, 0, '$process->exitstatus after %ENV test' ); } SKIP: { skip "This OS does not have signals", 2 unless IO::Async::OS->HAVE_SIGNALS; my $child_ready; $loop->watch_signal( USR1 => sub { $child_ready++ } ); my $parentpid = $$; my $process = IO::Async::Process->new( code => sub { my $exitcode = 10; eval { local $SIG{TERM} = sub { $exitcode = 20; die }; kill SIGUSR1 => $parentpid; sleep 60; # block on signal }; return $exitcode; }, on_finish => sub { }, ); $loop->add( $process ); wait_for { $child_ready }; $process->kill( SIGTERM ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after ->kill' ); is( $process->exitstatus, 20, '$process->exitstatus after ->kill' ); $loop->unwatch_signal( USR1 => ); } done_testing; IO-Async-0.804/t/34process-handles.t000444001750001750 3336415001742754 15714 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use IO::Async::Process; use IO::Async::Loop; use IO::Async::OS; plan skip_all => "POSIX fork() is not available" unless IO::Async::OS->HAVE_POSIX_FORK; use Socket qw( PF_INET sockaddr_family ); my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); { my $process = IO::Async::Process->new( code => sub { print "hello\n"; return 0 }, stdout => { via => "pipe_read" }, on_finish => sub { }, ); isa_ok( $process->stdout, [ "IO::Async::Stream" ], '$process->stdout isa IO::Async::Stream' ); is( $process->stdout->notifier_name, "stdout", '$process->stdout->notifier_name' ); my @stdout_lines; $process->stdout->configure( on_read => sub { my ( undef, $buffref ) = @_; push @stdout_lines, $1 while $$buffref =~ s/^(.*\n)//; return 0; }, ); $loop->add( $process ); ok( defined $process->stdout->read_handle, '$process->stdout has read_handle for sub { print }' ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after sub { print }' ); is( $process->exitstatus, 0, '$process->exitstatus after sub { print }' ); is( \@stdout_lines, [ "hello\n" ], '@stdout_lines after sub { print }' ); } { my @stdout_lines; my $process = IO::Async::Process->new( code => sub { print "hello\n"; return 0 }, stdout => { on_read => sub { my ( undef, $buffref ) = @_; push @stdout_lines, $1 while $$buffref =~ s/^(.*\n)//; return 0; }, }, on_finish => sub { }, ); isa_ok( $process->stdout, [ "IO::Async::Stream" ], '$process->stdout isa IO::Async::Stream' ); $loop->add( $process ); ok( defined $process->stdout->read_handle, '$process->stdout has read_handle for sub { print } inline' ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after sub { print } inline' ); is( $process->exitstatus, 0, '$process->exitstatus after sub { print } inline' ); is( \@stdout_lines, [ "hello\n" ], '@stdout_lines after sub { print } inline' ); } { my $stdout; my $process = IO::Async::Process->new( code => sub { print "hello\n"; return 0 }, stdout => { into => \$stdout }, on_finish => sub { }, ); isa_ok( $process->stdout, [ "IO::Async::Stream" ], '$process->stdout isa IO::Async::Stream' ); $loop->add( $process ); ok( defined $process->stdout->read_handle, '$process->stdout has read_handle for sub { print } into' ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after sub { print } into' ); is( $process->exitstatus, 0, '$process->exitstatus after sub { print } into' ); is( $stdout, "hello\n", '$stdout after sub { print } into' ) } { my $stdout; my $process = IO::Async::Process->new( command => [ $^X, "-e", 'print "hello\n"' ], stdout => { into => \$stdout }, on_finish => sub { }, ); $loop->add( $process ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after perl STDOUT' ); is( $process->exitstatus, 0, '$process->exitstatus after perl STDOUT' ); is( $stdout, "hello\n", '$stdout after perl STDOUT' ); } { my $stdout; my $stderr; my $process = IO::Async::Process->new( command => [ $^X, "-e", 'print STDOUT "output\n"; print STDERR "error\n";' ], stdout => { into => \$stdout }, stderr => { into => \$stderr }, on_finish => sub { }, ); isa_ok( $process->stderr, [ "IO::Async::Stream" ], '$process->stderr isa IO::Async::Stream' ); is( $process->stderr->notifier_name, "stderr", '$process->stderr->notifier_name' ); $loop->add( $process ); ok( defined $process->stderr->read_handle, '$process->stderr has read_handle' ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after perl STDOUT/STDERR' ); is( $process->exitstatus, 0, '$process->exitstatus after perl STDOUT/STDERR' ); is( $stdout, "output\n", '$stdout after perl STDOUT/STDERR' ); is( $stderr, "error\n", '$stderr after perl STDOUT/STDERR' ); } { my $stdout; my $process = IO::Async::Process->new( command => [ $^X, "-pe", '$_ = uc' ], stdin => { via => "pipe_write" }, stdout => { into => \$stdout }, on_finish => sub { }, ); isa_ok( $process->stdin, [ "IO::Async::Stream" ], '$process->stdin isa IO::Async::Stream' ); is( $process->stdin->notifier_name, "stdin", '$process->stdin->notifier_name' ); $process->stdin->write( "some data\n", on_flush => sub { $_[0]->close } ); $loop->add( $process ); ok( defined $process->stdin->write_handle, '$process->stdin has write_handle for perl STDIN->STDOUT' ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after perl STDIN->STDOUT' ); is( $process->exitstatus, 0, '$process->exitstatus after perl STDIN->STDOUT' ); is( $stdout, "SOME DATA\n", '$stdout after perl STDIN->STDOUT' ); } { my $process = IO::Async::Process->new( command => [ $^X, "-e", 'exit 4' ], stdin => { via => "pipe_write" }, on_finish => sub { }, ); isa_ok( $process->stdin, [ "IO::Async::Stream" ], '$process->stdin isa IO::Async::Stream' ); $loop->add( $process ); ok( defined $process->stdin->write_handle, '$process->stdin has write_handle for perl STDIN no-wait close' ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after perl STDIN no-wait close' ); is( $process->exitstatus, 4, '$process->exitstatus after perl STDIN no-wait close' ); } { my $stdout; my $process = IO::Async::Process->new( command => [ $^X, "-pe", '$_ = uc' ], stdin => { from => "some data\n" }, stdout => { into => \$stdout }, on_finish => sub { }, ); isa_ok( $process->stdin, [ "IO::Async::Stream" ], '$process->stdin isa IO::Async::Stream' ); $loop->add( $process ); ok( defined $process->stdin->write_handle, '$process->stdin has write_handle for perl STDIN->STDOUT from' ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after perl STDIN->STDOUT from' ); is( $process->exitstatus, 0, '$process->exitstatus after perl STDIN->STDOUT from' ); is( $stdout, "SOME DATA\n", '$stdout after perl STDIN->STDOUT from' ); } { my $stdout; my $process = IO::Async::Process->new( command => [ $^X, "-pe", '$_ = "line"' ], stdin => { from => "" }, stdout => { into => \$stdout }, on_finish => sub { }, ); isa_ok( $process->stdin, [ "IO::Async::Stream" ], '$process->stdin isa IO::Async::Stream' ); $loop->add( $process ); ok( defined $process->stdin->write_handle, '$process->stdin has write_handle for perl STDIN->STDOUT from empty string' ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after perl STDIN->STDOUT from empty string' ); is( $process->exitstatus, 0, '$process->exitstatus after perl STDIN->STDOUT from empty string' ); is( $stdout, "", '$stdout after perl STDIN->STDOUT from empty string' ); } { my $stdout; my $process = IO::Async::Process->new( command => [ $^X, "-pe", '$_ = uc' ], fd0 => { from => "some data\n" }, fd1 => { into => \$stdout }, on_finish => sub { }, ); $loop->add( $process ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after perl STDIN->STDOUT using fd[n]' ); is( $process->exitstatus, 0, '$process->exitstatus after perl STDIN->STDOUT using fd[n]' ); is( $stdout, "SOME DATA\n", '$stdout after perl STDIN->STDOUT using fd[n]' ); } { my $output; my $process = IO::Async::Process->new( command => [ $^X, "-pe", '$_ = uc' ], stdio => { via => "pipe_rdwr" }, on_finish => sub { }, ); isa_ok( $process->stdio, [ "IO::Async::Stream" ], '$process->stdio isa IO::Async::Stream' ); is( $process->stdio->notifier_name, "stdio", '$process->stdio->notifier_name' ); my @output_lines; $process->stdio->write( "some data\n", on_flush => sub { $_[0]->close_write } ); $process->stdio->configure( on_read => sub { my ( undef, $buffref ) = @_; push @output_lines, $1 while $$buffref =~ s/^(.*\n)//; return 0; }, ); $loop->add( $process ); ok( defined $process->stdio->read_handle, '$process->stdio has read_handle for perl STDIO' ); ok( defined $process->stdio->write_handle, '$process->stdio has write_handle for perl STDIO' ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after perl STDIO' ); is( $process->exitstatus, 0, '$process->exitstatus after perl STDIO' ); is( \@output_lines, [ "SOME DATA\n" ], '@output_lines after perl STDIO' ); } { my $output; my $process = IO::Async::Process->new( command => [ $^X, "-pe", '$_ = uc' ], stdio => { from => "some data\n", into => \$output, }, on_finish => sub { }, ); $loop->add( $process ); wait_for { !$process->is_running }; ok( $process->is_exited, '$process->is_exited after perl STDIN->STDOUT using stdio' ); is( $process->exitstatus, 0, '$process->exitstatus after perl STDIN->STDOUT using stdio' ); is( $output, "SOME DATA\n", '$stdout after perl STDIN->STDOUT using stdio' ); } { my $process = IO::Async::Process->new( code => sub { defined( recv STDIN, my $pkt, 8192, 0 ) or die "Cannot recv - $!"; send STDOUT, $pkt, 0 or die "Cannot send - $!"; return 0; }, stdio => { via => "socketpair" }, on_finish => sub { }, ); isa_ok( $process->stdio, [ "IO::Async::Stream" ], '$process->stdio isa IO::Async::Stream' ); $process->stdio->write( "A packet to be echoed" ); my $output_packet = ""; $process->stdio->configure( on_read => sub { my ( undef, $buffref ) = @_; $output_packet .= $$buffref; $$buffref = ""; return 0; }, ); $loop->add( $process ); isa_ok( $process->stdio->read_handle, [ "IO::Socket" ], '$process->stdio handle isa IO::Socket' ); wait_for { defined $output_packet and !$process->is_running }; ok( $process->is_exited, '$process->is_exited after perl STDIO via socketpair' ); is( $process->exitstatus, 0, '$process->exitstatus after perl STDIO via socketpair' ); is( $output_packet, "A packet to be echoed", '$output_packet after perl STDIO via socketpair' ); } { my $process = IO::Async::Process->new( code => sub { defined STDIN->sysread( my $pkt, 8192 ) or die "Cannot recv - $!"; STDOUT->syswrite( $pkt ) or die "Cannot send - $!"; return 0; }, stdio => { via => "socketpair", prefork => sub { my ( $myfd, $childfd ) = @_; $myfd->write( "Data from the prefork" ); }, }, on_finish => sub { }, ); isa_ok( $process->stdio, [ "IO::Async::Stream" ], '$process->stdio isa IO::Async::Stream' ); my $output_packet = ""; $process->stdio->configure( on_read => sub { my ( undef, $buffref ) = @_; $output_packet .= $$buffref; $$buffref = ""; return 0; }, ); $loop->add( $process ); isa_ok( $process->stdio->read_handle, [ "IO::Socket" ], '$process->stdio handle isa IO::Socket' ); wait_for { defined $output_packet and !$process->is_running }; ok( $process->is_exited, '$process->is_exited after perl STDIO via socketpair' ); is( $process->exitstatus, 0, '$process->exitstatus after perl STDIO via socketpair' ); is( $output_packet, "Data from the prefork", '$output_packet from prefork via socketpair' ); } { my $process = IO::Async::Process->new( code => sub { return 0 }, stdio => { via => "socketpair", family => "inet" }, on_finish => sub { }, ); isa_ok( $process->stdio, [ "IO::Async::Stream" ], '$process->stdio isa IO::Async::Stream' ); $process->stdio->configure( on_read => sub { } ); $loop->add( $process ); isa_ok( $process->stdio->read_handle, [ "IO::Socket" ], '$process->stdio handle isa IO::Socket' ); is( sockaddr_family( $process->stdio->read_handle->sockname ), PF_INET, '$process->stdio handle sockdomain is PF_INET' ); wait_for { !$process->is_running }; } { my $process = IO::Async::Process->new( code => sub { for( 1, 2 ) { defined( recv STDIN, my $pkt, 8192, 0 ) or die "Cannot recv - $!"; send STDOUT, $pkt, 0 or die "Cannot send - $!"; } return 0; }, stdio => { via => "socketpair", socktype => "dgram", family => "inet" }, on_finish => sub { }, ); isa_ok( $process->stdio, [ "IO::Async::Socket" ], '$process->stdio isa IO::Async::Socket' ); my @output_packets; $process->stdio->configure( on_recv => sub { my ( $self, $packet ) = @_; push @output_packets, $packet; $self->close if @output_packets == 2; return 0; }, ); $loop->add( $process ); isa_ok( $process->stdio->read_handle, [ "IO::Socket" ], '$process->stdio handle isa IO::Socket' ); ok( defined sockaddr_family( $process->stdio->read_handle->sockname ), '$process->stdio handle sockdomain is defined' ); $process->stdio->send( $_ ) for "First packet", "Second packet"; wait_for { @output_packets == 2 and !$process->is_running }; ok( $process->is_exited, '$process->is_exited after perl STDIO via dgram socketpair' ); is( $process->exitstatus, 0, '$process->exitstatus after perl STDIO via dgram socketpair' ); is( \@output_packets, [ "First packet", "Second packet" ], '@output_packets after perl STDIO via dgram socketpair' ); } done_testing; IO-Async-0.804/t/35loop-openprocess.t000444001750001750 277115001742754 16110 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use IO::Async::Loop; use IO::Async::OS; plan skip_all => "POSIX fork() is not available" unless IO::Async::OS->HAVE_POSIX_FORK; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); my $exitcode; my $proc = $loop->open_process( code => sub { 0 }, on_finish => sub { ( undef, $exitcode ) = @_; }, ); isa_ok( $proc, [ "IO::Async::Process" ], '$proc from ->open_process isa IO::Async::Process' ); undef $exitcode; wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after sub { 0 }' ); is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after sub { 0 }' ); ok( dies { $loop->open_process( command => [ $^X, "-e", 1 ] ) }, 'Missing on_finish fails' ); ok( dies { $loop->open_process( command => [ $^X, "-e", 1 ], on_finish => sub {}, on_exit => sub {}, ) }, 'on_exit parameter fails' ); # open_child compatibility wrapper { my $exitpid; my $pid = $loop->open_child( code => sub { 0 }, on_finish => sub { ( $exitpid, undef ) = @_; }, ); like( $pid, qr/^\d+$/, '$loop->open_child returns a PID-like number' ); wait_for { defined $exitpid }; is( $exitpid, $pid, 'on_finish passed the same PID as returned from ->open_child' ); ok( dies { $loop->open_child( command => [ $^X, "-e", 1 ], on_finish => "hello" ) }, 'on_finish not CODE ref fails' ); } done_testing; IO-Async-0.804/t/36loop-runchild.t000444001750001750 1126115001742754 15373 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use IO::Async::Loop; use IO::Async::OS; plan skip_all => "POSIX fork() is not available" unless IO::Async::OS->HAVE_POSIX_FORK; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); my ( $exitcode, $child_out, $child_err ); $loop->run_child( code => sub { 0 }, on_finish => sub { ( undef, $exitcode, $child_out, $child_err ) = @_; }, ); undef $exitcode; wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after sub { 0 }' ); is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after sub { 0 }' ); is( $child_out, "", '$child_out after sub { 0 }' ); is( $child_err, "", '$child_err after sub { 0 }' ); $loop->run_child( code => sub { 3 }, on_finish => sub { ( undef, $exitcode, $child_out, $child_err ) = @_; }, ); undef $exitcode; wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after sub { 3 }' ); is( ($exitcode >> 8), 3, 'WEXITSTATUS($exitcode) after sub { 3 }' ); is( $child_out, "", '$child_out after sub { 3 }' ); is( $child_err, "", '$child_err after sub { 3 }' ); $loop->run_child( command => [ $^X, "-e", '1' ], on_finish => sub { ( undef, $exitcode, $child_out, $child_err ) = @_; }, ); undef $exitcode; wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after perl -e 1' ); is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after perl -e 1' ); is( $child_out, "", '$child_out after perl -e 1' ); is( $child_err, "", '$child_err after perl -e 1' ); $loop->run_child( command => [ $^X, "-e", 'exit 5' ], on_finish => sub { ( undef, $exitcode, $child_out, $child_err ) = @_; }, ); undef $exitcode; wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after perl -e exit 5' ); is( ($exitcode >> 8), 5, 'WEXITSTATUS($exitcode) after perl -e exit 5' ); is( $child_out, "", '$child_out after perl -e exit 5' ); is( $child_err, "", '$child_err after perl -e exit 5' ); $loop->run_child( code => sub { print "hello\n"; 0 }, on_finish => sub { ( undef, $exitcode, $child_out, $child_err ) = @_; }, ); undef $exitcode; wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after sub { print }' ); is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after sub { print }' ); is( $child_out, "hello\n", '$child_out after sub { print }' ); is( $child_err, "", '$child_err after sub { print }' ); $loop->run_child( command => [ $^X, "-e", 'print "goodbye\n"' ], on_finish => sub { ( undef, $exitcode, $child_out, $child_err ) = @_; }, ); undef $exitcode; wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after perl STDOUT' ); is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after perl STDOUT' ); is( $child_out, "goodbye\n", '$child_out after perl STDOUT' ); is( $child_err, "", '$child_err after perl STDOUT' ); $loop->run_child( command => [ $^X, "-e", 'print STDOUT "output\n"; print STDERR "error\n";' ], on_finish => sub { ( undef, $exitcode, $child_out, $child_err ) = @_; }, ); undef $exitcode; wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after perl STDOUT/STDERR' ); is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after perl STDOUT/STDERR' ); is( $child_out, "output\n", '$child_out after perl STDOUT/STDERR' ); is( $child_err, "error\n", '$child_err after perl STDOUT/STDERR' ); # perl -pe 1 behaves like cat; copies STDIN to STDOUT $loop->run_child( command => [ $^X, "-pe", '1' ], stdin => "some data\n", on_finish => sub { ( undef, $exitcode, $child_out, $child_err ) = @_; }, ); undef $exitcode; wait_for { defined $exitcode }; ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after perl STDIN->STDOUT' ); is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after perl STDIN->STDOUT' ); is( $child_out, "some data\n", '$child_out after perl STDIN->STDOUT' ); is( $child_err, "", '$child_err after perl STDIN->STDOUT' ); ok( dies { $loop->run_child( command => [ $^X, "-e", 1 ] ) }, 'Missing on_finish fails' ); ok( dies { $loop->run_child( command => [ $^X, "-e", 1 ], on_finish => "hello" ) }, 'on_finish not CODE ref fails' ); ok( dies { $loop->run_child( command => [ $^X, "-e", 1 ], on_finish => sub {}, on_exit => sub {}, ) }, 'on_exit parameter fails' ); ok( dies { $loop->run_child( command => [ $^X, "-e", 1 ], on_finish => sub {}, some_key_you_fail => 1 ) }, 'unrecognised key fails' ); done_testing; IO-Async-0.804/t/37loop-child-root.t000444001750001750 357515001742754 15621 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use IO::Async::Loop; use IO::Async::OS; plan skip_all => "POSIX fork() is not available" unless IO::Async::OS->HAVE_POSIX_FORK; use POSIX qw( WEXITSTATUS ); # These tests check the parts of Loop->spawn_child that need to be root to # work. Since we're unlikely to be root, skip the lot if we're not. unless( $< == 0 ) { plan skip_all => "not root"; } is( $>, 0, 'am root'); my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); my ( $exitcode, $dollarbang, $dollarat ); $loop->spawn_child( code => sub { return $> }, setup => [ setuid => 10 ], on_exit => sub { ( undef, $exitcode, $dollarbang, $dollarat ) = @_ }, ); wait_for { defined $exitcode }; is( WEXITSTATUS($exitcode), 10, 'setuid' ); $loop->spawn_child( code => sub { return $) }, setup => [ setgid => 10 ], on_exit => sub { ( undef, $exitcode, $dollarbang, $dollarat ) = @_ }, ); undef $exitcode; wait_for { defined $exitcode }; is( WEXITSTATUS($exitcode), 10, 'setgid' ); $loop->spawn_child( code => sub { return $) =~ m/ 5 / }, setup => [ setgroups => [ 4, 5, 6 ] ], on_exit => sub { ( undef, $exitcode, $dollarbang, $dollarat ) = @_ }, ); undef $exitcode; wait_for { defined $exitcode }; is( WEXITSTATUS($exitcode), 1, 'setgroups' ); my $child_out; $loop->run_child( code => sub { print "EUID: $>\n"; my ( $gid, @groups ) = split( m/ /, $) ); print "EGID: $gid\n"; print "Groups: " . join( " ", sort { $a <=> $b } @groups ) . "\n"; return 0; }, setup => [ setgid => 10, setgroups => [ 4, 5, 6, 10 ], setuid => 20, ], on_finish => sub { ( undef, $exitcode, $child_out ) = @_; }, ); undef $exitcode; wait_for { defined $exitcode }; is( $child_out, "EUID: 20\nEGID: 10\nGroups: 4 5 6 10\n", 'combined setuid/gid/groups' ); done_testing; IO-Async-0.804/t/38loop-thread.t000444001750001750 236115001742754 15015 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use Test2::IPC; # initialise Test2 before starting threads use IO::Async::Loop; use IO::Async::OS; plan skip_all => "Threads are not available" unless IO::Async::OS->HAVE_THREADS; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); # thread in scalar context { my @result; $loop->create_thread( code => sub { return "A result" }, on_joined => sub { @result = @_ }, ); wait_for { @result }; is( \@result, [ return => "A result" ], 'result to on_joined for returning thread' ); } # thread in list context { my @result; $loop->create_thread( code => sub { return "A result", "of many", "values" }, context => "list", on_joined => sub { @result = @_ }, ); wait_for { @result }; is( \@result, [ return => "A result", "of many", "values" ], 'result to on_joined for returning thread in list context' ); } # thread that dies { my @result; $loop->create_thread( code => sub { die "Ooops I fail\n" }, on_joined => sub { @result = @_ }, ); wait_for { @result }; is( \@result, [ died => "Ooops I fail\n" ], 'result to on_joined for a died thread' ); } done_testing; IO-Async-0.804/t/39loop-runproccess.t000444001750001750 770315001742754 16122 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use IO::Async::Loop; use IO::Async::OS; plan skip_all => "POSIX fork() is not available" unless IO::Async::OS->HAVE_POSIX_FORK; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); # run_process capture exitcode { my $f; $f = $loop->run_process( code => sub { 3 }, capture => [qw( exitcode )], ); is( [ $f->get ], [ 3 << 8 ], '$f->get from code gives exitcode' ); $f = $loop->run_process( command => [ $^X, "-e", 'exit 5' ], capture => [qw( exitcode )], ); is( [ $f->get ], [ 5 << 8 ], '$f->get from command gives exitcode' ); } # run_process capture stdout { my $f; $f = $loop->run_process( code => sub { print "hello\n"; 0 }, capture => [qw( stdout )], ); is( [ $f->get ], [ "hello\n" ], '$f->get from code gives stdout' ); $f = $loop->run_process( command => [ $^X, "-e", 'print "goodbye\n"' ], capture => [qw( stdout )], ); is( [ $f->get ], [ "goodbye\n" ], '$f->get from command gives stdout' ); } # run_process capture stdout and stderr { my $f; $f = $loop->run_process( command => [ $^X, "-e", 'print STDOUT "output\n"; print STDERR "error\n";' ], capture => [qw( stdout stderr )], ); is( [ $f->get ], [ "output\n", "error\n" ], '$f->get from command gives stdout and stderr' ); } # run_process sending stdin { my $f; # perl -pe 1 behaves like cat; copies STDIN to STDOUT $f = $loop->run_process( command => [ $^X, "-pe", '1' ], stdin => "some data\n", capture => [qw( stdout )], ); is( [ $f->get ], [ "some data\n" ], '$f->get from command given stdin gives stdout' ); } # run_process default capture { my $f = $loop->run_process( command => [ $^X, "-e", 'print STDOUT "output";' ], ); is( [ $f->get ], [ 0, "output" ], '$f->get from command with default capture' ); } # run_process captures in weird order { my $f = $loop->run_process( command => [ $^X, "-e", 'print STDOUT "output"; print STDERR "error";' ], capture => [qw(stderr exitcode stdout)], ); is( [ $f->get ], [ "error", 0, "output" ], '$f->get from command with all captures' ); } # run_process cancel_signal { my ( $rd, $wr ) = IO::Async::OS->pipepair or die "Cannot pipe() - $!"; $wr->autoflush; my $f = $loop->run_process( setup => [ $wr => "keep", ], code => sub { $SIG{TERM} = sub { $wr->syswrite( "B" ); }; $wr->syswrite( "A" ); sleep 5; }, cancel_signal => "TERM" ); # Wait for startup notification "A" my $buf; wait_for_stream { length $buf } $rd => $buf; $f->cancel; # Wait for signal wait_for_stream { length $buf > 1 } $rd => $buf; is( $buf, "AB", 'Process received cancel signal' ); } # run_process fail_on_nonzero { my $f = $loop->run_process( code => sub { return 3 }, capture => [qw( exitcode )], fail_on_nonzero => 1, ); wait_for_future $f; ok( $f->is_failed, '$f->failed with fail_on_nonzero' ) and do { # ignore message my ( undef, $category, @captures ) = $f->failure; is( $category, "process", '$f->failure category' ); is( \@captures, [ 3<<8 ], '$f->failure details' ); }; } # Testing error handling ok( dies { $loop->run_process( command => [ $^X, "-e", 1 ], some_key_you_fail => 1 ) }, 'unrecognised key fails' ); ok( dies { $loop->run_process( command => [ $^X, "-e", 1 ], capture => 'pid' ) }, 'Capture in capture format' ); ok( dies { $loop->run_process( command => [ $^X, "-e", 1 ], capture => ['invalid_capture'] ) }, 'Invalid capture type' ); ok( dies { $loop->run_process( command => [ $^X, "-e", 1 ], on_finish => sub{ 0 } ) }, 'Failing when finish callback is passed' ); done_testing; IO-Async-0.804/t/40channel.t000444001750001750 1445415001742754 14226 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use IO::Async::Channel; use IO::Async::OS; use IO::Async::Loop; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); note( "Default IO::Async::Channel codec is " . IO::Async::Channel::_default_codec ); # sync->sync - mostly doesn't involve IO::Async { my ( $pipe_rd, $pipe_wr ) = IO::Async::OS->pipepair; my $channel_rd = IO::Async::Channel->new; $channel_rd->setup_sync_mode( $pipe_rd ); my $channel_wr = IO::Async::Channel->new; $channel_wr->setup_sync_mode( $pipe_wr ); $channel_wr->send( [ structure => "here" ] ); is( $channel_rd->recv, [ structure => "here" ], 'Sync mode channels can send/recv structures' ); $channel_wr->send_encoded( $channel_wr->encode( [ prefrozen => "data" ] ) ); is( $channel_rd->recv, [ prefrozen => "data" ], 'Sync mode channels can send_encoded' ); $channel_wr->send_encoded( IO::Async::Channel->encode( [ prefrozen => "again" ] ) ); is( $channel_rd->recv, [ prefrozen => "again" ], 'Channel->encode works as a class method' ); $channel_wr->close; is( $channel_rd->recv, undef, 'Sync mode can be closed' ); } # async->sync { my ( $pipe_rd, $pipe_wr ) = IO::Async::OS->pipepair; my $channel_rd = IO::Async::Channel->new; $channel_rd->setup_sync_mode( $pipe_rd ); my $channel_wr = IO::Async::Channel->new; $channel_wr->setup_async_mode( write_handle => $pipe_wr ); $loop->add( $channel_wr ); $channel_wr->send( [ data => "by async" ] ); # Cheat for semi-sync my $flushed; $channel_wr->{stream}->write( "", on_flush => sub { $flushed++ } ); wait_for { $flushed }; is( $channel_rd->recv, [ data => "by async" ], 'Async mode channel can send' ); $channel_wr->close; is( $channel_rd->recv, undef, 'Sync mode can be closed' ); } # sync->async configured on_recv { my ( $pipe_rd, $pipe_wr ) = IO::Async::OS->pipepair; my @recv_queue; my $recv_eof; my $channel_rd = IO::Async::Channel->new; $channel_rd->setup_async_mode( read_handle => $pipe_rd ); $loop->add( $channel_rd ); $channel_rd->configure( on_recv => sub { ref_is( $_[0], $channel_rd, 'Channel passed to on_recv' ); push @recv_queue, $_[1]; }, on_eof => sub { $recv_eof++; }, ); my $channel_wr = IO::Async::Channel->new; $channel_wr->setup_sync_mode( $pipe_wr ); $channel_wr->send( [ data => "by sync" ] ); wait_for { @recv_queue }; is( shift @recv_queue, [ data => "by sync" ], 'Async mode channel can on_recv' ); $channel_wr->close; wait_for { $recv_eof }; is( $recv_eof, 1, 'Async mode channel can on_eof' ); } # sync->async oneshot ->recv with future { my ( $pipe_rd, $pipe_wr ) = IO::Async::OS->pipepair; my $channel_rd = IO::Async::Channel->new; $channel_rd->setup_async_mode( read_handle => $pipe_rd ); $loop->add( $channel_rd ); my $channel_wr = IO::Async::Channel->new; $channel_wr->setup_sync_mode( $pipe_wr ); $channel_wr->send( [ data => "by sync" ] ); my $recv_f = wait_for_future $channel_rd->recv; is( scalar $recv_f->get, [ data => "by sync" ], 'Async mode future can receive data' ); $channel_wr->close; my $eof_f = wait_for_future $channel_rd->recv; is( ( $eof_f->failure )[1], "eof", 'Async mode future can receive EOF' ); } # sync->async oneshot ->recv with callbacks { my ( $pipe_rd, $pipe_wr ) = IO::Async::OS->pipepair; my $channel_rd = IO::Async::Channel->new; $channel_rd->setup_async_mode( read_handle => $pipe_rd ); $loop->add( $channel_rd ); my $channel_wr = IO::Async::Channel->new; $channel_wr->setup_sync_mode( $pipe_wr ); $channel_wr->send( [ data => "by sync" ] ); my $recved; $channel_rd->recv( on_recv => sub { ref_is( $_[0], $channel_rd, 'Channel passed to ->recv on_recv' ); $recved = $_[1]; }, on_eof => sub { die "Test failed early" }, ); wait_for { $recved }; is( $recved, [ data => "by sync" ], 'Async mode channel can ->recv on_recv' ); $channel_wr->close; my $recv_eof; $channel_rd->recv( on_recv => sub { die "Channel recv'ed when not expecting" }, on_eof => sub { $recv_eof++ }, ); wait_for { $recv_eof }; is( $recv_eof, 1, 'Async mode channel can ->recv on_eof' ); } # sync->async write once then close { my ( $pipe_rd, $pipe_wr ) = IO::Async::OS->pipepair; my $channel_rd = IO::Async::Channel->new; $channel_rd->setup_async_mode( read_handle => $pipe_rd ); $loop->add( $channel_rd ); my $channel_wr = IO::Async::Channel->new; $channel_wr->setup_sync_mode( $pipe_wr ); $channel_wr->send( [ "One value here" ] ); $channel_wr->close; undef $channel_wr; my $recved; $channel_rd->recv( on_recv => sub { $recved = $_[1]; }, on_eof => sub { die "Test failed early" }, ); wait_for { $recved }; is( $recved->[0], "One value here", 'Async mode channel can ->recv buffer at EOF' ); $loop->remove( $channel_rd ); } # Async ->recv cancellation { my ( $pipe_rd, $pipe_wr ) = IO::Async::OS->pipepair; my $channel_rd = IO::Async::Channel->new; $channel_rd->setup_async_mode( read_handle => $pipe_rd ); $loop->add( $channel_rd ); my $channel_wr = IO::Async::Channel->new; $channel_wr->setup_sync_mode( $pipe_wr ); $channel_wr->send( [ "first" ] ); $channel_wr->send( [ "second" ] ); my $r1_f = $channel_rd->recv; my $r2_f = $channel_rd->recv; $r1_f->cancel; wait_for { $r2_f->is_ready }; is( scalar $r2_f->get, [ "second" ], 'Async recv result after cancellation' ); $loop->remove( $channel_rd ); } # Sereal encoder SKIP: { skip "Sereal is not available", 1 unless defined eval { require Sereal::Encoder; require Sereal::Decoder }; my ( $pipe_rd, $pipe_wr ) = IO::Async::OS->pipepair; my $channel_rd = IO::Async::Channel->new( codec => "Sereal" ); $channel_rd->setup_async_mode( read_handle => $pipe_rd ); $loop->add( $channel_rd ); my $channel_wr = IO::Async::Channel->new( codec => "Sereal", ); $channel_wr->setup_sync_mode( $pipe_wr ); $channel_wr->send( [ data => "by sync" ] ); my $recv_f = wait_for_future $channel_rd->recv; is( scalar $recv_f->get, [ data => "by sync" ], 'Channel can use Sereal as codec' ); $loop->remove( $channel_rd ); } done_testing; IO-Async-0.804/t/41routine.t000444001750001750 2142315001742754 14276 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use IO::Async::Routine; use IO::Async::Channel; use IO::Async::Loop; use lib "."; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); sub test_with_model { my ( $model ) = @_; { my $calls = IO::Async::Channel->new; my $returns = IO::Async::Channel->new; my $routine = IO::Async::Routine->new( model => $model, channels_in => [ $calls ], channels_out => [ $returns ], code => sub { while( my $args = $calls->recv ) { last if ref $args eq "SCALAR"; my $ret = 0; $ret += $_ for @$args; $returns->send( \$ret ); } }, on_finish => sub {}, ); isa_ok( $routine, [ "IO::Async::Routine" ], "\$routine for $model model isa IO::Async::Routine" ); is_oneref( $routine, "\$routine has refcount 1 initially for $model model" ); $loop->add( $routine ); is_refcount( $routine, 2, "\$routine has refcount 2 after \$loop->add for $model model" ); is( $routine->model, $model, "\$routine->model for $model model" ); $calls->send( [ 1, 2, 3 ] ); my $f = wait_for_future $returns->recv; my $result = $f->get; is( ${$result}, 6, "Result for $model model" ); is_refcount( $routine, 2, '$routine has refcount 2 before $loop->remove' ); $loop->remove( $routine ); is_oneref( $routine, '$routine has refcount 1 before EOF' ); } { my $returned; my $return_routine = IO::Async::Routine->new( model => $model, code => sub { return 23 }, on_return => sub { $returned = $_[1]; }, ); $loop->add( $return_routine ); wait_for { defined $returned }; is( $returned, 23, "on_return for $model model" ); is( $return_routine->result_future->get, 23, 'Result from ->result_future of return' ); my $died; my $die_routine = IO::Async::Routine->new( model => $model, code => sub { die "ARGH!\n" }, on_die => sub { $died = $_[1]; }, ); $loop->add( $die_routine ); wait_for { defined $died }; is( $died, "ARGH!\n", "on_die for $model model" ); is( $die_routine->result_future->failure, "ARGH!\n", 'Failure from ->result_future of die' ); } { my $channel = IO::Async::Channel->new; my $finished; my $routine = IO::Async::Routine->new( model => $model, channels_in => [ $channel ], code => sub { while( $channel->recv ) { 1 } }, on_finish => sub { $finished++ }, ); $loop->add( $routine ); $channel->close; wait_for { $finished }; pass( "Recv on closed channel for $model model" ); } { my $channel = IO::Async::Channel->new; my $routine = IO::Async::Routine->new( model => $model, channels_out => [ $channel ], code => sub { $SIG{INT} = sub { $channel->send( \"SIGINT" ); die "SIGINT" }; $channel->send( \"READY" ); # Busy-wait so thread kill still works my $until = time() + 5; 1 while time() < $until; }, ); $loop->add( $routine ); my $f; $f = wait_for_future $channel->recv; is( ${ $f->get }, "READY", 'Routine is ready for SIGINT' ); $routine->kill( "INT" ); $f = wait_for_future $channel->recv; is( ${ $f->get }, "SIGINT", 'Routine caught SIGINT' ); } } foreach my $model (qw( fork thread )) { SKIP: { skip "This Perl does not support threads", 9 if $model eq "thread" and not IO::Async::OS->HAVE_THREADS; skip "This Perl does not support fork()", 9 if $model eq "fork" and not IO::Async::OS->HAVE_POSIX_FORK; test_with_model( $model ); } } foreach my $model (qw( fork thread spawn )) { SKIP: { skip "This Perl does not support threads", 1 if $model eq "thread" and not IO::Async::OS->HAVE_THREADS; skip "This Perl does not support fork()", 1 if $model =~ m/fork|spawn/ and not IO::Async::OS->HAVE_POSIX_FORK; my $in = IO::Async::Channel->new; my $out = IO::Async::Channel->new; my $routine = IO::Async::Routine->new( model => $model, module => "t::RoutineTester", func => "test_routine", channels_in => [ $in ], channels_out => [ $out ], on_finish => sub { print STDERR "Process exited @_\n"; }, ); $loop->add( $routine ); $in->send( \"value" ); my $f = wait_for_future $out->recv; my $result = eval { $f->get }; is( ${$result}, "VALUE", "Result for $model model via module+func" ); $loop->remove( $routine ); } } # multiple channels in and out { my $in1 = IO::Async::Channel->new; my $in2 = IO::Async::Channel->new; my $out1 = IO::Async::Channel->new; my $out2 = IO::Async::Channel->new; my $routine = IO::Async::Routine->new( channels_in => [ $in1, $in2 ], channels_out => [ $out1, $out2 ], code => sub { while( my $op = $in1->recv ) { $op = $$op; # deref $out1->send( \"Ready $op" ); my @args = @{ $in2->recv }; my $result = $op eq "+" ? $args[0] + $args[1] : "ERROR"; $out2->send( \$result ); } }, on_finish => sub { }, ); isa_ok( $routine, [ "IO::Async::Routine" ], '$routine isa IO::Async::Routine' ); $loop->add( $routine ); $in1->send( \"+" ); my $status_f = wait_for_future $out1->recv; is( ${ $status_f->get }, "Ready +", '$status_f result midway through Routine' ); $in2->send( [ 10, 20 ] ); my $result_f = wait_for_future $out2->recv; is( ${ $result_f->get }, 30, '$result_f result at end of Routine' ); $loop->remove( $routine ); } # sharing a Channel between Routines { my $channel = IO::Async::Channel->new; my $src_finished; my $src_routine = IO::Async::Routine->new( channels_out => [ $channel ], code => sub { $channel->send( [ some => "data" ] ); return 0; }, on_finish => sub { $src_finished++ }, on_die => sub { die "source routine failed - $_[1]" }, ); $loop->add( $src_routine ); my $sink_result; my $sink_routine = IO::Async::Routine->new( channels_in => [ $channel ], code => sub { my @data = @{ $channel->recv }; return ( $data[0] eq "some" and $data[1] eq "data" ) ? 0 : 1; }, on_return => sub { $sink_result = $_[1] }, on_die => sub { die "sink routine failed - $_[1]" }, ); $loop->add( $sink_routine ); wait_for { $src_finished and defined $sink_result }; is( $sink_result, 0, 'synchronous src->sink can share a channel' ); } # Test that 'setup' works SKIP: { skip "This Perl does not support fork()", 1 if not IO::Async::OS->HAVE_POSIX_FORK; my $channel = IO::Async::Channel->new; my $routine = IO::Async::Routine->new( model => "fork", setup => [ env => { FOO => "Here is a random string" }, ], channels_out => [ $channel ], code => sub { $channel->send( [ $ENV{FOO} ] ); $channel->close; return 0; }, on_finish => sub {}, ); $loop->add( $routine ); my $f = wait_for_future $channel->recv; my $result = $f->get; is( $result->[0], "Here is a random string", '$result from Routine with modified ENV' ); $loop->remove( $routine ); } # Test that STDOUT/STDERR are unaffected SKIP: { skip "This Perl does not support fork()", 1 if not IO::Async::OS->HAVE_POSIX_FORK; my ( $pipe_rd, $pipe_wr ) = IO::Async::OS->pipepair; $pipe_rd->blocking( 0 ); my $routine; { open my $stdoutsave, ">&", \*STDOUT; POSIX::dup2( $pipe_wr->fileno, STDOUT->fileno ); open my $stderrsave, ">&", \*STDERR; POSIX::dup2( $pipe_wr->fileno, STDERR->fileno ); $routine = IO::Async::Routine->new( model => "fork", code => sub { STDOUT->autoflush(1); print STDOUT "A line to STDOUT\n"; print STDERR "A line to STDERR\n"; return 0; } ); $loop->add( $routine ); POSIX::dup2( $stdoutsave->fileno, STDOUT->fileno ); POSIX::dup2( $stderrsave->fileno, STDERR->fileno ); } my $buffer = ""; $loop->watch_io( handle => $pipe_rd, on_read_ready => sub { sysread $pipe_rd, $buffer, 8192, length $buffer or die "Cannot read - $!" }, ); wait_for { $buffer =~ m/\n.*\n/ }; is( $buffer, "A line to STDOUT\nA line to STDERR\n", 'Write-to-STD{OUT+ERR} wrote to pipe' ); $loop->unwatch_io( handle => $pipe_rd, on_read_ready => 1 ); $loop->remove( $routine ); } done_testing; IO-Async-0.804/t/42function.t000444001750001750 3617315001742754 14447 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use constant HAVE_TEST_MEMORYGROWTH => eval { require Test::MemoryGrowth; }; use File::Temp qw( tempdir ); use Time::HiRes qw( sleep ); use IO::Async::Function; use IO::Async::OS; use IO::Async::Loop; use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); # by future { my $function = IO::Async::Function->new( min_workers => 1, max_workers => 1, code => sub { return $_[0] + $_[1] }, ); ok( defined $function, '$function defined' ); isa_ok( $function, [ "IO::Async::Function" ], '$function isa IO::Async::Function' ); is_oneref( $function, '$function has refcount 1' ); $loop->add( $function ); is_refcount( $function, 2, '$function has refcount 2 after $loop->add' ); is( $function->workers, 1, '$function has 1 worker' ); is( $function->workers_busy, 0, '$function has 0 workers busy' ); is( $function->workers_idle, 1, '$function has 1 workers idle' ); my $future = $function->call( args => [ 10, 20 ], ); isa_ok( $future, [ "Future" ], '$future isa Future' ); is_refcount( $function, 2, '$function has refcount 2 after ->call' ); is( $function->workers_busy, 1, '$function has 1 worker busy after ->call' ); is( $function->workers_idle, 0, '$function has 0 worker idle after ->call' ); wait_for { $future->is_ready }; my ( $result ) = $future->get; is( $result, 30, '$result after call returns by future' ); is( $function->workers_busy, 0, '$function has 0 workers busy after call returns' ); is( $function->workers_idle, 1, '$function has 1 workers idle after call returns' ); # ->stop future wait_for_future my $stop_f = $function->stop; ok( !$stop_f->failure, '$stop_f succeeds' ); $loop->remove( $function ); } # by callback { my $function = IO::Async::Function->new( min_workers => 1, max_workers => 1, code => sub { return $_[0] + $_[1] }, ); $loop->add( $function ); my $result; $function->call( args => [ 10, 20 ], on_return => sub { $result = shift }, on_error => sub { die "Test failed early - @_" }, ); wait_for { defined $result }; is( $result, 30, '$result after call returns by callback' ); $loop->remove( $function ); } # Test queueing { my $function = IO::Async::Function->new( min_workers => 1, max_workers => 1, code => sub { return $_[0] + $_[1] }, ); $loop->add( $function ); my @result; my $f1 = $function->call( args => [ 1, 2 ], on_return => sub { push @result, shift }, on_error => sub { die "Test failed early - @_" }, ); my $f2 = $function->call( args => [ 3, 4 ], on_return => sub { push @result, shift }, on_error => sub { die "Test failed early - @_" }, ); is( $function->workers, 1, '$function->workers is still 1 after 2 calls' ); isa_ok( $f1, [ "Future" ], '$f1 isa Future' ); isa_ok( $f2, [ "Future" ], '$f2 isa Future' ); wait_for { @result == 2 }; is( \@result, [ 3, 7 ], '@result after both calls return' ); is( $function->workers, 1, '$function->workers is still 1 after 2 calls return' ); $loop->remove( $function ); } # Queue priority { my $serial = 0; my $function = IO::Async::Function->new( # Keep exactly 1 process so captured lexical works for testing min_workers => 1, max_workers => 1, code => sub { return $serial++ }, ); $loop->add( $function ); # Push something just to make the function busy first $function->call( args => [], on_return => sub {}, on_error => sub {} ); my $f = Future->needs_all( $function->call( args => [] ), # no priority $function->call( args => [], priority => 1 ), $function->call( args => [], priority => 1 ), $function->call( args => [], priority => 2 ), ); is( [ ( wait_for_future $f )->get ], [ 4, 2, 3, 1 ], '$function->call with priority enqueues correctly' ); $loop->remove( $function ); } # References { my $function = IO::Async::Function->new( code => sub { return ref( $_[0] ), \$_[1] }, ); $loop->add( $function ); my @result; $function->call( args => [ \'a', 'b' ], on_return => sub { @result = @_ }, on_error => sub { die "Test failed early - @_" }, ); wait_for { scalar @result }; is( \@result, [ 'SCALAR', \'b' ], 'Call and result preserves references' ); $loop->remove( $function ); } # Exception throwing { my $line = __LINE__ + 2; my $function = IO::Async::Function->new( code => sub { die shift }, ); $loop->add( $function ); my $err; my $f = $function->call( args => [ "exception name" ], on_return => sub { }, on_error => sub { $err = shift }, ); wait_for { defined $err }; like( $err, qr/^exception name at \Q$0\E line \d+\.$/, '$err after exception' ); is( [ $f->failure ], [ "exception name at $0 line $line.", error => ], '$f->failure after exception' ); $loop->remove( $function ); } # Throwing exceptions with details { my $function = IO::Async::Function->new( code => sub { die [ "A message\n", category => 123, 456 ] }, ); $loop->add( $function ); my $f = wait_for_future $function->call( args => [], ); is( [ $f->failure ], [ "A message\n", category => 123, 456 ], '$f->failure after exception with detail' ); $loop->remove( $function ); } # max_workers { my $count = 0; my $function = IO::Async::Function->new( max_workers => 1, code => sub { $count++; die "$count\n" }, exit_on_die => 0, ); $loop->add( $function ); my @errs; $function->call( args => [], on_return => sub { }, on_error => sub { push @errs, shift }, ); $function->call( args => [], on_return => sub { }, on_error => sub { push @errs, shift }, ); undef @errs; wait_for { scalar @errs == 2 }; is( \@errs, [ "1", "2" ], 'Closed variables preserved when exit_on_die => 0' ); $loop->remove( $function ); } # exit_on_die { my $count = 0; my $function = IO::Async::Function->new( max_workers => 1, code => sub { $count++; die "$count\n" }, exit_on_die => 1, ); $loop->add( $function ); my @errs; $function->call( args => [], on_return => sub { }, on_error => sub { push @errs, shift }, ); $function->call( args => [], on_return => sub { }, on_error => sub { push @errs, shift }, ); undef @errs; wait_for { scalar @errs == 2 }; is( \@errs, [ "1", "1" ], 'Closed variables preserved when exit_on_die => 1' ); $loop->remove( $function ); } # restart after exit SKIP: { skip "This Perl does not support fork()", 4 if not IO::Async::OS->HAVE_POSIX_FORK; my $function = IO::Async::Function->new( model => "fork", min_workers => 0, max_workers => 1, code => sub { $_[0] ? exit shift : return 0 }, ); $loop->add( $function ); my $err; $function->call( args => [ 16 ], on_return => sub { $err = "" }, on_error => sub { $err = [ @_ ] }, ); wait_for { defined $err }; # Not sure what reason we might get - need to check both ok( $err->[0] eq "closed" || $err->[0] eq "exit", '$err->[0] after child death' ) or diag( 'Expected "closed" or "exit", found ' . $err->[0] ); is( scalar $function->workers, 0, '$function->workers is now 0' ); $function->call( args => [ 0 ], on_return => sub { $err = "return" }, on_error => sub { $err = [ @_ ] }, ); is( scalar $function->workers, 1, '$function->workers is now 1 again' ); undef $err; wait_for { defined $err }; is( $err, "return", '$err is "return" after child nondeath' ); $loop->remove( $function ); } # init_code { my $captured; my $function = IO::Async::Function->new( init_code => sub { $captured = 10 }, code => sub { return $captured }, ); $loop->add( $function ); my $f = wait_for_future $function->call( args => [], ); is( scalar $f->get, 10, 'init_code can side-effect captured variables' ); $loop->remove( $function ); } # module + func in all models foreach my $model (qw( fork thread spawn )) { SKIP: { skip "This Perl does not support threads", 9 if $model eq "thread" and not IO::Async::OS->HAVE_THREADS; skip "This Perl does not support fork()", 9 if $model =~ m/fork|spawn/ and not IO::Async::OS->HAVE_POSIX_FORK; my $function = IO::Async::Function->new( model => $model, # We're sure to have List::Util::sum available as that has been core since 5.8 module => "List::Util", func => "sum", ); $loop->add( $function ); my $f = wait_for_future $function->call( args => [ 10, 20, 30 ] ); is( scalar $f->get, 60, "result by module + func in '$model' model" ); } } ## Now test that parallel runs really are parallel { # touch $dir/$n in each worker, touch $dir/done to finish it sub touch { my ( $file ) = @_; open( my $fh, ">", $file ) or die "Cannot write $file - $!"; close( $fh ); } my $function = IO::Async::Function->new( min_workers => 3, code => sub { my ( $dir, $n ) = @_; my $file = "$dir/$n"; touch( $file ); # Wait for synchronisation sleep 0.1 while ! -e "$dir/done"; unlink( $file ); return $n; }, ); $loop->add( $function ); is( scalar $function->workers, 3, '$function->workers is 3' ); my $dir = tempdir( CLEANUP => 1 ); my %ret; foreach my $id ( 1, 2, 3 ) { $function->call( args => [ $dir, $id ], on_return => sub { $ret{$id} = shift }, on_error => sub { die "Test failed early - @_" }, ); } wait_for { -e "$dir/1" and -e "$dir/2" and -e "$dir/3" }; ok( 1, 'synchronise files created' ); # Synchronize deleting them; touch( "$dir/done" ); undef %ret; wait_for { keys %ret == 3 }; unlink( "$dir/done" ); is( \%ret, { 1 => 1, 2 => 2, 3 => 3 }, 'ret keys after parallel run' ); is( scalar $function->workers, 3, '$function->workers is still 3' ); $loop->remove( $function ); } # Test for idle timeout { my $function = IO::Async::Function->new( min_workers => 0, max_workers => 1, idle_timeout => 2 * AUT, code => sub { return $_[0] }, ); $loop->add( $function ); my $result; $function->call( args => [ 1 ], on_result => sub { $result = $_[0] }, ); wait_for { defined $result }; is( $function->workers, 1, '$function has 1 worker after call' ); my $waited; $loop->watch_time( after => 1 * AUT, code => sub { $waited++ } ); wait_for { $waited }; is( $function->workers, 1, '$function still has 1 worker after short delay' ); undef $result; $function->call( args => [ 1 ], on_result => sub { $result = $_[0] }, ); wait_for { defined $result }; undef $waited; $loop->watch_time( after => 3 * AUT, code => sub { $waited++ } ); wait_for { $waited }; is( $function->workers, 0, '$function has 0 workers after longer delay' ); $loop->remove( $function ); } # Restart { my $value = 1; my $function = IO::Async::Function->new( code => sub { return $value }, ); $loop->add( $function ); my $result; $function->call( args => [], on_return => sub { $result = shift }, on_error => sub { die "Test failed early - @_" }, ); wait_for { defined $result }; is( $result, 1, '$result before restart' ); $value = 2; $function->restart; undef $result; $function->call( args => [], on_return => sub { $result = shift }, on_error => sub { die "Test failed early - @_" }, ); wait_for { defined $result }; is( $result, 2, '$result after restart' ); undef $result; $function->call( args => [], on_return => sub { $result = shift }, on_error => sub { die "Test failed early - @_" }, ); $function->restart; wait_for { defined $result }; is( $result, 2, 'call before restart still returns result' ); $loop->remove( $function ); } # exit by POSIX::_exit { # We can't easily turn this into an assertion test, but if the required # behaviour doesn't hold then the test script will be killed early and # prove will notice this. my $testpid = $$; END { kill $testpid if defined $testpid and $testpid != $$ } my $function = IO::Async::Function->new( code => sub {}, ); $loop->add( $function ); $function->call( args => [] )->get; $function->stop; undef $testpid; } # max_worker_calls { my $counter; my $function = IO::Async::Function->new( max_workers => 1, max_worker_calls => 2, code => sub { return ++$counter; } ); $loop->add( $function ); my $result; $function->call( args => [], on_return => sub { $result = shift }, on_error => sub { die "Test failed early - @_" }, ); wait_for { defined $result }; is( $result, 1, '$result from first call' ); undef $result; $function->call( args => [], on_return => sub { $result = shift }, on_error => sub { die "Test failed early - @_" }, ); wait_for { defined $result }; is( $result, 2, '$result from second call' ); undef $result; $function->call( args => [], on_return => sub { $result = shift }, on_error => sub { die "Test failed early - @_" }, ); wait_for { defined $result }; is( $result, 1, '$result from third call' ); $loop->remove( $function ); } # Cancellation of sent calls { my $function = IO::Async::Function->new( max_workers => 1, code => sub { return 123; }, ); $loop->add( $function ); my $f1 = $function->call( args => [] ); $f1->cancel; my $f2 = $function->call( args => [] ); wait_for { $f2->is_ready }; is( scalar $f2->get, 123, 'Result of function call after cancelled call' ); $loop->remove( $function ); } # Cancellation of pending calls { my $function = IO::Async::Function->new( max_workers => 1, code => do { my $state; sub { my $oldstate = $state; $state = shift; return $oldstate; } }, ); $loop->add( $function ); # Queue 3 calls but immediately cancel the middle one my ( $f1, $f2, $f3 ) = map { $function->call( args => [ $_ ] ) } 1 .. 3; $f2->cancel; wait_for { $f1->is_ready and $f3->is_ready }; is( scalar $f1->get, undef, '$f1 result is undef' ); is( scalar $f3->get, 1, '$f3 result is 1' ); $loop->remove( $function ); } # Leak test (RT99552) if( HAVE_TEST_MEMORYGROWTH ) { diag( "Performing memory leak test" ); my $function = IO::Async::Function->new( max_workers => 8, code => sub {}, ); $loop->add( $function ); Test::MemoryGrowth::no_growth( sub { $function->restart; $function->call( args => [] )->get; }, calls => 100, 'IO::Async::Function calls do not leak memory' ); $loop->remove( $function ); undef $function; } done_testing; IO-Async-0.804/t/50resolver.t000444001750001750 2742315001742754 14460 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use Test::Metrics::Any; use Socket 1.93 qw( AF_INET SOCK_STREAM SOCK_DGRAM SOCK_RAW INADDR_LOOPBACK INADDR_ANY AI_NUMERICHOST AI_PASSIVE NI_NUMERICHOST NI_NUMERICSERV pack_sockaddr_in unpack_sockaddr_in sockaddr_family inet_aton inet_ntoa ); use IO::Async::Loop; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); my $resolver = $loop->resolver; isa_ok( $resolver, [ "IO::Async::Resolver" ], '$loop->resolver isa IO::Async::Resolver' ); SKIP: { my @pwuid; defined eval { @pwuid = getpwuid( $< ) } or skip "No getpwuid()", 5; { my $future = $resolver->resolve( type => 'getpwuid', data => [ $< ], ); isa_ok( $future, [ "Future" ], '$future isa Future' ); wait_for { $future->is_ready }; my @result = $future->get; is( \@result, \@pwuid, 'getpwuid from future' ); } { my $result; $resolver->resolve( type => 'getpwuid', data => [ $< ], on_resolved => sub { $result = [ @_ ] }, on_error => sub { die "Test died early" }, ); wait_for { $result }; is( $result, \@pwuid, 'getpwuid' ); } { my $result; $loop->resolve( type => 'getpwuid', data => [ $< ], on_resolved => sub { $result = [ @_ ] }, on_error => sub { die "Test died early" }, ); wait_for { $result }; is( $result, \@pwuid, 'getpwuid via $loop->resolve' ); } SKIP: { my $user_name = $pwuid[0]; skip "getpwnam - No user name", 1 unless defined $user_name; my @pwnam = getpwnam( $user_name ); my $result; $resolver->resolve( type => 'getpwnam', data => [ $user_name ], on_resolved => sub { $result = [ @_ ] }, on_error => sub { die "Test died early" }, ); wait_for { $result }; is( $result, \@pwnam, 'getpwnam' ); } } my @proto = getprotobyname( "tcp" ); SKIP: { skip "getprotobyname - No protocol", 1 unless @proto; my $result; $resolver->resolve( type => 'getprotobyname', data => [ "tcp" ], on_resolved => sub { $result = [ @_ ] }, on_error => sub { die "Test died early" }, ); wait_for { $result }; is( $result, \@proto, 'getprotobyname' ); } SKIP: { my $proto_number = $proto[2]; skip "getprotobynumber - No protocol number", 1 unless defined $proto_number; my @proto = getprotobynumber( $proto_number ); my $result; $resolver->resolve( type => 'getprotobynumber', data => [ $proto_number ], on_resolved => sub { $result = [ @_ ] }, on_error => sub { die "Test died early" }, ); wait_for { $result }; is( $result, \@proto, 'getprotobynumber' ); } BEGIN { # Rather than suffer various test failures because system resolver behaves # in a weird way when testing, lets just mock it out and replace it with a # virtual one so we can control the results no warnings 'redefine'; *Socket::getaddrinfo = sub { my ( $host, $service, $hints ) = @_; my $hint_flags = $hints->{flags} // 0; my $hint_family = $hints->{family}; my $hint_socktype = $hints->{socktype}; die "TODO: fake getaddrinfo on unrecognised family" if $hint_family and $hint_family != AF_INET; my $flag_numerichost = $hint_flags & AI_NUMERICHOST; return ( Socket::EAI_FAIL ) if $host =~ m/\.FAIL$/; my $inaddr; $inaddr = inet_aton( "1.2.3.4" ) if !$flag_numerichost and $host eq "one.FAKE"; $inaddr = INADDR_LOOPBACK if $host eq "127.0.0.1"; $inaddr = INADDR_ANY if $hint_flags & AI_PASSIVE and !$host; defined $inaddr or die "TODO: Unsure how to fake getaddrinfo on host=$host"; my $port = 0; $port = $service+0 if $service =~ m/^\d+$/; $port = 80 if $service eq "www"; my $addr = pack_sockaddr_in( $port, $inaddr ); my @res = map { { family => AF_INET, socktype => $_, protocol => 0, addr => $addr } } grep { !$hint_socktype or $_ == $hint_socktype } ( SOCK_STREAM, SOCK_DGRAM, SOCK_RAW ); return ( "", @res ); }; *Socket::getnameinfo = sub { my ( $addr, $flags ) = @_; my $family = sockaddr_family $addr; $family == AF_INET or die "TODO: Unsure how to fake getnameinfo on family=$family"; my ( $port, $inaddr ) = unpack_sockaddr_in $addr; $inaddr eq INADDR_LOOPBACK or die "TODO: Unsure how to fake getnameinfo on inaddr!=INADDR_LOOPBACK"; my $host; if( $flags & NI_NUMERICHOST ) { $host = inet_ntoa( $inaddr ); } else { $host = "localhost"; } my $service; if( $flags & NI_NUMERICSERV ) { $service = $port; } elsif( $port == 80 ) { $service = "www"; } else { die "TODO: convert port=$port to service name"; } return ( "", $host, $service ); }; } my @expect_one_www = ( { family => AF_INET, socktype => SOCK_STREAM, protocol => 0, addr => pack_sockaddr_in(80, inet_aton("1.2.3.4")) }, ); my @expect_lo_80 = ( { family => AF_INET, socktype => SOCK_STREAM, protocol => 0, addr => pack_sockaddr_in(80, INADDR_LOOPBACK) }, ); my @expect_passive_3000 = ( { family => AF_INET, socktype => SOCK_STREAM, protocol => 0, addr => pack_sockaddr_in(3000, INADDR_ANY) }, ); { my $result; $resolver->resolve( type => 'getaddrinfo_array', data => [ "one.FAKE", "www", "inet", "stream" ], on_resolved => sub { $result = [ 'resolved', @_ ] }, on_error => sub { $result = [ 'error', @_ ] }, ); wait_for { $result }; is( $result->[0], "resolved", 'getaddrinfo_array - resolved' ); my @got = @{$result}[1..$#$result]; my @expect = map { [ @{$_}{qw( family socktype protocol addr canonname )} ] } @expect_one_www; is( \@got, \@expect, 'getaddrinfo_array - resolved addresses' ); } { my $result; $resolver->resolve( type => 'getaddrinfo_hash', data => [ host => "one.FAKE", service => "www", family => "inet", socktype => "stream" ], on_resolved => sub { $result = [ 'resolved', @_ ] }, on_error => sub { $result = [ 'error', @_ ] }, ); wait_for { $result }; is( $result->[0], "resolved", 'getaddrinfo_hash - resolved' ); my @got = @{$result}[1..$#$result]; is( \@got, \@expect_one_www, 'getaddrinfo_hash - resolved addresses' ); } { my $result; $resolver->getaddrinfo( host => "one.FAKE", service => "www", family => "inet", socktype => "stream", on_resolved => sub { $result = [ 'resolved', @_ ] }, on_error => sub { $result = [ 'error', @_ ] }, ); wait_for { $result }; is( $result->[0], "resolved", '$resolver->getaddrinfo - resolved' ); my @got = @{$result}[1..$#$result]; is( \@got, \@expect_one_www, '$resolver->getaddrinfo - resolved addresses' ); } { my $future = $resolver->getaddrinfo( host => "one.FAKE", service => "www", family => "inet", socktype => "stream", ); isa_ok( $future, [ "Future" ], '$future for $resolver->getaddrinfo isa Future' ); wait_for { $future->is_ready }; my @got = $future->get; is( \@got, \@expect_one_www, '$resolver->getaddrinfo - resolved addresses' ); } { my $result; $resolver->getaddrinfo( host => "127.0.0.1", service => "80", socktype => SOCK_STREAM, on_resolved => sub { $result = [ 'resolved', @_ ] }, on_error => sub { $result = [ 'error', @_ ] }, ); is( $result->[0], 'resolved', '$resolver->getaddrinfo on numeric host/service is synchronous' ); my @got = @{$result}[1..$#$result]; is( \@got, \@expect_lo_80, '$resolver->getaddrinfo resolved addresses synchronously' ); undef $result; $resolver->getaddrinfo( host => "127.0.0.1", socktype => SOCK_RAW, on_resolved => sub { $result = [ 'resolved', @_ ] }, on_error => sub { $result = [ 'error', @_ ] }, ); is( $result->[0], 'resolved', '$resolver->getaddrinfo on numeric host/no service is synchronous' ); my @got_sinaddrs = map { $_->{addr} } @{$result}[1..$#$result]; is( \@got_sinaddrs, [ map { pack_sockaddr_in( 0, inet_aton "127.0.0.1" ) } @got_sinaddrs ], '$resolver->getaddrinfo resolved addresses synchronously with no service' ); } { my $result; $resolver->getaddrinfo( family => "inet", service => "3000", socktype => "stream", passive => 1, on_resolved => sub { $result = [ 'resolved', @_ ] }, on_error => sub { $result = [ 'error', @_ ] }, ); is( $result->[0], "resolved", '$resolver->getaddrinfo passive - resolved synchronously' ); my @got = @{$result}[1..$#$result]; is( \@got, \@expect_passive_3000, '$resolver->getaddrinfo passive - resolved addresses' ); } { my $future = $resolver->getaddrinfo( host => "127.0.0.1", service => "80", socktype => SOCK_STREAM, ); isa_ok( $future, [ "Future" ], '$future for $resolver->getaddrinfo numerical isa Future' ); wait_for { $future->is_ready }; my @got = $future->get; is( \@got, \@expect_lo_80, '$resolver->getaddrinfo resolved addresses synchronously' ); } { my $future = wait_for_future $resolver->getaddrinfo( host => "a-name-to.FAIL", service => "80", socktype => SOCK_STREAM, ); ok( $future->failure, '$future failed for missing host' ); is( ( $future->failure )[1], "resolve", '->failure [1] gives resolve' ); is( ( $future->failure )[2], "getaddrinfo", '->failure [2] gives getaddrinfo' ); my $errno = ( $future->failure )[3]; is( $errno, Socket::EAI_FAIL, '->failure [3] gives EAI_FAIL' ); } my $sinaddr_lo_www = pack_sockaddr_in( 80, INADDR_LOOPBACK ); { my $result; $resolver->getnameinfo( addr => $sinaddr_lo_www, on_resolved => sub { $result = [ 'resolved', @_ ] }, on_error => sub { $result = [ 'error', @_ ] }, ); wait_for { $result }; is( $result->[0], "resolved", '$resolver->getnameinfo - resolved' ); is( [ @{$result}[1..2] ], [ "localhost", "www" ], '$resolver->getnameinfo - resolved names' ); } { my $future = wait_for_future $resolver->getnameinfo( addr => $sinaddr_lo_www, ); my @got = $future->get; is( \@got, [ "localhost", "www" ], '$resolver->getnameinfo - resolved names from future' ); } { my $result; $resolver->getnameinfo( addr => $sinaddr_lo_www, numeric => 1, on_resolved => sub { $result = [ 'resolved', @_ ] }, on_error => sub { $result = [ 'error', @_ ] }, ); is( $result, [ resolved => "127.0.0.1", 80 ], '$resolver->getnameinfo with numeric is synchronous' ); } { my $future = $resolver->getnameinfo( addr => $sinaddr_lo_www, numeric => 1, ); is( [ $future->get ], [ "127.0.0.1", 80 ], '$resolver->getnameinfo with numeric is synchronous for future' ); } # Metrics SKIP: { skip "Metrics are unavailable" unless $IO::Async::Metrics::METRICS; is_metrics_from( sub { $resolver->getnameinfo( addr => $sinaddr_lo_www )->get; }, { "io_async_resolver_lookups type:getnameinfo" => 1 }, 'Resolver increments metrics' ); # Can't easily unit-test the failure counter because we can't guarantee to # create a failure } # $loop->set_resolver { my $callcount = 0; { package MockResolver; use base qw( IO::Async::Notifier ); sub new { bless {}, shift } sub resolve { $callcount++; return Future->done(); } sub getaddrinfo {} sub getnameinfo {} } $loop->set_resolver( MockResolver->new ); $loop->resolve( type => "getpwuid", data => [ 0 ] )->get; is( $callcount, 1, '$callcount 1 after ->resolve' ); } done_testing; IO-Async-0.804/t/51loop-connect.t000444001750001750 2362615001742754 15221 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use IO::Socket::INET; use POSIX qw( ENOENT ENETDOWN ); use Socket qw( AF_UNIX inet_ntoa ); use IO::Async::Loop; use IO::Async::Stream; use IO::Async::Socket; # Some odd locations like BSD jails might not like INADDR_LOOPBACK. We'll # establish a baseline first to test against my $INADDR_LOOPBACK = do { my $localsock = IO::Socket::INET->new( LocalAddr => "localhost", Listen => 1 ); $localsock->sockaddr; }; my $INADDR_LOOPBACK_HOST = inet_ntoa( $INADDR_LOOPBACK ); if( $INADDR_LOOPBACK ne INADDR_LOOPBACK ) { diag( "Testing with INADDR_LOOPBACK=$INADDR_LOOPBACK_HOST; this may be because of odd networking" ); } my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); # Try connect(2)ing to a socket we've just created my $listensock = IO::Socket::INET->new( Type => SOCK_STREAM, LocalAddr => 'localhost', LocalPort => 0, Listen => 1 ) or die "Cannot create listensock - $!"; my $addr = $listensock->sockname; { my $future = $loop->connect( addr => { family => "inet", socktype => "stream", addr => $addr }, ); isa_ok( $future, [ "Future" ], '$future isa Future' ); wait_for { $future->is_ready }; my ( $sock ) = $future->get; can_ok( $sock, qw( peerhost peerport ) ); is( [ unpack_sockaddr_in $sock->peername ], [ unpack_sockaddr_in $addr ], 'by addr: $sock->getpeername is $addr from future' ); $listensock->accept; # Throw it away } # handle { my $future = $loop->connect( handle => my $given_stream = IO::Async::Stream->new, addr => { family => "inet", socktype => "stream", addr => $addr }, ); isa_ok( $future, [ "Future" ], '$future for ->connect( handle ) isa Future' ); wait_for { $future->is_ready }; my $stream = $future->get; ref_is( $stream, $given_stream, '$future->get returns given Stream' ); ok( my $sock = $stream->read_handle, '$stream has a read handle' ); is( [ unpack_sockaddr_in $sock->peername ], [ unpack_sockaddr_in $addr ], 'Returned $stream->read_handle->getpeername is $addr' ); $listensock->accept; # Throw it away } # legacy callbacks { my $sock; $loop->connect( addr => { family => "inet", socktype => "stream", addr => $addr }, on_connected => sub { $sock = shift; }, on_connect_error => sub { die "Test died early - connect error $_[0]() - $_[-1]\n"; }, ); wait_for { $sock }; # Not sure if it'll be an IO::Socket::INET or ::IP, but either way it should support these can_ok( $sock, qw( peerhost peerport ) ); is( [ unpack_sockaddr_in $sock->peername ], [ unpack_sockaddr_in $addr ], 'by addr: $sock->getpeername is $addr' ); $listensock->accept; # Throw it away } # Now try by name { my $future = $loop->connect( host => $listensock->sockhost, service => $listensock->sockport, socktype => $listensock->socktype, ); isa_ok( $future, [ "Future" ], '$future isa Future' ); wait_for { $future->is_ready }; my ( $sock ) = $future->get; can_ok( $sock, qw( peerhost peerport ) ); is( [ unpack_sockaddr_in $sock->peername ], [ unpack_sockaddr_in $addr ], 'by host/service: $sock->getpeername is $addr from future' ); is( $sock->sockhost, $INADDR_LOOPBACK_HOST, '$sock->sockhost is INADDR_LOOPBACK_HOST from future' ); $listensock->accept; # Throw it away } # legacy callbacks { my $sock; $loop->connect( host => $listensock->sockhost, service => $listensock->sockport, socktype => $listensock->socktype, on_connected => sub { $sock = shift; }, on_resolve_error => sub { die "Test died early - resolve error - $_[-1]\n"; }, on_connect_error => sub { die "Test died early - connect error $_[0]() - $_[-1]\n"; }, ); wait_for { $sock }; can_ok( $sock, qw( peerhost peerport ) ); is( [ unpack_sockaddr_in $sock->peername ], [ unpack_sockaddr_in $addr ], 'by host/service: $sock->getpeername is $addr' ); is( $sock->sockhost, $INADDR_LOOPBACK_HOST, '$sock->sockhost is INADDR_LOOPBACK_HOST' ); $listensock->accept; # Throw it away } SKIP: { # Some OSes can't bind(2) locally to other addresses on 127./8 skip "Cannot bind to 127.0.0.2", 1 unless eval { IO::Socket::INET->new( LocalHost => "127.0.0.2", LocalPort => 0 ) }; # Some can bind(2) but then cannot connect() to 127.0.0.1 from it chomp($@), skip "Cannot connect to 127.0.0.1 from 127.0.0.2 - $@", 1 unless eval { my $s = IO::Socket::INET->new( LocalHost => "127.0.0.2", LocalPort => 0, PeerHost => $listensock->sockhost, PeerPort => $listensock->sockport, ) or die $@; $listensock->accept; # Throw it away $s->sockhost eq "127.0.0.2" or die "sockhost is not 127.0.0.2\n"; }; my $sock; $loop->connect( local_host => "127.0.0.2", host => $listensock->sockhost, service => $listensock->sockport, socktype => $listensock->socktype, on_connected => sub { $sock = shift; }, on_resolve_error => sub { die "Test died early - resolve error - $_[-1]\n"; }, on_connect_error => sub { die "Test died early - connect error $_[0]() - $_[-1]\n"; }, ); wait_for { $sock }; is( $sock->sockhost, "127.0.0.2", '$sock->sockhost is 127.0.0.2' ); $listensock->accept; # Throw it away undef $sock; # This too } # Now try on_stream event { my $stream; $loop->connect( host => $listensock->sockhost, service => $listensock->sockport, socktype => $listensock->socktype, on_stream => sub { $stream = shift; }, on_resolve_error => sub { die "Test died early - resolve error - $_[-1]\n"; }, on_connect_error => sub { die "Test died early - connect error $_[0]() - $_[-1]\n"; }, ); wait_for { $stream }; isa_ok( $stream, [ "IO::Async::Stream" ], 'on_stream $stream isa IO::Async::Stream' ); my $sock = $stream->read_handle; is( [ unpack_sockaddr_in $sock->peername ], [ unpack_sockaddr_in $addr ], 'on_stream $sock->getpeername is $addr' ); $listensock->accept; # Throw it away } my $udpsock = IO::Socket::INET->new( LocalAddr => 'localhost', Protocol => 'udp' ) or die "Cannot create udpsock - $!"; { my $future = $loop->connect( handle => my $given_socket = IO::Async::Socket->new, addr => { family => "inet", socktype => "dgram", addr => $udpsock->sockname }, ); isa_ok( $future, [ "Future" ], '$future for ->connect( handle socket ) isa Future' ); wait_for { $future->is_ready }; my $socket = $future->get; ref_is( $socket, $given_socket, '$future->get returns given Socket' ); is( [ unpack_sockaddr_in $socket->read_handle->peername ], [ unpack_sockaddr_in $udpsock->sockname ], 'Returned $socket->read_handle->getpeername is $addr' ); } # legacy callbacks { my $sock; $loop->connect( addr => { family => "inet", socktype => "dgram", addr => $udpsock->sockname }, on_socket => sub { $sock = shift; }, on_connect_error => sub { die "Test died early - connect error $_[0]() - $_[-1]\n"; }, ); wait_for { $sock }; isa_ok( $sock, [ "IO::Async::Socket" ], 'on_socket $sock isa IO::Async::Socket' ); is( [ unpack_sockaddr_in $sock->read_handle->peername ], [ unpack_sockaddr_in $udpsock->sockname ], 'on_socket $sock->read_handle->getpeername is $addr' ); } SKIP: { # Now try an address we know to be invalid - a UNIX socket that doesn't exist socket( my $dummy, AF_UNIX, SOCK_STREAM, 0 ) or skip "Cannot create AF_UNIX sockets - $!", 2; my $error; my $failop; my $failerr; $loop->connect( addr => { family => "unix", socktype => "stream", path => "/some/path/we/know/breaks" }, on_connected => sub { die "Test died early - connect succeeded\n"; }, on_fail => sub { $failop = shift @_; $failerr = pop @_; }, on_connect_error => sub { $error = 1 }, ); wait_for { $error }; is( $failop, "connect", '$failop is connect' ); like( $failerr+0, qr/^(${\ENOENT}|${\ENETDOWN})$/, '$failerr is ENOENT' ); } SKIP: { socket( my $dummy, AF_UNIX, SOCK_STREAM, 0 ) or skip "Cannot create AF_UNIX sockets - $!", 2; my $failop; my $failerr; my $future = wait_for_future $loop->connect( addr => { family => "unix", socktype => "stream", path => "/some/path/we/know/breaks" }, on_fail => sub { $failop = shift @_; $failerr = pop @_; }, ); is( $failop, "connect", '$failop is connect' ); like( $failerr+0, qr/^(${\ENOENT}|${\ENETDOWN})$/, '$failerr is ENOENT' ); ok( $future->is_failed, '$future failed' ); is( ( $future->failure )[2], "connect", '$future fail op is connect' ); like( ( $future->failure )[3]+0, qr/^(${\ENOENT}|${\ENETDOWN})$/, '$future fail err is ENOENT' ); } # UNIX sockets always connect(2) synchronously, meaning if they fail, the error # is available immediately. The above has therefore not properly tested # asynchronous connect(2) failures. INET sockets should do this. # First off we need a local socket that isn't listening - at lease one of the # first 100 is likely not to be my $port; my $failure; foreach ( 1 .. 100 ) { IO::Socket::INET->new( PeerHost => "127.0.0.1", PeerPort => $_ ) and next; $failure = "$!"; $port = $_; last; } SKIP: { skip "Cannot find an un-connect(2)able socket on 127.0.0.1", 2 unless defined $port; my $failop; my $failerr; my @error; $loop->connect( addr => { family => "inet", socktype => "stream", port => $port, ip => "127.0.0.1" }, on_connected => sub { die "Test died early - connect succeeded\n"; }, on_fail => sub { $failop = shift @_; $failerr = pop @_; }, on_connect_error => sub { @error = @_; }, ); wait_for { @error }; is( $failop, "connect", '$failop is connect' ); is( "$failerr", $failure, "\$failerr is '$failure'" ); is( $error[0], "connect", '$error[0] is connect' ); is( "$error[1]", $failure, "\$error[1] is '$failure'" ); } done_testing; IO-Async-0.804/t/52loop-listen.t000444001750001750 1220315001742754 15054 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use IO::Socket::INET; use Socket qw( inet_ntoa unpack_sockaddr_in ); use IO::Async::Loop; # Some odd locations like BSD jails might not like INADDR_LOOPBACK. We'll # establish a baseline first to test against my $INADDR_LOOPBACK = do { my $localsock = IO::Socket::INET->new( LocalAddr => "localhost", Listen => 1 ); $localsock->sockaddr; }; my $INADDR_LOOPBACK_HOST = inet_ntoa( $INADDR_LOOPBACK ); if( $INADDR_LOOPBACK ne INADDR_LOOPBACK ) { diag( "Testing with INADDR_LOOPBACK=$INADDR_LOOPBACK_HOST; this may be because of odd networking" ); } my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); { my $listensock = IO::Socket::INET->new( LocalAddr => "localhost", Type => SOCK_STREAM, Listen => 1, ) or die "Cannot socket() - $!"; $listensock->blocking( 0 ); my $newclient; my $f = $loop->listen( handle => $listensock, on_accept => sub { $newclient = $_[0]; }, ); ok( $f->is_ready, '$loop->listen on handle ready synchronously' ); my $notifier = $f->get; isa_ok( $notifier, [ "IO::Async::Notifier" ], 'synchronous on_notifier given a Notifier' ); ref_is( $notifier->loop, $loop, 'synchronous $notifier->loop is $loop' ); my $clientsock = IO::Socket::INET->new( Type => SOCK_STREAM ) or die "Cannot socket() - $!"; $clientsock->connect( $listensock->sockname ) or die "Cannot connect() - $!"; ok( defined $clientsock->peername, '$clientsock is connected' ); wait_for { defined $newclient }; is( [ unpack_sockaddr_in $newclient->peername ], [ unpack_sockaddr_in $clientsock->sockname ], '$newclient peer is correct' ); } { my $listensock; my $newclient; my $f = $loop->listen( family => "inet", socktype => "stream", service => "", # Ask the kernel to allocate a port for us host => "localhost", on_listen => sub { $listensock = $_[0]; }, on_accept => sub { $newclient = $_[0]; }, ); my $notifier = $f->get; ok( defined $listensock->fileno, '$listensock has a fileno' ); # Not sure if it'll be an IO::Socket::INET or ::IP, but either way it should support these can_ok( $listensock, qw( peerhost peerport ) ); isa_ok( $notifier, [ "IO::Async::Notifier" ], 'asynchronous on_notifier given a Notifier' ); ref_is( $notifier->loop, $loop, 'asynchronous $notifier->loop is $loop' ); my $listenaddr = $listensock->sockname; ok( defined $listenaddr, '$listensock has address' ); my ( $listenport, $listen_inaddr ) = unpack_sockaddr_in( $listenaddr ); is( inet_ntoa( $listen_inaddr ), $INADDR_LOOPBACK_HOST, '$listenaddr is INADDR_LOOPBACK' ); my $clientsock = IO::Socket::INET->new( Type => SOCK_STREAM ) or die "Cannot socket() - $!"; $clientsock->connect( $listenaddr ) or die "Cannot connect() - $!"; is( (unpack_sockaddr_in( $clientsock->peername ))[0], $listenport, '$clientsock on the correct port' ); wait_for { defined $newclient }; can_ok( $newclient, qw( peerhost peerport ) ); is( [ unpack_sockaddr_in $newclient->peername ], [ unpack_sockaddr_in $clientsock->sockname ], '$newclient peer is correct' ); } # Now we want to test failure. It's hard to know in a test script what will # definitely fail, but it's likely we're either running as non-root, or the # machine has at least one of an SSH or a webserver running. In this case, # it's likely we'll fail to bind TCP port 22 or 80. my $badport; my $failure; foreach my $port ( 22, 80 ) { IO::Socket::INET->new( Type => SOCK_STREAM, LocalHost => "localhost", LocalPort => $port, ReuseAddr => 1, Listen => 1, ) and next; $badport = $port; $failure = $!; last; } SKIP: { skip "No bind()-failing ports found", 6 unless defined $badport; my $failop; my $failerr; my @error; # We need to capture the Listener object before failure, so we can assert # it gets removed from the Loop again afterwards my $listener; no warnings 'redefine'; my $add = IO::Async::Loop->can( "add" ); local *IO::Async::Loop::add = sub { $listener = $_[1]; $add->( @_ ); }; $loop->listen( family => "inet", socktype => "stream", host => "localhost", service => $badport, on_resolve_error => sub { die "Test died early - resolve error $_[0]\n"; }, on_listen => sub { die "Test died early - listen on port $badport actually succeeded\n"; }, on_accept => sub { "DUMMY" }, # really hope this doesn't happen ;) on_fail => sub { $failop = shift; $failerr = pop; }, on_listen_error => sub { @error = @_; }, ); ok( defined $listener, 'Managed to capture listener being added to Loop' ); wait_for { @error }; is( $failop, "bind", '$failop is bind' ); is( "$failerr", $failure, "\$failerr is '$failure'" ); is( $error[0], "bind", '$error[0] is bind' ); is( "$error[1]", $failure, "\$error[1] is '$failure'" ); ok( defined $listener, '$listener defined after bind failure' ); ok( !$listener->loop, '$listener not in loop after bind failure' ); } done_testing; IO-Async-0.804/t/53loop-extend.t000444001750001750 454215001742754 15035 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use IO::Async::Loop; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); # connect { my %connectargs; my $connect_future; sub IO::Async::Loop::FOO_connect { my $self = shift; %connectargs = @_; ref_is( $self, $loop, 'FOO_connect invocant is $loop' ); return $connect_future = $loop->new_future; } my $sock; my $f = $loop->connect( extensions => [qw( FOO )], some_param => "here", on_connected => sub { $sock = shift }, ); is( ref delete $connectargs{on_connected}, "CODE", 'FOO_connect received on_connected continuation' ); is( \%connectargs, { some_param => "here" }, 'FOO_connect received some_param and no others' ); ref_is( $f, $connect_future, 'FOO_connect returns Future object' ); $loop->connect( extensions => [qw( FOO BAR )], param1 => "one", param2 => "two", on_connected => sub { $sock = shift }, ); delete $connectargs{on_connected}; is( \%connectargs, { extensions => [qw( BAR )], param1 => "one", param2 => "two" }, 'FOO_connect still receives other extensions' ); } # listen { my %listenargs; my $listen_future; sub IO::Async::Loop::FOO_listen { my $self = shift; %listenargs = @_; ref_is( $self, $loop, 'FOO_listen invocant is $loop' ); return $listen_future = $loop->new_future; } my $sock; my $f = $loop->listen( extensions => [qw( FOO )], some_param => "here", on_accept => sub { $sock = shift }, ); isa_ok( delete $listenargs{listener}, [ "IO::Async::Listener" ], '$listenargs{listener} isa IO::Async::Listener' ); is( \%listenargs, { some_param => "here" }, 'FOO_listen received some_param and no others' ); ref_is( $f, $listen_future, 'FOO_listen returns Future object' ); $loop->listen( extensions => [qw( FOO BAR )], param1 => "one", param2 => "two", on_accept => sub { $sock = shift }, ); delete $listenargs{listener}; is( \%listenargs, { extensions => [qw( BAR )], param1 => "one", param2 => "two" }, 'FOO_listen still receives other extensions' ); } done_testing; IO-Async-0.804/t/60protocol.t000444001750001750 640115001742754 14432 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use IO::Async::Loop; use IO::Async::OS; use IO::Async::Handle; use IO::Async::Protocol; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!"; # Need sockets in nonblocking mode $S1->blocking( 0 ); $S2->blocking( 0 ); my $handle = IO::Async::Handle->new( handle => $S1, on_read_ready => sub {}, on_write_ready => sub {}, ); my @setup_args; my @teardown_args; my $readready; my $writeready; my $proto = TestProtocol->new; ok( defined $proto, '$proto defined' ); isa_ok( $proto, [ "IO::Async::Protocol" ], '$proto isa IO::Async::Protocol' ); is_oneref( $proto, '$proto has refcount 1 initially' ); $proto->configure( transport => $handle ); ref_is( $proto->transport, $handle, '$proto->transport' ); is( scalar @setup_args, 1, '@setup_args after configure transport' ); ref_is( $setup_args[0], $handle, '$setup_args[0] after configure transport'); undef @setup_args; is_oneref( $proto, '$proto has refcount 1 after configure transport' ); # lexical $handle, $proto->{transport}, $proto->{children} == 3 is_refcount( $handle, 3, '$handle has refcount 3 after proto configure transport' ); $loop->add( $proto ); is_refcount( $proto, 2, '$proto has refcount 2 after adding to Loop' ); is_refcount( $handle, 4, '$handle has refcount 4 after adding proto to Loop' ); $S2->syswrite( "hello\n" ); wait_for { $readready }; is( $readready, 1, '$readready after wait' ); # Just to shut poll/select/etc... up $S1->sysread( my $dummy, 8192 ); my $newhandle = IO::Async::Handle->new( handle => $S1, on_read_ready => sub {}, on_write_ready => sub {}, ); $proto->configure( transport => $newhandle ); ref_is( $proto->transport, $newhandle, '$proto->transport after reconfigure' ); is( scalar @teardown_args, 1, '@teardown_args after reconfigure transport' ); ref_is( $teardown_args[0], $handle, '$teardown_args[0] after reconfigure transport'); is( scalar @setup_args, 1, '@setup_args after reconfigure transport' ); ref_is( $setup_args[0], $newhandle, '$setup_args[0] after reconfigure transport'); undef @teardown_args; undef @setup_args; is_oneref( $handle, '$handle has refcount 1 after reconfigure' ); my $closed = 0; $proto->configure( on_closed => sub { $closed++ }, ); $proto->transport->close; wait_for { $closed }; is( $closed, 1, '$closed after stream close' ); is( $proto->transport, undef, '$proto->transport is undef after close' ); is_refcount( $proto, 2, '$proto has refcount 2 before removal from Loop' ); $loop->remove( $proto ); is_oneref( $proto, '$proto has refcount 1 before EOF' ); done_testing; package TestProtocol; use base qw( IO::Async::Protocol ); sub setup_transport { my $self = shift; @setup_args = @_; my ( $transport ) = @_; $self->SUPER::setup_transport( $transport ); $transport->configure( on_read_ready => sub { $readready = 1 }, on_write_ready => sub { $writeready = 1 }, ); } sub teardown_transport { my $self = shift; @teardown_args = @_; my ( $transport ) = @_; $transport->configure( on_read_ready => sub {}, on_write_ready => sub {}, ); $self->SUPER::teardown_transport( $transport ); } IO-Async-0.804/t/61protocol-stream.t000444001750001750 1340415001742754 15745 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use IO::Async::Loop; use IO::Async::OS; use IO::Async::Stream; use IO::Async::Protocol::Stream; use IO::Socket::INET; use Socket qw( SOCK_STREAM ); my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); { my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!"; # Need sockets in nonblocking mode $S1->blocking( 0 ); $S2->blocking( 0 ); my @lines; my $streamproto = IO::Async::Protocol::Stream->new( transport => IO::Async::Stream->new( handle => $S1 ), on_read => sub { my $self = shift; my ( $buffref, $eof ) = @_; push @lines, $1 while $$buffref =~ s/^(.*\n)//; return 0; }, ); ok( defined $streamproto, '$streamproto defined' ); isa_ok( $streamproto, [ "IO::Async::Protocol::Stream" ], '$streamproto isa IO::Async::Protocol::Stream' ); is_oneref( $streamproto, '$streamproto has refcount 1 initially' ); $loop->add( $streamproto ); is_refcount( $streamproto, 2, '$streamproto has refcount 2 after adding to Loop' ); $S2->syswrite( "message\n" ); is( \@lines, [], '@lines before wait' ); wait_for { scalar @lines }; is( \@lines, [ "message\n" ], '@lines after wait' ); undef @lines; my @new_lines; $streamproto->configure( on_read => sub { my $self = shift; my ( $buffref, $eof ) = @_; push @new_lines, $1 while $$buffref =~ s/^(.*\n)//; return 0; }, ); $S2->syswrite( "new\nlines\n" ); wait_for { scalar @new_lines }; is( scalar @lines, 0, '@lines still empty after on_read replace' ); is( \@new_lines, [ "new\n", "lines\n" ], '@new_lines after on_read replace' ); $streamproto->write( "response\n" ); my $response = ""; wait_for_stream { $response =~ m/\n/ } $S2 => $response; is( $response, "response\n", 'response written by protocol' ); my $done; my $flushed; $streamproto->write( sub { ref_is( $_[0], $streamproto, 'writersub $_[0] is $streamproto' ); return $done++ ? undef : "a lazy message\n"; }, on_flush => sub { ref_is( $_[0], $streamproto, 'on_flush $_[0] is $streamproto' ); $flushed = 1; }, ); wait_for { $flushed }; $response = ""; wait_for_stream { $response =~ m/\n/ } $S2 => $response; is( $response, "a lazy message\n", 'response written by protocol writersub' ); my $closed = 0; $streamproto->configure( on_closed => sub { $closed++ }, ); $S2->close; wait_for { $closed }; is( $closed, 1, '$closed after stream close' ); is_refcount( $streamproto, 2, '$streamproto has refcount 2 before removing from Loop' ); $loop->remove( $streamproto ); is_oneref( $streamproto, '$streamproto refcount 1 finally' ); } my @sub_lines; { my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!"; # Need sockets in nonblocking mode $S1->blocking( 0 ); $S2->blocking( 0 ); my $streamproto = TestProtocol::Stream->new( transport => IO::Async::Stream->new( handle => $S1 ), ); ok( defined $streamproto, 'subclass $streamproto defined' ); isa_ok( $streamproto, [ "IO::Async::Protocol::Stream" ], '$streamproto isa IO::Async::Protocol::Stream' ); is_oneref( $streamproto, 'subclass $streamproto has refcount 1 initially' ); $loop->add( $streamproto ); is_refcount( $streamproto, 2, 'subclass $streamproto has refcount 2 after adding to Loop' ); $S2->syswrite( "message\n" ); is( \@sub_lines, [], '@sub_lines before wait' ); wait_for { scalar @sub_lines }; is( \@sub_lines, [ "message\n" ], '@sub_lines after wait' ); $loop->remove( $streamproto ); } { my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!"; # Need sockets in nonblocking mode $S1->blocking( 0 ); $S2->blocking( 0 ); my $serversock = IO::Socket::INET->new( Type => SOCK_STREAM, LocalHost => "localhost", LocalPort => 0, Listen => 1, ) or die "Cannot create server socket - $!"; my @lines; my $streamproto = IO::Async::Protocol::Stream->new( on_read => sub { my $self = shift; my ( $buffref, $eof ) = @_; push @lines, $1 while $$buffref =~ s/^(.*\n)//; return 0; } ); $loop->add( $streamproto ); my $connected = 0; $streamproto->connect( host => $serversock->sockhost, service => $serversock->sockport, family => $serversock->sockdomain, on_connected => sub { $connected++ }, on_connect_error => sub { die "Test failed early - $_[-1]" }, on_resolve_error => sub { die "Test failed early - $_[-1]" }, ); wait_for { $connected }; my $clientsock = $serversock->accept; is( $streamproto->transport->read_handle->peerport, $serversock->sockport, 'Protocol is connected to server socket port' ); $clientsock->syswrite( "A message\n" ); undef @lines; wait_for { @lines }; is( $lines[0], "A message\n", 'Protocol transport works' ); } { my $read_eof; my $write_eof; my $streamproto = IO::Async::Protocol::Stream->new( on_read_eof => sub { $read_eof++ }, on_write_eof => sub { $write_eof++ }, ); $streamproto->configure( transport => my $stream = IO::Async::Stream->new ); $stream->invoke_event( on_read_eof => ); is( $read_eof, 1, '$read_eof after on_read_eof' ); $stream->invoke_event( on_write_eof => ); is( $write_eof, 1, '$write_eof after on_write_eof' ); } done_testing; package TestProtocol::Stream; use base qw( IO::Async::Protocol::Stream ); sub on_read { my $self = shift; my ( $buffref, $eof ) = @_; push @sub_lines, $1 while $$buffref =~ s/^(.*\n)//; return 0; } IO-Async-0.804/t/62protocol-linestream.t000444001750001750 503115001742754 16573 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0 0.000149; use IO::Async::Loop; use IO::Async::OS; use IO::Async::Protocol::LineStream; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!"; # Need sockets in nonblocking mode $S1->blocking( 0 ); $S2->blocking( 0 ); my @lines; my $linestreamproto = IO::Async::Protocol::LineStream->new( handle => $S1, on_read_line => sub { my $self = shift; push @lines, $_[0]; }, ); ok( defined $linestreamproto, '$linestreamproto defined' ); isa_ok( $linestreamproto, [ "IO::Async::Protocol::LineStream" ], '$linestreamproto isa IO::Async::Protocol::LineStream' ); is_oneref( $linestreamproto, '$linestreamproto has refcount 1 initially' ); $loop->add( $linestreamproto ); is_refcount( $linestreamproto, 2, '$linestreamproto has refcount 2 after adding to Loop' ); $S2->syswrite( "message\r\n" ); is( \@lines, [], '@lines before wait' ); wait_for { scalar @lines }; is( \@lines, [ "message" ], '@lines after wait' ); undef @lines; my @new_lines; $linestreamproto->configure( on_read_line => sub { my $self = shift; push @new_lines, $_[0]; }, ); $S2->syswrite( "new\r\nlines\r\n" ); wait_for { scalar @new_lines }; is( scalar @lines, 0, '@lines still empty after on_read replace' ); is( \@new_lines, [ "new", "lines" ], '@new_lines after on_read replace' ); $linestreamproto->write_line( "response" ); my $response = ""; wait_for_stream { $response =~ m/\r\n/ } $S2 => $response; is( $response, "response\r\n", 'response written by protocol' ); my @sub_lines; $linestreamproto = TestProtocol::Stream->new( handle => $S1, ); ok( defined $linestreamproto, 'subclass $linestreamproto defined' ); isa_ok( $linestreamproto, [ "IO::Async::Protocol::LineStream" ], '$linestreamproto isa IO::Async::Protocol::LineStream' ); is_oneref( $linestreamproto, 'subclass $linestreamproto has refcount 1 initially' ); $loop->add( $linestreamproto ); is_refcount( $linestreamproto, 2, 'subclass $linestreamproto has refcount 2 after adding to Loop' ); $S2->syswrite( "message\r\n" ); is( \@sub_lines, [], '@sub_lines before wait' ); wait_for { scalar @sub_lines }; is( \@sub_lines, [ "message" ], '@sub_lines after wait' ); undef @lines; $loop->remove( $linestreamproto ); undef $linestreamproto; done_testing; package TestProtocol::Stream; use base qw( IO::Async::Protocol::LineStream ); sub on_read_line { my $self = shift; push @sub_lines, $_[0]; } IO-Async-0.804/t/63handle-connect.t000444001750001750 350015001742754 15453 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use IO::Async::Loop; use IO::Async::Handle; use IO::Async::OS; use IO::Socket::INET; use Socket qw( SOCK_STREAM ); my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); # Try connect(2)ing to a socket we've just created my $listensock = IO::Socket::INET->new( Type => SOCK_STREAM, LocalAddr => 'localhost', LocalPort => 0, Listen => 1 ) or die "Cannot create listensock - $!"; my $addr = $listensock->sockname; # ->connect to plain addr { my $handle = IO::Async::Handle->new( on_read_ready => sub {}, on_write_ready => sub {}, ); $loop->add( $handle ); my $f = $handle->connect( addr => [ 'inet', 'stream', 0, $addr ] ); ok( defined $f, '$handle->connect Future defined' ); wait_for { $f->is_ready }; $f->is_failed and $f->get; ok( defined $handle->read_handle, '$handle->read_handle defined after ->connect addr' ); is( $handle->read_handle->peerport, $listensock->sockport, '$handle->read_handle->peerport after ->connect addr' ); $listensock->accept; # drop it $loop->remove( $handle ); } # ->connect to host/service { my $handle = IO::Async::Handle->new( on_read_ready => sub {}, on_write_ready => sub {}, ); $loop->add( $handle ); my $f = wait_for_future $handle->connect( family => "inet", socktype => "stream", host => $listensock->sockhost, service => $listensock->sockport, ); $f->is_failed and $f->get; ok( defined $handle->read_handle, '$handle->read_handle defined after ->connect host/service' ); is( $handle->read_handle->peerport, $listensock->sockport, '$handle->read_handle->peerport after ->connect host/service' ); $listensock->accept; # drop it $loop->remove( $handle ); } done_testing; IO-Async-0.804/t/64handle-bind.t000444001750001750 155015001742754 14742 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use IO::Async::Loop; use IO::Async::Handle; use constant HAVE_IO_SOCKET_IP => eval { require IO::Socket::IP }; my $loop = IO::Async::Loop->new_builtin; testing_loop( $loop ); # ->bind a UDP service { my $recv_count; my $receiver = IO::Async::Handle->new( on_read_ready => sub { $recv_count++ }, on_write_ready => sub { }, ); $loop->add( $receiver ); $receiver->bind( service => "0", socktype => "dgram", # If we don't have IO::Socket::IP then force 'inet' so we don't get a # PF_INET6 that's then wrapped in a plain IO::Socket instance which # lacks ->sockport ( HAVE_IO_SOCKET_IP ? () : ( family => "inet" ) ), )->get; ok( $receiver->read_handle->sockport, '$receiver bound to a read handle' ); } done_testing; IO-Async-0.804/t/70future-io.t000444001750001750 272515001742754 14516 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use IO::Async::Test; use Test2::V0; use Test::Future::IO::Impl; use lib "."; use t::TimeAbout; use IO::Async::Loop; use IO::Async::OS; use Errno; eval { require Future::IO; require Future::IO::ImplBase } or plan skip_all => "Future::IO is not available"; require Future::IO::Impl::IOAsync; use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1; testing_loop( IO::Async::Loop->new_builtin ); # ->sleep { my $f = Future::IO->sleep( 2 * AUT ); time_about( sub { wait_for_future $f }, 2, 'Future::IO->sleep' ); } # ->sysread { my ( $rd, $wr ) = IO::Async::OS->pipepair or die "Cannot pipe() - $!"; $rd->blocking( 0 ); $wr->autoflush(); $wr->print( "Some bytes\n" ); my $f = Future::IO->sysread( $rd, 256 ); is( ( wait_for_future $f )->get, "Some bytes\n", 'Future::IO->sysread' ); } # ->syswrite { my ( $rd, $wr ) = IO::Async::OS->pipepair or die "Cannot pipe() - $!"; $wr->blocking( 0 ); $wr->autoflush(); 1 while $wr->syswrite( "X" x 4096 ); # This will eventually return undef/EAGAIN $! == Errno::EAGAIN or $! == Errno::EWOULDBLOCK or die "Expected EAGAIN, got $!"; my $f = Future::IO->syswrite( $wr, "ABCD" ); $rd->sysread( my $buf, 4096 ); is( ( wait_for_future $f )->get, 4, 'Future::IO->syswrite' ); 1 while $rd->sysread( $buf, 4096 ) == 4096; is( $buf, "ABCD", 'Future::IO->syswrite wrote data' ); } run_tests qw( sleep sysread syswrite waitpid ); done_testing; IO-Async-0.804/t/99pod.t000444001750001750 25515001742754 13350 0ustar00leoleo000000000000#!/usr/bin/perl use v5.14; use warnings; use Test2::V0; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); IO-Async-0.804/t/RoutineTester.pm000444001750001750 31715001742754 15370 0ustar00leoleo000000000000package t::RoutineTester; use v5.14; use warnings; sub test_routine { my ( $in, $out ) = @_; while( my $ref = $in->recv ) { my $value = $$ref; $out->send( \ uc $value ); } } 0x55AA; IO-Async-0.804/t/StupidLoop.pm000444001750001750 17215001742754 14655 0ustar00leoleo000000000000package t::StupidLoop; use v5.14; use warnings; use base qw( IO::Async::Loop ); sub new { return bless {}, shift; } 1; IO-Async-0.804/t/TimeAbout.pm000444001750001750 151515001742754 14466 0ustar00leoleo000000000000package t::TimeAbout; use v5.14; use warnings; use Test2::V0; use Time::HiRes qw( time ); use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1; use Exporter 'import'; our @EXPORT = qw( time_about ); # Kindof like Test::Timer only we use Time::HiRes # We'll be quite lenient on the time taken, in case of heavy test machine load sub time_about { my ( $code, $target, $name ) = @_; my $lower = $target*0.75; my $upper = $target*1.5 + 1; my $now = time; $code->(); my $took = (time - $now) / AUT; cmp_ok( $took, '>', $lower, "$name took at least $lower" ); cmp_ok( $took, '<', $upper * 3, "$name took no more than $upper" ); if( $took > $upper and $took <= $upper * 3 ) { diag( "$name took longer than $upper - this may just be an indication of a busy testing machine rather than a bug" ); } } 0x55AA;