diff options
| author | Lorry Tar Creator <lorry-tar-importer@lorry> | 2015-06-01 14:15:30 +0000 |
|---|---|---|
| committer | Lorry Tar Creator <lorry-tar-importer@lorry> | 2015-06-01 14:15:30 +0000 |
| commit | 1425eea04dd872dc6313f5315f317b2de288037c (patch) | |
| tree | f81c74f75429e829714029850f89ee4c7f13aa39 | |
| download | IO-Async-tarball-master.tar.gz | |
IO-Async-0.67HEADIO-Async-0.67master
113 files changed, 28618 insertions, 0 deletions
diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..ddb9c7a --- /dev/null +++ b/Build.PL @@ -0,0 +1,50 @@ +use strict; +use warnings; + +use Module::Build; + +my $build = Module::Build->new( + module_name => 'IO::Async', + requires => { + 'Future' => '0.26', # ->is_failed + 'Future::Utils' => '0.18', # try_repeat + 'Exporter' => '5.57', + 'File::stat' => 0, + 'IO::Poll' => 0, + 'Socket' => '2.007', + 'Storable' => 0, + 'Struct::Dumb' => 0, + 'Time::HiRes' => 0, + + # Fails on perl 5.8.3 for unknown reasons + # https://rt.cpan.org/Ticket/Display.html?id=64493 + # Now 5.16 is stable, I see even less reason to worry about such an old Perl + + # Furthermore we've started using 5.10'isms + 'perl' => '5.010', + }, + recommends => { + 'IO::Socket::IP' => 0, + }, + test_requires => { + 'File::Temp' => 0, + 'Test::Fatal' => 0, + 'Test::Identity' => 0, + 'Test::More' => '0.88', + 'Test::Refcount' => 0, + }, + configure_requires => { + 'Module::Build' => '0.4004', # test_requires + }, + license => 'perl', + create_makefile_pl => 'traditional', + create_license => 1, + create_readme => 1, + meta_merge => { + resources => { + x_IRC => "irc://irc.perl.org/#io-async", + }, + }, +); + +$build->create_build_script; @@ -0,0 +1,844 @@ +Revision history for IO-Async + +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. + @@ -0,0 +1,379 @@ +This software is copyright (c) 2015 by Paul Evans <leonerd@leonerd.org.uk>. + +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) 2015 by Paul Evans <leonerd@leonerd.org.uk>. + +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. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) 19yy <name of author> + + 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. + + <signature of Ty Coon>, 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! + + +--- The Artistic License 1.0 --- + +This software is Copyright (c) 2015 by Paul Evans <leonerd@leonerd.org.uk>. + +This is free software, licensed under: + + The 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. + - "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 ftp.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) accompany any non-standard executables with their corresponding Standard + Version executables, giving the non-standard executables non-standard + names, and clearly documenting 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. + +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 whomever generated them, and may be sold +commercially, and may be aggregated with this Package. + +7. C or perl subroutines supplied by you and linked into this Package shall not +be considered part of this Package. + +8. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF +MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + +The End + diff --git a/MANIFEST b/MANIFEST new file mode 100644 index 0000000..6c6c035 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,113 @@ +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/IO/Async.pm +lib/IO/Async/Channel.pm +lib/IO/Async/ChildManager.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/Connector.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/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 +Makefile.PL +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-child.t +t/14loop-select-child.t +t/15loop-poll-control.t +t/15loop-select-control.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-openchild.t +t/36loop-runchild.t +t/37loop-child-root.t +t/38loop-thread.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/99pod.t +t/StupidLoop.pm +t/TimeAbout.pm diff --git a/META.json b/META.json new file mode 100644 index 0000000..77300d3 --- /dev/null +++ b/META.json @@ -0,0 +1,195 @@ +{ + "abstract" : "Asynchronous event-driven programming", + "author" : [ + "Paul Evans <leonerd@leonerd.org.uk>" + ], + "dynamic_config" : 1, + "generated_by" : "Module::Build version 0.421", + "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.26", + "Future::Utils" : "0.18", + "IO::Poll" : "0", + "Socket" : "2.007", + "Storable" : "0", + "Struct::Dumb" : "0", + "Time::HiRes" : "0", + "perl" : "5.010" + } + }, + "test" : { + "requires" : { + "File::Temp" : "0", + "Test::Fatal" : "0", + "Test::Identity" : "0", + "Test::More" : "0.88", + "Test::Refcount" : "0" + } + } + }, + "provides" : { + "IO::Async" : { + "file" : "lib/IO/Async.pm", + "version" : "0.67" + }, + "IO::Async::Channel" : { + "file" : "lib/IO/Async/Channel.pm", + "version" : "0.67" + }, + "IO::Async::ChildManager" : { + "file" : "lib/IO/Async/ChildManager.pm", + "version" : "0.67" + }, + "IO::Async::Debug" : { + "file" : "lib/IO/Async/Debug.pm", + "version" : "0.67" + }, + "IO::Async::File" : { + "file" : "lib/IO/Async/File.pm", + "version" : "0.67" + }, + "IO::Async::FileStream" : { + "file" : "lib/IO/Async/FileStream.pm", + "version" : "0.67" + }, + "IO::Async::Function" : { + "file" : "lib/IO/Async/Function.pm", + "version" : "0.67" + }, + "IO::Async::Future" : { + "file" : "lib/IO/Async/Future.pm", + "version" : "0.67" + }, + "IO::Async::Handle" : { + "file" : "lib/IO/Async/Handle.pm", + "version" : "0.67" + }, + "IO::Async::Listener" : { + "file" : "lib/IO/Async/Listener.pm", + "version" : "0.67" + }, + "IO::Async::Loop" : { + "file" : "lib/IO/Async/Loop.pm", + "version" : "0.67" + }, + "IO::Async::Loop::Poll" : { + "file" : "lib/IO/Async/Loop/Poll.pm", + "version" : "0.67" + }, + "IO::Async::Loop::Select" : { + "file" : "lib/IO/Async/Loop/Select.pm", + "version" : "0.67" + }, + "IO::Async::LoopTests" : { + "file" : "lib/IO/Async/LoopTests.pm", + "version" : "0.67" + }, + "IO::Async::Notifier" : { + "file" : "lib/IO/Async/Notifier.pm", + "version" : "0.67" + }, + "IO::Async::OS" : { + "file" : "lib/IO/Async/OS.pm", + "version" : "0.67" + }, + "IO::Async::OS::MSWin32" : { + "file" : "lib/IO/Async/OS/MSWin32.pm", + "version" : "0.67" + }, + "IO::Async::OS::cygwin" : { + "file" : "lib/IO/Async/OS/cygwin.pm", + "version" : "0.67" + }, + "IO::Async::OS::linux" : { + "file" : "lib/IO/Async/OS/linux.pm", + "version" : "0.67" + }, + "IO::Async::PID" : { + "file" : "lib/IO/Async/PID.pm", + "version" : "0.67" + }, + "IO::Async::Process" : { + "file" : "lib/IO/Async/Process.pm", + "version" : "0.67" + }, + "IO::Async::Protocol" : { + "file" : "lib/IO/Async/Protocol.pm", + "version" : "0.67" + }, + "IO::Async::Protocol::LineStream" : { + "file" : "lib/IO/Async/Protocol/LineStream.pm", + "version" : "0.67" + }, + "IO::Async::Protocol::Stream" : { + "file" : "lib/IO/Async/Protocol/Stream.pm", + "version" : "0.67" + }, + "IO::Async::Resolver" : { + "file" : "lib/IO/Async/Resolver.pm", + "version" : "0.67" + }, + "IO::Async::Routine" : { + "file" : "lib/IO/Async/Routine.pm", + "version" : "0.67" + }, + "IO::Async::Signal" : { + "file" : "lib/IO/Async/Signal.pm", + "version" : "0.67" + }, + "IO::Async::Socket" : { + "file" : "lib/IO/Async/Socket.pm", + "version" : "0.67" + }, + "IO::Async::Stream" : { + "file" : "lib/IO/Async/Stream.pm", + "version" : "0.67" + }, + "IO::Async::Test" : { + "file" : "lib/IO/Async/Test.pm", + "version" : "0.67" + }, + "IO::Async::Timer" : { + "file" : "lib/IO/Async/Timer.pm", + "version" : "0.67" + }, + "IO::Async::Timer::Absolute" : { + "file" : "lib/IO/Async/Timer/Absolute.pm", + "version" : "0.67" + }, + "IO::Async::Timer::Countdown" : { + "file" : "lib/IO/Async/Timer/Countdown.pm", + "version" : "0.67" + }, + "IO::Async::Timer::Periodic" : { + "file" : "lib/IO/Async/Timer/Periodic.pm", + "version" : "0.67" + } + }, + "release_status" : "stable", + "resources" : { + "license" : [ + "http://dev.perl.org/licenses/" + ], + "x_IRC" : "irc://irc.perl.org/#io-async" + }, + "version" : "0.67" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..26967a1 --- /dev/null +++ b/META.yml @@ -0,0 +1,139 @@ +--- +abstract: 'Asynchronous event-driven programming' +author: + - 'Paul Evans <leonerd@leonerd.org.uk>' +build_requires: + File::Temp: '0' + Test::Fatal: '0' + Test::Identity: '0' + Test::More: '0.88' + Test::Refcount: '0' +configure_requires: + Module::Build: '0.4004' +dynamic_config: 1 +generated_by: 'Module::Build version 0.421, CPAN::Meta::Converter version 2.142690' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: IO-Async +provides: + IO::Async: + file: lib/IO/Async.pm + version: '0.67' + IO::Async::Channel: + file: lib/IO/Async/Channel.pm + version: '0.67' + IO::Async::ChildManager: + file: lib/IO/Async/ChildManager.pm + version: '0.67' + IO::Async::Debug: + file: lib/IO/Async/Debug.pm + version: '0.67' + IO::Async::File: + file: lib/IO/Async/File.pm + version: '0.67' + IO::Async::FileStream: + file: lib/IO/Async/FileStream.pm + version: '0.67' + IO::Async::Function: + file: lib/IO/Async/Function.pm + version: '0.67' + IO::Async::Future: + file: lib/IO/Async/Future.pm + version: '0.67' + IO::Async::Handle: + file: lib/IO/Async/Handle.pm + version: '0.67' + IO::Async::Listener: + file: lib/IO/Async/Listener.pm + version: '0.67' + IO::Async::Loop: + file: lib/IO/Async/Loop.pm + version: '0.67' + IO::Async::Loop::Poll: + file: lib/IO/Async/Loop/Poll.pm + version: '0.67' + IO::Async::Loop::Select: + file: lib/IO/Async/Loop/Select.pm + version: '0.67' + IO::Async::LoopTests: + file: lib/IO/Async/LoopTests.pm + version: '0.67' + IO::Async::Notifier: + file: lib/IO/Async/Notifier.pm + version: '0.67' + IO::Async::OS: + file: lib/IO/Async/OS.pm + version: '0.67' + IO::Async::OS::MSWin32: + file: lib/IO/Async/OS/MSWin32.pm + version: '0.67' + IO::Async::OS::cygwin: + file: lib/IO/Async/OS/cygwin.pm + version: '0.67' + IO::Async::OS::linux: + file: lib/IO/Async/OS/linux.pm + version: '0.67' + IO::Async::PID: + file: lib/IO/Async/PID.pm + version: '0.67' + IO::Async::Process: + file: lib/IO/Async/Process.pm + version: '0.67' + IO::Async::Protocol: + file: lib/IO/Async/Protocol.pm + version: '0.67' + IO::Async::Protocol::LineStream: + file: lib/IO/Async/Protocol/LineStream.pm + version: '0.67' + IO::Async::Protocol::Stream: + file: lib/IO/Async/Protocol/Stream.pm + version: '0.67' + IO::Async::Resolver: + file: lib/IO/Async/Resolver.pm + version: '0.67' + IO::Async::Routine: + file: lib/IO/Async/Routine.pm + version: '0.67' + IO::Async::Signal: + file: lib/IO/Async/Signal.pm + version: '0.67' + IO::Async::Socket: + file: lib/IO/Async/Socket.pm + version: '0.67' + IO::Async::Stream: + file: lib/IO/Async/Stream.pm + version: '0.67' + IO::Async::Test: + file: lib/IO/Async/Test.pm + version: '0.67' + IO::Async::Timer: + file: lib/IO/Async/Timer.pm + version: '0.67' + IO::Async::Timer::Absolute: + file: lib/IO/Async/Timer/Absolute.pm + version: '0.67' + IO::Async::Timer::Countdown: + file: lib/IO/Async/Timer/Countdown.pm + version: '0.67' + IO::Async::Timer::Periodic: + file: lib/IO/Async/Timer/Periodic.pm + version: '0.67' +recommends: + IO::Socket::IP: '0' +requires: + Exporter: '5.57' + File::stat: '0' + Future: '0.26' + Future::Utils: '0.18' + IO::Poll: '0' + Socket: '2.007' + Storable: '0' + Struct::Dumb: '0' + Time::HiRes: '0' + perl: '5.010' +resources: + IRC: irc://irc.perl.org/#io-async + license: http://dev.perl.org/licenses/ +version: '0.67' diff --git a/Makefile.PL b/Makefile.PL new file mode 100644 index 0000000..8275873 --- /dev/null +++ b/Makefile.PL @@ -0,0 +1,23 @@ +# Note: this file was auto-generated by Module::Build::Compat version 0.4210 +require 5.010; +use ExtUtils::MakeMaker; +WriteMakefile +( + 'NAME' => 'IO::Async', + 'VERSION_FROM' => 'lib/IO/Async.pm', + 'PREREQ_PM' => { + 'Exporter' => '5.57', + 'File::stat' => 0, + 'Future' => '0.26', + 'Future::Utils' => '0.18', + 'IO::Poll' => 0, + 'Socket' => '2.007', + 'Storable' => 0, + 'Struct::Dumb' => 0, + 'Time::HiRes' => 0 + }, + 'INSTALLDIRS' => 'site', + 'EXE_FILES' => [], + 'PL_FILES' => {} +) +; @@ -0,0 +1,278 @@ +NAME + `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 <leonerd@leonerd.org.uk> + diff --git a/examples/chat-server.pl b/examples/chat-server.pl new file mode 100644 index 0000000..00522e1 --- /dev/null +++ b/examples/chat-server.pl @@ -0,0 +1,71 @@ +#!/usr/bin/perl + +use strict; +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; +} diff --git a/examples/echo-server.pl b/examples/echo-server.pl new file mode 100644 index 0000000..a63f516 --- /dev/null +++ b/examples/echo-server.pl @@ -0,0 +1,69 @@ +#!/usr/bin/perl + +use strict; +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; diff --git a/examples/netcat-client.pl b/examples/netcat-client.pl new file mode 100644 index 0000000..8926131 --- /dev/null +++ b/examples/netcat-client.pl @@ -0,0 +1,68 @@ +#!/usr/bin/perl + +use strict; +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 ); diff --git a/examples/readwrite-futures.pl b/examples/readwrite-futures.pl new file mode 100644 index 0000000..9ab73b2 --- /dev/null +++ b/examples/readwrite-futures.pl @@ -0,0 +1,17 @@ +#!/usr/bin/perl + +use strict; +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; diff --git a/examples/tail-logfile.pl b/examples/tail-logfile.pl new file mode 100644 index 0000000..1f7d6eb --- /dev/null +++ b/examples/tail-logfile.pl @@ -0,0 +1,32 @@ +#!/usr/bin/perl + +use strict; +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; diff --git a/examples/tcp-proxy.pl b/examples/tcp-proxy.pl new file mode 100644 index 0000000..51bd44a --- /dev/null +++ b/examples/tcp-proxy.pl @@ -0,0 +1,81 @@ +#!/usr/bin/perl + +use strict; +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"; }, + ); +} diff --git a/examples/whoami-server.pl b/examples/whoami-server.pl new file mode 100644 index 0000000..f11f8ea --- /dev/null +++ b/examples/whoami-server.pl @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use strict; +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; diff --git a/lib/IO/Async.pm b/lib/IO/Async.pm new file mode 100644 index 0000000..bc2d196 --- /dev/null +++ b/lib/IO/Async.pm @@ -0,0 +1,366 @@ +# 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-2013 -- leonerd@leonerd.org.uk + +package IO::Async; + +use strict; +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 + +our $VERSION = '0.67'; + +=head1 NAME + +C<IO::Async> - 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<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. + +=head2 Notifiers + +The base class of all the event handling subclasses is L<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. + +=head2 File Handle IO + +An L<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 L<IO::Socket::INET> connection), it is possible +to have separate reading and writing handles (most likely for a program's +C<STDIN> and C<STDOUT> streams, or a pair of pipes connected to a child +process). + +The L<IO::Async::Stream> class is a subclass of L<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 C<IO::Async::Stream>, +datagram or raw sockets do not provide a bytestream. For these, the +L<IO::Async::Socket> class is another subclass of L<IO::Async::Handle> which +maintains an outgoing packet queue, and informs of packet receipt using a +callback or method. + +The L<IO::Async::Listener> class is another subclass of L<IO::Async::Handle> +which facilitates the use of C<listen(2)>-mode sockets. When a new connection +is available on the socket it will C<accept(2)> it and pass the new client +socket to its callback function. + +=head2 Timers + +An L<IO::Async::Timer::Absolute> object represents a timer that expires at a +given absolute time in the future. + +An L<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 L<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 L<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. + +=head2 Signals + +An L<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. + +=head2 Processes Management + +An L<IO::Async::PID> object invokes its event when a given child process +exits. An L<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. + +=head2 Loops + +The L<IO::Async::Loop> object class represents an abstract collection of +L<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. + +L<IO::Async::Loop::Poll> uses an L<IO::Poll> object for this test. + +L<IO::Async::Loop::Select> uses the C<select(2)> syscall. + +Other subclasses of loop may appear on CPAN under their own dists; see the +L</SEE ALSO> section below for more detail. + +As well as these general-purpose classes, the L<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. + +=head2 Child Processes + +The L<IO::Async::Loop> object provides a number of methods to facilitate the +running of child processes. C<spawn_child> is primarily a wrapper around the +typical C<fork(2)>/C<exec(2)> style of starting child processes, and +C<run_child> provide a method similar to perl's C<readpipe> (which is used +to implement backticks C<``>). + +=head2 File Change Watches + +The L<IO::Async::File> object observes changes to C<stat(2)> properties of a +file, directory, or other filesystem object. It invokes callbacks when +properties change. This is used by L<IO::Async::FileStream> which presents +the same events as a C<IO::Async::Stream> but operates on a regular file on +the filesystem, observing it for updates. + +=head2 Asynchronous Co-routines and Functions + +The C<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: + +=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<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 L<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 +L<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. + +=head2 Futures + +An L<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 C<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 C<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 C<fail> arguments to relate it to the legacy C<on_error>-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<NAME> 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<IO::Async::Loop> provides several methods for performing network-based +tasks. Primarily, the C<connect> and C<listen> methods allow the creation of +client or server network sockets. Additionally, the C<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. + +=head2 Protocols + +The L<IO::Async::Protocol> class provides storage for a L<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 L<IO::Async::Protocol::Stream> 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<ports>, BSD's I<Kevents> and anything that +might be useful on Win32. + +=item * + +Consider some form of persistent object wrapper in the form of an +C<IO::Async::Object>, based on C<IO::Async::Routine>. + +=item * + +C<IO::Async::Protocol::Datagram> + +=item * + +Support for watching filesystem entries for change. Extract logic from +C<IO::Async::File> and define a Loop watch/unwatch method pair. + +=item * + +Define more C<Future>-returning methods. Consider also one-shot Futures on +things like C<IO::Async::Process> exits, or C<IO::Async::Handle> 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<irc.perl.org> 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<IO::Async::Loop::AnyEvent> - use IO::Async with AnyEvent + +=item * + +L<IO::Async::Loop::Epoll> - use IO::Async with epoll on Linux + +=item * + +L<IO::Async::Loop::Event> - use IO::Async with Event + +=item * + +L<IO::Async::Loop::EV> - use IO::Async with EV + +=item * + +L<IO::Async::Loop::Glib> - use IO::Async with Glib or GTK + +=item * + +L<IO::Async::Loop::KQueue> - use IO::Async with kqueue + +=item * + +L<IO::Async::Loop::Mojo> - use IO::Async with Mojolicious + +=item * + +L<IO::Async::Loop::POE> - use IO::Async with POE + +=item * + +L<IO::Async::Loop::Ppoll> - use IO::Async with ppoll(2) + +=back + +Additionally, some other event loops or modules also support being run on top +of C<IO::Async>: + +=over 4 + +=item * + +L<AnyEvent::Impl::IOAsync> - AnyEvent adapter for IO::Async + +=item * + +L<Gungho::Engine::IO::Async> - IO::Async Engine + +=item * + +L<POE::Loop::IO_Async> - IO::Async event loop support for POE + +=back + +=cut + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Channel.pm b/lib/IO/Async/Channel.pm new file mode 100644 index 0000000..6e638f9 --- /dev/null +++ b/lib/IO/Async/Channel.pm @@ -0,0 +1,471 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Channel; + +use strict; +use warnings; +use base qw( IO::Async::Notifier ); + +our $VERSION = '0.67'; + +use Carp; + +use IO::Async::Stream; + +=head1 NAME + +C<IO::Async::Channel> - pass values into or out from an L<IO::Async::Routine> + +=head1 DESCRIPTION + +A C<IO::Async::Channel> object allows Perl values to be passed into or out of +an L<IO::Async::Routine>. 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<IO::Async::Routine>. + +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 +C<IO::Async>-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<send> method in either mode. Values may be +retrieved from it by the C<recv> method. Values inserted into the Channel are +snapshot by the C<send> method. Any changes to referred variables will not be +observed by the other end of the Channel after the C<send> method returns. + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 codec => STR + +Gives the name of the encoding method used to represent values over the +channel. + +By default this will be C<Storable>, to use the core L<Storable> module. As +this only supports references, to pass a single scalar value, C<send> a SCALAR +reference to it, and dereference the result of C<recv>. + +If the L<Sereal::Encoder> and L<Sereal::Decoder> modules are installed, this +can be set to C<Sereal> instead, and will use those to perform the encoding +and decoding. This optional dependency may give higher performance than using +C<Storable>. + +=cut + +=head1 CONSTRUCTOR + +=cut + +=head2 $channel = IO::Async::Channel->new + +Returns a new C<IO::Async::Channel> object. This object reference itself +should be shared by both sides of a C<fork()>ed process. After C<fork()> the +two C<setup_*> methods may be used to configure the object for operation on +either end. + +While this object does in fact inherit from L<IO::Async::Notifier>, it should +not be added to a Loop object directly; event management will be handled by +its containing C<IO::Async::Routine> object. + +=cut + +=head1 METHODS + +The following methods documented with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +=head2 $channel->configure( %params ) + +Similar to the standard C<configure> method on C<IO::Async::Notifier>, 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<recv> 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 + +sub _init +{ + my $self = shift; + my ( $params ) = @_; + + $params->{codec} //= "Storable"; + + $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->can( "_make_codec_$codec" ) or croak "Unrecognised codec name '$codec'" ) + ->( $self ); + } + + $self->SUPER::configure( %params ); +} + +sub _make_codec_Storable +{ + my $self = shift; + + require Storable; + + $self->{encode} = \&Storable::freeze; + $self->{decode} = \&Storable::thaw; +} + +sub _make_codec_Sereal +{ + my $self = shift; + + require Sereal::Encoder; + require Sereal::Decoder; + + my $encoder = Sereal::Encoder->new; + $self->{encode} = sub { $encoder->encode( $_[0] ) }; + + my $decoder = Sereal::Decoder->new; + $self->{decode} = sub { $decoder->decode( $_[0] ) }; +} + +=head2 $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<write()> call on the +underlying filehandle blocks. When called on an asynchronous mode channel this +method will not block. + +=cut + +sub send +{ + my $self = shift; + my ( $data ) = @_; + + $self->send_frozen( $self->{encode}->( $data ) ); +} + +=head2 $channel->send_frozen( $record ) + +A variant of the C<send> method; this method pushes the byte record given. +This should be the result of a call to C<Storable::freeze()>. + +=cut + +sub send_frozen +{ + 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->_send_sync( $bytes ) if $self->{mode} eq "sync"; + return $self->_send_async( $bytes ) if $self->{mode} eq "async"; +} + +=head2 $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<undef>. 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. + +=head2 $data = $channel->recv->get + +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<eof> failure. + +=head2 $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 + +sub recv +{ + my $self = shift; + + defined $self->{mode} or die "Cannot ->recv without being set up"; + + return $self->_recv_sync( @_ ) if $self->{mode} eq "sync"; + return $self->_recv_async( @_ ) if $self->{mode} eq "async"; +} + +=head2 $channel->close + +Closes the channel. Causes a pending C<recv> on the other end to return undef +or the queued C<on_eof> callbacks to be invoked. + +=cut + +sub close +{ + my $self = shift; + + return $self->_close_sync if $self->{mode} eq "sync"; + return $self->_close_async if $self->{mode} eq "async"; +} + +# 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}; + + $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 _send_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 ); + + $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 _send_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 <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/ChildManager.pm b/lib/IO/Async/ChildManager.pm new file mode 100644 index 0000000..48ac108 --- /dev/null +++ b/lib/IO/Async/ChildManager.pm @@ -0,0 +1,705 @@ +# 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-2014 -- leonerd@leonerd.org.uk + +package IO::Async::ChildManager; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +# 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 ) ); + +=head1 NAME + +C<IO::Async::ChildManager> - facilitates the execution of child processes + +=head1 SYNOPSIS + +This object is used indirectly via an C<IO::Async::Loop>: + + use IO::Async::Loop; + + my $loop = IO::Async::Loop->new; + + ... + + $loop->run_child( + command => "/bin/ps", + + on_finish => sub { + my ( $pid, $exitcode, $stdout, $stderr ) = @_; + my $status = ( $exitcode >> 8 ); + print "ps [PID $pid] exited with status $status\n"; + }, + ); + + $loop->open_child( + 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 ( $pid, $exitcode ) = @_; + my $status = ( $exitcode >> 8 ); + ... + }, + ); + + 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"; + }, + ); + +=head1 DESCRIPTION + +This module extends the functionality of the containing C<IO::Async::Loop> to +manage the execution of child processes. It acts as a central point to store +PID values of currently-running children, and to call the appropriate +continuation handler code when the process terminates. It provides useful +wrapper methods that set up filehandles and other child process details, and +to capture the child process's STDOUT and STDERR streams. + +=cut + +# 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; +} + +=head1 METHODS + +When active, the following methods are available on the containing C<Loop> +object. + +=cut + +=head2 $pid = $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<exec> function. + +=item code => CODE + +A block of code to execute in the child process. It will be called in scalar +context inside an C<eval> 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<command> or C<code> keys must be specified. + +If the C<command> key is used, the given array or string is executed using the +C<exec> function. + +If the C<code> key is used, the return value will be used as the C<exit(2)> +code from the child if it returns (or 255 if it returned C<undef> 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<open_child> method in simple cases +where an external program is being started in order to interact with it via +file IO, or even C<run_child> when only the final result is required, rather +than interaction while it is running. + +=cut + +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() - $!"; + } + + 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 ); +} + +=head2 C<setup> array + +This array gives a list of file descriptor operations to perform in the child +process after it has been C<fork(2)>ed 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<n> => ARRAY + +Gives an operation on file descriptor I<n>. 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 C<dup2(2)>ed 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<open> 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<close> and C<keep> +operations). + +=item IO => ARRAY + +Shortcut for passing C<fdI<n>>, where I<n> is the fileno of the IO +reference. In this case, the key must be a reference that implements the +C<fileno> method. This is mostly useful for + + $handle => 'keep' + +=item fdI<n> => IO + +A shortcut for the C<dup> case given above. + +=item stdin => ... + +=item stdout => ... + +=item stderr => ... + +Shortcuts for C<fd0>, C<fd1> and C<fd2> 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<POSIX::nice>. + +=item chdir => STRING + +Change the child process's working directory using C<chdir>. + +=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. +C<IO::Async> will B<NOT> 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<stdin>, C<stdout> and C<stderr> are +given, a default of C<keep> is implied. All other file descriptors will be +closed, unless a C<keep> operation is given for them. + +If C<setuid> is used, be sure to place it after any other operations that +might require superuser privileges, such as C<setgid> or opening special +files. + +=cut + +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_child( $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; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Debug.pm b/lib/IO/Async/Debug.pm new file mode 100644 index 0000000..b23db0e --- /dev/null +++ b/lib/IO/Async/Debug.pm @@ -0,0 +1,98 @@ +# 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 -- leonerd@leonerd.org.uk + +package IO::Async::Debug; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +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<IO::Async::Debug> - debugging control and support for L<IO::Async> + +=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<IO_ASYNC_DEBUG> having a true value. + +When debugging is enabled, the C<make_event_cb> and C<invoke_event> methods +on L<IO::Async::Notifier> (and their C<maybe_> variants) are altered such that +when the event is fired, a debugging line is printed, using the C<debug_printf> +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<IO_ASYNC_DEBUG>. + +By default the debugging log goes to C<STDERR>, but two other environment +variables can redirect it. If C<IO_ASYNC_DEBUG_FILE> is set, it names a file +which will be opened for writing, and logging written into it. Otherwise, if +C<IO_ASYNC_DEBUG_FD> 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<STDERR> as normal. + +Extra debugging flags can be set in a comma-separated list in an environment +variable called C<IO_ASYNC_DEBUG_FLAGS>. 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 <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/File.pm b/lib/IO/Async/File.pm new file mode 100644 index 0000000..cbb3604 --- /dev/null +++ b/lib/IO/Async/File.pm @@ -0,0 +1,219 @@ +# 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 -- leonerd@leonerd.org.uk + +package IO::Async::File; + +use 5.010; # // +use strict; +use warnings; + +our $VERSION = '0.67'; + +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<IO::Async::File> - 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<IO::Async::Notifier> watches an open filehandle or named +filesystem entity for changes in its C<stat()> 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<IO::Async::FileStream>. + +While called "File", it is not required that the watched filehandle be a +regular file. It is possible to watch anything that C<stat(2)> 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<stat()> fields have changed. All the +C<stat()> fields are supported apart from C<blocks> and C<blksize>. 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<dev> or C<ino> fields have changed. It is passed +two L<File::stat> instances containing the complete old and new C<stat()> +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<stat()> fields have changed. It is passed two +L<File::stat> instances containing the old and new C<stat()> fields. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>. + +=head2 handle => IO + +The opened filehandle to watch for C<stat()> changes if C<filename> is not +supplied. + +=head2 filename => STRING + +Optional. If supplied, watches the named file rather than the filehandle given +in C<handle>. 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<stat(2)> +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( $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 = $file->handle + +Returns the filehandle currently associated with the instance; either the one +passed to the C<handle> parameter, or opened from the C<filename> parameter. + +=cut + +sub handle +{ + my $self = shift; + return $self->{handle}; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/FileStream.pm b/lib/IO/Async/FileStream.pm new file mode 100644 index 0000000..96778c9 --- /dev/null +++ b/lib/IO/Async/FileStream.pm @@ -0,0 +1,413 @@ +# 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-2012 -- leonerd@leonerd.org.uk + +package IO::Async::FileStream; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Stream ); + +use IO::Async::File; + +use Carp; +use Fcntl qw( SEEK_SET SEEK_CUR ); + +=head1 NAME + +C<IO::Async::FileStream> - 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<IO::Async::Stream> allows reading the end of a regular file +which is being appended to by some other process. It invokes the C<on_read> +event when more data has been added to the file. + +This class provides an API identical to C<IO::Async::Stream> when given a +C<read_handle>; it should be treated similarly. In particular, it can be given +an C<on_read> handler, or subclassed to provide an C<on_read> method, or even +used as the C<transport> for an C<IO::Async::Protocol::Stream> object. + +It will not support writing. + +To watch a file, directory, or other filesystem entity for updates of other +properties, such as C<mtime>, see also L<IO::Async::File>. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters. + +Because this is a subclass of L<IO::Async::Stream> in read-only mode, all the +events supported by C<Stream> relating to the read handle are supported here. +This is not a full list; see also the documentation relating to +C<IO::Async::Stream>. + +=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 C<IO::Async::Stream>, 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<seek> or +C<seek_to_last> 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<new> or C<configure>, in +addition to the parameters relating to reading supported by +C<IO::Async::Stream>. + +=head2 filename => STRING + +Optional. If supplied, watches the named file rather than the filehandle given +in C<read_handle>. 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<stat(2)> +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 $filestream->seek( $offset, $whence ) + +Callable only during the C<on_initial> event. Moves the read position in the +filehandle to the given offset. C<$whence> is interpreted as for C<sysseek>, +should be either C<SEEK_SET>, C<SEEK_CUR> or C<SEEK_END>. Will be set to +C<SEEK_SET> 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"; + + defined $whence or $whence = SEEK_SET; + + sysseek( $self->read_handle, $offset, $whence ); +} + +=head2 $success = $filestream->seek_to_last( $str_pattern, %opts ) + +Callable only during the C<on_initial> event. Attempts to move the read +position in the filehandle to just after the last occurance 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<blocksize> 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; + + defined $opts{horizon} or $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 C<IO::Async::Loop>, possibly as +a new watch/unwatch method pair C<watch_file>. + +=item * + +Consider if a construction-time parameter of C<seek_to_end> or C<seek_to_last> +might be neater than a small code block in C<on_initial>, if that turns out to +be the only or most common form of use. + +=back + +=cut + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Function.pm b/lib/IO/Async/Function.pm new file mode 100644 index 0000000..adaf396 --- /dev/null +++ b/lib/IO/Async/Function.pm @@ -0,0 +1,667 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Function; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Notifier ); +use IO::Async::Timer::Countdown; + +use Carp; + +use Storable qw( freeze ); + +=head1 NAME + +C<IO::Async::Function> - call a function asynchronously + +=head1 SYNOPSIS + + 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 ); + + $function->call( + args => [ 123454321 ], + )->on_done( sub { + my $isprime = shift; + print "123454321 " . ( $isprime ? "is" : "is not" ) . " a prime number\n"; + })->on_fail( sub { + print STDERR "Cannot determine if it's prime - $_[0]\n"; + })->get; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Notifier> 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<call> 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<IO::Async::Routine> with two +L<IO::Async::Channel> objects to pass calls into and results out from it. + +The C<IO::Async> 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<is_prime> test in the example in the C<SYNOPSIS>). + +=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 +C<IO::Async::Resolver>. + +=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<IO::Async::Routine>. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 code => CODE + +The body of the function to execute. + +=head2 model => "fork" | "thread" + +Optional. Requests a specific C<IO::Async::Routine> 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<min_workers> of them. + +=head2 exit_on_die => BOOL + +Optional boolean, controls what happens after the C<code> 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<call> method to replace it, if necessary. + +=head2 setup => ARRAY + +Optional array reference. Specifies the C<setup> key to pass to the underlying +L<IO::Async::Process> 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( code setup )) { + $need_restart++, $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + $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 with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +=head2 $function->start + +Start the worker processes + +=cut + +sub start +{ + my $self = shift; + + $self->_new_worker for 1 .. $self->{min_workers}; +} + +=head2 $function->stop + +Stop the worker processes + +=cut + +sub stop +{ + my $self = shift; + + $self->{stopping} = 1; + foreach my $worker ( $self->_worker_objects ) { + $worker->stop; + } +} + +=head2 $function->restart + +Gracefully stop and restart all the worker processes. + +=cut + +sub restart +{ + my $self = shift; + + $self->stop; + $self->start; +} + +=head2 @result = $function->call( %params )->get + +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. + +=back + +=head2 $function->call( %params ) + +When not returning a future, the C<on_result>, C<on_return> and C<on_error> +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 occured 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<on_result>. 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 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 = $self->_capture_weakself( sub { + my $self = shift or return; + $self->debug_printf( "CONT on_result return" ); + $on_result->( return => @_ ); + } ); + $on_fail = $self->_capture_weakself( sub { + my $self = shift or return; + my ( $err, @values ) = @_; + $self->debug_printf( "CONT on_result error" ); + $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 = $self->_capture_weakself( sub { + my $self = shift or return; + $self->debug_printf( "CONT on_return" ); + $on_return->( @_ ); + } ); + $on_fail = $self->_capture_weakself( sub { + my $self = shift or return; + $self->debug_printf( "CONT on_error" ); + $on_error->( @_ ); + } ); + } + elsif( !defined wantarray ) { + croak "Expected either 'on_result' or 'on_return' and 'on_error' keys, or to return a Future"; + } + + my $request = freeze( $args ); + + my $future; + if( my $worker = $self->_get_worker ) { + $self->debug_printf( "CALL" ); + $future = $self->_call_worker( $worker, $request ); + } + else { + $self->debug_printf( "QUEUE" ); + push @{ $self->{pending_queue} }, my $wait_f = $self->loop->new_future; + + $future = $wait_f->then( sub { + my ( $self, $worker ) = @_; + $self->_call_worker( $worker, $request ); + }); + } + + $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 $count = $function->workers + +Returns the total number of worker processes available + +=cut + +sub workers +{ + my $self = shift; + return scalar keys %{ $self->{workers} }; +} + +=head2 $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 $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 code 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; + + next if $next->is_cancelled; + + $self->debug_printf( "UNQUEUE" ); + $next->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 IO::Async::Channel; + +sub new +{ + my $class = shift; + my %params = @_; + + my $arg_channel = IO::Async::Channel->new; + my $ret_channel = IO::Async::Channel->new; + + my $code = delete $params{code}; + $params{code} = sub { + while( my $args = $arg_channel->recv ) { + my @ret; + my $ok = eval { @ret = $code->( @$args ); 1 }; + + if( $ok ) { + $ret_channel->send( [ r => @ret ] ); + } + else { + chomp( my $e = "$@" ); + $ret_channel->send( [ e => $e, error => ] ); + } + } + }; + + my $worker = $class->SUPER::new( + %params, + channels_in => [ $arg_channel ], + channels_out => [ $ret_channel ], + ); + + $worker->{arg_channel} = $arg_channel; + $worker->{ret_channel} = $ret_channel; + + return $worker; +} + +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; + + if( my $function = $worker->parent ) { + delete $function->{workers}{$worker->id}; + + if( $worker->{busy} ) { + $worker->{remove_on_idle}++; + } + else { + $function->remove_child( $worker ); + } + } +} + +sub call +{ + my $worker = shift; + my ( $args ) = @_; + + $worker->{arg_channel}->send_frozen( $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 NOTES + +For the record, 123454321 is 11111 * 11111, a square number, and therefore not +prime. + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Future.pm b/lib/IO/Async/Future.pm new file mode 100644 index 0000000..5bf8395 --- /dev/null +++ b/lib/IO/Async/Future.pm @@ -0,0 +1,150 @@ +# 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 -- leonerd@leonerd.org.uk + +package IO::Async::Future; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( Future ); +Future->VERSION( '0.05' ); # to respect subclassing + +use Carp; + +=head1 NAME + +C<IO::Async::Future> - use L<Future> with L<IO::Async> + +=head1 SYNOPSIS + + 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 $future->get, "\n"; + +=head1 DESCRIPTION + +This subclass of L<Future> stores a reference to the L<IO::Async::Loop> +instance that created it, allowing the C<await> method to block until the +Future is ready. These objects should not be constructed directly; instead +the C<new_future> method on the containing Loop should be used. + +For a full description on how to use Futures, see the L<Future> documentation. + +=cut + +=head1 CONSTRUCTORS + +New C<IO::Async::Future> objects should be constructed by using the following +methods on the C<Loop>. For more detail see the L<IO::Async::Loop> +documentation. + +=head2 $future = $loop->new_future + +Returns a new pending Future. + +=head2 $future = $loop->delay_future( %args ) + +Returns a new Future that will become done at a given time. + +=head2 $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; + + if( ref $proto ) { + $self->{loop} = $proto->{loop}; + } + else { + $self->{loop} = shift; + } + + return $self; +} + +=head1 METHODS + +=cut + +=head2 $loop = $future->loop + +Returns the underlying C<IO::Async::Loop> object. + +=cut + +sub loop +{ + my $self = shift; + return $self->{loop}; +} + +sub await +{ + my $self = shift; + $self->{loop}->loop_once; +} + +=head2 $future->done_later( @result ) + +A shortcut to calling the C<done> method in a C<later> 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<done>, 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 $future->fail_later( $exception, @details ) + +A shortcut to calling the C<fail> method in a C<later> 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<fail>, 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 <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Handle.pm b/lib/IO/Async/Handle.pm new file mode 100644 index 0000000..201d900 --- /dev/null +++ b/lib/IO/Async/Handle.pm @@ -0,0 +1,687 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Handle; + +use strict; +use warnings; +use base qw( IO::Async::Notifier ); + +our $VERSION = '0.67'; + +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<IO::Async::Handle> - 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<IO::Async::Stream> class is likely to be more suitable. For +non-stream sockets, see L<IO::Async::Socket>. + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Notifier> 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<loop> will still return the containing +Loop object. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 read_handle => IO + +=head2 write_handle => IO + +The reading and writing IO handles. Each must implement the C<fileno> method. +Primarily used for passing C<STDIN> / C<STDOUT>; see the SYNOPSIS section of +C<IO::Async::Stream> for an example. + +=head2 handle => IO + +The IO handle for both reading and writing; instead of passing each separately +as above. Must implement C<fileno> method in way that C<IO::Handle> 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<read_handle> or C<write_handle> then a new C<IO::Handle> +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<want_readready> and C<want_writeready> methods. + +It is required that a matching C<on_read_ready> or C<on_write_ready> 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<read_handle> is +given, then C<on_write_ready> can be absent. If C<handle> 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<set_handle> or C<set_handles> methods, or by +C<configure>. This may be useful when constructing an object to represent a +network connection, before the C<connect(2)> 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 ); + + # 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; + + # 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; + if( length( my $name = $self->SUPER::notifier_name ) ) { + return $name; + } + + my $r = $self->read_fileno; + my $w = $self->write_fileno; + return "rw=$r" if defined $r and defined $w and $r == $w; + return "r=$r,w=$w" if defined $r and defined $w; + return "r=$r" if defined $r; + return "w=$w" if defined $w; + return "no"; +} + +=head1 METHODS + +The following methods documented with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +=head2 $handle->set_handles( %params ) + +Sets new reading or writing filehandles. Equivalent to calling the +C<configure> 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 $handle->set_handle( $fh ) + +Shortcut for + + $handle->configure( handle => $fh ) + +=cut + +sub set_handle +{ + my $self = shift; + my ( $fh ) = @_; + + $self->configure( handle => $fh ); +} + +=head2 $handle->close + +This method calls C<close> 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 $handle->close_read + +=head2 $handle->close_write + +Closes the underlying read or write handle, and deconfigures it from the +object. Neither of these methods will invoke the C<on_closed> 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<on_closed> 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 $handle->new_close_future->get + +Returns a new L<IO::Async::Future> 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 { $_ != $future } @{ $self->{close_futures} }; + }) + ); + + return $future; +} + +=head2 $handle = $handle->read_handle + +=head2 $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 $fileno = $handle->read_fileno + +=head2 $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 $value = $handle->want_readready + +=head2 $oldvalue = $handle->want_readready( $newvalue ) + +=head2 $value = $handle->want_writeready + +=head2 $oldvalue = $handle->want_writeready( $newvalue ) + +These are the accessor for the C<want_readready> and C<want_writeready> +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 $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<HASH> or C<ARRAY> reference of the same form as given +to L<IO::Async::OS>'s C<extract_addrinfo> 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 ); + $self->set_handle( $sock ); +} + +=head2 $handle = $handle->bind( %args )->get + +Performs a C<getaddrinfo> resolver operation with the C<passive> flag set, +and then attempts to bind a socket handle of any of the return values. + +=head2 $handle = $handle->bind( $ai )->get + +When invoked with a single argument, this method is a convenient shortcut to +creating a socket handle and C<bind()>ing 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<HASH> or C<ARRAY> reference of the same form as given +to L<IO::Async::OS>'s C<extract_addrinfo> 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 $handle = $handle->connect( %args )->get + +A convenient wrapper for calling the C<connect> method on the underlying +L<IO::Async::Loop> 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"; + + return $self->loop->connect( %args, handle => $self ); +} + +=head1 SEE ALSO + +=over 4 + +=item * + +L<IO::Handle> - Supply object methods for I/O handles + +=back + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Internals/Connector.pm b/lib/IO/Async/Internals/Connector.pm new file mode 100644 index 0000000..57029ef --- /dev/null +++ b/lib/IO/Async/Internals/Connector.pm @@ -0,0 +1,243 @@ +# 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-2013 -- leonerd@leonerd.org.uk + +package # hide from CPAN + IO::Async::Internals::Connector; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use Scalar::Util qw( weaken ); + +use POSIX qw( EINPROGRESS ); +use Socket qw( SOL_SOCKET SO_ERROR ); + +use Future; +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; + +# 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( sub { + 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 + die 'Oops; $loop->connect failed but no error cause was found'; + } ); +} + +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} ) { + $peeraddrfuture = $loop->new_future->done( exists $params{addrs} ? @{ $params{addrs} } : ( $params{addr} ) ); + } + 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->get; + my @localaddrs = $localaddrfuture->get; + + 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; diff --git a/lib/IO/Async/Internals/TimeQueue.pm b/lib/IO/Async/Internals/TimeQueue.pm new file mode 100644 index 0000000..4278fbd --- /dev/null +++ b/lib/IO/Async/Internals/TimeQueue.pm @@ -0,0 +1,205 @@ +# 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-2012 -- leonerd@leonerd.org.uk + +package # hide from CPAN + IO::Async::Internals::TimeQueue; + +use strict; +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; + +use strict; +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; diff --git a/lib/IO/Async/Listener.pm b/lib/IO/Async/Listener.pm new file mode 100644 index 0000000..277a9ab --- /dev/null +++ b/lib/IO/Async/Listener.pm @@ -0,0 +1,549 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Listener; + +use strict; +use warnings; +use base qw( IO::Async::Handle ); + +our $VERSION = '0.67'; + +use IO::Async::Handle; +use IO::Async::OS; + +use Errno qw( EAGAIN EWOULDBLOCK ); + +use Socket qw( sockaddr_family SOL_SOCKET SO_ACCEPTCONN SO_TYPE ); + +use Carp; + +=head1 NAME + +C<IO::Async::Listener> - listen on network sockets for incoming connections + +=head1 SYNOPSIS + + 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 ); + + $listener->listen( + service => "echo", + socktype => 'stream', + )->get; + + $loop->run; + +This object can also be used indirectly via an C<IO::Async::Loop>: + + use IO::Async::Stream; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + $loop->listen( + service => "echo", + socktype => 'stream', + + on_stream => sub { + ... + }, + )->get; + + $loop->run; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Handle> 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<listen> +method. Either a list of addresses can be provided, or a service name can be +looked up using the underlying loop's C<resolve> 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<handle_constructor> nor C<handle_class> 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<on_accept>, this an instance of L<IO::Async::Stream> 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<on_accept> with a handle +constructor or class. + +=head2 on_socket $socket + +Similar to C<on_stream>, but constructs an instance of L<IO::Async::Socket>. +This is most useful for C<SOCK_DGRAM> or C<SOCK_RAW> sockets. + +This is now vaguely deprecated in favour of using C<on_accept> with a handle +constructor or class. + +=head2 on_accept_error $socket, $errno + +Optional. Invoked if the C<accept> syscall indicates an error (other than +C<EAGAIN> or C<EWOULDBLOCK>). If not provided, failures of C<accept> will +be passed to the main C<on_error> handler. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=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 +C<IO::Async::Handle> 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<handle_constructor> isn't, then new wrapper handles +are constructed by invoking the C<new> 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 ) = $listener->acceptor( $socket )->get + + ( $handle ) = $listener->acceptor( $socket, handle => $handle )->get + +It is invoked with the listening socket as its its argument, and optionally +an C<IO::Async::Handle> instance as a named parameter, and is expected to +return a C<Future> 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( exists $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 ); + } + + 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 ); + })->on_fail( sub { + my ( $message, $name, @args ) = @_; + if( $name eq "accept" ) { + my ( $socket, $dollarbang ) = @args; + $self->maybe_invoke_event( on_accept_error => $socket, $dollarbang ) or + $self->invoke_error( "accept() failed - $dollarbang", accept => $socket, $dollarbang ); + } + }); + + # Caller is not going to keep hold of the Future, so we have to ensure it + # stays alive somehow + $self->adopt_future( $f->else( sub { Future->done } ) ); +} + +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 with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +=head2 $acceptor = $listener->acceptor + +Returns the currently-set C<acceptor> method name or code reference. This may +be of interest to Loop C<listen> 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 $name = $listener->sockname + +Returns the C<sockname> of the underlying listening socket + +=cut + +sub sockname +{ + my $self = shift; + + my $handle = $self->read_handle or return undef; + return $handle->sockname; +} + +=head2 $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 = $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 $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<listen> method of +the L<IO::Async::Loop> 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<handle> 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<addr> or C<addrs> parameters should contain a definition of a plain +socket address in a form that the L<IO::Async::OS> C<extract_addrinfo> +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<sockport> accessor on the actual socket filehandle. + +Either use the L<Future> returned by the C<listen> 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<on_listen> 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 <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Loop.pm b/lib/IO/Async/Loop.pm new file mode 100644 index 0000000..e510c64 --- /dev/null +++ b/lib/IO/Async/Loop.pm @@ -0,0 +1,2781 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Loop; + +use strict; +use warnings; +use 5.010; + +our $VERSION = '0.67'; + +# 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; + +# 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 IO::Socket (); # empty import +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 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; + +$SIG{PIPE} = "IGNORE" if ( $SIG{PIPE} // "" ) eq "DEFAULT"; + +=head1 NAME + +C<IO::Async::Loop> - core loop of the C<IO::Async> 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 +C<IO::Async> framework. Its primary purpose is to store a set of +L<IO::Async::Notifier> 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<IO::Async::Loop::Select> + +=item L<IO::Async::Loop::Poll> + +=back + +Or other subclasses that may appear on CPAN which are not part of the core +C<IO::Async> distribution. + +=head2 Ignoring SIGPIPE + +Since version I<0.66> loading this module automatically ignores C<SIGPIPE>, as +it is highly unlikely that the default-terminate action is the best course of +action for an C<IO::Async>-based program to take. If at load time the handler +disposition is still set as C<DEFAULT>, 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; + + # 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; + + # 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; +} + +=head1 MAGIC CONSTRUCTOR + +=head2 $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, C<require>ing the module then calling its C<new> +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 interract 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<really_new>, 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<IO::Async::Loop::> prepended to it. +This allows the end-user to specify a particular choice to fit the needs of +his use of a program using C<IO::Async>. + +=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<Glib>, it would be better to use the module specifically and invoke +its constructor directly. + +=item * IO::Async::OS->LOOP_PREFER_CLASSES + +The L<IO::Async::OS> 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<IO::Async::Loop::$^O> is tried next. This allows specific +OSes, such as the ever-tricky C<MSWin32>, 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 C<IO::Async::OS> hint instead. +At some future point it may be removed entirely, given as currently only +C<linux> uses it. + +=item * Poll and Select + +Finally, if no other choice has been made by now, the built-in C<Poll> module +is chosen. This should always work, but in case it doesn't, the C<Select> +module will be chosen afterwards as a last-case attempt. If this also fails, +then the magic constructor itself will throw an exception. + +=back + +If any of the explicitly-requested loop types (C<$ENV{IO_ASYNC_LOOP}> or +C<$IO::Async::Loop::LOOP>) fails to load then a warning is printed detailing +the error. + +Implementors of new C<IO::Async::Loop> subclasses should see the notes about +C<API_VERSION> below. + +=cut + +sub __try_new +{ + my ( $class ) = @_; + + ( my $file = "$class.pm" ) =~ s{::}{/}g; + + eval { + local $SIG{__WARN__} = sub {}; + require $file; + } or return; + + my $self; + $self = eval { $class->new } and return $self; + + # Oh dear. We've loaded the code OK but for some reason the constructor + # wasn't happy. Being polite we ought really to unload the file again, + # but perl doesn't actually provide us a way to do this. + + return undef; +} + +sub new +{ + return our $ONE_TRUE_LOOP ||= shift->really_new; +} + +# Ensure that the loop is DESTROYed recursively at exit time, before GD happens +END { + undef our $ONE_TRUE_LOOP; +} + +sub really_new +{ + shift; # We're going to ignore the class name actually given + my $self; + + my @candidates; + + push @candidates, split( m/,/, $ENV{IO_ASYNC_LOOP} ) if defined $ENV{IO_ASYNC_LOOP}; + + push @candidates, split( m/,/, $LOOP ) if defined $LOOP; + + foreach my $class ( @candidates ) { + $class =~ m/::/ or $class = "IO::Async::Loop::$class"; + $self = __try_new( $class ) and return $self; + + my ( $topline ) = split m/\n/, $@; # Ignore all the other lines; they'll be require's verbose output + warn "Unable to use $class - $topline\n"; + } + + unless( $LOOP_NO_OS ) { + foreach my $class ( IO::Async::OS->LOOP_PREFER_CLASSES, "IO::Async::Loop::$^O" ) { + $class =~ m/::/ or $class = "IO::Async::Loop::$class"; + $self = __try_new( $class ) and return $self; + + # Don't complain about these ones + } + } + + return IO::Async::Loop->new_builtin; +} + +sub new_builtin +{ + shift; + my $self; + + foreach my $class ( IO::Async::OS->LOOP_BUILTIN_CLASSES ) { + $self = __try_new( "IO::Async::Loop::$class" ) and return $self; + } + + croak "Cannot find a suitable candidate class"; +} + +####################### +# Notifier management # +####################### + +=head1 NOTIFIER MANAGEMENT + +The following methods manage the collection of C<IO::Async::Notifier> objects. + +=cut + +=head2 $loop->add( $notifier ) + +This method adds another notifier object to the stored collection. The object +may be a C<IO::Async::Notifier>, or any subclass of it. + +When a notifier is added, any children it has are also added, recursively. In +this way, entire sections of a program may be written within a tree of +notifier objects, and added or removed on one piece. + +=cut + +sub add +{ + my $self = shift; + my ( $notifier ) = @_; + + if( defined $notifier->parent ) { + croak "Cannot add a child notifier directly - add its parent"; + } + + if( defined $notifier->loop ) { + croak "Cannot add a notifier that is already a member of a loop"; + } + + $self->_add_noparentcheck( $notifier ); +} + +sub _add_noparentcheck +{ + my $self = shift; + my ( $notifier ) = @_; + + my $nkey = refaddr $notifier; + + $self->{notifiers}->{$nkey} = $notifier; + + $notifier->__set_loop( $self ); + + $self->_add_noparentcheck( $_ ) for $notifier->children; + + return; +} + +=head2 $loop->remove( $notifier ) + +This method removes a notifier object from the stored collection, and +recursively and children notifiers it contains. + +=cut + +sub remove +{ + my $self = shift; + my ( $notifier ) = @_; + + if( defined $notifier->parent ) { + croak "Cannot remove a child notifier directly - remove its parent"; + } + + $self->_remove_noparentcheck( $notifier ); +} + +sub _remove_noparentcheck +{ + my $self = shift; + my ( $notifier ) = @_; + + my $nkey = refaddr $notifier; + + exists $self->{notifiers}->{$nkey} or croak "Notifier does not exist in collection"; + + delete $self->{notifiers}->{$nkey}; + + $notifier->__set_loop( undef ); + + $self->_remove_noparentcheck( $_ ) for $notifier->children; + + return; +} + +=head2 @notifiers = $loop->notifiers + +Returns a list of all the notifier objects currently stored in the Loop. + +=cut + +sub notifiers +{ + my $self = shift; + # Sort so the order remains stable under additions/removals + return map { $self->{notifiers}->{$_} } sort keys %{ $self->{notifiers} }; +} + +################### +# Looping support # +################### + +=head1 LOOPING CONTROL + +The following methods control the actual run cycle of the loop, and hence the +program. + +=cut + +=head2 $count = $loop->loop_once( $timeout ) + +This method performs a single wait loop using the specific subclass's +underlying mechanism. If C<$timeout> is undef, then no timeout is applied, and +it will wait until an event occurs. The intention of the return value is to +indicate the number of callbacks that this loop executed, though different +subclasses vary in how accurately they can report this. See the documentation +for this method in the specific subclass for more information. + +=cut + +sub loop_once +{ + my $self = shift; + my ( $timeout ) = @_; + + croak "Expected that $self overrides ->loop_once"; +} + +=head2 @result = $loop->run + +=head2 $result = $loop->run + +Runs the actual IO event loop. This method blocks until the C<stop> method is +called, and returns the result that was passed to C<stop>. In scalar context +only the first result is returned; the others will be discarded if more than +one value was provided. This method may be called recursively. + +This method is a recent addition and may not be supported by all the +C<IO::Async::Loop> subclasses currently available on CPAN. + +=cut + +sub run +{ + my $self = shift; + + local $self->{running} = 1; + local $self->{result} = []; + + while( $self->{running} ) { + $self->loop_once( undef ); + } + + return wantarray ? @{ $self->{result} } : $self->{result}[0]; +} + +=head2 $loop->stop( @result ) + +Stops the inner-most C<run> method currently in progress, causing it to return +the given C<@result>. + +This method is a recent addition and may not be supported by all the +C<IO::Async::Loop> subclasses currently available on CPAN. + +=cut + +sub stop +{ + my $self = shift; + + @{ $self->{result} } = @_; + undef $self->{running}; +} + +=head2 $loop->loop_forever + +A synonym for C<run>, though this method does not return a result. + +=cut + +sub loop_forever +{ + my $self = shift; + $self->run; + return; +} + +=head2 $loop->loop_stop + +A synonym for C<stop>, though this method does not pass any results. + +=cut + +sub loop_stop +{ + my $self = shift; + $self->stop; +} + +=head2 $loop->post_fork + +The base implementation of this method does nothing. It is provided in case +some Loop subclasses should take special measures after a C<fork()> system +call if the main body of the program should survive in both running processes. + +This may be required, for example, in a long-running server daemon that forks +multiple copies on startup after opening initial listening sockets. A loop +implementation that uses some in-kernel resource that becomes shared after +forking (for example, a Linux C<epoll> or a BSD C<kqueue> filehandle) would +need recreating in the new child process before the program can continue. + +=cut + +sub post_fork +{ + # empty +} + +########### +# Futures # +########### + +=head1 FUTURE SUPPORT + +The following methods relate to L<IO::Async::Future> objects. + +=cut + +=head2 $future = $loop->new_future + +Returns a new C<IO::Async::Future> instance with a reference to the Loop. + +=cut + +sub new_future +{ + my $self = shift; + require IO::Async::Future; + return IO::Async::Future->new( $self ); +} + +=head2 $loop->await( $future ) + +Blocks until the given future is ready, as indicated by its C<is_ready> method. +As a convenience it returns the future, to simplify code: + + my @result = $loop->await( $future )->get; + +=cut + +sub await +{ + my $self = shift; + my ( $future ) = @_; + + $self->loop_once until $future->is_ready; + + return $future; +} + +=head2 $loop->await_all( @futures ) + +Blocks until all the given futures are ready, as indicated by the C<is_ready> +method. Equivalent to calling C<await> on a C<< Future->wait_all >> except +that it doesn't create the surrounding future object. + +=cut + +sub _all_ready { $_->is_ready or return 0 for @_; return 1 } + +sub await_all +{ + my $self = shift; + my @futures = @_; + + $self->loop_once until _all_ready @futures; +} + +=head2 $loop->delay_future( %args )->get + +Returns a new C<IO::Async::Future> instance which will become done at a given +point in time. The C<%args> should contain an C<at> or C<after> key as per the +C<watch_time> method. The returned future may be cancelled to cancel the +timer. At the alloted time the future will succeed with an empty result list. + +=cut + +sub delay_future +{ + my $self = shift; + my %args = @_; + + my $future = $self->new_future; + my $id = $self->watch_time( %args, + code => sub { $future->done }, + ); + + $future->on_cancel( sub { shift->loop->unwatch_time( $id ) } ); + + return $future; +} + +=head2 $loop->timeout_future( %args )->get + +Returns a new C<IO::Async::Future> instance which will fail at a given point +in time. The C<%args> should contain an C<at> or C<after> key as per the +C<watch_time> method. The returned future may be cancelled to cancel the +timer. At the alloted time, the future will fail with the string C<"Timeout">. + +=cut + +sub timeout_future +{ + my $self = shift; + my %args = @_; + + my $future = $self->new_future; + my $id = $self->watch_time( %args, + code => sub { $future->fail( "Timeout" ) }, + ); + + $future->on_cancel( sub { shift->loop->unwatch_time( $id ) } ); + + return $future; +} + +############ +# Features # +############ + +=head1 FEATURES + +Most of the following methods are higher-level wrappers around base +functionality provided by the low-level API documented below. They may be +used by C<IO::Async::Notifier> subclasses or called directly by the program. + +The following methods documented with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +sub __new_feature +{ + my $self = shift; + my ( $classname ) = @_; + + ( my $filename = "$classname.pm" ) =~ s{::}{/}g; + require $filename; + + # These features aren't supposed to be "user visible", so if methods called + # on it carp or croak, the shortmess line ought to skip IO::Async::Loop and + # go on report its caller. To make this work, add the feature class to our + # @CARP_NOT list. + push our(@CARP_NOT), $classname; + + return $classname->new( loop => $self ); +} + +=head2 $id = $loop->attach_signal( $signal, $code ) + +This method adds a new signal handler to watch the given signal. The same +signal can be attached to multiple times; its callback functions will all be +invoked, in no particular order. + +The returned C<$id> value can be used to identify the signal handler in case +it needs to be removed by the C<detach_signal> method. Note that this value +may be an object reference, so if it is stored, it should be released after it +cancelled, so the object itself can be freed. + +=over 8 + +=item $signal + +The name of the signal to attach to. This should be a bare name like C<TERM>. + +=item $code + +A CODE reference to the handling callback. + +=back + +Attaching to C<SIGCHLD> is not recommended because of the way all child +processes use it to report their termination. Instead, the C<watch_child> +method should be used to watch for termination of a given child process. A +warning will be printed if C<SIGCHLD> is passed here, but in future versions +of C<IO::Async> this behaviour may be disallowed altogether. + +See also L<POSIX> for the C<SIGI<name>> constants. + +For a more flexible way to use signals from within Notifiers, see instead the +L<IO::Async::Signal> object. + +=cut + +sub attach_signal +{ + my $self = shift; + my ( $signal, $code ) = @_; + + HAVE_SIGNALS or croak "This OS cannot ->attach_signal"; + + if( $signal eq "CHLD" ) { + # We make special exception to allow $self->watch_child to do this + caller eq "IO::Async::Loop" or + carp "Attaching to SIGCHLD is not advised - use ->watch_child instead"; + } + + if( not $self->{sigattaches}->{$signal} ) { + my @attaches; + $self->watch_signal( $signal, sub { + foreach my $attachment ( @attaches ) { + $attachment->(); + } + } ); + $self->{sigattaches}->{$signal} = \@attaches; + } + + push @{ $self->{sigattaches}->{$signal} }, $code; + + return \$self->{sigattaches}->{$signal}->[-1]; +} + +=head2 $loop->detach_signal( $signal, $id ) + +Removes a previously-attached signal handler. + +=over 8 + +=item $signal + +The name of the signal to remove from. This should be a bare name like +C<TERM>. + +=item $id + +The value returned by the C<attach_signal> method. + +=back + +=cut + +sub detach_signal +{ + my $self = shift; + my ( $signal, $id ) = @_; + + HAVE_SIGNALS or croak "This OS cannot ->detach_signal"; + + # Can't use grep because we have to preserve the addresses + my $attaches = $self->{sigattaches}->{$signal} or return; + + for (my $i = 0; $i < @$attaches; ) { + $i++, next unless \$attaches->[$i] == $id; + + splice @$attaches, $i, 1, (); + } + + if( !@$attaches ) { + $self->unwatch_signal( $signal ); + delete $self->{sigattaches}->{$signal}; + } +} + +=head2 $loop->later( $code ) + +Schedules a code reference to be invoked as soon as the current round of IO +operations is complete. + +The code reference is never invoked immediately, though the loop will not +perform any blocking operations between when it is installed and when it is +invoked. It may call C<select>, C<poll> 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<watch_idle> method, with the C<when> +parameter set to C<later>. It will return an ID value that can be passed to +C<unwatch_idle> if required. + +=cut + +sub later +{ + my $self = shift; + my ( $code ) = @_; + + return $self->watch_idle( when => 'later', code => $code ); +} + +=head2 $loop->spawn_child( %params ) + +This method creates a new child process to run a given code block or command. +For more detail, see the C<spawn_child> method on the +L<IO::Async::ChildManager> class. + +=cut + +sub spawn_child +{ + my $self = shift; + my %params = @_; + + my $childmanager = $self->{childmanager} ||= + $self->__new_feature( "IO::Async::ChildManager" ); + + $childmanager->spawn_child( %params ); +} + +=head2 $pid = $loop->open_child( %params ) + +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<IO::Async::Process> object, provided +largely for backward compatibility. New code ought to construct such an object +directly, as it may provide more features than are available here. + +The C<%params> hash takes the following keys: + +=over 8 + +=item command => ARRAY or STRING + +=item code => CODE + +The command or code to run in the child process (as per the C<spawn> method) + +=item on_finish => CODE + +A continuation to be called when the child process exits and has closed all of +the filehandles that were set up for it. It will be invoked in the following +way: + + $on_finish->( $pid, $exitcode ) + +The second argument is passed the plain perl C<$?> value. + +=item on_error => CODE + +Optional continuation to be called when the child code block throws an +exception, or the command could not be C<exec(2)>ed. It will be invoked in the +following way (as per C<spawn>) + + $on_error->( $pid, $exitcode, $dollarbang, $dollarat ) + +If this continuation is not supplied, then C<on_finish> is used instead. The +value of C<$!> and C<$@> will not be reported. + +=item setup => ARRAY + +Optional reference to an array to pass to the underlying C<spawn> method. + +=back + +In addition, the hash takes keys that define how to set up file descriptors in +the child process. (If the C<setup> array is also given, these operations will +be performed after those specified by C<setup>.) + +=over 8 + +=item fdI<n> => HASH + +A hash describing how to set up file descriptor I<n>. The hash may contain one +of the following sets of keys: + +=over 4 + +=item on_read => CODE + +The child will be given the writing end of a pipe. The reading end will be +wrapped by an C<IO::Async::Stream> using this C<on_read> callback function. + +=item from => STRING + +The child will be given the reading end of a pipe. The string given by the +C<from> parameter will be written to the child. When all of the data has been +written the pipe will be closed. + +=back + +=item stdin => ... + +=item stdout => ... + +=item stderr => ... + +Shortcuts for C<fd0>, C<fd1> and C<fd2> respectively. + +=back + +=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 ); + }; + } + + $params{on_exit} and croak "Cannot pass 'on_exit' parameter through ChildManager->open"; + + require IO::Async::Process; + my $process = IO::Async::Process->new( %params ); + + $self->add( $process ); + + return $process->pid; +} + +=head2 $pid = $loop->run_child( %params ) + +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. + +=over 8 + +=item command => ARRAY or STRING + +=item code => CODE + +The command or code to run in the child process (as per the C<spawn_child> +method) + +=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. + +=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<spawn> method. + +=back + +This method is intended mainly as an IO::Async-compatible replacement for the +perl C<readpipe> function (`backticks`), allowing it to replace + + my $output = `command here`; + +with + + $loop->run_child( + command => "command here", + on_finish => sub { + my ( undef, $exitcode, $output ) = @_; + ... + } + ); + +=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 $stdout; + my $stderr; + + my %subparams; + + if( my $child_stdin = delete $params{stdin} ) { + ref $child_stdin and croak "Expected 'stdin' not to be a reference"; + $subparams{stdin} = { from => $child_stdin }; + } + + $subparams{code} = delete $params{code}; + $subparams{command} = delete $params{command}; + $subparams{setup} = delete $params{setup}; + + croak "Unrecognised parameters " . join( ", ", keys %params ) if keys %params; + + require IO::Async::Process; + my $process = IO::Async::Process->new( + %subparams, + stdout => { into => \$stdout }, + stderr => { into => \$stderr }, + + on_finish => sub { + my ( $process, $exitcode ) = @_; + $on_finish->( $process->pid, $exitcode, $stdout, $stderr ); + }, + ); + + $self->add( $process ); + + return $process->pid; +} + +=head2 $loop->resolver + +Returns the internally-stored L<IO::Async::Resolver> object, used for name +resolution operations by the C<resolve>, C<connect> and C<listen> 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 $loop->set_resolver( $resolver ) + +Sets the internally-stored L<IO::Async::Resolver> 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 @result = $loop->resolve( %params )->get + +This method performs a single name resolution operation. It uses an +internally-stored C<IO::Async::Resolver> object. For more detail, see the +C<resolve> method on the L<IO::Async::Resolver> class. + +=cut + +sub resolve +{ + my $self = shift; + my ( %params ) = @_; + + $self->resolver->resolve( %params ); +} + +=head2 $handle|$socket = $loop->connect( %params )->get + +This method performs a non-blocking connection to a given address or set of +addresses, returning a L<IO::Async::Future> which represents the operation. On +completion, the future will yield the connected socket handle, or the given +L<IO::Async::Handle> 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<resolve> 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<connect(2)> 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<on_fail> callback can be used. This will be invoked on each +individual C<socket(2)> or C<connect(2)> failure, which may be useful for +debugging or logging. + +Because this module simply uses the C<getaddrinfo> 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<addr>. Such a layout +is returned by the C<getaddrinfo> 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<IO::Async::OS>'s C<extract_addrinfo> method. + +This example shows how to use the C<Socket> 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<echo.sock>. + + $loop->connect( + addr => { + family => "unix", + socktype => "stream", + path => "echo.sock", + }, + ... + ); + +=item local_addrs => ARRAY + +=item local_addr => HASH or ARRAY + +Optional. Similar to the C<addrs> or C<addr> parameters, these specify a local +address or set of addresses to C<bind(2)> the socket to before +C<connect(2)>ing it. + +=back + +When performing the resolution step too, the C<addrs> or C<addr> 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<bind(2)> 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<host> and C<service> to the +C<getaddrinfo> call. + +=item socktype => STRING + +Optionally may instead be one of the values C<'stream'>, C<'dgram'> or +C<'raw'> to stand for C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_RAW>. This +utility is provided to allow the caller to avoid a separate C<use Socket> only +for importing these constants. + +=back + +It is necessary to pass the C<socktype> hint to the resolver when resolving +the host/service names into an address, as some OS's C<getaddrinfo> functions +require this hint. A warning is emitted if neither C<socktype> nor C<protocol> +hint is defined when performing a C<getaddrinfo> lookup. To avoid this warning +while still specifying no particular C<socktype> hint (perhaps to invoke some +OS-specific behaviour), pass C<0> as the C<socktype> value. + +In either case, it also accepts the following arguments: + +=over 8 + +=item handle => IO::Async::Handle + +Optional. If given a L<IO::Async::Handle> object or a subclass (such as +L<IO::Async::Stream> or L<IO::Async::Socket> 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<socket(2)> or C<connect(2)> 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<extensions> parameter; see the C<EXTENSIONS> section +below. + +=head2 $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<connect(2)> call to a valid +socket. It will be passed the connected socket handle, as an C<IO::Socket> +object. + + $on_connected->( $handle ) + +=item on_stream => CODE + +An alternative to C<on_connected>, a continuation that is passed an instance +of L<IO::Async::Stream> 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<on_stream>, but constructs an instance of L<IO::Async::Socket>. +This is most useful for C<SOCK_DGRAM> or C<SOCK_RAW> 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<connect(2)> syscall are considered most significant, then C<bind(2)>, then +finally C<socket(2)>. + + $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<on_error> continuation for the C<resolve> +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 $listener = $loop->listen( %params )->get + +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<IO::Async::Listener> 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<host> and C<service> to the +C<getaddrinfo> call. + +=item socktype => STRING + +Optionally may instead be one of the values C<'stream'>, C<'dgram'> or +C<'raw'> to stand for C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_RAW>. This +utility is provided to allow the caller to avoid a separate C<use Socket> only +for importing these constants. + +=back + +It is necessary to pass the C<socktype> hint to the resolver when resolving +the host/service names into an address, as some OS's C<getaddrinfo> functions +require this hint. A warning is emitted if neither C<socktype> nor C<protocol> +hint is defined when performing a C<getaddrinfo> lookup. To avoid this warning +while still specifying no particular C<socktype> hint (perhaps to invoke some +OS-specific behaviour), pass C<0> as the C<socktype> 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<addr>. Such a layout +is returned by the C<getaddrinfo> 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<IO::Async::OS>'s C<extract_addrinfo> method. See also +the C<EXAMPLES> 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<listen(2)> calls. If not supplied, +then 3 will be given instead. + +=item reuseaddr => BOOL + +Optional. If true or not supplied then the C<SO_REUSEADDR> 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<IPV6_V6ONLY> socket option on +C<PF_INET6> sockets. This option disables the ability of C<PF_INET6> socket to +accept connections from C<AF_INET> 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 +C<IO::Async::Listener> object directly and add it explicitly to the Loop. + +This method accepts an C<extensions> parameter; see the C<EXTENSIONS> section +below. + +=head2 $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<listen(2)> syscall are considered most significant, then C<bind(2)>, then +C<sockopt(2)>, then finally C<socket(2)>. + +=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<on_error> continuation for the C<resolve> +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; + } + + 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 ||= ""; + defined $service or $service = ""; # might be 0 + + 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 $signum = $loop->signame2num( $signame ) + +Legacy wrappers around L<IO::Async::OS> functions. + +=cut + +sub signame2num { shift; IO::Async::OS->signame2num( @_ ) } + +=head2 $time = $loop->time + +Returns the current UNIX time in fractional seconds. This is currently +equivalent to C<Time::HiRes::time> but provided here as a utility for +programs to obtain the time current used by C<IO::Async> for its own timing +purposes. + +=cut + +sub time +{ + my $self = shift; + return Time::HiRes::time; +} + +=head2 $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<eval> block. The return value will be used as the +C<exit(2)> code from the child if it returns (or 255 if it returned C<undef> 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<watch_child> 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<DEFAULT> 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"; + } + } + + my $exitvalue = eval { $code->() }; + + defined $exitvalue or $exitvalue = -1; + + POSIX::_exit( $exitvalue ); + } + + if( defined $params{on_exit} ) { + $self->watch_child( $kid => $params{on_exit} ); + } + + return $kid; +} + +=head2 $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<context> argument, and its return value will be available to the +C<on_joined> callback. It is called inside an C<eval> block; if it fails the +exception will be caught. + +=item context => "scalar" | "list" | "void" + +Optional. Gives the calling context that C<code> is invoked in. Defaults to +C<scalar> 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 - $!"; + $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<IO::Async::Loop> 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<IO::Async::Loop> subclass. + +=cut + +=head2 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<constant>; e.g + + use constant API_VERSION => '0.49'; + +=cut + +=head2 $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 C<IO::Async::Handle> or C<IO::Async::Stream> instead +of using this method. + +If the filehandle does not yet have the C<O_NONBLOCK> flag set, it will be +enabled by this method. This will ensure that any subsequent C<sysread>, +C<syswrite>, 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 $loop->unwatch_io( %params ) + +This method removes a watch on an IO handle which was previously installed by +C<watch_io>. + +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<watch_io> 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 $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<TERM>. + +=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 C<IO::Async::Signal> object, or call +C<attach_signal> instead of using this method. + +This and C<unwatch_signal> 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 $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<TERM>. + +=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 $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<at> key), or +as a delay from the time it is installed (the C<after> key). + +The returned C<$id> value can be used to identify the timer in case it needs +to be cancelled by the C<unwatch_time> 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<at> is not supplied. A +zero or negative delayed timer should be executed as soon as possible; the +next time the C<loop_once> method is invoked. + +=item now => NUM + +The time to consider as now if calculating an absolute time based on C<after>; +defaults to C<time()> if not specified. + +=item code => CODE + +CODE reference to the continuation to run at the allotted time. + +=back + +Either one of C<at> or C<after> is required. + +For more powerful timer functionality as a C<IO::Async::Notifier> (so it can +be used as a child within another Notifier), see instead the +L<IO::Async::Timer> 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<loop_once> 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<enqueue_timer>. It is +unspecified how this method pair interacts with the older +C<enqueue/requeue/cancel_timer> 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 $loop->unwatch_time( $id ) + +Removes a timer callback previously created by C<watch_time>. + +This is the newer version of the API, replacing C<cancel_timer>. It is +unspecified how this method pair interacts with the older +C<enqueue/requeue/cancel_timer> 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 $id = $loop->enqueue_timer( %params ) + +An older version of C<watch_time>. 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<watch_time> method; though note it has differently-named +arguments. For requeueable timers, consider using an +L<IO::Async::Timer::Countdown> or L<IO::Async::Timer::Absolute> 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 $loop->cancel_timer( $id ) + +An older version of C<unwatch_time>. 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 $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<enqueue_timer>, except for the +C<code> 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<IO::Async::Timer::Countdown> or +L<IO::Async::Timer::Absolute> 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 $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<when> 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<loop_once> method. + +If a new idle watch is installed from within a C<later> callback, the +installed one will not be invoked during this round. It will be deferred for +the next time C<loop_once> is called, after any IO events have been handled. + +=back + +If there are pending idle handlers, then the C<loop_once> 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<unwatch_idle> 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<unwatch_idle> 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 $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 $loop->watch_child( $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<unwatch_child>. + +This and C<unwatch_child> are optional; a subclass may implement neither, or +both. If it implements neither then child watching will be performed by using +C<watch_signal> to install a C<SIGCHLD> handler, which will use C<waitpid> 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. + +=cut + +sub watch_child +{ + my $self = shift; + my ( $pid, $code ) = @_; + + 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; +} + +=head2 $loop->unwatch_child( $pid ) + +This method removes a watch on an existing child process PID. + +=cut + +sub unwatch_child +{ + my $self = shift; + my ( $pid ) = @_; + + my $childwatches = $self->{childwatches}; + + delete $childwatches->{$pid}; + + if( HAVE_SIGNALS and !keys %$childwatches ) { + $self->detach_signal( CHLD => delete $self->{childwatch_sigid} ); + } +} + +=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 $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 $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<IO::Async::Loop> 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<extensions> 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<extensions> list contains more extension names, it will be passed the +remaining ones in another C<extensions> 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<IO::Async::SSL> can +easily be invoked indirectly, by passing extra arguments to C<connect> methods +or similar, without needing every module to be aware of the C<SSL> extension. +This functionality is generic and not limited to C<SSL>; other extensions may +also use it. + +The following methods take an C<extensions> parameter: + + $loop->connect + $loop->listen + +If an extension C<listen> method is invoked, it will be passed a C<listener> +parameter even if one was not provided to the original C<< $loop->listen >> +call, and it will not receive any of the C<on_*> event callbacks. It should +use the C<acceptor> parameter on the C<listener> object. + +=cut + +=head1 STALL WATCHDOG + +A well-behaved C<IO::Async> program should spend almost all of its time +blocked on input using the underlying C<IO::Async::Loop> 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<SIGALRM>, so if enabled, this signal will no longer +be available to user code. (Though in any case, most uses of C<alarm()> and +C<SIGALRM> are better served by one of the L<IO::Async::Timer> 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<alarm(2)> call. Defaults to 10 +seconds. + +=item IO_ASYNC_WATCHDOG_SIGABRT => BOOL + +If enabled, the watchdog signal handler will raise a C<SIGABRT>, which usually +has the effect of breaking out of a running program in debuggers such as +F<gdb>. If not set then the process is terminated by throwing an exception with +C<die>. + +=back + +=cut + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Loop/Poll.pm b/lib/IO/Async/Loop/Poll.pm new file mode 100644 index 0000000..fb7bbf1 --- /dev/null +++ b/lib/IO/Async/Loop/Poll.pm @@ -0,0 +1,350 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Loop::Poll; + +use strict; +use warnings; + +our $VERSION = '0.67'; +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<IO::Async::Loop::Poll> - use C<IO::Async> with C<poll(2)> + +=head1 SYNOPSIS + +Normally an instance of this class would not be directly constructed by a +program. It may however, be useful for runinng L<IO::Async> with an existing +program already using an C<IO::Poll> 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 C<IO::Async::Loop> uses the C<poll(2)> system call to perform +read-ready and write-ready tests. + +By default, this loop will use the underlying C<poll()> system call directly, +bypassing the usual L<IO::Poll> object wrapper around it because of a number +of bugs and design flaws in that class; namely + +=over 2 + +=item * + +L<https://rt.cpan.org/Ticket/Display.html?id=93107> - IO::Poll relies on +stable stringification of IO handles + +=item * + +L<https://rt.cpan.org/Ticket/Display.html?id=25049> - IO::Poll->poll() with no +handles always returns immediately + +=back + +However, to integrate with existing code that uses an C<IO::Poll> object, a +C<post_poll> can be called immediately after the C<poll> method that +C<IO::Poll> object. The appropriate mask bits are maintained on the +C<IO::Poll> object when notifiers are added or removed from the loop, or when +they change their C<want_*> status. The C<post_poll> method inspects the +result bits and invokes the C<on_read_ready> or C<on_write_ready> methods on +the notifiers. + +=cut + +=head1 CONSTRUCTOR + +=cut + +=head2 $loop = IO::Async::Loop::Poll->new( %args ) + +This function returns a new instance of a C<IO::Async::Loop::Poll> object. It +takes the following named arguments: + +=over 8 + +=item C<poll> + +The C<IO::Poll> object to use for notification. Optional; if a value is not +given, the underlying C<IO::Poll::_poll()> 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 $count = $loop->post_poll + +This method checks the returned event list from a C<IO::Poll::poll> 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<on_read_ready> and C<on_write_ready> callbacks for +C<watch_io>, and C<watch_time> 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 occured, we'll have to + # attempt to fire any waiting timeout events anyway + $count += $self->_manage_queues; + + alarm( 0 ) if WATCHDOG_ENABLE; + + return $count; +} + +=head2 $count = $loop->loop_once( $timeout ) + +This method calls the C<poll> method on the stored C<IO::Poll> object, +passing in the value of C<$timeout>, and then runs the C<post_poll> method +on itself. It returns the total number of callbacks invoked by the +C<post_poll> method, or C<undef> if the underlying C<poll> 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; + + # 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 occured 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 ); + } + + return undef unless defined $pollret; + return $self->post_poll; + } + else { + my $msec = defined $timeout ? $timeout * 1000 : -1; + my @pollmasks = %{ $self->{pollmask} }; + + my $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; + } + + 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 <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Loop/Select.pm b/lib/IO/Async/Loop/Select.pm new file mode 100644 index 0000000..0c3bd9c --- /dev/null +++ b/lib/IO/Async/Loop/Select.pm @@ -0,0 +1,294 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Loop::Select; + +use strict; +use warnings; + +our $VERSION = '0.67'; +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<IO::Async::Loop::Select> - use C<IO::Async> with C<select(2)> + +=head1 SYNOPSIS + +Normally an instance of this class would not be directly constructed by a +program. It may however, be useful for runinng L<IO::Async> with an existing +program already using a C<select> call. + + use IO::Async::Loop::Select; + + my $loop = IO::Async::Loop::Select->new; + + $loop->add( ... ); + + while(1) { + my ( $rvec, $wvec, $evec ) = ('') x 3; + my $timeout; + + $loop->pre_select( \$rvec, \$wvec, \$evec, \$timeout ); + ... + my $ret = select( $rvec, $wvec, $evec, $timeout ); + ... + $loop->post_select( $rvec, $evec, $wvec ); + } + +=head1 DESCRIPTION + +This subclass of C<IO::Async::Loop> uses the C<select(2)> syscall to perform +read-ready and write-ready tests. + +To integrate with an existing C<select>-based event loop, a pair of methods +C<pre_select> and C<post_select> can be called immediately before and +after a C<select> call. The relevant bits in the read-ready, write-ready and +exceptional-state bitvectors are set by the C<pre_select> method, and tested +by the C<post_select> method to pick which event callbacks to invoke. + +=cut + +=head1 CONSTRUCTOR + +=cut + +=head2 $loop = IO::Async::Loop::Select->new + +This function returns a new instance of a C<IO::Async::Loop::Select> object. +It takes no special arguments. + +=cut + +sub new +{ + my $class = shift; + + my $self = $class->__new( @_ ); + + $self->{rvec} = ''; + $self->{wvec} = ''; + $self->{evec} = ''; + + $self->{avec} = ''; # Bitvector of handles always to claim are ready + + return $self; +} + +=head1 METHODS + +=cut + +=head2 $loop->pre_select( \$readvec, \$writevec, \$exceptvec, \$timeout ) + +This method prepares the bitvectors for a C<select> 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 $loop->post_select( $readvec, $writevec, $exceptvec ) + +This method checks the returned bitvectors from a C<select> call, and calls +any of the callbacks that are appropriate. + +=over 8 + +=item $readvec + +=item $writevec + +=item $exceptvec + +Scalars containing the read-ready, write-ready and exception bitvectors + +=back + +=cut + +sub post_select +{ + my $self = shift; + my ( $readvec, $writevec, $exceptvec ) = @_; + + my $iowatches = $self->{iowatches}; + + my $count = 0; + + alarm( IO::Async::Loop->WATCHDOG_INTERVAL ) if WATCHDOG_ENABLE; + + foreach my $fd ( keys %$iowatches ) { + my $watch = $iowatches->{$fd} or next; + + my $fileno = $watch->[0]->fileno; + + if( vec( $readvec, $fileno, 1 ) or + FAKE_ISREG_READY and vec( $self->{avec}, $fileno, 1 ) and vec( $self->{rvec}, $fileno, 1 ) ) { + $count++, $watch->[1]->() if defined $watch->[1]; + } + + if( vec( $writevec, $fileno, 1 ) or + SELECT_CONNECT_EVEC and vec( $exceptvec, $fileno, 1 ) or + FAKE_ISREG_READY and vec( $self->{avec}, $fileno, 1 ) and vec( $self->{wvec}, $fileno, 1 ) ) { + $count++, $watch->[2]->() if defined $watch->[2]; + } + } + + # Since we have no way to know if the timeout occured, we'll have to + # attempt to fire any waiting timeout events anyway + + $self->_manage_queues; + + alarm( 0 ) if WATCHDOG_ENABLE; +} + +=head2 $count = $loop->loop_once( $timeout ) + +This method calls the C<pre_select> method to prepare the bitvectors for a +C<select> syscall, performs it, then calls C<post_select> to process the +result. It returns the total number of callbacks invoked by the +C<post_select> method, or C<undef> if the underlying C<select(2)> 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 ); + + my $ret = select( $rvec, $wvec, $evec, $timeout ); + + 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<IO::Select> - OO interface to select system call + +=back + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/LoopTests.pm b/lib/IO/Async/LoopTests.pm new file mode 100644 index 0000000..63f1257 --- /dev/null +++ b/lib/IO/Async/LoopTests.pm @@ -0,0 +1,833 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::LoopTests; + +use strict; +use warnings; + +use Exporter 'import'; +our @EXPORT = qw( + run_tests +); + +use Test::More; +use Test::Fatal; +use Test::Refcount; + +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 ); + +our $VERSION = '0.67'; + +# 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<IO::Async::LoopTests> - acceptance testing for C<IO::Async::Loop> 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<IO::Async::Loop> subclasses. It is provided as a facility for +authors of such subclasses to ensure that the code conforms to the Loop API +required by C<IO::Async>. + +=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<TEST_QUICK_TIMERS> 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( $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<require> or C<use> it first. + +This function runs C<Test::More::plan> to output its expected test count; the +containing script should not do this. + +=cut + +sub run_tests +{ + my ( $testclass, @tests ) = @_; + + my $count = 0; + $count += __PACKAGE__->can( "count_tests_$_" )->() + 4 for @tests; + + plan tests => $count; + + ( 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' ); + } +} + +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<run_tests>: + +=cut + +=head2 io + +Tests the Loop's ability to watch filehandles for IO readiness + +=cut + +use constant count_tests_io => 18; +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' ); + } + + 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' ); + } + + # 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 + { + 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, + ); + } +} + +=head2 timer + +Tests the Loop's ability to handle timer events + +=cut + +use constant count_tests_timer => 21; +sub run_tests_timer +{ + my $done = 0; + # New watch/unwatch API + + cmp_ok( abs( $loop->time - time ), "<", 0.1, '$loop->time gives the current time' ); + + $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'; + + $loop->watch_time( at => time + 2 * AUT, code => sub { $done = 2; } ); + + 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'; + + 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' ); + + $loop->watch_time( after => -1, code => sub { $done = 1 } ); + + $done = 0; + + time_between { + $loop->loop_once while !$done; + } 0, 0.1, 'loop_once while waiting for negative interval timer'; + + { + 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' ); + } + + # Legacy enqueue/requeue/cancel API + $done = 0; + + $loop->enqueue_timer( delay => 2 * AUT, code => sub { $done = 1; } ); + + is_oneref( $loop, '$loop has refcount 1 after enqueue_timer' ); + + 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 timer'; + + 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->enqueue_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" ); + } + } + + $cancelled_fired = 0; + $id = $loop->enqueue_timer( delay => 1 * AUT, code => sub { $cancelled_fired = 1 } ); + $loop->cancel_timer( $id ); + undef $id; + + $loop->loop_once( 2 * AUT ); + + ok( !$cancelled_fired, 'cancelled timer does not fire' ); + + $id = $loop->enqueue_timer( delay => 1 * AUT, code => sub { $done = 2; } ); + $id = $loop->requeue_timer( $id, delay => 2 * AUT ); + + $done = 0; + + time_between { + $loop->loop_once( 1 * AUT ); + + is( $done, 0, '$done still 0 so far' ); + + 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, 'requeued timer of delay 2'; + + is( $done, 2, '$done is 2 after requeued timer' ); +} + +=head2 signal + +Tests the Loop's ability to watch POSIX signals + +=cut + +use constant count_tests_signal => 14; +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( exception { $loop->attach_signal( 'this signal name does not exist', sub {} ) }, + 'Bad signal name fails' ); +} + +=head2 idle + +Tests the Loop's support for idle handlers + +=cut + +use constant count_tests_idle => 11; +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 ); + + 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 child + +Tests the Loop's support for watching child processes by PID + +=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"; +} + +use constant count_tests_child => 7; +sub run_tests_child +{ + my $kid = run_in_child { + exit( 3 ); + }; + + my $exitcode; + + $loop->watch_child( $kid => sub { ( undef, $exitcode ) = @_; } ); + + is_oneref( $loop, '$loop has refcount 1 after watch_child' ); + 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_child( $kid => sub { ( undef, $exitcode ) = @_; } ); + + kill SIGTERM, $kid; + + undef $exitcode; + wait_for { defined $exitcode }; + + is( ($exitcode & 0x7f), SIGTERM, 'WTERMSIG($exitcode) after SIGTERM' ); + } + + my %kids; + + $loop->watch_child( 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' ); +} + +=head2 control + +Tests that the C<run>, C<stop>, C<loop_once> and C<loop_forever> methods +behave correctly + +=cut + +use constant count_tests_control => 8; +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_deeply( \@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 { + $loop->watch_time( after => 0.1, code => sub { $loop->stop( "inner" ) } ); + my @result = $loop->run; + $loop->stop( @result, "outer" ); + } ); + + @result = $loop->run; + + is_deeply( \@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' ); +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Notifier.pm b/lib/IO/Async/Notifier.pm new file mode 100644 index 0000000..f21c346 --- /dev/null +++ b/lib/IO/Async/Notifier.pm @@ -0,0 +1,919 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Notifier; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +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<IO::Async::Notifier> - base class for C<IO::Async> 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 +C<IO::Async> program uses. It provides the lowest level of integration with a +C<IO::Async::Loop> 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<IO::Async::Handle> - event callbacks for a non-blocking file descriptor + +=item * + +L<IO::Async::Stream> - event callbacks and write bufering for a stream +filehandle + +=item * + +L<IO::Async::Socket> - event callbacks and send buffering for a socket +filehandle + +=item * + +L<IO::Async::Timer> - base class for Notifiers that use timed delays + +=item * + +L<IO::Async::Signal> - event callback on receipt of a POSIX signal + +=item * + +L<IO::Async::PID> - event callback on exit of a child process + +=item * + +L<IO::Async::Process> - 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<Notifier> +subclasses, such as C<Handle>s and C<Timers>, but no particular object is +suitable to be the root of a tree. In this case, a plain C<Notifier> 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<isa> 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<IO::Async::Notifier> 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<IO::Async::Notifier>, suitable to be added to an C<IO::Async::Loop>. + + 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<configure> and C<make_event_cb> or C<invoke_event> +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<invoke_error>. + +=cut + +=head1 PARAMETERS + +A specific subclass of C<IO::Async::Notifier> defines named parameters that +control its behaviour. These may be passed to the C<new> constructor, or to +the C<configure> 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<notifier_name> method. + +=back + +=cut + +=head1 CONSTRUCTOR + +=cut + +=head2 $notifier = IO::Async::Notifier->new( %params ) + +This function returns a new instance of a C<IO::Async::Notifier> object with +the given initial values of the named parameters. + +Up until C<IO::Async> version 0.19, this module used to implement the IO +handle features now found in the C<IO::Async::Handle> subclass. Code that +needs to use any of C<handle>, C<read_handle>, C<write_handle>, +C<on_read_ready> or C<on_write_ready> should use L<IO::Async::Handle> 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 $notifier->configure( %params ) + +Adjust the named parameters of the C<Notifier> 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 = $notifier->loop + +Returns the C<IO::Async::Loop> 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 $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 $f = $notifier->adopt_future( $f ) + +Stores a reference to the L<Future> 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<invoke_error> method will be informed. + +This means that if the notifier does not provide an C<on_error> 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<else_done> 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; +} + +=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 +C<accept()>ed from a listening socket. To facilitate these, a notifier may +contain child notifier objects, that are automatically added to or removed +from the C<IO::Async::Loop> that manages their parent. + +=cut + +=head2 $parent = $notifier->parent + +Returns the parent of the notifier, or C<undef> if does not have one. + +=cut + +sub parent +{ + my $self = shift; + return $self->{IO_Async_Notifier__parent}; +} + +=head2 @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 $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 $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 ) { + 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 $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<IO::Async::Notifier> 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 $notifier->_init( $paramsref ) + +This method is called by the constructor just before calling C<configure>. +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 C<delete>d from the hash. + +=cut + +sub _init +{ + # empty default +} + +=head2 $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<delete> from the C<%params> hash any keys it has dealt +with, then pass the remaining ones to the C<SUPER::configure>. The base +class implementation will throw an exception if there are any unrecognised +keys remaining. + +=cut + +=head2 $notifier->configure_unknown( %params ) + +This method is called by the base class C<configure> method, for any remaining +parameters that are not recognised. The default implementation throws an +exception using C<Carp> 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 $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 $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 $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<undef>. 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<curry> +and C<curry::weak>. + +=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 $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 $code = $notifier->can_event( $event_name ) + +Returns a C<CODE> reference if the object can perform the given event name, +either by a configured C<CODE> reference parameter, or by implementing a +method. If the object is unable to handle this event, C<undef> is returned. + +=cut + +sub can_event +{ + my $self = shift; + my ( $event_name ) = @_; + + return $self->{$event_name} || $self->can( $event_name ); +} + +=head2 $callback = $notifier->make_event_cb( $event_name ) + +Returns a C<CODE> reference which, when invoked, will execute the given event +handler. Event handlers may either be subclass methods, or parameters given to +the C<new> or C<configure> method. + +The event handler can be passed extra arguments by giving them to the C<CODE> +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<CODE> 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 $callback = $notifier->maybe_make_event_cb( $event_name ) + +Similar to C<make_event_cb> but will return C<undef> 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 @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<new> or +C<configure> 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 $retref = $notifier->maybe_invoke_event( $event_name, @args ) + +Similar to C<invoke_event> but will return C<undef> 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<undef>, 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 $notifier->debug_printf( $format, @args ) + +Conditionally print a debugging message to C<STDERR> if debugging is enabled. +If such a message is printed, it will be printed using C<printf> using the +given format and arguments. The message will be prefixed with an 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<notifier_name> +parameter has that name appended in braces. + +For example, invoking + + $stream->debug_printf( "EVENT on_read" ) + +On an C<IO::Async::Stream> instance reading and writing a file descriptor +whose C<fileno> is 4, which is a child of an C<IO::Async::Protocol::Stream>, +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 $notifier->invoke_error( $message, $name, @details ) + +Invokes the stored C<on_error> 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<die()> 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<Future> +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 <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/OS.pm b/lib/IO/Async/OS.pm new file mode 100644 index 0000000..db16138 --- /dev/null +++ b/lib/IO/Async/OS.pm @@ -0,0 +1,599 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::OS; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +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 IO::Socket (); # empty import + +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; + +# Do we have IO::Socket::IP available? +use constant HAVE_IO_SOCKET_IP => defined eval { require IO::Socket::IP }; + +# 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<IO::Async::OS> - operating system abstractions for C<IO::Async> + +=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<HAVE_> 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<fork()> 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<IO_ASYNC_NO_FORK>. + +=item * HAVE_THREADS + +True if C<ithreads> are available, meaning that the C<threads> 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<IO_ASYNC_NO_THREADS>. + +=back + +=cut + +=head2 $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<inet>, C<inet6> and +C<unix> will be converted to the appropriate C<AF_*> 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 socktype name '$name'"; +} + +=head2 $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<stream>, C<dgram> and +C<raw> will be converted to the appropriate C<SOCK_*> 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 +sub socket +{ + my $self = shift; + my ( $family, $socktype, $proto ) = @_; + + 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; + + defined $proto or $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 ( $S1, $S2 ) = IO::Async::OS->socketpair( $family, $socktype, $proto ) + +An abstraction of the C<socketpair(2)> syscall, where any argument may be +missing (or given as C<undef>). + +If C<$family> is not provided, a suitable value will be provided by the OS +(likely C<AF_UNIX> on POSIX-based platforms). If C<$socktype> is not provided, +then C<SOCK_STREAM> will be used. + +Additionally, this method supports building connected C<SOCK_STREAM> or +C<SOCK_DGRAM> pairs in the C<AF_INET> family even if the underlying platform's +C<socketpair(2)> does not, by connecting two normal sockets together. + +C<$family> and C<$socktype> may also be given symbolically as defined by +C<getfamilybyname> and C<getsocktypebyname>. + +=cut + +sub socketpair +{ + my $self = shift; + my ( $family, $socktype, $proto ) = @_; + + # 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 ( $rd, $wr ) = IO::Async::OS->pipepair + +An abstraction of the C<pipe(2)> syscall, which returns the two new handles. + +=cut + +sub pipepair +{ + my $self = shift; + + pipe( my ( $rd, $wr ) ) or return; + return ( $rd, $wr ); +} + +=head2 ( $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<socketpair(2)>, 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 C<IO::Async::Stream> or subclass of it, the C<read_handle> +and C<write_handle> parameters should always be used. + + my ( $childRd, $myWr, $myRd, $childWr ) = IO::Async::OS->pipequad; + + IO::Async::OS->open_child( + stdin => $childRd, + stdout => $childWr, + ... + ); + + my $str = IO::Async::Stream->new( + read_handle => $myRd, + write_handle => $myWr, + ... + ); + IO::Async::OS->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 $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<POSIX::SigSet> or use +in other places which use numbers instead of symbolic names. + +=cut + +my %sig_num; +sub _init_signum +{ + my $self = shift; + # Copypasta from Config.pm's documentation + + our %Config; + require Config; + Config->import; + + unless($Config{sig_name} && $Config{sig_num}) { + die "No signals found"; + } + else { + my @names = split ' ', $Config{sig_name}; + @sig_num{@names} = split ' ', $Config{sig_num}; + } +} + +sub signame2num +{ + my $self = shift; + my ( $signame ) = @_; + + %sig_num or $self->_init_signum; + + return $sig_num{$signame}; +} + +=head2 ( $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<socket> call and an +address suitable for C<connect> or C<bind>. + +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<getfamilybyname>. + +The socktype may also be given as a symbolic string; C<stream>, C<dgram> or +C<raw>; this will be converted to the appropriate C<SOCK_*> constant. + +Note that the C<addr> field, if provided, must be a packed socket address, +such as returned by C<pack_sockaddr_in> or C<pack_sockaddr_un>. + +If the HASH form is used, rather than passing a packed socket address in the +C<addr> 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<ip> and C<port>. +If C<ip> is missing it will be set to "0.0.0.0". If C<port> 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<ip> and C<port>. +If C<ip> is missing it will be set to "::". If C<port> is missing it will be +set to 0. Optionally will also include values from C<scopeid> and C<flowinfo> +keys if provided. + +This will only work if a C<pack_sockaddr_in6> function can be found in +C<Socket> + +=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<path>. + +=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 + +=head1 LOOP IMPLEMENTATION METHODS + +The following methods are provided on C<IO::Async::OS> because they are likely +to require OS-specific implementations, but are used by L<IO::Async::Loop> to +implement its functionality. It can use the HASH reference C<< $loop->{os} >> +to store other data it requires. + +=cut + +=head2 IO::Async::OS->loop_watch_signal( $loop, $signal, $code ) + +=head2 IO::Async::OS->loop_unwatch_signal( $loop, $signal ) + +Used to implement the C<watch_signal> / C<unwatch_signal> Loop pair. + +=cut + +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; + unless( $sigpipe = $loop->{os}{sigpipe} ) { + require IO::Async::Handle; + + ( my $reader, $sigpipe ) = $self->pipepair or croak "Cannot pipe() - $!"; + $_->blocking( 0 ) for $reader, $sigpipe; + + $loop->{os}{sigpipe} = $sigpipe; + + $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}; + } + }, + ) ); + } + + 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 @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; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/OS/MSWin32.pm b/lib/IO/Async/OS/MSWin32.pm new file mode 100644 index 0000000..bfed7f7 --- /dev/null +++ b/lib/IO/Async/OS/MSWin32.pm @@ -0,0 +1,111 @@ +# 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; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +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<IO::Async::OS::MSWin32> - operating system abstractions on C<MSWin32> for C<IO::Async> + +=head1 DESCRIPTION + +This module contains OS support code for C<MSWin32>. + +See instead L<IO::Async::OS>. + +=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 <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/OS/cygwin.pm b/lib/IO/Async/OS/cygwin.pm new file mode 100644 index 0000000..630bf9a --- /dev/null +++ b/lib/IO/Async/OS/cygwin.pm @@ -0,0 +1,40 @@ +# 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 -- leonerd@leonerd.org.uk + +package IO::Async::OS::cygwin; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +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<IO::Async::OS::cygwin> - operating system abstractions on C<cygwin> for C<IO::Async> + +=head1 DESCRIPTION + +This module contains OS support code for C<cygwin>. + +See instead L<IO::Async::OS>. + +=cut + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/OS/linux.pm b/lib/IO/Async/OS/linux.pm new file mode 100644 index 0000000..c12949b --- /dev/null +++ b/lib/IO/Async/OS/linux.pm @@ -0,0 +1,59 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::OS::linux; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +our @ISA = qw( IO::Async::OS::_Base ); + +=head1 NAME + +C<IO::Async::OS::linux> - operating system abstractions on C<Linux> for C<IO::Async> + +=head1 DESCRIPTION + +This module contains OS support code for C<Linux>. + +See instead L<IO::Async::OS>. + +=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 <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/PID.pm b/lib/IO/Async/PID.pm new file mode 100644 index 0000000..fc59f9c --- /dev/null +++ b/lib/IO/Async/PID.pm @@ -0,0 +1,196 @@ +# 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-2011 -- leonerd@leonerd.org.uk + +package IO::Async::PID; + +use strict; +use warnings; +use base qw( IO::Async::Notifier ); + +our $VERSION = '0.67'; + +use Carp; + +=head1 NAME + +C<IO::Async::PID> - 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<IO::Async::Notifier> invokes its callback when a process +exits. + +For most use cases, a L<IO::Async::Process> 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<new> or C<configure>: + +=head2 pid => INT + +The process ID to watch. Must be given before the object has been added to the +containing C<IO::Async::Loop> object. + +=head2 on_exit => CODE + +CODE reference for the C<on_exit> event. + +Once the C<on_exit> continuation has been invoked, the C<IO::Async::PID> +object is removed from the containing C<IO::Async::Loop> 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_child( $self->pid, $self->{cb} ); +} + +sub _remove_from_loop +{ + my $self = shift; + my ( $loop ) = @_; + + $loop->unwatch_child( $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 $process_id = $pid->pid + +Returns the underlying process ID + +=cut + +sub pid +{ + my $self = shift; + return $self->{pid}; +} + +=head2 $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 <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Process.pm b/lib/IO/Async/Process.pm new file mode 100644 index 0000000..31c70d5 --- /dev/null +++ b/lib/IO/Async/Process.pm @@ -0,0 +1,849 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Process; + +use strict; +use warnings; +use base qw( IO::Async::Notifier ); + +our $VERSION = '0.67'; + +use Carp; + +use Socket qw( SOCK_STREAM ); + +use Future; + +use IO::Async::OS; + +=head1 NAME + +C<IO::Async::Process> - 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; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Notifier> starts a child process, and invokes a +callback when it exits. The child process can either execute a given block of +code (via C<fork(2)>), 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<exit(2)> +syscall from a process, or C<return>ing 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<code>, or by failing to +C<exec(2)> the given command. C<$errno> will be a dualvar, containing both +number and string values. After a successful C<exec()> call, this condition +can no longer happen. + +Note that this has a different name and a different argument order from +C<< Loop->open_child >>'s C<on_error>. + +If this is not provided and the process exits with an exception, then +C<on_finish> is invoked instead, being passed just the exit code. + +Since this is just the results of the underlying C<< $loop->spawn_child >> +C<on_exit> 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, $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 $process = IO::Async::Process->new( %args ) + +Constructs a new C<IO::Async::Process> object and returns it. + +Once constructed, the C<Process> will need to be added to the C<Loop> 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<new> or C<configure>: + +=head2 on_finish => CODE + +=head2 on_exception => CODE + +CODE reference for the event handlers. + +Once the C<on_finish> continuation has been invoked, the C<IO::Async::Process> +object is removed from the containing C<IO::Async::Loop> object. + +The following parameters may be passed to C<new>, or to C<configure> before +the process has been started (i.e. before it has been added to the C<Loop>). +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<exec(2)> function. + +=head2 code => CODE + +A block of code to execute in the child process. It will be called in scalar +context inside an C<eval> block. + +=head2 setup => ARRAY + +Optional reference to an array to pass to the underlying C<Loop> +C<spawn_child> method. + +=head2 fdI<n> => HASH + +A hash describing how to set up file descriptor I<n>. 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<pipe(2)>; the parent may read +from the other. + +=item pipe_write + +The child will be given the reading end of a C<pipe(2)>; the parent may write +to the other. Since an EOF condition of this kind of handle cannot reliably be +detected, C<on_finish> will not wait for this type of pipe to be closed. + +=item pipe_rdwr + +Only valid on the C<stdio> filehandle. The child will be given the reading end +of one C<pipe(2)> 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<socketpair(2)>; the parent will be +given the other. The family of this socket may be given by the extra key +called C<family>; defaulting to C<unix>. The socktype of this socket may be +given by the extra key called C<socktype>; defaulting to C<stream>. If the +type is not C<SOCK_STREAM> then a L<IO::Async::Socket> object will be +constructed for the parent side of the handle, rather than +C<IO::Async::Stream>. + +=back + +Once the filehandle is set up, the C<fd> method (or its shortcuts of C<stdin>, +C<stdout> or C<stderr>) may be used to access the +C<IO::Async::Handle>-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 C<IO::Async::Stream> using this C<on_read> 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<from> parameter will be written to the child. When all of the data has been +written the pipe will be closed. + +=back + +=head2 stdin => ... + +=head2 stdout => ... + +=head2 stderr => ... + +Shortcuts for C<fd0>, C<fd1> and C<fd2> 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 ); + } + + 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() - $!"; + + $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() - $!"; + $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() - $!"; + + $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() - $!"; + + $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}; + + $self->{finish_future} = Future->needs_all( @$finish_futures ) + ->on_done( $self->_capture_weakself( sub { + my $self = shift or return; + + $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 ); + } + + $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 $pid = $process->pid + +Returns the process ID of the process, if it has been started, or C<undef> if +not. Its value is preserved after the process exits, so it may be inspected +during the C<on_finish> or C<on_exception> events. + +=cut + +sub pid +{ + my $self = shift; + return $self->{pid}; +} + +=head2 $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 $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 $exited = $process->is_exited + +Returns true if the Process has finished running, and finished due to normal +C<exit(2)>. + +=cut + +sub is_exited +{ + my $self = shift; + return defined $self->{exitcode} ? ( $self->{exitcode} & 0x7f ) == 0 : undef; +} + +=head2 $status = $process->exitstatus + +If the process exited due to normal C<exit(2)>, returns the value that was +passed to C<exit(2)>. Otherwise, returns C<undef>. + +=cut + +sub exitstatus +{ + my $self = shift; + return defined $self->{exitcode} ? ( $self->{exitcode} >> 8 ) : undef; +} + +=head2 $exception = $process->exception + +If the process exited due to an exception, returns the exception that was +thrown. Otherwise, returns C<undef>. + +=cut + +sub exception +{ + my $self = shift; + return $self->{dollarat}; +} + +=head2 $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<undef>. + +=cut + +sub errno +{ + my $self = shift; + return $self->{dollarbang}+0; +} + +=head2 $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<undef>. + +=cut + +sub errstr +{ + my $self = shift; + return $self->{dollarbang}.""; +} + +=head2 $stream = $process->fd( $fd ) + +Returns the L<IO::Async::Stream> or L<IO::Async::Socket> associated with the +given FD number. This must have been set up by a C<configure> argument prior +to adding the C<Process> object to the C<Loop>. + +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<write> method on, to write more data into the +child, or to set an C<on_read> handler to read data out of the child. + +The C<on_closed> event for these streams must not be changed, or it will break +the close detection used by the C<Process> object and the C<on_finish> 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 $stream = $process->stdin + +=head2 $stream = $process->stdout + +=head2 $stream = $process->stderr + +=head2 $stream = $process->stdio + +Shortcuts for calling C<fd> with 0, 1, 2 or C<io> respectively, to obtain the +L<IO::Async::Stream> 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<stdout> filehandle of the process using the C<into> 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 { + print "The process has finished, and wrote:\n"; + print $stdout; + } + ); + + $loop->add( $process ); + +Note that until C<on_finish> 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<run_child> method of L<IO::Async::Loop>. + +To handle data more interactively as it arrives, the C<on_read> 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<configure> +method on the C<stdout> filestream at some point before it gets added to the +Loop. In this case, C<stdin> should be configured using C<pipe_read> in the +C<via> 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<stdin> filehandle of the process using the C<from> key, +data can be written into the C<STDIN> 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<STDIN> before it exits. + +To have the ability to write more data into the process once it has started. +the C<write> method on the C<stdin> stream can be used, when it is configured +using the C<pipe_write> value for C<via>: + + 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" ); + +=cut + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Protocol.pm b/lib/IO/Async/Protocol.pm new file mode 100644 index 0000000..c155963 --- /dev/null +++ b/lib/IO/Async/Protocol.pm @@ -0,0 +1,259 @@ +# 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 -- leonerd@leonerd.org.uk + +package IO::Async::Protocol; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Notifier ); + +use Carp; + +=head1 NAME + +C<IO::Async::Protocol> - base class for transport-based protocols + +=head1 DESCRIPTION + +This subclass of L<IO::Async:Notifier> provides storage for a +L<IO::Async::Handle> 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<IO::Async::SSLStream> 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<IO::Async::Protocol::Stream> - 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<new> or C<configure>: + +=head2 transport => IO::Async::Handle + +The C<IO::Async::Handle> to delegate communications to. + +=head2 on_closed => CODE + +CODE reference for the C<on_closed> event. + +When a new C<transport> object is given, it will be configured by calling the +C<setup_transport> 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<teardown_transport>. + +=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 = $protocol->transport + +Returns the stored transport object + +=cut + +sub transport +{ + my $self = shift; + return $self->{transport}; +} + +=head2 $protocol->connect( %args ) + +Sets up a connection to a peer, and configures the underlying C<transport> 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<SOCK_STREAM> then C<on_stream> +continuation will be used; otherwise C<on_socket> 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<configure>), and the C<on_connected> callback will be +invoked. This is provided as a convenient shortcut. + +=back + +Other arguments will be passed to the underlying C<IO::Async::Loop> C<connect> +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<IO::Async::Protocol> 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 $protocol->setup_transport( $transport ) + +Called by C<configure> when a new C<transport> 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 $protocol->teardown_transport( $transport ) + +The reverse of C<setup_transport>; called by C<configure> 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 <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Protocol/LineStream.pm b/lib/IO/Async/Protocol/LineStream.pm new file mode 100644 index 0000000..f6148e9 --- /dev/null +++ b/lib/IO/Async/Protocol/LineStream.pm @@ -0,0 +1,138 @@ +# 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 -- leonerd@leonerd.org.uk + +package IO::Async::Protocol::LineStream; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Protocol::Stream ); + +use Carp; + +=head1 NAME + +C<IO::Async::Protocol::LineStream> - 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<new> or C<configure>: + +=head2 on_read_line => CODE + +CODE reference for the C<on_read_line> 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 $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 <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Protocol/Stream.pm b/lib/IO/Async/Protocol/Stream.pm new file mode 100644 index 0000000..11d1144 --- /dev/null +++ b/lib/IO/Async/Protocol/Stream.pm @@ -0,0 +1,237 @@ +# 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-2013 -- leonerd@leonerd.org.uk + +package IO::Async::Protocol::Stream; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Protocol ); + +use Carp; + +=head1 NAME + +C<IO::Async::Protocol::Stream> - 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<IO::Async::Protocol> is intended to stand as a base class +for implementing stream-based protocols. It provides an interface similar to +L<IO::Async::Stream>, primarily, a C<write> method and an C<on_read> event +handler. + +It contains an instance of an C<IO::Async::Stream> 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<IO::Async::SSLStream> to allow the protocol to be used over +SSL. + +As with C<IO::Async::Stream>, it is required that by the time the protocol +object is added to a Loop, that it either has an C<on_read> method, or has +been configured with an C<on_read> 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 C<IO::Async::Stream>. + +=head2 on_closed + +The C<on_closed> handler is optional, but if provided, will be invoked after +the stream is closed by either side (either because the C<close()> method has +been invoked on it, or on an incoming EOF). + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=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 +C<IO::Async::Stream> object. If this argument is provided without a +C<transport> object, a new C<IO::Async::Stream> 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 $protocol->write( $data ) + +Writes the given data by calling the C<write> 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 $protocol->connect( %args ) + +Sets up a connection to a peer, and configures the underlying C<transport> for +the Protocol. Calls C<IO::Async::Protocol> C<connect> with C<socktype> set to +C<"stream">. + +=cut + +sub connect +{ + my $self = shift; + $self->SUPER::connect( + @_, + socktype => "stream", + ); +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Resolver.pm b/lib/IO/Async/Resolver.pm new file mode 100644 index 0000000..10c0a15 --- /dev/null +++ b/lib/IO/Async/Resolver.pm @@ -0,0 +1,689 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Resolver; + +use strict; +use warnings; +use 5.010; +use base qw( IO::Async::Function ); + +our $VERSION = '0.67'; + +# 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::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<IO::Async::Resolver> - performing name resolutions asynchronously + +=head1 SYNOPSIS + +This object is used indirectly via an C<IO::Async::Loop>: + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + $loop->resolver->getaddrinfo( + host => "www.example.com", + service => "http", + )->on_done( sub { + foreach my $addr ( @_ ) { + printf "http://www.example.com can be reached at " . + "socket(%d,%d,%d) + connect('%v02x')\n", + @{$addr}{qw( family socktype protocol addr )}; + } + }); + + $loop->resolve( type => 'getpwuid', data => [ $< ] ) + ->on_done( sub { + print "My passwd ent: " . join( "|", @_ ) . "\n"; + }); + + $loop->run; + +=head1 DESCRIPTION + +This module extends an C<IO::Async::Loop> 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 C<IO::Async::Function> 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<workers> argument to the constructor. + +The C<idle_timeout> parameter for the underlying C<IO::Async::Function> object +is set to a default of 30 seconds, and C<min_workers> 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->{code} = sub { + 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'"; + } + }; + + $params->{idle_timeout} = 30; + $params->{min_workers} = 0; + + $started = 1; +} + +=head1 METHODS + +The following methods documented with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +=head2 @result = $loop->resolve( %params )->get + +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<type>; 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 + +=head2 $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" ) { + $type = "getaddrinfo_hash"; + } + + 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; + + my $future = $self->call( + args => [ $type, $timeout, @{$args{data}} ], + ); + + $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 @addrs = $resolver->getaddrinfo( %args )->get + +A shortcut wrapper around the C<getaddrinfo> 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<getaddrinfo(3)> function. See the C<AI_*> constants in +L<Socket>'s C<getaddrinfo> function for more detail. + +=item passive => BOOL + +If true, sets the C<AI_PASSIVE> flag. This is provided as a convenience to +avoid the caller from having to import the C<AI_PASSIVE> constant from +C<Socket>. + +=item timeout => NUMBER + +Time in seconds after which to abort the lookup with a C<Timed out> 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<family>, +C<socktype>, C<protocol> and C<addr>. If requested by C<AI_CANONNAME> then the +C<canonname> field will also be present. + +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<AI_NUMERICHOST> flag. If this gives an C<EAI_NONAME> error, then +the lookup is performed asynchronously instead. + +=head2 $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_hash", + data => [ + host => $host, + service => $service, + flags => $flags, + map { exists $args{$_} ? ( $_ => $args{$_} ) : () } qw( family socktype protocol ), + ], + timeout => $args{timeout}, + )->else( sub { + my $message = shift; + Future->fail( $message, resolve => getaddrinfo => @_ ); + }); + + $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 ( $host, $service ) = $resolver->getnameinfo( %args )->get + +A shortcut wrapper around the C<getnameinfo> 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<getnameinfo(3)> function. See the C<NI_*> constants in +L<Socket>'s C<getnameinfo> for more detail. + +=item numerichost => BOOL + +=item numericserv => BOOL + +=item dgram => BOOL + +If true, set the C<NI_NUMERICHOST>, C<NI_NUMERICSERV> or C<NI_DGRAM> flags. + +=item numeric => BOOL + +If true, sets both C<NI_NUMERICHOST> and C<NI_NUMERICSERV> flags. + +=item timeout => NUMBER + +Time in seconds after which to abort the lookup with a C<Timed out> exception + +=back + +As a specific optimisation, this method will try to perform a lookup of +numeric values synchronously, rather than asynchronously, if both the +C<NI_NUMERICHOST> and C<NI_NUMERICSERV> flags are given. + +=head2 $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 + )->else( sub { + my $message = shift; + Future->fail( $message, resolve => getnameinfo => @_ ); + }); + + $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( $name, $code ) + +Registers a new named resolver function that can be called by the C<resolve> +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<type> argument to the C<resolve> 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<data> argument to +the C<resolve> method. The returned list will be passed to the +C<on_resolved> callback. If the code throws an exception at call time, it will +be passed to the C<on_error> continuation. If it returns normally, the list of +values it returns will be passed to C<on_resolved>. + +=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<Socket> module. + + getaddrinfo_hash + getaddrinfo_array + getnameinfo + +The C<getaddrinfo_hash> resolver takes arguments in a hash of name/value pairs +and returns a list of hash structures, as the C<Socket::getaddrinfo> function +does. For neatness it takes all its arguments as named values; taking the host +and service names from arguments called C<host> and C<service> respectively; +all the remaining arguments are passed into the hints hash. This name is also +aliased as simply C<getaddrinfo>. + +The C<getaddrinfo_array> resolver behaves more like the C<Socket6> 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<family> argument, converting C<inet> and possibly +C<inet6> into the appropriate C<AF_*> value, and for the C<socktype> argument, +converting C<stream>, C<dgram> or C<raw> into the appropriate C<SOCK_*> value. + +The C<getnameinfo> resolver returns its result in the same form as C<Socket>. + +Because this module simply uses the system's C<getaddrinfo> 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_hash => 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\n" 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\n" 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\n" 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 +C<IO::Async::Resolver> 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 TODO + +=over 4 + +=item * + +Look into (system-specific) ways of accessing asynchronous resolvers directly + +=back + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Routine.pm b/lib/IO/Async/Routine.pm new file mode 100644 index 0000000..f9a5a3b --- /dev/null +++ b/lib/IO/Async/Routine.pm @@ -0,0 +1,436 @@ +# 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::Routine; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Notifier ); + +use Carp; + +use IO::Async::OS; +use IO::Async::Process; + +=head1 NAME + +C<IO::Async::Routine> - 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<IO::Async::Notifier> 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<IO::Async::Channel> objects. + +A choice of detachment model is available, with options being a C<fork()>ed +child process, or a thread. In both cases 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 C<IO::Async>-based program. + +Code running inside a C<fork()>-based Routine runs within its own process; it +is isolated from the rest of the program in terms of memory, CPU time, and +other resources. Code running in a thread-based Routine however, shares memory +and other resources such as open filehandles with the main thread. + +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<IO::Async::Function> instead, which uses an +C<IO::Async::Routine> to contain the body of the function and manages the +Channels itself. + +=cut + +=head1 EVENTS + +=head2 on_finish $exitcode + +For C<fork()>-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<on_joined> result. + +As the behaviour of these events differs per model, it may be more convenient +to use C<on_return> and C<on_die> instead. + +=head2 on_return $result + +Invoked if the code block returns normally. Note that C<fork()>-based Routines +can only transport an integer result between 0 and 255, as this is the actual +C<exit()> 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<new> or C<configure>: + +=head2 model => "fork" | "thread" + +Optional. Defines how the routine will detach itself from the main process. +C<fork> uses a child process detached using an L<IO::Async::Process>. +C<thread> uses a thread, and is only available on threaded Perls. + +If the model is not specified, the environment variable +C<IO_ASYNC_ROUTINE_MODEL> is used to pick a default. If that isn't defined, +C<fork> is preferred if it is available, otherwise C<thread>. + +=head2 channels_in => ARRAY of IO::Async::Channel + +ARRAY reference of C<IO::Async::Channel> objects to set up for passing values +in to the Routine. + +=head2 channels_out => ARRAY of IO::Async::Channel + +ARRAY reference of C<IO::Async::Channel> 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. + +=head2 setup => ARRAY + +Optional. For C<fork()>-based Routines, gives a reference to an array to pass +to the underlying C<Loop> C<fork_child> 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( @_ ); +} + +sub configure +{ + my $self = shift; + my %params = @_; + + # TODO: Can only reconfigure when not running + foreach (qw( channels_in channels_out code setup on_finish on_return on_die )) { + $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + if( defined( my $model = delete $params{model} ) ) { + $model eq "fork" or $model eq "thread" or + croak "Expected 'model' to be either 'fork' or 'thread'"; + + $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 ); + + return $self->_setup_fork if $self->{model} eq "fork"; + return $self->_setup_thread if $self->{model} eq "thread"; + + die "TODO: unrecognised Routine model $self->{model}"; +} + +sub _setup_fork +{ + my $self = shift; + + my @setup; + my @channels_in; + my @channels_out; + + foreach my $ch ( @{ $self->{channels_in} || [] } ) { + my ( $rd, $wr ); + unless( $rd = $ch->_extract_read_handle ) { + ( $rd, $wr ) = IO::Async::OS->pipepair; + } + push @setup, $rd => "keep"; + push @channels_in, [ $ch, $wr, $rd ]; + } + + foreach my $ch ( @{ $self->{channels_out} || [] } ) { + my ( $rd, $wr ); + unless( $wr = $ch->_extract_write_handle ) { + ( $rd, $wr ) = IO::Async::OS->pipepair; + } + push @setup, $wr => "keep"; + push @channels_out, [ $ch, $rd, $wr ]; + } + + my $code = $self->{code}; + + my $setup = $self->{setup}; + push @setup, @$setup if $setup; + + my $process = IO::Async::Process->new( + setup => \@setup, + code => sub { + foreach ( @channels_in ) { + my ( $ch, undef, $rd ) = @$_; + $ch->setup_sync_mode( $rd ); + } + foreach ( @channels_out ) { + my ( $ch, undef, $wr ) = @$_; + $ch->setup_sync_mode( $wr ); + } + + my $ret = $code->(); + + foreach ( @channels_in, @channels_out ) { + my ( $ch ) = @$_; + $ch->close; + } + + return $ret; + }, + on_finish => $self->_replace_weakself( sub { + my $self = shift or return; + my ( $exitcode ) = @_; + $self->maybe_invoke_event( on_finish => $exitcode ); + + $self->maybe_invoke_event( on_return => ($exitcode >> 8) ) unless $exitcode & 0x7f; + }), + on_exception => $self->_replace_weakself( sub { + my $self = shift or return; + my ( $exception, $errno, $exitcode ) = @_; + + $self->maybe_invoke_event( on_die => $exception ); + }), + ); + + foreach ( @channels_in ) { + my ( $ch, $wr ) = @$_; + + $ch->setup_async_mode( write_handle => $wr ); + + $self->add_child( $ch ) unless $ch->parent; + } + + foreach ( @channels_out ) { + my ( $ch, $rd ) = @$_; + + $ch->setup_async_mode( read_handle => $rd ); + + $self->add_child( $ch ) unless $ch->parent; + } + + $self->add_child( $self->{process} = $process ); + $self->{id} = "P" . $process->pid; + + foreach ( @channels_in, @channels_out ) { + my ( undef, undef, $other ) = @$_; + $other->close; + } +} + +sub _setup_thread +{ + my $self = shift; + + my @channels_in; + my @channels_out; + + foreach my $ch ( @{ $self->{channels_in} || [] } ) { + my ( $rd, $wr ); + unless( $rd = $ch->_extract_read_handle ) { + ( $rd, $wr ) = IO::Async::OS->pipepair; + } + push @channels_in, [ $ch, $wr, $rd ]; + } + + foreach my $ch ( @{ $self->{channels_out} || [] } ) { + my ( $rd, $wr ); + unless( $wr = $ch->_extract_write_handle ) { + ( $rd, $wr ) = IO::Async::OS->pipepair; + } + push @channels_out, [ $ch, $rd, $wr ]; + } + + my $code = $self->{code}; + + my $tid = $self->loop->create_thread( + code => sub { + foreach ( @channels_in ) { + my ( $ch, $wr, $rd ) = @$_; + $ch->setup_sync_mode( $rd ); + $wr->close if $wr; + } + foreach ( @channels_out ) { + my ( $ch, $rd, $wr ) = @$_; + $ch->setup_sync_mode( $wr ); + $rd->close if $rd; + } + + my $ret = $code->(); + + foreach ( @channels_in, @channels_out ) { + my ( $ch ) = @$_; + $ch->close; + } + + return $ret; + }, + on_joined => $self->_capture_weakself( sub { + my $self = shift or return; + my ( $ev, @result ) = @_; + $self->maybe_invoke_event( on_finish => @_ ); + + $self->maybe_invoke_event( on_return => @result ) if $ev eq "return"; + $self->maybe_invoke_event( on_die => $result[0] ) if $ev eq "died"; + + delete $self->{tid}; + }), + ); + + $self->{tid} = $tid; + $self->{id} = "T" . $tid; + + foreach ( @channels_in ) { + my ( $ch, $wr, $rd ) = @$_; + + $ch->setup_async_mode( write_handle => $wr ); + $rd->close; + + $self->add_child( $ch ) unless $ch->parent; + } + + foreach ( @channels_out ) { + my ( $ch, $rd, $wr ) = @$_; + + $ch->setup_async_mode( read_handle => $rd ); + $wr->close; + + $self->add_child( $ch ) unless $ch->parent; + } +} + +=head1 METHODS + +=cut + +=head2 $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 = $routine->model + +Returns the detachment model in use by the Routine. + +=cut + +sub model +{ + my $self = shift; + return $self->{model}; +} + +=head2 $routine->kill( $signal ) + +Sends the specified signal to the routine code. This is either implemented by +C<CORE::kill()> or C<threads::kill> 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"; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Signal.pm b/lib/IO/Async/Signal.pm new file mode 100644 index 0000000..4ef68f5 --- /dev/null +++ b/lib/IO/Async/Signal.pm @@ -0,0 +1,150 @@ +# 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-2011 -- leonerd@leonerd.org.uk + +package IO::Async::Signal; + +use strict; +use warnings; +use base qw( IO::Async::Notifier ); + +our $VERSION = '0.67'; + +use Carp; + +=head1 NAME + +C<IO::Async::Signal> - 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<IO::Async::Notifier> invokes its callback when a particular +POSIX signal is received. + +Multiple objects can be added to a C<Loop> 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<new> or C<configure>: + +=head2 name => STRING + +The name of the signal to watch. This should be a bare name like C<TERM>. Can +only be given at construction time. + +=head2 on_receipt => CODE + +CODE reference for the C<on_receipt> event. + +Once constructed, the C<Signal> will need to be added to the C<Loop> 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 <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Socket.pm b/lib/IO/Async/Socket.pm new file mode 100644 index 0000000..23a4973 --- /dev/null +++ b/lib/IO/Async/Socket.pm @@ -0,0 +1,358 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Socket; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Handle ); + +use Errno qw( EAGAIN EWOULDBLOCK EINTR ); + +use Carp; + +=head1 NAME + +C<IO::Async::Socket> - event callbacks and send buffering for a socket +filehandle + +=head1 SYNOPSIS + + 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 ); + + $socket->connect( + host => "some.host.here", + service => "echo", + socktype => 'dgram', + )->get; + + $socket->send( "A TEST DATAGRAM" ); + + $loop->run; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Handle> contains a socket filehandle. It +provides a queue of outgoing data. It invokes the C<on_recv> handler when new +data is received from the filehandle. Data may be sent to the filehandle by +calling the C<send> method. + +It is primarily intended for C<SOCK_DGRAM> or C<SOCK_RAW> sockets (such as UDP +or packet-capture); for C<SOCK_STREAM> sockets (such as TCP) an instance of +L<IO::Async::Stream> 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<on_recv> 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<recv> method on the receiving handle fails. + +=head2 on_send_error $errno + +Optional. Invoked when the C<send> method on the sending handle fails. + +The C<on_recv_error> and C<on_send_error> handlers are passed the value of +C<$!> at the time the error occured. (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<close> 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<new> or C<configure>: + +=head2 read_handle => IO + +The IO handle to receive from. Must implement C<fileno> and C<recv> methods. + +=head2 write_handle => IO + +The IO handle to send to. Must implement C<fileno> and C<send> 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<send> 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<recv> calls. Defaults to 64 KiB. + +=head2 recv_all => BOOL + +Optional. If true, repeatedly call C<recv> 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<recv_all> option, but for sending. When +C<autoflush> is enabled, this option only affects deferred sending if the +initial attempt failed. + +The condition requiring an C<on_recv> handler is checked at the time the +object is added to a Loop; it is allowed to create a C<IO::Async::Socket> +object with a read handle but without a C<on_recv> handler, provided that +one is later given using C<configure> 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 $socket->send( $data, $flags, $addr ) + +This method adds a segment of data to be sent, or sends it immediately, +according to the C<autoflush> parameter. C<$flags> and C<$addr> are optional. + +If the C<autoflush> 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<autoflush> 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<UDP> is carried by the C<SOCK_DGRAM> socket type, for which the string +C<'dgram'> is a convenient shortcut: + + $socket->connect( + host => $hostname, + service => $service, + socktype => 'dgram', + ... + ) + +=head2 Receive-first on a UDP Socket + +A typical server pattern with C<UDP> involves binding a well-known port +number instead of connecting to one, and waiting on incoming packets. + + $socket->bind( + service => 12345, + socktype => 'dgram', + )->get; + +=head1 SEE ALSO + +=over 4 + +=item * + +L<IO::Handle> - Supply object methods for I/O handles + +=back + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Stream.pm b/lib/IO/Async/Stream.pm new file mode 100644 index 0000000..487eb38 --- /dev/null +++ b/lib/IO/Async/Stream.pm @@ -0,0 +1,1419 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Stream; + +use strict; +use warnings; +use 5.010; # // + +our $VERSION = '0.67'; + +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 IO::Async::Debug; + +# 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<IO::Async::Stream> - 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<IO::Async::Handle> contains a filehandle that represents +a byte-stream. It provides buffering for both incoming and outgoing data. It +invokes the C<on_read> handler when new data is read from the filehandle. Data +may be written to the filehandle by calling the C<write> 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<SOCK_STREAM> socket (such as TCP or a byte-oriented UNIX local socket). For +datagram or raw message-based sockets (such as UDP) see instead +L<IO::Async::Socket>. + +=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 is confident no more useful data remains, it should +return C<0>. If not, it should return C<1>, and the handler will be called +again. This makes it easy to implement code that handles multiple incoming +records at the same time. 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<on_read> 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<undef>. 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<push_on_read> method can be used to insert new, temporary handlers that +take precedence over the global C<on_read> handler. This event is only used if +there are no further pending handlers created by C<push_on_read>. + +=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<on_read> 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<write> +syscall returns the C<EPIPE> 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<sysread> method on the read handle fails. + +=head2 on_write_error $errno + +Optional. Invoked when the C<syswrite> method on the write handle fails. + +The C<on_read_error> and C<on_write_error> handlers are passed the value of +C<$!> at the time the error occured. (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<close> 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<on_writeable_start> is invoked by the +C<on_write_ready> event if previously it was known to be not writeable. +C<on_writeable_stop> is invoked after a C<syswrite> operation fails with +C<EAGAIN> or C<EWOULDBLOCK>. 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<on_writeable_stop>. + +=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<new> or C<configure>: + +=head2 read_handle => IO + +The IO handle to read from. Must implement C<fileno> and C<sysread> methods. + +=head2 write_handle => IO + +The IO handle to write to. Must implement C<fileno> and C<syswrite> 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<write> 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 +C<IO::Async> may enable this by default on STDOUT and STDERR. + +=head2 read_len => INT + +Optional. Sets the buffer size for C<read> 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<write> calls. Defaults to 8 KiBytes. + +=head2 write_all => BOOL + +Optional. Analogous to the C<read_all> option, but for writing. When +C<autoflush> 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<on_read_high_watermark> 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<on_read> handler the read buffer is now +smaller than the low watermark, the C<on_read_low_watermark> 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<push_on_read> method or one of the +Future-returning C<read_*> methods. + +By default these options are not defined, so this behaviour will not happen. +C<read_low_watermark> may not be set to a larger value than +C<read_high_watermark>, 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<on_read> 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<reader> by appending to it, +C<writer> by removing a prefix from it. Each is expected to return a true +value on success, zero on EOF, or C<undef> with C<$!> set for errors. If not +provided, they will be substituted by implenentations using C<sysread> and +C<syswrite> 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 C<close>d 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<write> method will expect to receive Unicode +strings and encodes them into bytes, and incoming bytes will be decoded into +Unicode strings for the C<on_read> event. + +If an encoding is not supplied then C<write> and C<on_read> will work in byte +strings. + +I<IMPORTANT NOTE:> in order to handle reads of UTF-8 content or other +multibyte encodings, the code implementing the C<on_read> event uses a feature +of L<Encode>; the C<STOP_AT_PARTIAL> 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<Encode> 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<on_read> event; data written using the +C<write> method does not rely on any undocumented features of C<Encode>. + +If a read handle is given, it is required that either an C<on_read> callback +reference is configured, or that the object provides an C<on_read> method. It +is optional whether either is true for C<on_outgoing_empty>; if neither is +supplied then no action will be taken when the writing buffer becomes empty. + +An C<on_read> 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<set_handles> +method. + +This condition is checked at the time the object is added to a Loop; it is +allowed to create a C<IO::Async::Stream> object with a read handle but without +a C<on_read> handler, provided that one is later given using C<configure> +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'; + } +} + +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 with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +=head2 $stream->want_readready_for_read( $set ) + +=head2 $stream->want_readready_for_write( $set ) + +Mutators for the C<want_readready> property on L<IO::Async::Handle>, which +control whether the C<read> or C<write> behaviour should be continued once the +filehandle becomes ready for read. + +Normally, C<want_readready_for_read> is always true (though the read watermark +behaviour can modify it), and C<want_readready_for_write> is not used. +However, if a custom C<writer> 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 $stream->want_writeready_for_write( $set ) + +=head2 $stream->want_writeready_for_read( $set ) + +Mutators for the C<want_writeready> property on L<IO::Async::Handle>, which +control whether the C<write> or C<read> behaviour should be continued once the +filehandle becomes ready for write. + +Normally, C<want_writeready_for_write> is managed by the C<write> method and +associated flushing, and C<want_writeready_for_read> is not used. However, if +a custom C<reader> 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 $stream->close + +A synonym for C<close_when_empty>. This should not be used when the deferred +wait behaviour is required, as the behaviour of C<close> may change in a +future version of C<IO::Async>. Instead, call C<close_when_empty> directly. + +=cut + +sub close +{ + my $self = shift; + $self->close_when_empty; +} + +=head2 $stream->close_when_empty + +If the write buffer is empty, this method calls C<close> 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<close_now> method. + +=cut + +sub close_when_empty +{ + my $self = shift; + + return $self->SUPER::close if $self->_is_empty; + + $self->{stream_closing} = 1; +} + +=head2 $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->( "stream closing" ) if $_->on_error; + } + + undef @{ $self->{writequeue} }; + undef $self->{stream_closing}; + + $self->SUPER::close; +} + +=head2 $eof = $stream->is_read_eof + +=head2 $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 $stream->write( $data, %params ) + +This method adds data to the outgoing data queue, or writes it immediately, +according to the C<autoflush> parameter. + +If the C<autoflush> 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<autoflush> were not set, and will +be flushed as normal. + +C<$data> can either be a plain string, a L<Future>, 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<Future>, 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 C<Future>s yield CODE references, or CODE references return +C<Future>s, 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<write_len> parameter for the data written by this call. + +=item on_write => CODE + +A CODE reference which will be invoked after every successful C<syswrite> +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<syscall> 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<write> +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<syswrite> error happens while +performing this write. Invoked as for the C<Stream>'s C<on_write_error> event. + + $on_error->( $stream, $errno ) + +=back + +If the object is not yet a member of a loop and doesn't yet have a +C<write_handle>, then calls to the C<write> 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<on_flush> 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 $stream->write( ... )->get + +If called in non-void context, this method returns a L<Future> 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<on_flush> 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->get; + 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 ); + + if( $errno == EPIPE ) { + $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; + } + + 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; + }; + } + + push @{ $self->{writequeue} }, Writer( + $data, $params{write_len} // $self->{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->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}; + } + + 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->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 $stream->push_on_read( $on_read ) + +Pushes a new temporary C<on_read> handler to the end of the queue. This queue, +if non-empty, is used to provide C<on_read> 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<on_read> event handler, each can return a (defined) boolean +to indicate if they wish to be invoked again or not, another C<CODE> reference +to replace themself with, or C<undef> to indicate it is now complete and +should be removed. When a temporary handler returns C<undef> 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<Future> 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<Future> object to complete +it. + + my $f = $stream->read_... + + my ( $string ) = $f->get; + +Unlike the C<on_read> 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<Future> is cancelled before it completes it is removed from the read +queue without consuming any data; i.e. each C<Future> atomically either +completes or is cancelled. + +Since it is possible to use a readable C<Stream> entirely using these +C<Future>-returning methods instead of the C<on_read> 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<Loop> 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 C<Future>s +pending, they are all completed. In the case of a read EOF, they are done with +C<undef>; 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<Future>, 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<read_exactly>'s case, or lacking the ending pattern in +C<read_until>'s case). Additionally, each C<Future> will yield the C<$eof> +value in its results. + + my ( $string, $eof ) = $f->get; + +=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 ( $string, $eof ) = $stream->read_atmost( $len )->get + +=head2 ( $string, $eof ) = $stream->read_exactly( $len )->get + +Completes the C<Future> when the read buffer contains C<$len> or more +characters of input. C<read_atmost> will also complete after the first +invocation of C<on_read>, even if fewer characters are available, whereas +C<read_exactly> 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 ( $string, $eof ) = $stream->read_until( $end )->get + +Completes the C<Future> when the read buffer contains a match for C<$end>, +which may either be a plain string or a compiled C<Regexp> 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 ( $string, $eof ) = $stream->read_until_eof->get + +Completes the C<Future> 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 $stream = IO::Async::Stream->new_for_stdin + +=head2 $stream = IO::Async::Stream->new_for_stdout + +=head2 $stream = IO::Async::Stream->new_for_stdio + +Return a C<IO::Async::Stream> object preconfigured with the correct +C<read_handle>, C<write_handle> 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 $future = $stream->connect( %args ) + +A convenient wrapper for calling the C<connect> method on the underlying +L<IO::Async::Loop> object, passing the C<socktype> hint as C<stream> if not +otherwise supplied. + +=cut + +sub connect +{ + my $self = shift; + return $self->SUPER::connect( socktype => "stream", @_ ); +} + +=head1 DEBUGGING FLAGS + +The following flags in C<IO_ASYNC_DEBUG_FLAGS> enable extra logging: + +=over 4 + +=item C<Sr> + +Log byte buffers as data is read from a Stream + +=item C<Sw> + +Log byte buffers as data is written to a Stream + +=back + +=cut + +=head1 EXAMPLES + +=head2 A line-based C<on_read> method + +The following C<on_read> method accepts incoming C<\n>-terminated lines and +prints them to the program's C<STDOUT> 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<s///> 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. If no data is +available then C<0> is returned, to indicate it should not be tried again. If +a line was successfully extracted, then C<1> is returned, to indicate it +should try again in case more lines exist in the buffer. + +=head2 Reading binary data + +This C<on_read> 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; + } + +The 4-argument form of C<substr()> 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<on_read> 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 C<unpack()>ed 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<substr()> to remove them. + +=head2 Dynamic replacement of C<on_read> + +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<on_read> +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<undef>. + +=head1 SEE ALSO + +=over 4 + +=item * + +L<IO::Handle> - Supply object methods for I/O handles + +=back + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Test.pm b/lib/IO/Async/Test.pm new file mode 100644 index 0000000..933330f --- /dev/null +++ b/lib/IO/Async/Test.pm @@ -0,0 +1,185 @@ +# 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-2012 -- leonerd@leonerd.org.uk + +package IO::Async::Test; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use Exporter 'import'; +our @EXPORT = qw( + testing_loop + wait_for + wait_for_stream +); + +=head1 NAME + +C<IO::Async::Test> - utility functions for use in test scripts + +=head1 SYNOPSIS + + use Test::More tests => 1; + 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' ); + +=head1 DESCRIPTION + +This module provides utility functions that may be useful when writing test +scripts for code which uses C<IO::Async> (as well as being used in the +C<IO::Async> 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 C<IO::Async> which, being an +asynchronisation framework, does not provide a linear stepped way of working. + +In order to write a test, the C<wait_for> 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 occured, the outcome of which can +now be tested using the usual testing primitives. + +Because the primary purpose of C<IO::Async> is to provide IO operations on +filehandles, a great many tests will likely be based around connected pipes or +socket handles. The C<wait_for_stream> 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( $loop ) + +Set the C<IO::Async::Loop> object which the C<wait_for> function will loop +on. + +=cut + +sub testing_loop +{ + $loop = shift; +} + +=head2 wait_for( $condfunc ) + +Repeatedly call the C<loop_once> method on the underlying loop (given to the +C<testing_loop> function), until the given condition function callback +returns true. + +To guard against stalled scripts, if the loop indicates a timeout for 10 +consequentive seconds, then an error is thrown. + +=cut + +sub wait_for(&) +{ + my ( $cond ) = @_; + + my ( undef, $callerfile, $callerline ) = caller; + + my $timedout = 0; + my $timerid = $loop->watch_time( + after => 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( $condfunc, $handle, $buffer ) + +As C<wait_for>, 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 ); + } + ); + + # Have to defeat the prototype... grr I hate these + &wait_for( $cond ); + + $loop->unwatch_io( + handle => $handle, + on_read_ready => 1, + ); +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Timer.pm b/lib/IO/Async/Timer.pm new file mode 100644 index 0000000..8e5961b --- /dev/null +++ b/lib/IO/Async/Timer.pm @@ -0,0 +1,187 @@ +# 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; + +use strict; +use warnings; +use base qw( IO::Async::Notifier ); + +our $VERSION = '0.67'; + +use Carp; + +=head1 NAME + +C<IO::Async::Timer> - base class for Notifiers that use timed delays + +=head1 DESCRIPTION + +This module provides a subclass of L<IO::Async::Notifier> for implementing +notifiers that use timed delays. For specific implementations, see one of the +subclasses: + +=over 8 + +=item * + +L<IO::Async::Timer::Absolute> - event callback at a fixed future time + +=item * + +L<IO::Async::Timer::Countdown> - event callback after a fixed delay + +=item * + +L<IO::Async::Timer::Periodic> - event callback at regular intervals + +=back + +=cut + +=head1 CONSTRUCTOR + +=cut + +=head2 $timer = IO::Async::Timer->new( %args ) + +Constructs a particular subclass of C<IO::Async::Timer> 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<countdown> +but more types may be added in the future. + +=back + +Once constructed, the C<Timer> will need to be added to the C<Loop> before it +will work. It will also need to be started by the C<start> 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 $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 $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 $timer->stop + +Stops the Timer if it is running. If it has not yet been added to the C<Loop> +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 <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Timer/Absolute.pm b/lib/IO/Async/Timer/Absolute.pm new file mode 100644 index 0000000..a925415 --- /dev/null +++ b/lib/IO/Async/Timer/Absolute.pm @@ -0,0 +1,142 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Timer::Absolute; + +use strict; +use warnings; +use base qw( IO::Async::Timer ); + +our $VERSION = '0.67'; + +use Carp; + +=head1 NAME + +C<IO::Async::Timer::Absolute> - 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<IO::Async::Timer> 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<Timer> object that waits for a delay relative to the time it is +started, see instead L<IO::Async::Timer::Countdown>. + +=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<new> or C<configure>: + +=head2 on_expire => CODE + +CODE reference for the C<on_expire> 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<Loop> before +it will work. + +Unlike other timers, it does not make sense to C<start> 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 <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Timer/Countdown.pm b/lib/IO/Async/Timer/Countdown.pm new file mode 100644 index 0000000..201ba42 --- /dev/null +++ b/lib/IO/Async/Timer/Countdown.pm @@ -0,0 +1,274 @@ +# 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; + +use strict; +use warnings; +use base qw( IO::Async::Timer ); + +our $VERSION = '0.67'; + +use Carp; + +=head1 NAME + +C<IO::Async::Timer::Countdown> - 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<IO::Async::Timer> 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<Timer> object that repeatedly runs a callback at regular intervals, +see instead L<IO::Async::Timer::Periodic>. For a C<Timer> that invokes its +callback at a fixed time in the future, see L<IO::Async::Timer::Absolute>. + +=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<new> or C<configure>: + +=head2 on_expire => CODE + +CODE reference for the C<on_expire> 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<Loop> before +it will work. It will also need to be started by the C<start> 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 $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 $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<reset> 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<on_expire> closure can call C<close> on it, the parent/child +relationship between the two Notifier objects is used. At the time the Timer +C<on_expire> closure is invoked, it will have been added as a child notifier +of the Stream; this means the Timer's C<parent> method will return the Stream +Notifier. This enables it to call C<close> without needing to capture a +lexical variable, which would create a cyclic reference. + +=head2 Fixed-Delay Repeating Timer + +The C<on_expire> event fires a fixed delay after the C<start> method has begun +the countdown. The C<start> method can be invoked again at some point during +the C<on_expire> 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<IO::Async::Timer::Periodic>, 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<start_some_operation> function 60 seconds after the +previous iteration has indicated it has finished. + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Timer/Periodic.pm b/lib/IO/Async/Timer/Periodic.pm new file mode 100644 index 0000000..f99a43c --- /dev/null +++ b/lib/IO/Async/Timer/Periodic.pm @@ -0,0 +1,249 @@ +# 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-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Timer::Periodic; + +use strict; +use warnings; +use base qw( IO::Async::Timer ); + +our $VERSION = '0.67'; + +use Carp; + +=head1 NAME + +C<IO::Async::Timer::Periodic> - 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<IO::Async::Timer> 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<Timer> object that only runs a callback once, after a given delay, see +instead L<IO::Async::Timer::Countdown>. 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<IO::Async::Timer::Countdown>. + +=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<new> or C<configure>: + +=head2 on_tick => CODE + +CODE reference for the C<on_tick> 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<start> +method before the first invocation of the callback or method. Thereafter, the +regular C<interval> 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<Loop> object, and not synchronously by the C<start> method +itself. + +=head2 reschedule => STRING + +Optional. Must be one of C<hard>, C<skip> or C<drift>. Defines the algorithm +used to reschedule the next invocation. + +C<hard> schedules each iteration at the fixed interval from the previous +iteration's schedule time, ensuring a regular repeating event. + +C<skip> schedules similarly to C<hard>, 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<SIGSTOP> or similar. + +C<drift> 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<Loop> before +it will work. It will also need to be started by the C<start> 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 _next_interval +{ + my $self = shift; + return $self->{first_interval} if defined $self->{first_interval}; + return $self->{interval}; +} + +sub start +{ + my $self = shift; + + # 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( my $loop = $self->loop ) { + my $now = $loop->time; + my $resched = $self->{reschedule}; + + if( !defined $self->{next_time} ) { + $self->{next_time} = $now + $self->_next_interval; + } + elsif( $resched eq "hard" ) { + $self->{next_time} += $self->_next_interval; + } + elsif( $resched eq "skip" ) { + # How many ticks are needed? + my $ticks = POSIX::ceil( $now - $self->{next_time} ); + # $self->{last_ticks} = $ticks; + $self->{next_time} += $self->_next_interval * $ticks; + } + elsif( $resched eq "drift" ) { + $self->{next_time} = $now + $self->_next_interval; + } + } + + $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->{first_interval}; + + undef $self->{id}; + + my $ok = eval { $self->invoke_event( on_tick => ); 1 } or + my $e = $@; + + # detect ->stop + $self->start if defined $self->{next_time}; + + die $e if !$ok; + } ); +} + +sub _make_enqueueargs +{ + my $self = shift; + + return at => $self->{next_time}; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/t/00use.t b/t/00use.t new file mode 100644 index 0000000..268ef56 --- /dev/null +++ b/t/00use.t @@ -0,0 +1,35 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +use_ok( "IO::Async::Notifier" ); +use_ok( "IO::Async::Handle" ); +use_ok( "IO::Async::Stream" ); +use_ok( "IO::Async::Timer" ); +use_ok( "IO::Async::Timer::Absolute" ); +use_ok( "IO::Async::Timer::Countdown" ); +use_ok( "IO::Async::Timer::Periodic" ); +use_ok( "IO::Async::Signal" ); +use_ok( "IO::Async::Listener" ); +use_ok( "IO::Async::Socket" ); +use_ok( "IO::Async::File" ); +use_ok( "IO::Async::FileStream" ); + +use_ok( "IO::Async::OS" ); + +use_ok( "IO::Async::Loop::Select" ); +use_ok( "IO::Async::Loop::Poll" ); + +use_ok( "IO::Async::Test" ); + +use_ok( "IO::Async::Function" ); +use_ok( "IO::Async::Resolver" ); + +use_ok( "IO::Async::Protocol" ); +use_ok( "IO::Async::Protocol::Stream" ); +use_ok( "IO::Async::Protocol::LineStream" ); + +done_testing; diff --git a/t/01timequeue.t b/t/01timequeue.t new file mode 100644 index 0000000..0b05f10 --- /dev/null +++ b/t/01timequeue.t @@ -0,0 +1,94 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +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( exception { $queue->enqueue( code => sub { "DUMMY" } ) }, + 'enqueue no time fails' ); + +ok( exception { $queue->enqueue( time => 123 ) }, + 'enqueue no code fails' ); + +ok( exception { $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; diff --git a/t/02os.t b/t/02os.t new file mode 100644 index 0000000..b2d5a94 --- /dev/null +++ b/t/02os.t @@ -0,0 +1,170 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; + +use IO::Async::OS; + +use Socket qw( + AF_INET AF_INET6 AF_UNIX SOCK_STREAM SOCK_DGRAM SO_TYPE + pack_sockaddr_in pack_sockaddr_in6 pack_sockaddr_un inet_aton inet_pton + 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")' ); + + 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")' ); + } +} + +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->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_deeply( [ IO::Async::OS->extract_addrinfo( [ "inet", "stream", 0, $sinaddr ] ) ], + [ AF_INET, SOCK_STREAM, 0, $sinaddr ], + 'extract_addrinfo( ARRAY )' ); + + is_deeply( [ IO::Async::OS->extract_addrinfo( { + family => "inet", + socktype => "stream", + addr => $sinaddr + } ) ], + [ AF_INET, SOCK_STREAM, 0, $sinaddr ], + 'extract_addrinfo( HASH )' ); + + is_deeply( [ 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_deeply( [ 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_deeply( [ 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( exception { IO::Async::OS->extract_addrinfo( { + family => "inet", + host => "foobar.com", + } ) }, 'extract_addrinfo for inet complains about unrecognised key' ); +} + +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_deeply( [ 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' ); +} + +SKIP: { + skip "No pack_sockaddr_un", 1 unless IO::Async::OS->HAVE_SOCKADDR_UN; + my $sunaddr = pack_sockaddr_un( "foo.sock" ); + + is_deeply( [ IO::Async::OS->extract_addrinfo( { + family => "unix", + socktype => "stream", + path => "foo.sock", + } ) ], + [ AF_UNIX, SOCK_STREAM, 0, $sunaddr ], + 'extract_addrinfo( HASH ) with unix, path' ); +} + +ok( exception { IO::Async::OS->extract_addrinfo( { family => "hohum" } ) }, + 'extract_addrinfo on unrecognised family complains' ); + +done_testing; diff --git a/t/03loop-magic.t b/t/03loop-magic.t new file mode 100644 index 0000000..ede4105 --- /dev/null +++ b/t/03loop-magic.t @@ -0,0 +1,51 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +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; diff --git a/t/04notifier.t b/t/04notifier.t new file mode 100644 index 0000000..8016583 --- /dev/null +++ b/t/04notifier.t @@ -0,0 +1,194 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Refcount; + +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( !exception { $notifier->configure; }, + '$notifier->configure no params succeeds' ); + + ok( exception { $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( !exception { $notifier->configure( oranges => 3 ) }, + '$notifier->configure with configure_unknown succeeds' ); + + is_deeply( \%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_deeply( \@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_deeply( \@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_deeply( \@args, [ $notifier, 456 ], '@args after invoking replacer $mref' ); + + isa_ok( $outerself, "OtherClass", '$outerself unchanged' ); + + ok( exception { $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_deeply( \@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_deeply( \@subargs, [], '@subargs empty after TestNotifier::frobnicate replacement' ); + is_deeply( \@newargs, [ $subn, 321 ], '@newargs after TestNotifier::frobnicate replacement' ); + } + + undef @subargs; + + $subn->invoke_event( 'frobnicate', 78 ); + is_deeply( \@subargs, [ $subn, 78 ], '@subargs after ->invoke_event' ); + + undef @subargs; + + is_deeply( $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_deeply( \@subargs, [ $subn, 90 ], '@subargs after ->make_event_cb->()' ); + + isa_ok( $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 ); + + is( $child->parent, $parent, '$child->parent is $parent' ); + is_deeply( [ $parent->children ], [ $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( exception { $parent->add_child( $child ) }, 'Adding child again fails' ); + + $parent->remove_child( $child ); + + is_oneref( $child, '$child has refcount 1 after remove_child' ); + is_deeply( [ $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( exception { $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( !exception { $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( !exception { $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; diff --git a/t/05notifier-loop.t b/t/05notifier-loop.t new file mode 100644 index 0000000..ceaea6e --- /dev/null +++ b/t/05notifier-loop.t @@ -0,0 +1,129 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Refcount; + +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_deeply( [ $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' ); + + is( $notifier->loop, $loop, 'loop $loop' ); + + is_deeply( [ $loop->notifiers ], + [ $notifier ], + '$loop->notifiers contains new Notifier' ); + + ok( $in_loop, '_add_to_loop called' ); + + ok( exception { $loop->add( $notifier ) }, 'adding again produces error' ); + + $loop->remove( $notifier ); + + is( $notifier->loop, undef, '$notifier->loop is undef' ); + + is_deeply( [ $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' ); + + is( $parent->loop, $loop, '$parent->loop is $loop' ); + 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( exception { $loop->remove( $child ) }, 'Directly removing a child from the loop fails' ); + + $loop->remove( $parent ); + + is_deeply( [ $parent->children ], [ $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( exception { $loop->add( $child ) }, 'Directly adding a child to the loop fails' ); + + $loop->add( $parent ); + + 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' ); +} + +is_refcount( $loop, 2, '$loop has refcount 2 finally' ); + +done_testing; diff --git a/t/06notifier-mixin.t b/t/06notifier-mixin.t new file mode 100644 index 0000000..7554fc4 --- /dev/null +++ b/t/06notifier-mixin.t @@ -0,0 +1,50 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Refcount; + +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' ); + +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 } diff --git a/t/07notifier-future.t b/t/07notifier-future.t new file mode 100644 index 0000000..066fbb9 --- /dev/null +++ b/t/07notifier-future.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Fatal; +use Test::Refcount; + +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; + + $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' ); + + $f->done( "result" ); + + is_refcount( $f, 1, '$f has refcount 1 after $f->done' ); +} + +# 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_deeply( \@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; diff --git a/t/10loop-poll-io.t b/t/10loop-poll-io.t new file mode 100644 index 0000000..8c34ffa --- /dev/null +++ b/t/10loop-poll-io.t @@ -0,0 +1,7 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::LoopTests; +run_tests( 'IO::Async::Loop::Poll', 'io' ); diff --git a/t/10loop-select-io.t b/t/10loop-select-io.t new file mode 100644 index 0000000..b3e3916 --- /dev/null +++ b/t/10loop-select-io.t @@ -0,0 +1,7 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::LoopTests; +run_tests( 'IO::Async::Loop::Select', 'io' ); diff --git a/t/11loop-poll-timer.t b/t/11loop-poll-timer.t new file mode 100644 index 0000000..748ba2a --- /dev/null +++ b/t/11loop-poll-timer.t @@ -0,0 +1,7 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::LoopTests; +run_tests( 'IO::Async::Loop::Poll', 'timer' ); diff --git a/t/11loop-select-timer.t b/t/11loop-select-timer.t new file mode 100644 index 0000000..314bd38 --- /dev/null +++ b/t/11loop-select-timer.t @@ -0,0 +1,7 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::LoopTests; +run_tests( 'IO::Async::Loop::Select', 'timer' ); diff --git a/t/12loop-poll-signal.t b/t/12loop-poll-signal.t new file mode 100644 index 0000000..4c8ef24 --- /dev/null +++ b/t/12loop-poll-signal.t @@ -0,0 +1,9 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::LoopTests; +Test::More::plan skip_all => "This OS does not have signals" unless IO::Async::OS->HAVE_SIGNALS; + +run_tests( 'IO::Async::Loop::Poll', 'signal' ); diff --git a/t/12loop-select-signal.t b/t/12loop-select-signal.t new file mode 100644 index 0000000..66a6c91 --- /dev/null +++ b/t/12loop-select-signal.t @@ -0,0 +1,9 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::LoopTests; +Test::More::plan skip_all => "This OS does not have signals" unless IO::Async::OS->HAVE_SIGNALS; + +run_tests( 'IO::Async::Loop::Select', 'signal' ); diff --git a/t/13loop-poll-idle.t b/t/13loop-poll-idle.t new file mode 100644 index 0000000..3ce457b --- /dev/null +++ b/t/13loop-poll-idle.t @@ -0,0 +1,7 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::LoopTests; +run_tests( 'IO::Async::Loop::Poll', 'idle' ); diff --git a/t/13loop-select-idle.t b/t/13loop-select-idle.t new file mode 100644 index 0000000..8cea7a7 --- /dev/null +++ b/t/13loop-select-idle.t @@ -0,0 +1,7 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::LoopTests; +run_tests( 'IO::Async::Loop::Select', 'idle' ); diff --git a/t/14loop-poll-child.t b/t/14loop-poll-child.t new file mode 100644 index 0000000..5337166 --- /dev/null +++ b/t/14loop-poll-child.t @@ -0,0 +1,7 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::LoopTests; +run_tests( 'IO::Async::Loop::Poll', 'child' ); diff --git a/t/14loop-select-child.t b/t/14loop-select-child.t new file mode 100644 index 0000000..8e31e23 --- /dev/null +++ b/t/14loop-select-child.t @@ -0,0 +1,7 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::LoopTests; +run_tests( 'IO::Async::Loop::Select', 'child' ); diff --git a/t/15loop-poll-control.t b/t/15loop-poll-control.t new file mode 100644 index 0000000..74839dd --- /dev/null +++ b/t/15loop-poll-control.t @@ -0,0 +1,7 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::LoopTests; +run_tests( 'IO::Async::Loop::Poll', 'control' ); diff --git a/t/15loop-select-control.t b/t/15loop-select-control.t new file mode 100644 index 0000000..ff62634 --- /dev/null +++ b/t/15loop-select-control.t @@ -0,0 +1,7 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::LoopTests; +run_tests( 'IO::Async::Loop::Select', 'control' ); diff --git a/t/18loop-poll-legacy.t b/t/18loop-poll-legacy.t new file mode 100644 index 0000000..3c20dfb --- /dev/null +++ b/t/18loop-poll-legacy.t @@ -0,0 +1,95 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +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_deeply( [ $poll->handles ], [], '$poll->handles empty initially' ); + +# watch_io + +my $readready = 0; +$loop->watch_io( + handle => $S1, + on_read_ready => sub { $readready = 1 }, +); + +is_deeply( [ $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_deeply( [ $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_deeply( [ $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_deeply( [ $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 - $!"; + +# 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; diff --git a/t/18loop-select-legacy.t b/t/18loop-select-legacy.t new file mode 100644 index 0000000..d5796b0 --- /dev/null +++ b/t/18loop-select-legacy.t @@ -0,0 +1,152 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +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; diff --git a/t/19loop-future.t b/t/19loop-future.t new file mode 100644 index 0000000..45ab441 --- /dev/null +++ b/t/19loop-future.t @@ -0,0 +1,107 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Identity; +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 ); + identical( $ret, $future, '$loop->await( $future ) returns $future' ); + + is_deeply( [ $future->get ], [ "result" ], '$future->get' ); +} + +{ + 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 ); + + identical( $future->loop, $loop, '$future->loop yields $loop' ); + + $loop->later( sub { $future->done( "result" ) } ); + + is_deeply( [ $future->get ], [ "result" ], '$future->get on IO::Async::Future' ); +} + +{ + my $future = $loop->new_future; + + $loop->later( sub { $future->done( "result" ) } ); + + is_deeply( [ $future->get ], [ "result" ], '$future->get on IO::Async::Future from $loop->new_future' ); +} + +# done_later +{ + my $future = $loop->new_future; + + identical( $future->done_later( "deferred result" ), $future, '->done_later returns $future' ); + ok( !$future->is_ready, '$future not yet ready after ->done_later' ); + + is_deeply( [ $future->get ], [ "deferred result" ], '$future now ready after ->get' ); +} + +# fail_later +{ + my $future = $loop->new_future; + + identical( $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_deeply( [ $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_deeply( [ $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; diff --git a/t/19test.t b/t/19test.t new file mode 100644 index 0000000..cc24d45 --- /dev/null +++ b/t/19test.t @@ -0,0 +1,69 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Refcount; +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 - $!"; + +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; diff --git a/t/20handle.t b/t/20handle.t new file mode 100644 index 0000000..194a621 --- /dev/null +++ b/t/20handle.t @@ -0,0 +1,422 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Fatal; +use Test::Identity; +use Test::Refcount; + +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( exception { 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_deeply( \@rrargs, [ $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( exception { $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_deeply( \@wrargs, [ $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' ); + + 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' ); + + 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, "no", '$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 { }, + ); + + identical( $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 } diff --git a/t/21stream-1read.t b/t/21stream-1read.t new file mode 100644 index 0000000..aa49453 --- /dev/null +++ b/t/21stream-1read.t @@ -0,0 +1,637 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Fatal; +use Test::Refcount; + +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_deeply( \@lines, [], '@lines before wait' ); + + wait_for { scalar @lines }; + + is_deeply( \@lines, [ "message\n" ], '@lines after wait' ); + + undef @lines; + + $wr->syswrite( "return" ); + + $loop->loop_once( 0.1 ); # nothing happens + + is_deeply( \@lines, [], '@lines partial still empty' ); + + $wr->syswrite( "\n" ); + + wait_for { scalar @lines }; + + is_deeply( \@lines, [ "return\n" ], '@lines partial completed now received' ); + + undef @lines; + + $wr->syswrite( "hello\nworld\n" ); + wait_for { scalar @lines }; + + is_deeply( \@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_deeply( \@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_deeply( \@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_deeply( \@chunks, [ "pa" ], '@lines with read_len=2 without read_all' ); + + wait_for { @chunks == 4 }; + + is_deeply( \@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_deeply( \@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( !exception { $no_on_read_stream = IO::Async::Stream->new( read_handle => $rd ) }, + 'Allowed to construct a Stream without an on_read handler' ); + ok( exception { $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_deeply( \@sub_lines, [], '@sub_lines before wait' ); + + wait_for { scalar @sub_lines }; + + is_deeply( \@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' ); + 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 = $stream->read_exactly( 4 )->then( sub { + $stream->read_exactly( 4 ); + }); + + wait_for { $f->is_ready }; + + 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 = $stream->read_atmost( 256 ); + + wait_for { $f->is_ready }; + 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' ); +} + +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; +} diff --git a/t/21stream-2write.t b/t/21stream-2write.t new file mode 100644 index 0000000..b49cea8 --- /dev/null +++ b/t/21stream-2write.t @@ -0,0 +1,479 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Refcount; + +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 { + is( $_[0], $stream, 'on_write $_[0] is $stream' ); + $written += $_[1]; + }, + on_flush => sub { + 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 { + 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' ); +} + +done_testing; diff --git a/t/21stream-3split.t b/t/21stream-3split.t new file mode 100644 index 0000000..1fd99e4 --- /dev/null +++ b/t/21stream-3split.t @@ -0,0 +1,187 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Fatal; +use Test::Refcount; + +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_deeply( \@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( exception { $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 - $!"; + +$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( !exception { $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; diff --git a/t/21stream-4encoding.t b/t/21stream-4encoding.t new file mode 100644 index 0000000..cae0cac --- /dev/null +++ b/t/21stream-4encoding.t @@ -0,0 +1,151 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Fatal; +use Test::Refcount; + +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; diff --git a/t/22timer-absolute.t b/t/22timer-absolute.t new file mode 100644 index 0000000..6192bec --- /dev/null +++ b/t/22timer-absolute.t @@ -0,0 +1,143 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Refcount; +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_deeply( \@eargs, [ $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 } diff --git a/t/22timer-countdown.t b/t/22timer-countdown.t new file mode 100644 index 0000000..db8b49c --- /dev/null +++ b/t/22timer-countdown.t @@ -0,0 +1,257 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Fatal; +use Test::Refcount; +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' ); + + 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_deeply( \@eargs, [ $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( exception { $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 } diff --git a/t/22timer-periodic.t b/t/22timer-periodic.t new file mode 100644 index 0000000..a2fc28e --- /dev/null +++ b/t/22timer-periodic.t @@ -0,0 +1,233 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Fatal; +use Test::Refcount; +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' ); + + 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_deeply( \@targs, [ $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( exception { $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( exception { wait_for { $count > 0 } }, + qr/FAIL 1/, 'on_tick death throws exception' ); + + like( exception { 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++ } diff --git a/t/23signal.t b/t/23signal.t new file mode 100644 index 0000000..fc28642 --- /dev/null +++ b/t/23signal.t @@ -0,0 +1,148 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Fatal; +use Test::Refcount; + +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_deeply( \@rargs, [ $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( exception { + 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++ } diff --git a/t/24listener.t b/t/24listener.t new file mode 100644 index 0000000..5a296aa --- /dev/null +++ b/t/24listener.t @@ -0,0 +1,301 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Identity; +use Test::Refcount; + +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, +) 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_deeply( [ 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_deeply( [ 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_deeply( [ 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_deeply( [ unpack_sockaddr_in $newsocket->read_handle->peername ], + [ unpack_sockaddr_in $clientsock->sockname ], '$newsocket sock peer is correct' ); + + $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_deeply( [ 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' ); + + 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_deeply( [ unpack_sockaddr_in $newclient->peername ], + [ unpack_sockaddr_in $clientsock->sockname ], '$newclient peer is correct' ); + + $loop->remove( $listener ); +} + +done_testing; diff --git a/t/25socket.t b/t/25socket.t new file mode 100644 index 0000000..8da852f --- /dev/null +++ b/t/25socket.t @@ -0,0 +1,325 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Fatal; +use Test::Refcount; + +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( !exception { 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_deeply( \@received, [], '@received before wait' ); + + wait_for { scalar @received }; + + is_deeply( \@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_deeply( \@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_deeply( \@frags, [ "A ni" ], '@frags with recv_len=4 without recv_all' ); + + wait_for { @frags == 3 }; + + is_deeply( \@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_deeply( \@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( !exception { $no_on_recv_socket = IO::Async::Socket->new( handle => $S1 ) }, + 'Allowed to construct a Socket without an on_recv handler' ); + ok( exception { $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_deeply( \@sub_received, [], '@sub_received before wait' ); + + wait_for { scalar @sub_received }; + + is_deeply( \@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 - $!"; + $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 { } diff --git a/t/26pid.t b/t/26pid.t new file mode 100644 index 0000000..cdd770b --- /dev/null +++ b/t/26pid.t @@ -0,0 +1,89 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Refcount; + +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; diff --git a/t/27file.t b/t/27file.t new file mode 100644 index 0000000..6c79ff7 --- /dev/null +++ b/t/27file.t @@ -0,0 +1,113 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Refcount; + +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; diff --git a/t/28filestream.t b/t/28filestream.t new file mode 100644 index 0000000..f51887e --- /dev/null +++ b/t/28filestream.t @@ -0,0 +1,323 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Fatal; +use Test::Refcount; + +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_deeply( \@lines, [], '@lines before wait' ); + + wait_for { scalar @lines }; + + is_deeply( \@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_deeply( \@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_deeply( \@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_deeply( \@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_deeply( \@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_deeply( \@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_deeply( $lines[0], "last line of old file\n", '@lines sees last line of old file' ); + wait_for { scalar @lines >= 2 }; + is_deeply( $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_deeply( \@sub_lines, [], '@sub_lines before wait' ); + + wait_for { scalar @sub_lines }; + + is_deeply( \@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; +} diff --git a/t/30loop-fork.t b/t/30loop-fork.t new file mode 100644 index 0000000..927b6c9 --- /dev/null +++ b/t/30loop-fork.t @@ -0,0 +1,81 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; + +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' ); +} + +done_testing; diff --git a/t/31loop-spawnchild.t b/t/31loop-spawnchild.t new file mode 100644 index 0000000..1cac1d9 --- /dev/null +++ b/t/31loop-spawnchild.t @@ -0,0 +1,168 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Fatal; + +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( exception { $loop->spawn_child( badoption => 1 ); }, 'Bad option to spawn fails' ); + +ok( exception { $loop->spawn_child( code => sub { 1 }, command => "hello" ); }, + 'Both code and command options to spawn fails' ); + +ok( exception { $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; diff --git a/t/32loop-spawnchild-setup.t b/t/32loop-spawnchild-setup.t new file mode 100644 index 0000000..7ecdf85 --- /dev/null +++ b/t/32loop-spawnchild-setup.t @@ -0,0 +1,439 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Fatal; + +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( exception { $loop->spawn_child( code => sub { 1 }, setup => "hello" ); }, + 'Bad setup type fails' ); + +ok( exception { $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 <STDIN>; 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; diff --git a/t/33process.t b/t/33process.t new file mode 100644 index 0000000..72c07b1 --- /dev/null +++ b/t/33process.t @@ -0,0 +1,245 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Refcount; + +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 }; + + 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' ); + + is_oneref( $process, '$process has refcount 1 before EOS' ); +} + +{ + 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 }; + + 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; diff --git a/t/34process-handles.t b/t/34process-handles.t new file mode 100644 index 0000000..f199ef7 --- /dev/null +++ b/t/34process-handles.t @@ -0,0 +1,429 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; + +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' ); + + 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_deeply( \@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' ); + + $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_deeply( \@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' ); + + $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' ); + + 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' ); + + 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' ); + + $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' ); + + $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' ); + + $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' ); + + 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_deeply( \@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 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_deeply( $output_packet, "A packet to be echoed", '$output_packet after perl STDIO 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 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 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_deeply( \@output_packets, + [ "First packet", "Second packet" ], + '@output_packets after perl STDIO via dgram socketpair' ); +} + +done_testing; diff --git a/t/35loop-openchild.t b/t/35loop-openchild.t new file mode 100644 index 0000000..608952d --- /dev/null +++ b/t/35loop-openchild.t @@ -0,0 +1,65 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Fatal; + +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->open_child( + code => sub { 0 }, + on_finish => sub { ( undef, $exitcode ) = @_; }, +); + +undef $exitcode; +wait_for { defined $exitcode }; + +ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after sub { 0 }' ); +is( ($exitcode >> 8), 0, 'WEXITSTATUS($exitcode) after sub { 0 }' ); + +$loop->open_child( + command => [ $^X, "-e", 'exit 5' ], + on_finish => sub { ( undef, $exitcode ) = @_; }, +); + +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' ); + +ok( exception { $loop->open_child( + command => [ $^X, "-e", 1 ] + ) }, + 'Missing on_finish fails' +); + +ok( exception { $loop->open_child( + command => [ $^X, "-e", 1 ], + on_finish => "hello" + ) }, + 'on_finish not CODE ref fails' +); + +ok( exception { $loop->open_child( + command => [ $^X, "-e", 1 ], + on_finish => sub {}, + on_exit => sub {}, + ) }, + 'on_exit parameter fails' +); + +done_testing; diff --git a/t/36loop-runchild.t b/t/36loop-runchild.t new file mode 100644 index 0000000..50801d1 --- /dev/null +++ b/t/36loop-runchild.t @@ -0,0 +1,158 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Fatal; + +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( exception { $loop->run_child( + command => [ $^X, "-e", 1 ] + ) }, + 'Missing on_finish fails' +); + +ok( exception { $loop->run_child( + command => [ $^X, "-e", 1 ], + on_finish => "hello" + ) }, + 'on_finish not CODE ref fails' +); + +ok( exception { $loop->run_child( + command => [ $^X, "-e", 1 ], + on_finish => sub {}, + on_exit => sub {}, + ) }, + 'on_exit parameter fails' +); + +ok( exception { $loop->run_child( + command => [ $^X, "-e", 1 ], + on_finish => sub {}, + some_key_you_fail => 1 + ) }, + 'unrecognised key fails' +); + +done_testing; diff --git a/t/37loop-child-root.t b/t/37loop-child-root.t new file mode 100644 index 0000000..237b338 --- /dev/null +++ b/t/37loop-child-root.t @@ -0,0 +1,89 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; + +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; diff --git a/t/38loop-thread.t b/t/38loop-thread.t new file mode 100644 index 0000000..f2d2389 --- /dev/null +++ b/t/38loop-thread.t @@ -0,0 +1,59 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; + +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_deeply( \@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_deeply( \@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_deeply( \@result, [ died => "Ooops I fail\n" ], 'result to on_joined for a died thread' ); +} + +done_testing; diff --git a/t/40channel.t b/t/40channel.t new file mode 100644 index 0000000..930129b --- /dev/null +++ b/t/40channel.t @@ -0,0 +1,263 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Identity; + +use IO::Async::Channel; + +use IO::Async::OS; + +use IO::Async::Loop; +use Storable qw( freeze ); + +my $loop = IO::Async::Loop->new_builtin; + +testing_loop( $loop ); + +# 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_deeply( $channel_rd->recv, [ structure => "here" ], 'Sync mode channels can send/recv structures' ); + + $channel_wr->send_frozen( freeze [ prefrozen => "data" ] ); + + is_deeply( $channel_rd->recv, [ prefrozen => "data" ], 'Sync mode channels can send_frozen' ); + + $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_deeply( $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 { + identical( $_[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_deeply( 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 = $channel_rd->recv; + + wait_for { $recv_f->is_ready }; + + is_deeply( scalar $recv_f->get, [ data => "by sync" ], 'Async mode future can receive data' ); + + $channel_wr->close; + + my $eof_f = $channel_rd->recv; + + wait_for { $eof_f->is_ready }; + + 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 { + identical( $_[0], $channel_rd, 'Channel passed to ->recv on_recv' ); + $recved = $_[1]; + }, + on_eof => sub { die "Test failed early" }, + ); + + wait_for { $recved }; + + is_deeply( $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_deeply( scalar $r2_f->get, [ "second" ], 'Async recv result after cancellation' ); + + $loop->remove( $channel_rd ); +} + +# Sereal encoder +SKIP: { + skip "Sereal is not available", 1 unless 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 = $channel_rd->recv; + + wait_for { $recv_f->is_ready }; + + is_deeply( scalar $recv_f->get, [ data => "by sync" ], 'Channel can use Sereal as codec' ); + + $loop->remove( $channel_rd ); +} + +done_testing; diff --git a/t/41routine.t b/t/41routine.t new file mode 100644 index 0000000..945a1ec --- /dev/null +++ b/t/41routine.t @@ -0,0 +1,322 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Identity; +use Test::Refcount; + +use IO::Async::Routine; + +use IO::Async::Channel; +use IO::Async::Loop; + +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" ); + 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 = $returns->recv; + + wait_for { $f->is_ready }; + + 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" ); + + 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" ); + } + + { + 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 = $channel->recv; + + wait_for { $f->is_ready }; + + is( ${ $f->get }, "READY", 'Routine is ready for SIGINT' ); + + $routine->kill( "INT" ); + + $f = $channel->recv; + + wait_for { $f->is_ready }; + + 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 ); + } +} + +# 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' ); + + $loop->add( $routine ); + + $in1->send( \"+" ); + + my $status_f = $out1->recv; + + wait_for { $status_f->is_ready }; + is( ${ $status_f->get }, "Ready +", '$status_f result midway through Routine' ); + + $in2->send( [ 10, 20 ] ); + + my $result_f = $out2->recv; + + wait_for { $result_f->is_ready }; + + 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 = $channel->recv; + + wait_for { $f->is_ready }; + + 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; + + 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; diff --git a/t/42function.t b/t/42function.t new file mode 100644 index 0000000..f4b1c4d --- /dev/null +++ b/t/42function.t @@ -0,0 +1,569 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Fatal; +use Test::Refcount; +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' ); + + 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' ); + + $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_ok( $f2, "Future", '$f2' ); + + wait_for { @result == 2 }; + + is_deeply( \@result, [ 3, 7 ], '@result after both calls return' ); + + is( $function->workers, 1, '$function->workers is still 1 after 2 calls return' ); + + $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_deeply( \@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_deeply( [ $f->failure ], + [ "exception name at $0 line $line.", error => ], + '$f->failure after exception' ); + + $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_deeply( \@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_deeply( \@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 ); +} + +## 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_deeply( \%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 ); +} + +# 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; diff --git a/t/50resolver.t b/t/50resolver.t new file mode 100644 index 0000000..c73bc0f --- /dev/null +++ b/t/50resolver.t @@ -0,0 +1,389 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; + +use Socket 1.93 qw( + AF_INET SOCK_STREAM INADDR_LOOPBACK AI_PASSIVE + pack_sockaddr_in getaddrinfo getnameinfo +); + +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' ); + +SKIP: { + my @pwuid; + defined eval { @pwuid = getpwuid( $< ) } or + skip "No getpwuid()", 5; + + { + my $future = $resolver->resolve( + type => 'getpwuid', + data => [ $< ], + ); + + isa_ok( $future, "Future", '$future' ); + + wait_for { $future->is_ready }; + + my @result = $future->get; + + is_deeply( \@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_deeply( $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_deeply( $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_deeply( $result, \@pwnam, 'getpwnam' ); + } +} + +my @proto = getprotobyname( "tcp" ); + +{ + my $result; + + $resolver->resolve( + type => 'getprotobyname', + data => [ "tcp" ], + on_resolved => sub { $result = [ @_ ] }, + on_error => sub { die "Test died early" }, + ); + + wait_for { $result }; + + is_deeply( $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_deeply( $result, \@proto, 'getprotobynumber' ); +} + +# Some systems seem to mangle the order of results between PF_INET and +# PF_INET6 depending on who asks. We'll hint AF_INET + SOCK_STREAM to minimise +# the risk of a spurious test failure because of ordering issues + +my ( $localhost_err, @localhost_addrs ) = getaddrinfo( "localhost", "www", { family => AF_INET, socktype => SOCK_STREAM } ); + +{ + my $result; + + $resolver->resolve( + type => 'getaddrinfo_array', + data => [ "localhost", "www", "inet", "stream" ], + on_resolved => sub { $result = [ 'resolved', @_ ] }, + on_error => sub { $result = [ 'error', @_ ] }, + ); + + wait_for { $result }; + + if( $localhost_err ) { + is( $result->[0], "error", 'getaddrinfo_array - error' ); + is_deeply( $result->[1], "$localhost_err\n", 'getaddrinfo_array - error message' ); + } + else { + is( $result->[0], "resolved", 'getaddrinfo_array - resolved' ); + + my @got = @{$result}[1..$#$result]; + my @expect = map { [ @{$_}{qw( family socktype protocol addr canonname )} ] } @localhost_addrs; + + is_deeply( \@got, \@expect, 'getaddrinfo_array - resolved addresses' ); + } +} + +{ + my $result; + + $resolver->resolve( + type => 'getaddrinfo_hash', + data => [ host => "localhost", service => "www", family => "inet", socktype => "stream" ], + on_resolved => sub { $result = [ 'resolved', @_ ] }, + on_error => sub { $result = [ 'error', @_ ] }, + ); + + wait_for { $result }; + + if( $localhost_err ) { + is( $result->[0], "error", 'getaddrinfo_hash - error' ); + is_deeply( $result->[1], "$localhost_err\n", 'getaddrinfo_hash - error message' ); + } + else { + is( $result->[0], "resolved", 'getaddrinfo_hash - resolved' ); + + my @got = @{$result}[1..$#$result]; + + is_deeply( \@got, \@localhost_addrs, 'getaddrinfo_hash - resolved addresses' ); + } +} + +{ + my $result; + + $resolver->getaddrinfo( + host => "localhost", + service => "www", + family => "inet", + socktype => "stream", + on_resolved => sub { $result = [ 'resolved', @_ ] }, + on_error => sub { $result = [ 'error', @_ ] }, + ); + + wait_for { $result }; + + if( $localhost_err ) { + is( $result->[0], "error", '$resolver->getaddrinfo - error' ); + is_deeply( $result->[1], "$localhost_err\n", '$resolver->getaddrinfo - error message' ); + } + else { + is( $result->[0], "resolved", '$resolver->getaddrinfo - resolved' ); + + my @got = @{$result}[1..$#$result]; + + is_deeply( \@got, \@localhost_addrs, '$resolver->getaddrinfo - resolved addresses' ); + } +} + +{ + my $future = $resolver->getaddrinfo( + host => "localhost", + service => "www", + family => "inet", + socktype => "stream", + ); + + isa_ok( $future, "Future", '$future for $resolver->getaddrinfo' ); + + wait_for { $future->is_ready }; + + if( $localhost_err ) { + is( scalar $future->failure, "$localhost_err\n", '$resolver->getaddrinfo - error message' ); + } + else { + my @got = $future->get; + + is_deeply( \@got, \@localhost_addrs, '$resolver->getaddrinfo - resolved addresses' ); + } +} + +{ + my ( $lo_err, @lo_addrs ) = getaddrinfo( "127.0.0.1", "80", { socktype => SOCK_STREAM } ); + + 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_deeply( \@got, \@lo_addrs, '$resolver->getaddrinfo resolved addresses synchronously' ); +} + +{ + my ( $passive_err, @passive_addrs ) = getaddrinfo( "", "3000", { socktype => SOCK_STREAM, family => AF_INET, flags => AI_PASSIVE } ); + + my $result; + + $resolver->getaddrinfo( + family => "inet", + service => "3000", + socktype => "stream", + passive => 1, + on_resolved => sub { $result = [ 'resolved', @_ ] }, + on_error => sub { $result = [ 'error', @_ ] }, + ); + + if( $passive_err ) { + is( $result->[0], "error", '$resolver->getaddrinfo passive - error synchronously' ); + is_deeply( $result->[1], "$passive_err\n", '$resolver->getaddrinfo passive - error message' ); + } + else { + is( $result->[0], "resolved", '$resolver->getaddrinfo passive - resolved synchronously' ); + + my @got = @{$result}[1..$#$result]; + + is_deeply( \@got, \@passive_addrs, '$resolver->getaddrinfo passive - resolved addresses' ); + } +} + +{ + my ( $lo_err, @lo_addrs ) = getaddrinfo( "127.0.0.1", "80", { socktype => SOCK_STREAM } ); + + my $future = $resolver->getaddrinfo( + host => "127.0.0.1", + service => "80", + socktype => SOCK_STREAM, + ); + + isa_ok( $future, "Future", '$future for $resolver->getaddrinfo numerical' ); + + wait_for { $future->is_ready }; + + my @got = $future->get; + + is_deeply( \@got, \@lo_addrs, '$resolver->getaddrinfo resolved addresses synchronously' ); +} + +my $testaddr = pack_sockaddr_in( 80, INADDR_LOOPBACK ); +my ( $testerr, $testhost, $testserv ) = getnameinfo( $testaddr ); + +{ + my $result; + + $resolver->getnameinfo( + addr => $testaddr, + on_resolved => sub { $result = [ 'resolved', @_ ] }, + on_error => sub { $result = [ 'error', @_ ] }, + ); + + wait_for { $result }; + + if( $testerr ) { + is( $result->[0], "error", '$resolver->getnameinfo - error' ); + is_deeply( $result->[1], "$testerr\n", '$resolver->getnameinfo - error message' ); + } + else { + is( $result->[0], "resolved", '$resolver->getnameinfo - resolved' ); + is_deeply( [ @{$result}[1..2] ], [ $testhost, $testserv ], '$resolver->getnameinfo - resolved names' ); + } +} + +{ + my $future = $resolver->getnameinfo( + addr => $testaddr, + ); + + wait_for { $future->is_ready }; + + if( $testerr ) { + is( scalar $future->failure, "$testerr\n", '$resolver->getnameinfo - error message from future' ); + } + else { + my @got = $future->get; + + is_deeply( \@got, [ $testhost, $testserv ], '$resolver->getnameinfo - resolved names from future' ); + } +} + +{ + my $result; + + $resolver->getnameinfo( + addr => $testaddr, + numeric => 1, + on_resolved => sub { $result = [ 'resolved', @_ ] }, + on_error => sub { $result = [ 'error', @_ ] }, + ); + + is_deeply( $result, [ resolved => "127.0.0.1", 80 ], '$resolver->getnameinfo with numeric is synchronous' ); +} + +{ + my $future = $resolver->getnameinfo( + addr => $testaddr, + numeric => 1, + ); + + is_deeply( [ $future->get ], [ "127.0.0.1", 80 ], '$resolver->getnameinfo with numeric is synchronous for future' ); +} + +# $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; diff --git a/t/51loop-connect.t b/t/51loop-connect.t new file mode 100644 index 0000000..c217397 --- /dev/null +++ b/t/51loop-connect.t @@ -0,0 +1,333 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Identity; + +use IO::Socket::INET; +use POSIX qw( ENOENT ); +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' ); + + wait_for { $future->is_ready }; + + my ( $sock ) = $future->get; + + can_ok( $sock, qw( peerhost peerport ) ); + is_deeply( [ 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 )' ); + + wait_for { $future->is_ready }; + + my $stream = $future->get; + identical( $stream, $given_stream, '$future->get returns given Stream' ); + ok( my $sock = $stream->read_handle, '$stream has a read handle' ); + is_deeply( [ 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_deeply( [ 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' ); + + wait_for { $future->is_ready }; + + my ( $sock ) = $future->get; + + can_ok( $sock, qw( peerhost peerport ) ); + is_deeply( [ 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_deeply( [ 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_deeply( [ 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 )' ); + + wait_for { $future->is_ready }; + + my $socket = $future->get; + identical( $socket, $given_socket, '$future->get returns given Socket' ); + is_deeply( [ 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_deeply( [ 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' ); + is( $failerr+0, ENOENT, '$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 = $loop->connect( + addr => { family => "unix", socktype => "stream", path => "/some/path/we/know/breaks" }, + on_fail => sub { $failop = shift @_; $failerr = pop @_; }, + ); + + wait_for { $future->is_ready }; + + is( $failop, "connect", '$failop is connect' ); + is( $failerr+0, ENOENT, '$failerr is ENOENT' ); + + ok( $future->is_failed, '$future failed' ); + is( ( $future->failure )[2], "connect", '$future fail op is connect' ); + is( ( $future->failure )[3]+0, ENOENT, '$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; diff --git a/t/52loop-listen.t b/t/52loop-listen.t new file mode 100644 index 0000000..5453630 --- /dev/null +++ b/t/52loop-listen.t @@ -0,0 +1,183 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Identity; + +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() - $!"; + + 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' ); + + identical( $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_deeply( [ 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' ); + + identical( $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_deeply( [ 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; diff --git a/t/53loop-extend.t b/t/53loop-extend.t new file mode 100644 index 0000000..82e7088 --- /dev/null +++ b/t/53loop-extend.t @@ -0,0 +1,103 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Identity; + +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 = @_; + + identical( $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_deeply( \%connectargs, + { some_param => "here" }, + 'FOO_connect received some_param and no others' ); + + identical( $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_deeply( \%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 = @_; + + identical( $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}' ); + is_deeply( \%listenargs, + { some_param => "here" }, + 'FOO_listen received some_param and no others' ); + + identical( $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_deeply( \%listenargs, + { extensions => [qw( BAR )], + param1 => "one", + param2 => "two" }, + 'FOO_listen still receives other extensions' ); +} + +done_testing; diff --git a/t/60protocol.t b/t/60protocol.t new file mode 100644 index 0000000..493931e --- /dev/null +++ b/t/60protocol.t @@ -0,0 +1,146 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Identity; +use Test::Refcount; + +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 ); + +identical( $proto->transport, $handle, '$proto->transport' ); + +is( scalar @setup_args, 1, '@setup_args after configure transport' ); +identical( $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 ); + +identical( $proto->transport, $newhandle, '$proto->transport after reconfigure' ); + +is( scalar @teardown_args, 1, '@teardown_args after reconfigure transport' ); +identical( $teardown_args[0], $handle, '$teardown_args[0] after reconfigure transport'); + +is( scalar @setup_args, 1, '@setup_args after reconfigure transport' ); +identical( $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 ); +} diff --git a/t/61protocol-stream.t b/t/61protocol-stream.t new file mode 100644 index 0000000..da5832a --- /dev/null +++ b/t/61protocol-stream.t @@ -0,0 +1,245 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Refcount; + +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_deeply( \@lines, [], '@lines before wait' ); + + wait_for { scalar @lines }; + + is_deeply( \@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_deeply( \@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 { + is( $_[0], $streamproto, 'writersub $_[0] is $streamproto' ); + return $done++ ? undef : "a lazy message\n"; + }, + on_flush => sub { + 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_deeply( \@sub_lines, [], '@sub_lines before wait' ); + + wait_for { scalar @sub_lines }; + + is_deeply( \@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; +} diff --git a/t/62protocol-linestream.t b/t/62protocol-linestream.t new file mode 100644 index 0000000..2acab97 --- /dev/null +++ b/t/62protocol-linestream.t @@ -0,0 +1,118 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; +use Test::Refcount; + +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_deeply( \@lines, [], '@lines before wait' ); + +wait_for { scalar @lines }; + +is_deeply( \@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_deeply( \@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_deeply( \@sub_lines, [], '@sub_lines before wait' ); + +wait_for { scalar @sub_lines }; + +is_deeply( \@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]; +} diff --git a/t/63handle-connect.t b/t/63handle-connect.t new file mode 100644 index 0000000..1318923 --- /dev/null +++ b/t/63handle-connect.t @@ -0,0 +1,84 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; + +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 = $handle->connect( + family => "inet", + socktype => "stream", + host => $listensock->sockhost, + service => $listensock->sockport, + ); + + wait_for { $f->is_ready }; + $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; diff --git a/t/64handle-bind.t b/t/64handle-bind.t new file mode 100644 index 0000000..772f9e6 --- /dev/null +++ b/t/64handle-bind.t @@ -0,0 +1,36 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use IO::Async::Test; + +use Test::More; + +use IO::Async::Loop; + +use IO::Async::Handle; + +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", + )->get; + + ok( $receiver->read_handle->sockport, '$receiver bound to a read handle' ); +} + +done_testing; diff --git a/t/99pod.t b/t/99pod.t new file mode 100644 index 0000000..eb319fb --- /dev/null +++ b/t/99pod.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod 1.00"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; + +all_pod_files_ok(); diff --git a/t/StupidLoop.pm b/t/StupidLoop.pm new file mode 100644 index 0000000..0b4fc9a --- /dev/null +++ b/t/StupidLoop.pm @@ -0,0 +1,8 @@ +package t::StupidLoop; + +use strict; +use base qw( IO::Async::Loop ); + +sub new { return bless {}, shift; } + +1; diff --git a/t/TimeAbout.pm b/t/TimeAbout.pm new file mode 100644 index 0000000..86b3d1f --- /dev/null +++ b/t/TimeAbout.pm @@ -0,0 +1,31 @@ +package t::TimeAbout; + +use Test::More; +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; |