IO-Async-0.61000755001750001750 012227104373 11544 5ustar00leoleo000000000000IO-Async-0.61/Changes000444001750001750 7463512227104373 13233 0ustar00leoleo000000000000Revision history for IO-Async 0.61 2013/10/15 01:10:51 [CHANGES] * Some OSes lack signals; forbid the ->*_signal methods, and use waitpid() polling for child processes if so * Rearrangement of $loop->listen and IO::Async::Listener logic to allow Listener subclasses to use listen extensions (e.g. SSL) * Allow ->listen to construct new Stream or Socket handles * Updated documentation and tests to emphasise futures with resolver and ->listen * Support spawning threads and watching for exit * Support IO::Async::Routine based on threads * Various MSWin32 improvements and fixes - it now passes tests \o/ * Declare that MSWin32 does not support POSIX-like fork(); skip all unit tests and functionallity based on it if so Note: These changes break IO::Async::SSL versions 0.12 or older. [BUGFIXES] * Ensure that $stream->write( CODE, on_write/write_len ) works correctly With many thanks to Mithaldu for the use of his Windows smoker for development and testing of the MSWin32 fixes 0.60 2013/09/19 14:26:22 [CHANGES] * Updated for Future 0.16 - no longer needs 'return' argument for Future::Utils functions * $stream->connect() ought to default socktype => "stream" [BUGFIXES] * Fix unit tests to better handle INADDR_LOOPBACK not being 127.0.0.1 * Skip-guard ->socket("inet6") unit tests on machines unable to socket(AF_INET6) * Remmeber to ->accept connections to testing socket in t/63handle-connect.t 0.59 CHANGES: * Allow IO::Async::Stream to define custom reader/writer methods * Support writeready-for-read and readready-for-write in Stream * Allow Stream->write() on_write and write_len args * Neatened and documented Future ->fail arguments and conventions * Added Stream on_writeable_{start,stop} events * Added Handle->socket, ->bind and ->connect methods * Revamp of Loop->connect logic; allow passing through an IO::Async::Handle instance BUGFIXES: * Ensure that stream read EOF state is visible during queued on_read events that caused it * Fix 'return ... or die' precendence bug in Resolver (RT87051) * Need to poll() for POLLPRI on MSWin32 and Cygwin 0.58 CHANGES: * Added Stream read watermarks BUGFIXES: * Fix weakself event handlers' use of "shift or return" 0.57 CHANGES: * Allow Stream->write from a Future, CODE that returns Future, Future that returns CODE, etc... * Added Future-returning Stream->read_* methods and ->push_on_read * Return a flush-complete notification Future from Stream->write * Allow Timer::Periodic to stop itself from its own on_tick event * Wrap transport on_{read,write}_eof from Protocol::Stream 0.56 CHANGES: * Added $loop->delay_future and $loop->timeout_future * Added $future->loop accessor * Use a faster splice()-based mechanism for the ARRAY-based TimeQueue * Updated for Future::Utils 0.12 'repeat' function BUGFIXES: * Ensure that Process from => "" works * If select() returns -1 ignore the bit vectors * pipe() on Windows doesn't play with select(); emulate ->pipepair using ->socketpair * Correct use of S_ISREG and stat() 0.55 CHANGES: * Try to ensure IO::Async::OS->socket returns an IO::Socket::IP instance for PF_INET or PF_INET6 if it is available * Don't bother testing subsecond loop_once behaviour because most loops can't actually do it * Use Future::Utils instead of CPS, removing a dependency * Removed IO::Async::Sequencer * Print a deprecation warning on old loop classes with old timer support 0.54 CHANGES: * Use Future instead of CPS::Future * Created IO::Async::Future subclass * Initial support for Futures on Loops * Rewrite lots of internals to use Futures instead of MergePoints or other logic * Renamed all "task" to "future" in APIs * Allow packing of inet/inet6 address structures to omit the IP or port and presume passive or port 0 * Removed $notifier->get_loop synonym * Make IO::Async::MergePoint throw a deprecation warning 0.53 CHANGES: * Added IO_ASYNC_WATCHDOG debugging support BUGFIXES: * Remember to return a task from Function->call even if it's queued (RT79248) 0.52 CHANGES: * Initial attempt at Tasks using CPS::Future * Minor fixes to timer LoopTests to prevent spurious failures of sub-second timing * Declare dependence on perl 5.10 now we're using 5.10 features * Removed long-since deprecated IO::Async::DetachedCode 0.51 CHANGES: * Split much code out to new IO::Async::OS heirarchy * Drop dead dependency on Test::Warn * Smaller simpler signal handling, avoid POSIX::SigSet * Expose getfamilybyname and getsocktypebyname as OS methods BUGFIXES: * Many small MSWin32 fixes that might help pass some tests. Likely still incomplete though 0.50 CHANGES: * Added IO::Async::File * Added filename mode of IO::Async::FileStream * Make Heap dependency optional by reimplementing a tiny but less efficient version of TimeQueue using a plain array * No longer need MB-only Build.PL BUGFIXES: * Round up select() and poll() timeouts to nearest milisecond, might help correct wait-time vs. gettimeofday() mismatches * Fake read- and write-readiness of S_ISREG filehandles in select() on MSWin32 * select() for exceptional status on MSWin32 to check for connect() failures * Don't unit-test that getsockname() works on socketpair()ed sockets 0.49 CHANGES: * Fix watch_time => enqueue_timer conversions; fix unit tests and Timer implementations 0.48 CHANGES: * Support Channel long-running on_recv handler * Support Channel directly between two Routines, in sync. mode at both ends * Added Loop->{watch,unwatch}_time API * Added Function->restart and max_worker_calls parameter * Support other reschedule policies for Timer::Periodic to allow tick skipping, or drift BUGFIXES: * Fix example in Routine SYNOPSIS (thanks apeiron) * Connector should check definedness of local_{host,port} rather than existence 0.47 CHANGES: * Support $listener->listen( v6only => ... ) * Added new data-passing $loop->run and $loop->stop methods BUGFIXES: * Emulate ->socketpair on MSWin32 by connecting to a temporary socket * Account for EWOULDBLOCK on MSWin32 * Don't try reading STDIN to block awaiting a signal in unit-tests * Allow zero-delay Countdown timers (RT75954) * Handle dup2() collisions in ChildManager filehandle setups (RT75573) * Fix race condition in t/33process.t (RT75573) * Ensure Timer->stop doesn't fail if the timer isn't running (RT75571) * Possibly-fix some cygwin test failures (RT71706) * Ensure that 'passive' getaddrinfo hint is handled in both synchronous and numeric cases 0.46 ADDITIONS: * IO::Async::Routine + IO::Async::Channel * IO::Async::Process->kill method CHANGES: * Use Socket 1.93 rather than dual-dependency logic on Socket::GetAddrInfo * Rewrote ::Function based on ::Routine and ::Channel * Cleaner refcount behaviour in ::Process * ::Process no longer waits for EOF condition on write-only pipes * Don't unit-test the reading end of a pipe for HUP condition * Documentation updates * Removed documentation for long-since deprecated $loop->detach_child and ->detach_code methods 0.45 CHANGES: * Added Timer->is_expired predicate, remove_on_expire parameter (RT71767) BUGFIXES: * Use fd3/4 in ::Function rather than STDIN/STDOUT, to avoid corrupting the return channel if the body function prints (RT72448) * Better error detection around setuid/setgid/setgroups (RT72407) * IO::Handle->binmode is not available as a method before perl 5.12; use CORE::binmode() instead * Don't attempt to invoke a missing on_notifier callback in Loop->listen (RT71768) 0.44 CHANGES: * Allow Process to have sockets as handles; including datagram sockets BUGFIXES: * Extract TimeQueue entiries before firing them, in case they do something weird like cancelling themselves (RT70231) * Test dollarbang for EWOULDBLOCK which might help MSWin32 * Cope correctly with Function handles in the presence of -CS or PERL_UNICODE=S 0.43 CHANGES: * Allow IO::Async::Notifier to be used as a non-principle mixin class * Provide Notifier->loop accessor * Added (still-experimental) Notifier debug features * Deleted various deprecated features: + Notifier to Handle upgrade + Loop->enable_childmanager, Loop->disable_childmanager * Print deprecation warnings on Loop->detach_code, Loop->detach_child * Minor improvements to LoopTests 0.42 BUGFIXES: * Test Stream encoding errors on a sequence which still returns U+FFFD immediately on 5.14.0 (RT69020) 0.41 CHANGES: * Support 'encoding' parameter in IO::Async::Stream * Allow IO::Async::Stream->write with an empty string, for the side-effect of setting an on_flush handler * Support 'first_interval' parameter to IO::Async::Timer::Periodic * Expanded documentation of timers BUGFIXES: * Explicitly 'use IO::Handle;' 0.40 ADDITIONS: * Added IO::Async::FileStream - RT66520 * Added IO::Async::Stream 'close_on_read_eof' parameter * Added IO::Async::Listener 'on_accept_failure' event CHANGES: * Allow Loop->listen to be extended via extensions, similar to ->connect * Autoflush streams used in Function::Worker objects by default * Default Resolver to idle_timeout=30, min_workers=0 BUGFIXES: * Don't convert method names to CODErefs during _capture_weakself as it breaks dynamic dispatch and code reload - RT65785 * Only calculate Timer::Periodic's next tick time if it actually has a Loop * Put primary GID first in a 'setgroups' list, otherwise some BSDs get upset - RT65127 * Load getaddrinfo() from Socket or Socket::GetAddrInfo in t/50resolver.t * Remove the anonymous Listener from the Loop if Loop->listen fails - RT66168 * Supply LocalPort => 0 to IO::Socket::INET constructor explicitly during testing 0.39 CHANGES: * Added IO::Async::Notifier 'notifier_name' parameter, which may be used in debugging code in a later version * Added IO::Async::Stream on_write_eof event * Complain about unrecognised keys in IO::Async::Loop->watch_io and IO::Async::Stream->write BUGFIXES: * Don't claim on_hangup supported except on those places we know it will be (Linux, FreeBSD >= 8.0) * Fixed race condition in t/41detached-code.t * Fixed race condition in IO::Async::Function 0.38 ADDITIONS: * IO::Async::Function * IO::Async::Loop->notifiers accessor CHANGES: * Symbolic flags in IO::Async::Resolver as convenience for commonly used flag constants * Distribution now uses Test::Fatal rather than Test::Exception * Resolver is now a subclass of Function, not DetachedCode BUGFIXES: * More robust detection of Socket vs Socket::GetAddrInfo * Portability fix for ChildManager's FD_CLOEXEC flag 0.37 ADDITIONS: * Handle->close_read, ->close_write * Stream on_read_eof event * extract_addrinfo conveniences for 'inet', 'inet6' and 'unix' CHANGES: * Allow Process filehandles to set up plain pipes without read/write behaviour on the associated Stream * Renamed Loop->unpack_addrinfo to ->extract_addrinfo * Prepare for Socket::getaddrinfo() in core; prefer it to Socket::GetAddrInfo::getaddrinfo() 0.36 ADDITIONS: * IO::Async::Process CHANGES: * Allow prequeuing of ->write data in Stream * Check that signal handling remains properly deferred in LoopTests * Miscellaneous documentation and examples updates BUGFIXES: * RT 64558 - getaddrinfo() returns duplicate addresses for localhost * Don't rely on having NI_NUMERICSERV 0.35 ADDITIONS: * Loop->unpack_addrinfo CHANGES: * Recognise 'inet' and 'unix' as socket families * Recognise 'stream', 'dgram' and 'raw' as socket types * Recognise nicer HASH-based addrinfo layout in ->connect and ->listen * Listener now has on_stream / on_socket as full events, not just CODEref parameters * Make Resolver->getaddrinfo try synchronously if given numeric names * Make Resolver->getnameinfo run synchronously if given NI_NUMERICHOST|NI_NUMERICSERV flags * Try to combine small data buffers from Stream->write calls if possible BUGFIXES: * Linefeed in die case of getaddrinfo_hash to preserve exeception string * Deconfigure Protocol->transport after it is closed 0.34 ADDITIONS: * New Notifier methods ->_replace_weakself, ->maybe_invoke_event, ->maybe_make_event_cb * New Protocol method ->connect * New subclass Protocol::LineStream * Direct Resolver->getaddrinfo and ->getnameinfo methods CHANGES: * New Protocol::Stream->new( handle => $io ) parameters, which creates an IO::Async::Stream to use as a transport * Renamed Loop->detach_child to Loop->fork * Pass errno values into ->connect on_connect_error and ->listen on_listen_error * Support timeouts on Resolver operations * Allow direct access to Resolver via Loop->resolver BUGFIXES: * Make sure Protocol::Stream handles writersub and on_flush callback 0.33 ADDITIONS: * Allow watching child PID 0, to capture every child process exit * $loop->time accessor * Stream->write( sub { ... } ) dynamic stream generation * Stream->write( $data, on_flush => sub { ... } ) callback CHANGES: * IO::Async::Loop->new magic constructor now caches the loop; useful for wrapping modules, other event system integration, etc.. 0.32 ADDITIONS: * IO::Async::Timer::Absolute * Listener accessors for ->sockname, ->family, ->socktype CHANGES: * Implement and document Handle's want_{read,write}ready parameters * Rearranged documentation for Notifier subclasses; new EVENTS sections * Correct location for #io-async channel on irc.perl.org 0.31 ADDITIONS: * Delegate Protocol->close method and on_closed continuation to its transport object * Stream->new_for_stdin, ->new_for_stdout, ->new_for_stdio * Support Listener->new( handle => $fh ) * IO::Async::PID notifier subclass CHANGES: * Better documentation of Listener and Connector addr and addrs arguments BUGFIXES: * INADDR_ANY/INADDR_LOOPBACK fixes inside BSD jails with restricted networking 0.30 ADDITIONS: * Added IO::Async::Socket * Added IO::Async::Protocol and ::Protocol::Stream * Added on_stream and on_socket continuations for $loop->connect and Listener CHANGES: * Emulate socketpair(AF_INET,...) * Allow IO::Async::Stream 's read_len and write_len to be configured per-instance * Allow a Stream object without an on_read handler BUGFIXES: * Cope with exceptional-state sockets in Loop::Poll 0.29 CHANGES: * Don't require 'CODE' refs for callbacks/continations; this allows the use of CODEref objects, &{} operator overloads, or other things that are callable * Implement 'read_all' and 'write_all' options on IO::Async::Stream * Allow IO::Async::Stream subclasses to override on_closed BUGFIXES: * Work around some OSes not implementing SO_ACCEPTCONN * Ensure Handle's on_read_ready/on_write_ready callbacks also take a $self reference 0.28 BUGFIXES: * Ensure that Timer->start returns $self even when not in a Loop * Accept bare GLOB refs as IO::Async::Listener handles; upgrade them to IO::Socket refs if required * Applied documentation patch from RT 55375 - thanks to Chris Williams 0.27 CHANGES: * Implement 'autoflush' option on IO::Async::Stream BUGFIXES: * Avoid $_ breaking stored signal handler references when invoking them * Ignore EINTR from sysread/syswrite * More reliable socket address tests - don't rely on uninitialised padding bytes between struct members 0.26 BUGFIXES: * Connect to INADDR_LOOPBACK rather than INADDR_ANY during t/24listener.t; hopefully fixes FAILs on OpenBSD * Fix IO::Async::Stream during combined read/write-ready of a closed stream 0.25 CHANGES: * Accept 'stream'/'dgram'/'raw' as symbolic shortcuts for socket types in connect/listen operations - avoids 'use Socket' * Accept IO::Handle-derived objects in ChildManager setup keys as well as raw GLOB refs BUGFIXES: * Various changes to test scripts to hopefully improve portability or reliability during smoke tests 0.24 ADDITIONS: * Timer subclasses - Countdown and Periodic * Idleness event watching via low-level 'watch_io/unwatch_io' methods and higher-level 'later' method * Added the missing 'unwatch_child' method * Shareable acceptance testing suite for IO::Async::Loop subclasses for better testing in subclass implementations CHANGES: * More future-proof API version checking for subclasses - requires subclasses to declare their version. ### pre-0.24 Loop subclasses are no longer compatible. ### * Entirely remove the need to $loop->enable_childmanager by calling waitpid() in 'watch_child'. 0.23 CHANGES: * Rearranged IO::Async::Listener to be a constructable Notifier suclass * Allow Signal, Timer and Listener to act as base classes as well as standalone with callbacks * Renamed IO::Async::Loop::IO_Poll to ::Poll; created transparent backward-compatibility wrapper 0.22 CHANGES: * Added tcp-proxy.pl example * More documentation on IO::Async::Notifier subclass-override methods * Documented that IO::Async::MergePoint is just an Async::MergePoint * Various small updates to keep CPANTS happy BUGFIXES: * Don't test Async::MergePoint locally as it's now a separate dist, and the tests here were reporting false negatives. 0.21 CHANGES: * Added "use warnings" to all modules * Created Notifier->configure method to allow changing properties of a Notifier or subclass after construction * New 'examples' dir with some small example scripts BUGFIXES: * More robust timing tests to avoid some spurious test failures due to busy testing servers or other non-issues 0.20 CHANGES: * Major reworking of underlying Loop implementation: + Unified low-level IO, timer and signal watches as callbacks + Split IO handle parts of Notifier into new IO::Async::Handle class + Created Timer and Signal subclasses of Notifier These changes will require a compatible upgrade to the underlying Loop implementation. * Hide SignalProxy and TimeQueue from CPAN's indexer, as they are internal-only details that don't need exposing there. * Loop magic constructor now warns if a specifically-requested class is not available * Allow multiple attachment of signals via Loop->attach_signal or new Signal objects 0.19 CHANGES: * Allow control of Sequencer's pipelining * Documentation fixes * Allow Loop->run_child to take a 'setup' array * Added 'setuid', 'setgid' and 'setgroups' child setup operations * Support 'on_notifier' in Loop->listen BUGFIXES: * carp before return in Stream->write so it actually prints * Ensure Streams still work after being closed and reopened by ->set_handle * If IO::Socket->new() fails, try again with generic ->socket (makes IPv6 work on platforms without IO::Socket::INET6) 0.18 CHANGES: * Allow Sequencer to be a base class as well as using constructor callbacks * Use signal names from Config.pm rather than relying on POSIX.pm. Covers more signals that way BUGFIXES: * Gracefully handle accept() returning EAGAIN * Fixed handling of IO::Socket->getsockopt( SOL_SOCKET, SO_ERROR ) 0.17 CHANGES: * Added Stream->close_when_empty and ->close_now. Added docs * Added OS abstractions of socketpair() and pipe() * Many documentation changes and updates BUGFIXES: * Properly handle stream read/write errors; close immediately rather than deferring until empty. * Various CPAN testers somketest bug fixes * Fixed http://rt.cpan.org/Ticket/Display.html?id=38476 0.16 ADDITIONS: * Loop->requeue_timer() * Magic constructor in IO::Async::Loop which tries to find the best subclass * 'chdir' and 'nice' ChildManager operations CHANGES: * Make sure that top-level objects are refcount-clean by using Test::Refcount, and Scalar::Util::weaken() BUGFIXES: * Keep perl 5.6.1 happy by not passing LocalPort => 0 when constructing IO::Socket::INETs * Pass the Type option to IO::Socket::INET constructor in test scripts 0.15 REMOVALS: * IO::Async::Set subclasses and IO::Async::Buffer have now been entirely removed. CHANGES: * Support handle-less IO::Async::Sequencer, like ::Notifier * Set SO_REUSEADDR on listening sockets by default * Allow Loop->listen() on a plain filehandle containing a socket * No longer any need to explcitly call Loop->enable_childmanager BUGFIXES: * IO::Async::Loop->_adjust_timeout actually works properly * Notifier->close() only runs on_closed callback if it actually closed - allows for neater cross-connected Notifiers * Made Notifier->want_{read,write}ready more efficient * Notifier->close() on a child notifier works * Loop->listen() should take the first successful address, rather than trying them all 0.14 REMOVALS: * IO::Async::Set subclasses and IO::Async::Buffer are now completely deprecated. Any attempt to use them will fail immediately. ADDITIONS: * 'keep' ChildManager operation * IO::Async::Test::wait_for_stream() * Loop->listen() * IO::Async::Sequencer class CHANGES: * Support dynamic swapping of temporary 'on_read' handlers in Stream * Now requires Socket::GetAddrInfo >= 0.08 * Further shortcuts in ChildManager setup keys - IO references and simple string operation names * Support handle-less IO::Async::Notifiers that have IO handles added to them later * Allow 'setup' key to Loop->detach_code() * Various documentation updates BUGFIXES: * Allow the same filehandle to be 'dup'ed more than once in ChildManager 0.13 CHANGES: * Flush all awaiting data from Stream when it becomes writeready * Supply a real IO::Async::Test module to allow testing in 3rd party distros * Various documentation fixes BUGFIXES: * Don't rely on STDOUT being writable during test scripts 0.12 CHANGES: * Allow Notifiers that are write-only. * Added ChildManager->open and ->run; with ->open_child and ->run_child on the containing Loop. * Moved IO::Async::Loop::Glib out to its own CPAN dist, to simplify Build.PL and testing scripts BUGFIXES: * Make sure to "use IO::Socket" in IO::Async::Connector * Pass 'socktype' argument to ->connect during testing 0.11 INCOMPATIBLE CHANGES: * Renamed IO::Async::Set::* to IO::Async::Loop::* - provided backward-compatibility wrappers around old names. IO::Async::Set::GMainLoop has become IO::Async::Lib::Glib * Renamed IO::Async::Buffer to IO::Async::Stream - provided backward- compatibility wrapper around old name. * Loop->get_childmanager() and ->get_sigproxy() no longer allowed CHANGES: * Extended ->loop_once() and ->loop() feature out to all IO::Async::Loop classes * Added IO::Async::Resolver and IO::Async::Connector, plus Loop integration * Allow write-only IO::Async::Notifiers that have no read handle or readiness callback. 0.10 INCOMPATIBLE CHANGES: * Renamed events and methods in IO::Async::Notifier to better fit the naming scheme of normal Perl handles. Backward-compatibility hooks are currently provided, but will be removed in a later release. Any code using the old names should be updated CHANGES: * Allow DetachedCode to have multiple back-end worker processes. * Control if a back-end worker exits when the code "die"s * Added 'close()' method on Notifiers/Buffers. Sensible behaviour on buffers with queued data to send * Reset %SIG hash in ChildManager->detach_child() BUGFIXES: * Clean up temporary directory during testing * Shut down DetachedCode workers properly on object deref * Better handling of borderline timing failures in t/11set-*.t * Close old handles before dup2()ing new ones when detaching code * Various other minor test script improvements 0.09 CHANGES: * Added TimeQueue object and integration with IO::Async::Set and subclasses. * Added MergePoint object * Added 'on_closed' callback support to IO::Async::Notifier BUGFIXES: * Don't depend on system locale when checking string value of $! * Fixed test scripts to more closely approximate real code behaviour in the presence of poll() vs. deferred signal delivery 0.08 CHANGES: * Added ChildManager->detach_child() method * Added DetachedCode object BUGFIXES: * Better tests for presence of Glib to improve test false failures * More lenient times in test script 11set-IO-Poll-timing to allow for variances at test time * Avoid bugs in post_select()/post_poll() caused by some notifier callbacks removing other notifiers from the set 0.07 BUGFIXES: * Avoid race condition in t/30childmanager.t - wait for child process to actually exit * Avoid race condition in IO::Async::ChildManager->spawn() by waiting for SIGCHLD+pipe close, rather than SIGCHLD+pipe data 0.06 CHANGES: * Allow 'env' setup key to ChildManager->spawn() to change the child's %ENV * Updated the way some of the ->spawn() tests are conducted. There seems to be massive failures reported on cpantesters against 0.05. These changes won't fix the bugs, but should assist in reporting and tracking them down. BUGFIXES: * Don't rely on existence of /bin/true - test for /usr/bin/true as well, fall back on "$^X -e 1" * Avoid kernel race condition in t/32childmanager-spawn-setup.t by proper use of select() when testing. 0.05 CHANGES: * Added ChildManager object * Added singleton storage in IO::Async::Set to store a SignalProxy or ChildManager conveniently BUGFIXES: * Workaround for a bug in IO::Poll version 0.05 0.04 CHANGES: * Added dynamic signal attach / detach methods to SignalProxy * Buffer now has on_read_error / on_write_error callbacks for handling IO errors on underlying sysread()/syswrite() calls 0.03 CHANGES: * No longer build_requires 'Glib' - print a warning if it's not installed but carry on anyway. * IO_Poll->loop_once() now returns the result from the poll() call * Added concept of nested child notifiers within Notifier object BUGFIXES: * Fix to test scripts that call IO_Poll's loop_once() with a timeout of zero. This can cause a kernel race condition, so supply some small non-zero value instead. 0.02 INCOMPATIBLE CHANGES: * Event methods/callback functions now called "on_*" to distinguish them * Callback functions now pass $self as first argument to simplify called code CHANGES: * Improved POD in Notifier.pm and Buffer.pm BUGFIXES: * GMainLoop.pm - return 1 from callbacks so that glib doesn't remove our IO sources * GMainLoop.pm - make sure re-asserting want_writeready actually adds the IO source again 0.01 First version, released on an unsuspecting world. IO-Async-0.61/META.json000444001750001750 1173212227104373 13346 0ustar00leoleo000000000000{ "abstract" : "Asynchronous event-driven programming", "author" : [ "Paul Evans " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4007, CPAN::Meta::Converter version 2.132661", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "IO-Async", "prereqs" : { "build" : { "requires" : { "File::Temp" : "0", "Test::Fatal" : "0", "Test::Identity" : "0", "Test::More" : "0.88", "Test::Refcount" : "0" } }, "runtime" : { "recommends" : { "IO::Socket::IP" : "0" }, "requires" : { "Exporter" : "5.57", "File::stat" : "0", "Future" : "0.12", "Future::Utils" : "0.18", "IO::Poll" : "0", "Socket" : "2.007", "Storable" : "0", "Time::HiRes" : "0", "perl" : "5.010" } } }, "provides" : { "IO::Async" : { "file" : "lib/IO/Async.pm", "version" : "0.61" }, "IO::Async::Channel" : { "file" : "lib/IO/Async/Channel.pm", "version" : "0.61" }, "IO::Async::ChildManager" : { "file" : "lib/IO/Async/ChildManager.pm", "version" : "0.61" }, "IO::Async::File" : { "file" : "lib/IO/Async/File.pm", "version" : "0.61" }, "IO::Async::FileStream" : { "file" : "lib/IO/Async/FileStream.pm", "version" : "0.61" }, "IO::Async::Function" : { "file" : "lib/IO/Async/Function.pm", "version" : "0.61" }, "IO::Async::Future" : { "file" : "lib/IO/Async/Future.pm", "version" : "0.61" }, "IO::Async::Handle" : { "file" : "lib/IO/Async/Handle.pm", "version" : "0.61" }, "IO::Async::Listener" : { "file" : "lib/IO/Async/Listener.pm", "version" : "0.61" }, "IO::Async::Loop" : { "file" : "lib/IO/Async/Loop.pm", "version" : "0.61" }, "IO::Async::Loop::Poll" : { "file" : "lib/IO/Async/Loop/Poll.pm", "version" : "0.61" }, "IO::Async::Loop::Select" : { "file" : "lib/IO/Async/Loop/Select.pm", "version" : "0.61" }, "IO::Async::LoopTests" : { "file" : "lib/IO/Async/LoopTests.pm", "version" : "0.61" }, "IO::Async::MergePoint" : { "file" : "lib/IO/Async/MergePoint.pm", "version" : "0.61" }, "IO::Async::Notifier" : { "file" : "lib/IO/Async/Notifier.pm", "version" : "0.61" }, "IO::Async::OS" : { "file" : "lib/IO/Async/OS.pm", "version" : "0.61" }, "IO::Async::OS::MSWin32" : { "file" : "lib/IO/Async/OS/MSWin32.pm", "version" : "0.61" }, "IO::Async::OS::cygwin" : { "file" : "lib/IO/Async/OS/cygwin.pm", "version" : "0.61" }, "IO::Async::PID" : { "file" : "lib/IO/Async/PID.pm", "version" : "0.61" }, "IO::Async::Process" : { "file" : "lib/IO/Async/Process.pm", "version" : "0.61" }, "IO::Async::Protocol" : { "file" : "lib/IO/Async/Protocol.pm", "version" : "0.61" }, "IO::Async::Protocol::LineStream" : { "file" : "lib/IO/Async/Protocol/LineStream.pm", "version" : "0.61" }, "IO::Async::Protocol::Stream" : { "file" : "lib/IO/Async/Protocol/Stream.pm", "version" : "0.61" }, "IO::Async::Resolver" : { "file" : "lib/IO/Async/Resolver.pm", "version" : "0.61" }, "IO::Async::Routine" : { "file" : "lib/IO/Async/Routine.pm", "version" : "0.61" }, "IO::Async::Signal" : { "file" : "lib/IO/Async/Signal.pm", "version" : "0.61" }, "IO::Async::Socket" : { "file" : "lib/IO/Async/Socket.pm", "version" : "0.61" }, "IO::Async::Stream" : { "file" : "lib/IO/Async/Stream.pm", "version" : "0.61" }, "IO::Async::Test" : { "file" : "lib/IO/Async/Test.pm", "version" : "0.61" }, "IO::Async::Timer" : { "file" : "lib/IO/Async/Timer.pm", "version" : "0.61" }, "IO::Async::Timer::Absolute" : { "file" : "lib/IO/Async/Timer/Absolute.pm", "version" : "0.61" }, "IO::Async::Timer::Countdown" : { "file" : "lib/IO/Async/Timer/Countdown.pm", "version" : "0.61" }, "IO::Async::Timer::Periodic" : { "file" : "lib/IO/Async/Timer/Periodic.pm", "version" : "0.61" } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.61" } IO-Async-0.61/README000444001750001750 2671012227104373 12607 0ustar00leoleo000000000000NAME `IO::Async' - Asynchronous event-driven programming SYNOPSIS use IO::Async::Stream; use IO::Async::Loop; my $loop = IO::Async::Loop->new; $loop->connect( host => "some.other.host", service => 12345, socktype => 'stream', on_stream => sub { my ( $stream ) = @_; $stream->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*\n)// ) { print "Received a line $1"; } return 0; } ); $stream->write( "An initial line here\n" ); $loop->add( $stream ); }, on_resolve_error => sub { die "Cannot resolve - $_[-1]\n"; }, on_connect_error => sub { die "Cannot connect - $_[0] failed $_[-1]\n"; }, ); $loop->run; DESCRIPTION This collection of modules allows programs to be written that perform asynchronous filehandle IO operations. A typical program using them would consist of a single subclass of IO::Async::Loop to act as a container of other objects, which perform the actual IO work required by the program. As well as IO handles, the loop also supports timers and signal handlers, and includes more higher-level functionality built on top of these basic parts. Because there are a lot of classes in this collection, the following overview gives a brief description of each. Notifiers The base class of all the event handling subclasses is IO::Async::Notifier. It does not perform any IO operations itself, but instead acts as a base class to build the specific IO functionality upon. It can also coordinate a collection of other Notifiers contained within it, forming a tree structure. The following sections describe particular types of Notifier. File Handle IO An IO::Async::Handle object is a Notifier that represents a single IO handle being managed. While in most cases it will represent a single filehandle, such as a socket (for example, an IO::Socket::INET connection), it is possible to have separate reading and writing handles (most likely for a program's `STDIN' and `STDOUT' streams, or a pair of pipes connected to a child process). The IO::Async::Stream class is a subclass of IO::Async::Handle which maintains internal incoming and outgoing data buffers. In this way, it implements bidirectional buffering of a byte stream, such as a TCP socket. The class automatically handles reading of incoming data into the incoming buffer, and writing of the outgoing buffer. Methods or callbacks are used to inform when new incoming data is available, or when the outgoing buffer is empty. While stream-based sockets can be handled using using `IO::Async::Stream', datagram or raw sockets do not provide a bytestream. For these, the IO::Async::Socket class is another subclass of IO::Async::Handle which maintains an outgoing packet queue, and informs of packet receipt using a callback or method. The IO::Async::Listener class is another subclass of IO::Async::Handle which facilitates the use of `listen(2)'-mode sockets. When a new connection is available on the socket it will `accept(2)' it and pass the new client socket to its callback function. Timers An IO::Async::Timer::Absolute object represents a timer that expires at a given absolute time in the future. An IO::Async::Timer::Countdown object represents a count time timer, which will invoke a callback after a given delay. It can be stopped and restarted. An IO::Async::Timer::Periodic object invokes a callback at regular intervals from its initial start time. It is reliable and will not drift due to the time taken to run the callback. The IO::Async::Loop also supports methods for managing timed events on a lower level. Events may be absolute, or relative in time to the time they are installed. Signals An IO::Async::Signal object represents a POSIX signal, which will invoke a callback when the given signal is received by the process. Multiple objects watching the same signal can be used; they will all invoke in no particular order. Processes Management An IO::Async::PID object invokes its event when a given child process exits. An IO::Async::Process object can start a new child process running either a given block of code, or executing a given command, set up pipes on its filehandles, write to or read from these pipes, and invoke its event when the child process exits. Loops The IO::Async::Loop object class represents an abstract collection of IO::Async::Notifier objects, and manages the actual filehandle IO watchers, timers, signal handlers, and other functionality. It performs all of the abstract collection management tasks, and leaves the actual OS interactions to a particular subclass for the purpose. IO::Async::Loop::Poll uses an IO::Poll object for this test. IO::Async::Loop::Select uses the `select(2)' syscall. Other subclasses of loop may appear on CPAN under their own dists; see the SEE ALSO section below for more detail. As well as these general-purpose classes, the IO::Async::Loop constructor also supports looking for OS-specific subclasses, in case a more efficient implementation exists for the specific OS it runs on. Child Processes The IO::Async::Loop object provides a number of methods to facilitate the running of child processes. `spawn_child' is primarily a wrapper around the typical `fork(2)'/`exec(2)' style of starting child processes, and `run_child' provide a method similar to perl's `readpipe' (which is used to implement backticks ```'). File Change Watches The IO::Async::File object observes changes to `stat(2)' properties of a file, directory, or other filesystem object. It invokes callbacks when properties change. This is used by IO::Async::FileStream which presents the same events as a `IO::Async::Stream' but operates on a regular file on the filesystem, observing it for updates. Asynchronous Co-routines and Functions The `IO::Async' framework generally provides mechanisms for multiplexing IO tasks between different handles, so there aren't many occasions when it is necessary to run code in another thread or process. Two cases where this does become useful are when: * A large amount of computationally-intensive work needs to be performed. * An OS or library-level function needs to be called, that will block, and no asynchronous version is supplied. For these cases, an instance of IO::Async::Function can be used around a code block, to execute it in a worker child process or set of processes. The code in the sub-process runs isolated from the main program, communicating only by function call arguments and return values. This can be used to solve problems involving state-less library functions. An IO::Async::Routine object wraps a code block running in a separate process to form a kind of co-routine. Communication with it happens via IO::Async::Channel objects. It can be used to solve any sort of problem involving keeping a possibly-stateful co-routine running alongside the rest of an asynchronous program. Futures An IO::Async::Future object represents a single outstanding action that is yet to complete, such as a name resolution operation or a socket connection. It stands in contrast to a `IO::Async::Notifier', which is an object that represents an ongoing source of activity, such as a readable filehandle of bytes or a POSIX signal. Futures are a recent addition to the `IO::Async' API and details are still subject to change and experimentation. In general, methods that support Futures return a new Future object to represent the outstanding operation. If callback functions are supplied as well, these will be fired in addition to the Future object becoming ready. Any failures that are reported will, in general, use the same conventions for the Future's `fail' arguments to relate it to the legacy `on_error'-style callbacks. $on_NAME_error->( $message, @argmuents ) $f->fail( $message, NAME, @arguments ) where `$message' is a message intended for humans to read (so that this is the message displayed by `$f->get' if the failure is not otherwise caught), `NAME' is the name of the failing operation. If the failure is due to a failed system call, the value of `$!' will be the final argument. The message should not end with a linefeed. Networking The IO::Async::Loop provides several methods for performing network-based tasks. Primarily, the `connect' and `listen' methods allow the creation of client or server network sockets. Additionally, the `resolve' method allows the use of the system's name resolvers in an asynchronous way, to resolve names into addresses, or vice versa. These methods are fully IPv6-capable if the underlying operating system is. Protocols The IO::Async::Protocol class provides storage for a IO::Async::Handle object, to act as a transport for some protocol. It allows a level of independence from the actual transport being for that protocol, allowing it to be easily reused. The IO::Async::Protocol::Stream subclass provides further support for protocols based on stream connections, such as TCP sockets. TODO This collection of modules is still very much in development. As a result, some of the potentially-useful parts or features currently missing are: * Consider further ideas on Solaris' *ports*, BSD's *Kevents* and anything that might be useful on Win32. * Consider some form of persistent object wrapper in the form of an `IO::Async::Object', based on `IO::Async::Routine'. * `IO::Async::Protocol::Datagram' * Support for watching filesystem entries for change. Extract logic from `IO::Async::File' and define a Loop watch/unwatch method pair. * Define more `Future'-returning methods. Consider also one-shot Futures on things like `IO::Async::Process' exits, or `IO::Async::Handle' close. SUPPORT Bugs may be reported via RT at https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Async Support by IRC may also be found on irc.perl.org in the #io-async channel. SEE ALSO As well as the two loops supplied in this distribution, many more exist on CPAN. At the time of writing this includes: * IO::Async::Loop::AnyEvent - use IO::Async with AnyEvent * IO::Async::Loop::Epoll - use IO::Async with epoll on Linux * IO::Async::Loop::Event - use IO::Async with Event * IO::Async::Loop::EV - use IO::Async with EV * IO::Async::Loop::Glib - use IO::Async with Glib or GTK * IO::Async::Loop::KQueue - use IO::Async with kqueue * IO::Async::Loop::Mojo - use IO::Async with Mojolicious * IO::Async::Loop::POE - use IO::Async with POE * IO::Async::Loop::Ppoll - use IO::Async with ppoll(2) Additionally, some other event loops or modules also support being run on top of `IO::Async': * AnyEvent::Impl::IOAsync - AnyEvent adapter for IO::Async * Gungho::Engine::IO::Async - IO::Async Engine * POE::Loop::IO_Async - IO::Async event loop support for POE AUTHOR Paul Evans IO-Async-0.61/Build.PL000444001750001750 204512227104373 13176 0ustar00leoleo000000000000use strict; use warnings; use Module::Build; my $build = Module::Build->new( module_name => 'IO::Async', requires => { 'Future' => '0.12', 'Future::Utils' => '0.18', # try_repeat 'Exporter' => '5.57', 'File::stat' => 0, 'IO::Poll' => 0, 'Socket' => '2.007', 'Storable' => 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, }, build_requires => { 'File::Temp' => 0, 'Test::Fatal' => 0, 'Test::Identity' => 0, 'Test::More' => '0.88', 'Test::Refcount' => 0, }, auto_configure_requires => 0, # Don't add M::B to configure_requires license => 'perl', create_makefile_pl => 'traditional', create_license => 1, create_readme => 1, ); $build->create_build_script; IO-Async-0.61/LICENSE000444001750001750 4376012227104373 12740 0ustar00leoleo000000000000This software is copyright (c) 2013 by Paul Evans . This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2013 by Paul Evans . This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Suite 500, Boston, MA 02110-1335 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2013 by Paul Evans . 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 IO-Async-0.61/META.yml000444001750001750 622612227104373 13160 0ustar00leoleo000000000000--- abstract: 'Asynchronous event-driven programming' author: - 'Paul Evans ' build_requires: File::Temp: 0 Test::Fatal: 0 Test::Identity: 0 Test::More: 0.88 Test::Refcount: 0 dynamic_config: 1 generated_by: 'Module::Build version 0.4007, CPAN::Meta::Converter version 2.132661' 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.61 IO::Async::Channel: file: lib/IO/Async/Channel.pm version: 0.61 IO::Async::ChildManager: file: lib/IO/Async/ChildManager.pm version: 0.61 IO::Async::File: file: lib/IO/Async/File.pm version: 0.61 IO::Async::FileStream: file: lib/IO/Async/FileStream.pm version: 0.61 IO::Async::Function: file: lib/IO/Async/Function.pm version: 0.61 IO::Async::Future: file: lib/IO/Async/Future.pm version: 0.61 IO::Async::Handle: file: lib/IO/Async/Handle.pm version: 0.61 IO::Async::Listener: file: lib/IO/Async/Listener.pm version: 0.61 IO::Async::Loop: file: lib/IO/Async/Loop.pm version: 0.61 IO::Async::Loop::Poll: file: lib/IO/Async/Loop/Poll.pm version: 0.61 IO::Async::Loop::Select: file: lib/IO/Async/Loop/Select.pm version: 0.61 IO::Async::LoopTests: file: lib/IO/Async/LoopTests.pm version: 0.61 IO::Async::MergePoint: file: lib/IO/Async/MergePoint.pm version: 0.61 IO::Async::Notifier: file: lib/IO/Async/Notifier.pm version: 0.61 IO::Async::OS: file: lib/IO/Async/OS.pm version: 0.61 IO::Async::OS::MSWin32: file: lib/IO/Async/OS/MSWin32.pm version: 0.61 IO::Async::OS::cygwin: file: lib/IO/Async/OS/cygwin.pm version: 0.61 IO::Async::PID: file: lib/IO/Async/PID.pm version: 0.61 IO::Async::Process: file: lib/IO/Async/Process.pm version: 0.61 IO::Async::Protocol: file: lib/IO/Async/Protocol.pm version: 0.61 IO::Async::Protocol::LineStream: file: lib/IO/Async/Protocol/LineStream.pm version: 0.61 IO::Async::Protocol::Stream: file: lib/IO/Async/Protocol/Stream.pm version: 0.61 IO::Async::Resolver: file: lib/IO/Async/Resolver.pm version: 0.61 IO::Async::Routine: file: lib/IO/Async/Routine.pm version: 0.61 IO::Async::Signal: file: lib/IO/Async/Signal.pm version: 0.61 IO::Async::Socket: file: lib/IO/Async/Socket.pm version: 0.61 IO::Async::Stream: file: lib/IO/Async/Stream.pm version: 0.61 IO::Async::Test: file: lib/IO/Async/Test.pm version: 0.61 IO::Async::Timer: file: lib/IO/Async/Timer.pm version: 0.61 IO::Async::Timer::Absolute: file: lib/IO/Async/Timer/Absolute.pm version: 0.61 IO::Async::Timer::Countdown: file: lib/IO/Async/Timer/Countdown.pm version: 0.61 IO::Async::Timer::Periodic: file: lib/IO/Async/Timer/Periodic.pm version: 0.61 recommends: IO::Socket::IP: 0 requires: Exporter: 5.57 File::stat: 0 Future: 0.12 Future::Utils: 0.18 IO::Poll: 0 Socket: 2.007 Storable: 0 Time::HiRes: 0 perl: 5.010 resources: license: http://dev.perl.org/licenses/ version: 0.61 IO-Async-0.61/MANIFEST000444001750001750 436312227104373 13040 0ustar00leoleo000000000000Build.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/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/MergePoint.pm lib/IO/Async/Notifier.pm lib/IO/Async/OS.pm lib/IO/Async/OS/cygwin.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-child.t t/06notifier-mixin.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/99pod.t t/StupidLoop.pm t/TimeAbout.pm IO-Async-0.61/Makefile.PL000444001750001750 147112227104373 13656 0ustar00leoleo000000000000# Note: this file was auto-generated by Module::Build::Compat version 0.4007 require 5.010; use ExtUtils::MakeMaker; WriteMakefile ( 'NAME' => 'IO::Async', 'VERSION_FROM' => 'lib/IO/Async.pm', 'PREREQ_PM' => { 'Exporter' => '5.57', 'File::Temp' => 0, 'File::stat' => 0, 'Future' => '0.12', 'Future::Utils' => '0.18', 'IO::Poll' => 0, 'Socket' => '2.007', 'Storable' => 0, 'Test::Fatal' => 0, 'Test::Identity' => 0, 'Test::More' => '0.88', 'Test::Refcount' => 0, 'Time::HiRes' => 0 }, 'INSTALLDIRS' => 'site', 'EXE_FILES' => [], 'PL_FILES' => {} ) ; IO-Async-0.61/lib000755001750001750 012227104373 12312 5ustar00leoleo000000000000IO-Async-0.61/lib/IO000755001750001750 012227104373 12621 5ustar00leoleo000000000000IO-Async-0.61/lib/IO/Async.pm000444001750001750 2710712227104373 14420 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2008-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.61'; =head1 NAME C - Asynchronous event-driven programming =head1 SYNOPSIS use IO::Async::Stream; use IO::Async::Loop; my $loop = IO::Async::Loop->new; $loop->connect( host => "some.other.host", service => 12345, socktype => 'stream', on_stream => sub { my ( $stream ) = @_; $stream->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*\n)// ) { print "Received a line $1"; } return 0; } ); $stream->write( "An initial line here\n" ); $loop->add( $stream ); }, on_resolve_error => sub { die "Cannot resolve - $_[-1]\n"; }, on_connect_error => sub { die "Cannot connect - $_[0] failed $_[-1]\n"; }, ); $loop->run; =head1 DESCRIPTION This collection of modules allows programs to be written that perform asynchronous filehandle IO operations. A typical program using them would consist of a single subclass of L to act as a container of other objects, which perform the actual IO work required by the program. As well as IO handles, the loop also supports timers and signal handlers, and includes more higher-level functionality built on top of these basic parts. Because there are a lot of classes in this collection, the following overview gives a brief description of each. =head2 Notifiers The base class of all the event handling subclasses is L. It does not perform any IO operations itself, but instead acts as a base class to build the specific IO functionality upon. It can also coordinate a collection of other Notifiers contained within it, forming a tree structure. The following sections describe particular types of Notifier. =head2 File Handle IO An L object is a Notifier that represents a single IO handle being managed. While in most cases it will represent a single filehandle, such as a socket (for example, an L connection), it is possible to have separate reading and writing handles (most likely for a program's C and C streams, or a pair of pipes connected to a child process). The L class is a subclass of L which maintains internal incoming and outgoing data buffers. In this way, it implements bidirectional buffering of a byte stream, such as a TCP socket. The class automatically handles reading of incoming data into the incoming buffer, and writing of the outgoing buffer. Methods or callbacks are used to inform when new incoming data is available, or when the outgoing buffer is empty. While stream-based sockets can be handled using using C, datagram or raw sockets do not provide a bytestream. For these, the L class is another subclass of L which maintains an outgoing packet queue, and informs of packet receipt using a callback or method. The L class is another subclass of L which facilitates the use of C-mode sockets. When a new connection is available on the socket it will C it and pass the new client socket to its callback function. =head2 Timers An L object represents a timer that expires at a given absolute time in the future. An L object represents a count time timer, which will invoke a callback after a given delay. It can be stopped and restarted. An L object invokes a callback at regular intervals from its initial start time. It is reliable and will not drift due to the time taken to run the callback. The L also supports methods for managing timed events on a lower level. Events may be absolute, or relative in time to the time they are installed. =head2 Signals An L object represents a POSIX signal, which will invoke a callback when the given signal is received by the process. Multiple objects watching the same signal can be used; they will all invoke in no particular order. =head2 Processes Management An L object invokes its event when a given child process exits. An L object can start a new child process running either a given block of code, or executing a given command, set up pipes on its filehandles, write to or read from these pipes, and invoke its event when the child process exits. =head2 Loops The L object class represents an abstract collection of L objects, and manages the actual filehandle IO watchers, timers, signal handlers, and other functionality. It performs all of the abstract collection management tasks, and leaves the actual OS interactions to a particular subclass for the purpose. L uses an L object for this test. L uses the C syscall. Other subclasses of loop may appear on CPAN under their own dists; see the L section below for more detail. As well as these general-purpose classes, the L constructor also supports looking for OS-specific subclasses, in case a more efficient implementation exists for the specific OS it runs on. =head2 Child Processes The L object provides a number of methods to facilitate the running of child processes. C is primarily a wrapper around the typical C/C style of starting child processes, and C provide a method similar to perl's C (which is used to implement backticks C<``>). =head2 File Change Watches The L object observes changes to C properties of a file, directory, or other filesystem object. It invokes callbacks when properties change. This is used by L which presents the same events as a C but operates on a regular file on the filesystem, observing it for updates. =head2 Asynchronous Co-routines and Functions The C framework generally provides mechanisms for multiplexing IO tasks between different handles, so there aren't many occasions when it is necessary to run code in another thread or process. Two cases where this does become useful are when: =over 4 =item * A large amount of computationally-intensive work needs to be performed. =item * An OS or library-level function needs to be called, that will block, and no asynchronous version is supplied. =back For these cases, an instance of L can be used around a code block, to execute it in a worker child process or set of processes. The code in the sub-process runs isolated from the main program, communicating only by function call arguments and return values. This can be used to solve problems involving state-less library functions. An L object wraps a code block running in a separate process to form a kind of co-routine. Communication with it happens via L objects. It can be used to solve any sort of problem involving keeping a possibly-stateful co-routine running alongside the rest of an asynchronous program. =head2 Futures An L object represents a single outstanding action that is yet to complete, such as a name resolution operation or a socket connection. It stands in contrast to a C, which is an object that represents an ongoing source of activity, such as a readable filehandle of bytes or a POSIX signal. Futures are a recent addition to the C API and details are still subject to change and experimentation. In general, methods that support Futures return a new Future object to represent the outstanding operation. If callback functions are supplied as well, these will be fired in addition to the Future object becoming ready. Any failures that are reported will, in general, use the same conventions for the Future's C arguments to relate it to the legacy C-style callbacks. $on_NAME_error->( $message, @argmuents ) $f->fail( $message, NAME, @arguments ) where C<$message> is a message intended for humans to read (so that this is the message displayed by C<< $f->get >> if the failure is not otherwise caught), C is the name of the failing operation. If the failure is due to a failed system call, the value of C<$!> will be the final argument. The message should not end with a linefeed. =head2 Networking The L provides several methods for performing network-based tasks. Primarily, the C and C methods allow the creation of client or server network sockets. Additionally, the C method allows the use of the system's name resolvers in an asynchronous way, to resolve names into addresses, or vice versa. These methods are fully IPv6-capable if the underlying operating system is. =head2 Protocols The L class provides storage for a L object, to act as a transport for some protocol. It allows a level of independence from the actual transport being for that protocol, allowing it to be easily reused. The L subclass provides further support for protocols based on stream connections, such as TCP sockets. =head1 TODO This collection of modules is still very much in development. As a result, some of the potentially-useful parts or features currently missing are: =over 4 =item * Consider further ideas on Solaris' I, BSD's I and anything that might be useful on Win32. =item * Consider some form of persistent object wrapper in the form of an C, based on C. =item * C =item * Support for watching filesystem entries for change. Extract logic from C and define a Loop watch/unwatch method pair. =item * Define more C-returning methods. Consider also one-shot Futures on things like C exits, or C close. =back =head1 SUPPORT Bugs may be reported via RT at https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Async Support by IRC may also be found on F in the F<#io-async> channel. =cut =head1 SEE ALSO As well as the two loops supplied in this distribution, many more exist on CPAN. At the time of writing this includes: =over 4 =item * L - use IO::Async with AnyEvent =item * L - use IO::Async with epoll on Linux =item * L - use IO::Async with Event =item * L - use IO::Async with EV =item * L - use IO::Async with Glib or GTK =item * L - use IO::Async with kqueue =item * L - use IO::Async with Mojolicious =item * L - use IO::Async with POE =item * L - use IO::Async with ppoll(2) =back Additionally, some other event loops or modules also support being run on top of C: =over 4 =item * L - AnyEvent adapter for IO::Async =item * L - IO::Async Engine =item * L - IO::Async event loop support for POE =back =cut =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async000755001750001750 012227104373 13676 5ustar00leoleo000000000000IO-Async-0.61/lib/IO/Async/Routine.pm000444001750001750 2432212227104373 16041 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2012-2013 -- leonerd@leonerd.org.uk package IO::Async::Routine; use strict; use warnings; our $VERSION = '0.61'; use base qw( IO::Async::Notifier ); use Carp; use IO::Async::OS; use IO::Async::Process; =head1 NAME C - execute code in an independent sub-process or thread =head1 SYNOPSIS use IO::Async::Routine; use IO::Async::Channel; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $nums_ch = IO::Async::Channel->new; my $ret_ch = IO::Async::Channel->new; my $routine = IO::Async::Routine->new( channels_in => [ $nums_ch ], channels_out => [ $ret_ch ], code => sub { my @nums = @{ $nums_ch->recv }; my $ret = 0; $ret += $_ for @nums; # Can only send references $ret_ch->send( \$ret ); }, on_finish => sub { say "The routine aborted early - $_[-1]"; $loop->stop; }, ); $loop->add( $routine ); $nums_ch->send( [ 10, 20, 30 ] ); $ret_ch->recv( on_recv => sub { my ( $ch, $totalref ) = @_; say "The total of 10, 20, 30 is: $$totalref"; $loop->stop; } ); $loop->run; =head1 DESCRIPTION This L contains a body of code and executes it in a sub-process or thread, allowing it to act independently of the main program. Once set up, all communication with the code happens by values passed into or out of the Routine via L objects. A choice of detachment model is available, with options being a Ced 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-based program. Code running inside a C-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 instead, which uses an C to contain the body of the function and manages the Channels itself. =cut =head1 EVENTS =head2 on_finish $exitcode For C-based Routines, this is invoked after the process has exited and is passed the raw exitcode status. =head2 on_finish $type, @result For thread-based Routines, this is invoked after the thread has returned from its code block and is passed the C result. As the behaviour of these events differs per model, it may be more convenient to use C and C instead. =head2 on_return $result Invoked if the code block returns normally. Note that C-based Routines can only transport an integer result between 0 and 255, as this is the actual C value. =head2 on_die $exception Invoked if the code block fails with an exception. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item model => "fork" | "thread" Optional. Defines how the routine will detach itself from the main process. C uses a child process detached using an L. C uses a thread, and is only available on threaded Perls. If the model is not specified, the environment variable C is used to pick a default. If that isn't defined, C is preferred if it is available, otherwise C. =item channels_in => ARRAY of IO::Async::Channel ARRAY reference of C objects to set up for passing values in to the Routine. =item channels_out => ARRAY of IO::Async::Channel ARRAY reference of C objects to set up for passing values out of the Routine. =item code => CODE CODE reference to the body of the Routine, to execute once the channels are set up. =item setup => ARRAY Optional. For C-based Routines, gives a reference to an array to pass to the underlying C C method. Ignored for thread-based Routines. =back =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}; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Channel.pm000444001750001750 2335312227104373 15767 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2013 -- leonerd@leonerd.org.uk package IO::Async::Channel; use strict; use warnings; use base qw( IO::Async::Notifier ); # just to get _capture_weakself our $VERSION = '0.61'; use Carp; use Storable qw( freeze thaw ); use IO::Async::Stream; =head1 NAME C - pass values into or out from an L =head1 DESCRIPTION A C object allows Perl values to be passed into or out of an L. It is intended to be used primarily with a Routine object rather than independently. For more detail and examples on how to use this object see also the documentation for L. A Channel object is shared between the main process of the program and the process running within the Routine. In the main process it will be used in asynchronous mode, and in the Routine process it will be used in synchronous mode. In asynchronous mode all methods return immediately and use C-style callback functions. In synchronous within the Routine process the methods block until they are ready and may be used for flow-control within the routine. Alternatively, a Channel may be shared between two different Routine objects, and not used directly by the controlling program. The channel itself represents a FIFO of Perl reference values. New values may be put into the channel by the C method in either mode. Values may be retrieved from it by the C method. Values inserted into the Channel are snapshot by the C method. Any changes to referred variables will not be observed by the other end of the Channel after the C method returns. Since the channel uses L to serialise values to write over the communication filehandle only reference values may be passed. To pass a single scalar value, C a SCALAR reference to it, and dereference the result of C. =cut =head1 CONSTRUCTOR =cut =head2 $channel = IO::Async::Channel->new Returns a new C object. This object reference itself should be shared by both sides of a Ced process. After C the two C methods may be used to configure the object for operation on either end. While this object does in fact inherit from L for implementation reasons it is not intended that this object be used as a Notifier. It should not be added to a Loop object directly; event management will be handled by its containing C object. =cut sub new { my $class = shift; return bless { mode => "", }, $class; } =head1 METHODS =cut =head2 $channel->configure( %params ) Similar to the standard C method on C, this is used to change details of the Channel's operation. =over 4 =item on_recv => CODE May only be set on an async mode channel. If present, will be invoked whenever a new value is received, rather than using the C method. $on_recv->( $channel, $data ) =item on_eof => CODE May only be set on an async mode channel. If present, will be invoked when the channel gets closed by the peer. $on_eof->( $channel ) =back =cut 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; } $self->SUPER::configure( %params ); } =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 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 ) = @_; my $record = freeze $data; $self->send_frozen( $record ); } =head2 $channel->send_frozen( $record ) A variant of the C method; this method pushes the byte record given. This should be the result of a call to C. =cut sub send_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. 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 $channel->recv( %args ) When called on an asynchronous mode Channel this method appends a callback function to the receiver queue to handle the next Perl reference value that becomes available from the other end. 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 on the other end to return undef or the queued C 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 thaw $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}; $self->_build_stream; push @{ $self->{on_result_queue} }, sub { my ( $self, $type, $result ) = @_; if( $type eq "recv" ) { $on_recv->( $self, $result ); } else { $on_eof->( $self ); } } } 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 = thaw( substr( $$buffref, 4, $len ) ); substr( $$buffref, 0, 4 + $len ) = ""; if( my $on_result = shift @{ $self->{on_result_queue} } ) { $on_result->( $self, recv => $record ); } else { $self->{on_recv}->( $self, $record ); } return 1; } sub _extract_read_handle { my $self = shift; return undef if !$self->{mode}; croak "Cannot extract filehandle" if $self->{mode} ne "async"; $self->{mode} = "dead"; return $self->{read_handle}; } sub _extract_write_handle { my $self = shift; return undef if !$self->{mode}; croak "Cannot extract filehandle" if $self->{mode} ne "async"; $self->{mode} = "dead"; return $self->{write_handle}; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/ChildManager.pm000444001750001750 4515412227104373 16740 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2007-2013 -- leonerd@leonerd.org.uk package IO::Async::ChildManager; use strict; use warnings; our $VERSION = '0.61'; # Not a notifier use IO::Async::Stream; use IO::Async::OS; use Carp; use Scalar::Util qw( weaken ); use POSIX qw( _exit sysconf _SC_OPEN_MAX dup dup2 nice ); use constant LENGTH_OF_I => length( pack( "I", 0 ) ); # 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; =head1 NAME C - facilitates the execution of child processes =head1 SYNOPSIS This object is used indirectly via an C: 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 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 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 function. =item code => CODE A block of code to execute in the child process. It will be called in scalar context inside an C block. =item setup => ARRAY A reference to an array which gives file descriptors to set up in the child process before running the code or command. See below. =item on_exit => CODE A continuation to be called when the child processes exits. It will be invoked in the following way: $on_exit->( $pid, $exitcode, $dollarbang, $dollarat ) The second argument is passed the plain perl C<$?> value. =back Exactly one of the C or C keys must be specified. If the C key is used, the given array or string is executed using the C function. If the C key is used, the return value will be used as the C code from the child if it returns (or 255 if it returned C or thows an exception). Case | ($exitcode >> 8) | $dollarbang | $dollarat --------------+------------------------+-------------+---------- exec succeeds | exit code from program | 0 | "" exec fails | 255 | $! | "" $code returns | return value | $! | "" $code dies | 255 | $! | $@ It is usually more convenient to use the C method in simple cases where an external program is being started in order to interact with it via file IO, or even C when only the final result is required, rather than interaction while it is running. =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 array This array gives a list of file descriptor operations to perform in the child process after it has been Ced from the parent, before running the code or command. It consists of name/value pairs which are ordered; the operations are performed in the order given. =over 8 =item fdI => ARRAY Gives an operation on file descriptor I. The first element of the array defines the operation to be performed: =over 4 =item [ 'close' ] The file descriptor will be closed. =item [ 'dup', $io ] The file descriptor will be Ced from the given IO handle. =item [ 'open', $mode, $file ] The file descriptor will be opened from the named file in the given mode. The C<$mode> string should be in the form usually given to the C function; such as '<' or '>>'. =item [ 'keep' ] The file descriptor will not be closed; it will be left as-is. =back A non-reference value may be passed as a shortcut, where it would contain the name of the operation with no arguments (i.e. for the C and C operations). =item IO => ARRAY Shortcut for passing C>, where I is the fileno of the IO reference. In this case, the key must be a reference that implements the C method. This is mostly useful for $handle => 'keep' =item fdI => IO A shortcut for the C case given above. =item stdin => ... =item stdout => ... =item stderr => ... Shortcuts for C, C and C respectively. =item env => HASH A reference to a hash to set as the child process's environment. =item nice => INT Change the child process's scheduling priority using C. =item chdir => STRING Change the child process's working directory using C. =item setuid => INT =item setgid => INT Change the child process's effective UID or GID. =item setgroups => ARRAY Change the child process's groups list, to those groups whose numbers are given in the ARRAY reference. On most systems, only the privileged superuser change user or group IDs. C will B check before detaching the child process whether this is the case. If setting both the primary GID and the supplementary groups list, it is suggested to set the primary GID first. Moreover, some operating systems may require that the supplementary groups list contains the primary GID. =back If no directions for what to do with C, C and C are given, a default of C is implied. All other file descriptors will be closed, unless a C operation is given for them. If C is used, be sure to place it after any other operations that might require superuser privileges, such as C or opening special files. =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 ( 0 .. OPEN_MAX_FD ) { 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 =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Process.pm000444001750001750 5331112227104373 16032 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2013 -- leonerd@leonerd.org.uk package IO::Async::Process; use strict; use warnings; use base qw( IO::Async::Notifier ); our $VERSION = '0.61'; use Carp; use Socket qw( SOCK_STREAM ); use Future; use IO::Async::OS; =head1 NAME C - start and manage a child process =head1 SYNOPSIS use IO::Async::Process; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $process = IO::Async::Process->new( command => [ "tr", "a-z", "n-za-m" ], stdin => { from => "hello world\n", }, stdout => { on_read => sub { my ( $stream, $buffref ) = @_; while( $$buffref =~ s/^(.*)\n// ) { print "Rot13 of 'hello world' is '$1'\n"; } return 0; }, }, on_finish => sub { $loop->stop; }, ); $loop->add( $process ); $loop->run; =head1 DESCRIPTION This subclass of L starts a child process, and invokes a callback when it exits. The child process can either execute a given block of code (via C), or a command. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_finish $exitcode Invoked after the process has exited by normal means (i.e. an C syscall from a process, or Cing from the code block), and has closed all its file descriptors. =head2 on_exception $exception, $errno, $exitcode Invoked when the process exits by an exception from C, or by failing to C the given command. C<$errno> will be a dualvar, containing both number and string values. Note that this has a different name and a different argument order from C<< Loop->open_child >>'s C. If this is not provided and the process exits with an exception, then C is invoked instead, being passed just the exit code. =cut =head1 CONSTRUCTOR =cut =head2 $process = IO::Async::Process->new( %args ) Constructs a new C object and returns it. Once constructed, the C will need to be added to the C before the child process is started. =cut sub _init { my $self = shift; $self->SUPER::_init( @_ ); $self->{to_close} = {}; $self->{finish_futures} = []; } =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item on_finish => CODE =item on_exception => CODE CODE reference for the event handlers. =back Once the C continuation has been invoked, the C object is removed from the containing C object. The following parameters may be passed to C, or to C before the process has been started (i.e. before it has been added to the C). Once the process is running these cannot be changed. =over 8 =item command => ARRAY or STRING Either a reference to an array containing the command and its arguments, or a plain string containing the command. This value is passed into perl's C function. =item code => CODE A block of code to execute in the child process. It will be called in scalar context inside an C block. =item setup => ARRAY Optional reference to an array to pass to the underlying C C method. =item fdI => HASH A hash describing how to set up file descriptor I. The hash may contain the following keys: =over 4 =item via => STRING Configures how this file descriptor will be configured for the child process. Must be given one of the following mode names: =over 4 =item pipe_read The child will be given the writing end of a C; the parent may read from the other. =item pipe_write The child will be given the reading end of a C; the parent may write to the other. Since an EOF condition of this kind of handle cannot reliably be detected, C will not wait for this type of pipe to be closed. =item pipe_rdwr Only valid on the C filehandle. The child will be given the reading end of one C on STDIN and the writing end of another on STDOUT. A single Stream object will be created in the parent configured for both filehandles. =item socketpair The child will be given one end of a C; the parent will be given the other. The family of this socket may be given by the extra key called C; defaulting to C. The socktype of this socket may be given by the extra key called C; defaulting to C. If the type is not C then a L object will be constructed for the parent side of the handle, rather than C. =back Once the filehandle is set up, the C method (or its shortcuts of C, C or C) may be used to access the C-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 using this C callback function. =item into => SCALAR The child will be given the writing end of a pipe. The referenced scalar will be filled by data read from the child process. This data may not be available until the pipe has been closed by the child. =item from => STRING The child will be given the reading end of a pipe. The string given by the C parameter will be written to the child. When all of the data has been written the pipe will be closed. =back =item stdin => ... =item stdout => ... =item stderr => ... Shortcuts for C, C and C respectively. =item 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. =back =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 => sub { ( undef, $exitcode, $dollarbang, $dollarat ) = @_; $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 if not. Its value is preserved after the process exits, so it may be inspected during the C or C events. =cut sub pid { my $self = shift; return $self->{pid}; } =head2 $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. =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, returns the value that was passed to C. Otherwise, returns C. =cut sub exitstatus { my $self = shift; return defined $self->{exitcode} ? ( $self->{exitcode} >> 8 ) : undef; } =head2 $exception = $process->exception If the process exited due to an exception, returns the exception that was thrown. Otherwise, returns C. =cut sub exception { my $self = shift; return $self->{dollarat}; } =head2 $errno = $process->errno If the process exited due to an exception, returns the numerical value of C<$!> at the time the exception was thrown. Otherwise, returns C. =cut sub errno { my $self = shift; return $self->{dollarbang}+0; } =head2 $errstr = $process->errstr If the process exited due to an exception, returns the string value of C<$!> at the time the exception was thrown. Otherwise, returns C. =cut sub errstr { my $self = shift; return $self->{dollarbang}.""; } =head2 $stream = $process->fd( $fd ) Returns the L or L associated with the given FD number. This must have been set up by a C argument prior to adding the C object to the C. The returned object have its read or write handle set to the other end of a pipe or socket connected to that FD number in the child process. Typically, this will be used to call the C method on, to write more data into the child, or to set an C handler to read data out of the child. The C event for these streams must not be changed, or it will break the close detection used by the C object and the C event will not be invoked. =cut sub fd { my $self = shift; my ( $fd ) = @_; return $self->{fd_handle}{$fd} ||= do { my $opts = $self->{fd_opts}{$fd} or croak "$self does not have an fd Stream for $fd"; my $handle_class; if( defined $opts->{socktype} && IO::Async::OS->getsocktypebyname( $opts->{socktype} ) != SOCK_STREAM ) { require IO::Async::Socket; $handle_class = "IO::Async::Socket"; } else { require IO::Async::Stream; $handle_class = "IO::Async::Stream"; } my $handle = $handle_class->new( notifier_name => $fd eq "0" ? "stdin" : $fd eq "1" ? "stdout" : $fd eq "2" ? "stderr" : $fd eq "io" ? "stdio" : "fd$fd", %{ $opts->{handle} }, ); if( defined $opts->{from} ) { $handle->write( $opts->{from}, on_flush => sub { my ( $handle ) = @_; $handle->close_write; }, ); } $handle }; } =head2 $stream = $process->stdin =head2 $stream = $process->stdout =head2 $stream = $process->stderr =head2 $stream = $process->stdio Shortcuts for calling C with 0, 1, 2 or C respectively, to obtain the L representing the standard input, output, error, or combined input/output streams of the child process. =cut sub stdin { shift->fd( 0 ) } sub stdout { shift->fd( 1 ) } sub stderr { shift->fd( 2 ) } sub stdio { shift->fd( 'io' ) } =head1 EXAMPLES =head2 Capturing the STDOUT stream of a process By configuring the C filehandle of the process using the C key, data written by the process can be captured. my $stdout; my $process = IO::Async::Process->new( command => [ "writing-program", "arguments" ], stdout => { into => \$stdout }, on_finish => sub { print "The process has finished, and wrote:\n"; print $stdout; } ); $loop->add( $process ); Note that until C is invoked, no guarantees are made about how much of the data actually written by the process is yet in the C<$stdout> scalar. See also the C method of L. To handle data more interactively as it arrives, the C key can instead be used, to provide a callback function to invoke whenever more data is available from the process. my $process = IO::Async::Process->new( command => [ "writing-program", "arguments" ], stdout => { on_read => sub { my ( $stream, $buffref ) = @_; while( $$buffref =~ s/^(.*)\n// ) { print "The process wrote a line: $1\n"; } return 0; }, }, on_finish => sub { print "The process has finished\n"; } ); $loop->add( $process ); If the code to handle data read from the process isn't available yet when the object is constructed, it can be supplied later by using the C method on the C filestream at some point before it gets added to the Loop. In this case, C should be configured using C in the C key. my $process = IO::Async::Process->new( command => [ "writing-program", "arguments" ], stdout => { via => "pipe_read" }, on_finish => sub { print "The process has finished\n"; } ); $process->stdout->configure( on_read => sub { my ( $stream, $buffref ) = @_; while( $$buffref =~ s/^(.*)\n// ) { print "The process wrote a line: $1\n"; } return 0; }, ); $loop->add( $process ); =head2 Sending data to STDIN of a process By configuring the C filehandle of the process using the C key, data can be written into the C stream of the process. my $process = IO::Async::Process->new( command => [ "reading-program", "arguments" ], stdin => { from => "Here is the data to send\n" }, on_finish => sub { print "The process has finished\n"; } ); $loop->add( $process ); The data in this scalar will be written until it is all consumed, then the handle will be closed. This may be useful if the program waits for EOF on C before it exits. To have the ability to write more data into the process once it has started. the C method on the C stream can be used, when it is configured using the C value for C: my $process = IO::Async::Process->new( command => [ "reading-program", "arguments" ], stdin => { via => "pipe_write" }, on_finish => sub { print "The process has finished\n"; } ); $loop->add( $process ); $process->stdin->write( "Here is some more data\n" ); =cut =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Listener.pm000444001750001750 3072612227104373 16206 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2008-2013 -- leonerd@leonerd.org.uk package IO::Async::Listener; use strict; use warnings; use base qw( IO::Async::Handle ); our $VERSION = '0.61'; 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 - 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', on_resolve_error => sub { print STDERR "Cannot resolve - $_[0]\n"; }, on_listen_error => sub { print STDERR "Cannot listen\n"; }, ); $loop->run; This object can also be used indirectly via an C: use IO::Async::Stream; use IO::Async::Loop; my $loop = IO::Async::Loop->new; $loop->listen( service => "echo", socktype => 'stream', on_stream => sub { ... }, on_resolve_error => sub { print STDERR "Cannot resolve - $_[0]\n"; }, on_listen_error => sub { print STDERR "Cannot listen\n"; }, ); $loop->run; =head1 DESCRIPTION This subclass of L adds behaviour which watches a socket in listening mode, to accept incoming connections on them. A Listener can be constructed and given a existing socket in listening mode. Alternatively, the Listener can construct a socket by calling the C method. Either a list of addresses can be provided, or a service name can be looked up using the underlying loop's C method. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_accept $clientsocket | $handle Invoked whenever a new client connects to the socket. If neither C nor C parameters are set, this will be invoked with the new client socket directly. If a handle constructor or class are set, this will be invoked with the newly-constructed handle, having the new socket already configured onto it. =head2 on_stream $stream An alternative to C, this an instance of L when a new client connects. This is provided as a convenience for the common case that a Stream object is required as the transport for a Protocol object. This is now vaguely deprecated in favour of using C with a handle constructor or class. =head2 on_socket $socket Similar to C, but constructs an instance of L. This is most useful for C or C sockets. This is now vaguely deprecated in favour of using C with a handle constructor or class. =head2 on_accept_error $socket, $errno Optional. Invoked if the C syscall indicates an error (other than C or C). If not provided, failures of C will simply be ignored. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item on_accept => CODE =item on_stream => CODE =item 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. =item handle => IO The IO handle containing an existing listen-mode socket. =item 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 or a subclass, used to wrap the new client socket. $handle = $handle_constructor->( $listener ) =item handle_class => STRING Optional. If defined and C isn't, then new wrapper handles are constructed by invoking the C method on the given class name, passing in no additional parameters. $handle = $handle_class->new() =item 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: $listener->acceptor( $socket ) ==> $accepted $listener->acceptor( $socket, handle => $handle ) ==> $handle It is invoked with the listening socket as its its argument, and optionally an C instance as a named parameter, and is expected to return a C that will eventually yield the newly-accepted socket or handle instance, if such was provided. =back =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{$_}; } my $new_handle; if( my $constructor = $self->{handle_constructor} ) { $new_handle = $self->{handle_constructor}; } elsif( my $class = $self->{handle_class} ) { $new_handle = sub { $class->new }; } $self->{new_handle} = $new_handle; 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 $new_handle = $self->{new_handle}; $acceptor_params{handle} = $new_handle->( $self ) if $new_handle; } else { die "ARG! Missing on_accept,on_stream,on_socket!"; } my $acceptor = $self->acceptor; $self->$acceptor( $socket, %acceptor_params )->on_done( sub { my ( $result ) = @_ or return; # false-alarm $on_done->( $self, $result ); })->on_fail( sub { my ( $message, undef, $socket, $dollarbang ) = @_; $self->maybe_invoke_event( on_accept_error => $socket, $dollarbang ); }); } 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->new->done( $handle ); } else { return Future->new->done( $accepted ); } } elsif( $! == EAGAIN or $! == EWOULDBLOCK ) { return Future->new->done; } else { return Future->new->fail( "Cannot accept() - $!", accept => $listen_sock, $! ); } } =head1 METHODS =cut =head2 $acceptor = $listener->acceptor Returns the currently-set C method name or code reference. This may be of interest to Loop C extension methods that wish to extend or wrap it. =cut sub acceptor { my $self = shift; return $self->{acceptor}; } sub is_listening { my $self = shift; return ( defined $self->sockname ); } =head2 $name = $listener->sockname Returns the C of the underlying listening socket =cut sub sockname { my $self = shift; my $handle = $self->read_handle or return undef; return $handle->sockname; } =head2 $family = $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 method of the L object. In addition, the following arguments are also recognised directly: =over 8 =item on_listen => CODE Optional. A callback that is invoked when the listening socket is ready. Similar to that on the underlying loop method, except it is passed the listener object itself. $on_listen->( $listener ) =back =cut sub listen { my $self = shift; my ( %params ) = @_; my $loop = $self->loop; defined $loop or croak "Cannot listen when not a member of a Loop"; # TODO: defer? if( my $on_listen = delete $params{on_listen} ) { $params{on_listen} = sub { $on_listen->( $self ) }; } $loop->listen( listener => $self, %params ); } =head1 EXAMPLES =head2 Listening on UNIX Sockets The C argument can be passed an existing socket already in listening mode, making it possible to listen on other types of socket such as UNIX sockets. use IO::Async::Listener; use IO::Socket::UNIX; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $listener = IO::Async::Listener->new( on_stream => sub { my ( undef, $stream ) = @_; $stream->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; $self->write( $$buffref ); $$buffref = ""; return 0; }, ); $loop->add( $stream ); }, ); $loop->add( $listener ); my $socket = IO::Socket::UNIX->new( Local => "echo.sock", Listen => 1, ) or die "Cannot make UNIX socket - $!\n"; $listener->listen( handle => $socket, ); $loop->run; =head2 Passing Plain Socket Addresses The C or C parameters should contain a definition of a plain socket address in a form that the L C method can use. This example shows how to use the C functions to construct one for 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", }, ... ); =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Function.pm000444001750001750 3714012227104373 16203 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2013 -- leonerd@leonerd.org.uk package IO::Async::Function; use strict; use warnings; our $VERSION = '0.61'; use base qw( IO::Async::Notifier ); use IO::Async::Timer::Countdown; use Carp; use Storable qw( freeze ); =head1 NAME C - 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_return => sub { my $isprime = shift; print "123454321 " . ( $isprime ? "is" : "is not" ) . " a prime number\n"; }, on_error => sub { print STDERR "Cannot determine if it's prime - $_[0]\n"; }, ); $loop->run; =head1 DESCRIPTION This subclass of L wraps a function body in a collection of worker processes, to allow it to execute independently of the main process. The object acts as a proxy to the function, allowing invocations to be made by passing in arguments, and invoking a continuation in the main process when the function returns. The object represents the function code itself, rather than one specific invocation of it. It can be called multiple times, by the C method. Multiple outstanding invocations can be called; they will be dispatched in the order they were queued. If only one worker process is used then results will be returned in the order they were called. If multiple are used, then each request will be sent in the order called, but timing differences between each worker may mean results are returned in a different order. Since the code block will be called multiple times within the same child process, it must take care not to modify any of its state that might affect subsequent calls. Since it executes in a child process, it cannot make any modifications to the state of the parent program. Therefore, all the data required to perform its task must be represented in the call arguments, and all of the result must be represented in the return values. The Function object is implemented using an L with two L objects to pass calls into and results out from it. The C framework generally provides mechanisms for multiplexing IO tasks between different handles, so there aren't many occasions when such an asynchronous function is necessary. Two cases where this does become useful are: =over 4 =item 1. When a large amount of computationally-intensive work needs to be performed (for example, the C test in the example in the C). =item 2. When a blocking OS syscall or library-level function needs to be called, and no nonblocking or asynchronous version is supplied. This is used by C. =back This object is ideal for representing "pure" functions; that is, blocks of code which have no stateful effect on the process, and whose result depends only on the arguments passed in. For a more general co-routine ability, see also L. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item code => CODE The body of the function to execute. =item model => "spawn" | "thread" Optional. Requests a specific C model. If not supplied, leaves the default choice up to Routine. =item min_workers => INT =item 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. =item 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). =item idle_timeout => NUM Optional. If provided, idle worker processes will be shut down after this amount of time, if there are more than C of them. =item exit_on_die => BOOL Optional boolean, controls what happens after the C throws an exception. If missing or false, the worker will continue running to process more requests. If true, the worker will be shut down. A new worker might be constructed by the C method to replace it, if necessary. =item setup => ARRAY Optional array reference. Specifies the C key to pass to the underlying L when setting up new worker processes. =back =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 =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 $function->call( %params ) Schedules an invocation of the contained function to be executed on one of the worker processes. If a non-busy worker is available now, it will be called immediately. If not, it will be queued and sent to the next free worker that becomes available. The request will already have been serialised by the marshaller, so it will be safe to modify any referenced data structures in the arguments after this call returns. The C<%params> hash takes the following keys: =over 8 =item args => ARRAY A reference to the array of arguments to pass to the code. =item 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. Two continuations to use in either of the circumstances given above. They will be called directly, without the leading 'return' or 'error' value. =back =head2 $future = $function->call( %params ) When returning a future, the C, C and C continuations are optional. =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 $future = $self->loop->new_future; if( defined $params{on_result} ) { my $on_result = delete $params{on_result}; ref $on_result or croak "Expected 'on_result' to be a reference"; $future->on_done( $self->_capture_weakself( sub { my $self = shift or return; $self->debug_printf( "CONT on_return" ); $on_result->( return => @_ ); } ) ); $future->on_fail( $self->_capture_weakself( sub { my $self = shift or return; my ( $err, @values ) = @_; $self->debug_printf( "CONT on_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"; $future->on_done( $self->_capture_weakself( sub { my $self = shift or return; $self->debug_printf( "CONT on_return" ); $on_return->( @_ ); } ) ); $future->on_fail( $self->_capture_weakself( sub { my $self = shift or return; my ( $err, @values ) = @_; $self->debug_printf( "CONT on_error" ); $on_error->( @values ); } ) ); } elsif( !defined wantarray ) { croak "Expected either 'on_result' or 'on_return' and 'on_error' keys, or to return a Future"; } my $worker = $self->_get_worker; if( !$worker ) { my $request = freeze( $args ); push @{ $self->{pending_queue} }, [ $request, $future ]; return $future; } $self->_call_worker( $worker, args => $args, $future ); return $future; } 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, $future ) = @_; $worker->call( $type, $args, $future ); if( $self->workers_idle == 0 ) { $self->{idle_timer}->stop if $self->{idle_timer}; } } sub _dispatch_pending { my $self = shift; if( my $next = shift @{ $self->{pending_queue} } ) { my $worker = $self->_get_worker or return; $self->_call_worker( $worker, frozen => @$next ); } elsif( $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 { $ret_channel->send( [ e => "$@" ] ); } } }; 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}; } } sub call { my $worker = shift; my ( $type, $args, $future ) = @_; if( $type eq "args" ) { $worker->{arg_channel}->send( $args ); } elsif( $type eq "frozen" ) { $worker->{arg_channel}->send_frozen( $args ); } else { die "TODO: unsure $type\n"; } $worker->{ret_channel}->recv( on_recv => $worker->_capture_weakself( sub { my ( $worker, $channel, $result ) = @_; my ( $type, @values ) = @$result; $worker->{busy} = 0; my $function = $worker->parent; if( $type eq "r" ) { $future->done( @values ); } elsif( $type eq "e" ) { $future->fail( $values[0], @values ); $worker->stop if $worker->{exit_on_die}; } else { die "Unrecognised type from worker - $type\n"; } $worker->stop if !$worker->{max_calls}; $function->_dispatch_pending if $function; } ), on_eof => $worker->_capture_weakself( sub { my ( $worker, $channel ) = @_; $worker->{busy} = 0; my $function = $worker->parent; $future->fail( "closed", "closed" ); $worker->stop; $function->_dispatch_pending if $function; } ), ); $worker->{busy} = 1; $worker->{max_calls}--; } =head1 NOTES For the record, 123454321 is 11111 * 11111, a square number, and therefore not prime. =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Test.pm000444001750001750 1035612227104373 15335 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2007-2012 -- leonerd@leonerd.org.uk package IO::Async::Test; use strict; use warnings; our $VERSION = '0.61'; use Exporter 'import'; our @EXPORT = qw( testing_loop wait_for wait_for_stream ); =head1 NAME C - 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 (as well as being used in the C 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 which, being an asynchronisation framework, does not provide a linear stepped way of working. In order to write a test, the C function provides a way of synchronising the code, so that a given condition is known to hold, which would typically signify that some event has occured, the outcome of which can now be tested using the usual testing primitives. Because the primary purpose of C is to provide IO operations on filehandles, a great many tests will likely be based around connected pipes or socket handles. The C function provides a convenient way to wait for some content to be written through such a connected stream. =cut my $loop; END { undef $loop } =head1 FUNCTIONS =cut =head2 testing_loop( $loop ) Set the C object which the C function will loop on. =cut sub testing_loop { $loop = shift; } =head2 wait_for( $condfunc ) Repeatedly call the C method on the underlying loop (given to the C function), until the given condition function callback returns true. To guard against stalled scripts, if the loop indicates a timeout for 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, 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 =cut 0x55AA; IO-Async-0.61/lib/IO/Async/FileStream.pm000444001750001750 2463712227104373 16460 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011-2012 -- leonerd@leonerd.org.uk package IO::Async::FileStream; use strict; use warnings; our $VERSION = '0.61'; use base qw( IO::Async::Stream ); use IO::Async::File; use Carp; use Fcntl qw( SEEK_SET SEEK_CUR ); =head1 NAME C - read the tail of a file =head1 SYNOPSIS use IO::Async::FileStream; use IO::Async::Loop; my $loop = IO::Async::Loop->new; open my $logh, "<", "var/logs/daemon.log" or die "Cannot open logfile - $!"; my $filestream = IO::Async::FileStream->new( read_handle => $logh, on_initial => sub { my ( $self ) = @_; $self->seek_to_last( "\n" ); }, on_read => sub { my ( $self, $buffref ) = @_; while( $$buffref =~ s/^(.*\n)// ) { print "Received a line $1"; } return 0; }, ); $loop->add( $filestream ); $loop->run; =head1 DESCRIPTION This subclass of L allows reading the end of a regular file which is being appended to by some other process. It invokes the C event when more data has been added to the file. This class provides an API identical to C when given a C; it should be treated similarly. In particular, it can be given an C handler, or subclassed to provide an C method, or even used as the C for an C object. It will not support writing. To watch a file, directory, or other filesystem entity for updates of other properties, such as C, see also L. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters. Because this is a subclass of L in read-only mode, all the events supported by C relating to the read handle are supported here. This is not a full list; see also the documentation relating to C. =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, this object will not stop watching after this condition. Instead, it will continue watching the file for updates. =head2 on_truncated Invoked when the file size shrinks. If this happens, it is presumed that the file content has been replaced. Reading will then commence from the start of the file. =head2 on_initial $size Invoked the first time the file is looked at. It is passed the initial size of the file. The code implementing this method can use the C or C methods to set the initial read position in the file to skip over some initial content. This method may be useful to skip initial content in the file, if the object should only respond to new content added after it was created. =cut sub _init { my $self = shift; my ( $params ) = @_; $self->SUPER::_init( $params ); $params->{close_on_read_eof} = 0; $self->{last_size} = undef; $self->add_child( $self->{file} = IO::Async::File->new( on_devino_changed => $self->_replace_weakself( 'on_devino_changed' ), on_size_changed => $self->_replace_weakself( 'on_size_changed' ), ) ); } =head1 PARAMETERS The following named parameters may be passed to C or C, in addition to the parameters relating to reading supported by C. =over 8 =item filename => STRING Optional. If supplied, watches the named file rather than the filehandle given in C. The file will be opened by the constructor, and then watched for renames. If the file is renamed, the new filename is opened and tracked similarly after closing the previous file. =item interval => NUM Optional. The interval in seconds to poll the filehandle using C looking for size changes. A default of 2 seconds will be applied if not defined. =back =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{read_handle} ) { $self->{file}->configure( handle => delete $params{read_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 event. Moves the read position in the filehandle to the given offset. C<$whence> is interpreted as for C, should be either C, C or C. Will be set to C if not provided. Normally this would be used to seek to the end of the file, for example on_initial => sub { my ( $self, $filesize ) = @_; $self->seek( $filesize ); } =cut sub seek { my $self = shift; my ( $offset, $whence ) = @_; $self->{running_initial} or croak "Cannot ->seek except during on_initial"; 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 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 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, possibly as a new watch/unwatch method pair C. =item * Consider if a construction-time parameter of C or C might be neater than a small code block in C, if that turns out to be the only or most common form of use. =back =cut =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/LoopTests.pm000444001750001750 5053312227104373 16353 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2009-2013 -- 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.61'; # Abstract Units of Time use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1; # The loop under test. We keep it in a single lexical here, so we can use # is_oneref tests in the individual test suite functions my $loop; END { undef $loop } =head1 NAME C - acceptance testing for C subclasses =head1 SYNOPSIS use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Shiney', 'io' ); =head1 DESCRIPTION This module contains a collection of test functions for running acceptance tests on L subclasses. It is provided as a facility for authors of such subclasses to ensure that the code conforms to the Loop API required by C. =head1 TIMING Certain tests require the use of timers or timed delays. Normally these are counted in units of seconds. By setting the environment variable C to some true value, these timers run 10 times quicker, being measured in units of 0.1 seconds instead. This value may be useful when running the tests interactively, to avoid them taking too long. The slower timers are preferred on automated smoke-testing machines, to help guard against false negatives reported simply because of scheduling delays or high system load while testing. TEST_QUICK_TIMERS=1 ./Build test =cut =head1 FUNCTIONS =cut =head2 run_tests( $class, @tests ) Runs a test or collection of tests against the loop subclass given. The class being tested is loaded by this function; the containing script does not need to C or C it first. This function runs C to output its expected test count; the containing script should not do this. =cut sub run_tests { my ( $testclass, @tests ) = @_; my $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: =cut =head2 io Tests the Loop's ability to watch filehandles for IO readiness =cut use constant count_tests_io => 17; 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 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, C, C and C 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 =cut 0x55AA; IO-Async-0.61/lib/IO/Async/OS.pm000444001750001750 3722212227104373 14740 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2012-2013 -- leonerd@leonerd.org.uk package IO::Async::OS; use strict; use warnings; our $VERSION = '0.61'; 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 # 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 ); =head1 NAME C - operating system abstractions for C =head1 DESCRIPTION This module acts as a class to provide a number of utility methods whose exact behaviour may depend on the type of OS it is running on. It is provided as a class so that specific kinds of operating system can override methods in it. As well as these support functions it also provides a number of constants, all with names beginning C which describe various features that may or may not be available on the OS or perl build. Most of these are either hard-coded per OS, or detected at runtime. The following constants may be overridden by environment variables. =over 4 =item * HAVE_POSIX_FORK True if the C call has full POSIX semantics (full process separation). This is true on most OSes but false on MSWin32. This may be overridden to be false by setting the environment variable C. =item * HAVE_THREADS True if C are available, meaning that the C module can be used. This depends on whether perl was built with threading support. This may be overridable to be false by setting the environment variable C. =back =cut =head2 $family = IO::Async::OS->getfamilybyname( $name ) Return a protocol family value based on the given name. If C<$name> looks like a number it will be returned as-is. The string values C, C and C will be converted to the appropriate C constant. =cut sub getfamilybyname { shift; my ( $name ) = @_; return undef unless defined $name; return $name if $name =~ m/^\d+$/; return AF_INET if $name eq "inet"; return AF_INET6() if $name eq "inet6" and defined &AF_INET6; return AF_UNIX if $name eq "unix"; croak "Unrecognised 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, C and C will be converted to the appropriate C constant. =cut sub getsocktypebyname { shift; my ( $name ) = @_; return undef unless defined $name; return $name if $name =~ m/^\d+$/; return SOCK_STREAM if $name eq "stream"; return SOCK_DGRAM if $name eq "dgram"; return SOCK_RAW if $name eq "raw"; croak "Unrecognised socktype name '$name'"; } # This one isn't documented because it's not really overridable. It's largely # here just for completeness 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 syscall, where any argument may be missing (or given as C). If C<$family> is not provided, a suitable value will be provided by the OS (likely C on POSIX-based platforms). If C<$socktype> is not provided, then C will be used. Additionally, this method supports building connected C or C pairs in the C family even if the underlying platform's C does not, by connecting two normal sockets together. C<$family> and C<$socktype> may also be given symbolically as defined by C and C. =cut sub socketpair { my $self = shift; my ( $family, $socktype, $proto ) = @_; # 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 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, 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 or subclass of it, the C and C 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 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 call and an address suitable for C or C. If given an ARRAY it should be in the following form: [ $family, $socktype, $protocol, $addr ] If given a HASH it should contain the following keys: family socktype protocol addr Each field in the result will be initialised to 0 (or empty string for the address) if not defined in the C<$ai> value. The family type may also be given as a symbolic string as defined by C. The socktype may also be given as a symbolic string; C, C or C; this will be converted to the appropriate C constant. Note that the C field, if provided, must be a packed socket address, such as returned by C or C. If the HASH form is used, rather than passing a packed socket address in the C field, certain other hash keys may be used instead for convenience on certain named families. =over 4 =cut use constant ADDRINFO_FAMILY => 0; use constant ADDRINFO_SOCKTYPE => 1; use constant ADDRINFO_PROTOCOL => 2; use constant ADDRINFO_ADDR => 3; sub extract_addrinfo { my $self = shift; my ( $ai, $argname ) = @_; $argname ||= "addr"; my @ai; if( ref $ai eq "ARRAY" ) { @ai = @$ai; } elsif( ref $ai eq "HASH" ) { @ai = @{$ai}{qw( family socktype protocol addr )}; } else { croak "Expected '$argname' to be an ARRAY or HASH reference"; } if( defined $ai[ADDRINFO_FAMILY] and !defined $ai[ADDRINFO_ADDR] and ref $ai eq "HASH" ) { 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 ); } $ai[ADDRINFO_FAMILY] = $self->getfamilybyname( $ai[ADDRINFO_FAMILY] ); $ai[ADDRINFO_SOCKTYPE] = $self->getsocktypebyname( $ai[ADDRINFO_SOCKTYPE] ); # Make sure all fields are defined $ai[$_] ||= 0 for ADDRINFO_FAMILY, ADDRINFO_SOCKTYPE, ADDRINFO_PROTOCOL; $ai[ADDRINFO_ADDR] = "" if !defined $ai[ADDRINFO_ADDR]; return @ai; } =item family => 'inet' Will pack an IP address and port number from keys called C and C. If C is missing it will be set to "0.0.0.0". If C is missing it will be set to 0. =cut sub _extract_addrinfo_inet { my $self = shift; my ( $ai ) = @_; my $port = $ai->{port} || 0; my $ip = $ai->{ip} || "0.0.0.0"; return pack_sockaddr_in( $port, inet_aton( $ip ) ); } =item family => 'inet6' Will pack an IP address and port number from keys called C and C. If C is missing it will be set to "::". If C is missing it will be set to 0. Optionally will also include values from C and C keys if provided. This will only work if a C function can be found in C =cut sub _extract_addrinfo_inet6 { my $self = shift; my ( $ai ) = @_; my $port = $ai->{port} || 0; my $ip = $ai->{ip} || "::"; my $scopeid = $ai->{scopeid} || 0; my $flowinfo = $ai->{flowinfo} || 0; if( HAVE_SOCKADDR_IN6 ) { return pack_sockaddr_in6( $port, inet_pton( AF_INET6, $ip ), $scopeid, $flowinfo ); } else { croak "Cannot pack_sockaddr_in6"; } } =item family => 'unix' Will pack a UNIX socket path from a key called C. =cut sub _extract_addrinfo_unix { my $self = shift; my ( $ai ) = @_; defined( my $path = $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 because they are likely to require OS-specific implementations, but are used by L to implement its functionality. It can use the HASH reference C<< $loop->{os} >> to store other data it requires. =cut =head2 IO::Async::OS->loop_watch_signal( $loop, $signal, $code ) =head2 IO::Async::OS->loop_unwatch_signal( $loop, $signal ) Used to implement the C / C 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}; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Loop.pm000444001750001750 22160212227104373 15345 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2007-2013 -- leonerd@leonerd.org.uk package IO::Async::Loop; use strict; use warnings; our $VERSION = '0.61'; # 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; =head1 NAME C - core loop of the C framework =head1 SYNOPSIS use IO::Async::Stream; use IO::Async::Timer::Countdown; use IO::Async::Loop; my $loop = IO::Async::Loop->new; $loop->add( IO::Async::Timer::Countdown->new( delay => 10, on_expire => sub { print "10 seconds have passed\n" }, )->start ); $loop->add( IO::Async::Stream->new_for_stdin( on_read => sub { my ( $self, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*)\n// ) { print "You typed a line $1\n"; } return 0; }, ) ); $loop->run; =head1 DESCRIPTION This module provides an abstract class which implements the core loop of the C framework. Its primary purpose is to store a set of L objects or subclasses of them. It handles all of the lower-level set manipulation actions, and leaves the actual IO readiness testing/notification to the concrete class that implements it. It also provides other functionality such as signal handling, child process managing, and timers. See also the two bundled Loop subclasses: =over 4 =item L =item L =back Or other subclasses that may appear on CPAN which are not part of the core C distribution. =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, Cing the module then calling its C method. If either of these operations fails, the next subclass is tried. If no class was successful, then an exception is thrown. The constructed object is cached, and will be returned again by a subsequent call. The cache will also be set by a constructor on a specific subclass. This behaviour makes it possible to simply use the normal constructor in a module that wishes to 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, or invoke one of the subclass-specific constructors directly. The list of candidates is formed from the following choices, in this order: =over 4 =item * $ENV{IO_ASYNC_LOOP} If this environment variable is set, it should contain a comma-separated list of subclass names. These names may or may not be fully-qualified; if a name does not contain C<::> then it will have C prepended to it. This allows the end-user to specify a particular choice to fit the needs of his use of a program using C. =item * $IO::Async::Loop::LOOP If this scalar is set, it should contain a comma-separated list of subclass names. These may or may not be fully-qualified, as with the above case. This allows a program author to suggest a loop module to use. In cases where the module subclass is a hard requirement, such as GTK programs using C, it would be better to use the module specifically and invoke its constructor directly. =item * $^O The module called C is tried next. This allows specific OSes, such as the ever-tricky C, to provide an implementation that might be more efficient than the generic ones, or even work at all. =item * Poll and Select Finally, if no other choice has been made by now, the built-in C module is chosen. This should always work, but in case it doesn't, the C, C or equivalent with a zero-second timeout, and process any currently-pending IO conditions before the code is invoked, but it will not block for a non-zero amount of time. This method is implemented using the C method, with the C parameter set to C. It will return an ID value that can be passed to C if required. =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 method on the L 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 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 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 Ced. It will be invoked in the following way (as per C) $on_error->( $pid, $exitcode, $dollarbang, $dollarat ) If this continuation is not supplied, then C 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 method. =back In addition, the hash takes keys that define how to set up file descriptors in the child process. (If the C array is also given, these operations will be performed after those specified by C.) =over 8 =item fdI => HASH A hash describing how to set up file descriptor I. 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 using this C callback function. =item from => STRING The child will be given the reading end of a pipe. The string given by the C parameter will be written to the child. When all of the data has been written the pipe will be closed. =back =item stdin => ... =item stdout => ... =item stderr => ... Shortcuts for C, C and C 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 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 method. =back This method is intended mainly as an IO::Async-compatible replacement for the perl C function (`backticks`), allowing it to replace my $output = `command here`; with $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 object, used for name resolution operations by the C, C and C methods. =cut sub resolver { my $self = shift; return $self->{resolver} ||= do { require IO::Async::Resolver; my $resolver = IO::Async::Resolver->new; $self->add( $resolver ); $resolver; } } =head2 $loop->resolve( %params ) This method performs a single name resolution operation. It uses an internally-stored C object. For more detail, see the C method on the L class. =cut sub resolve { my $self = shift; my ( %params ) = @_; $self->resolver->resolve( %params ); } =head2 $future = $loop->connect( %params ) This method performs a non-blocking connection to a given address or set of addresses, returning a L which represents the operation. On completion, the future will yield the connected socket handle, or the given L object. There are two modes of operation. Firstly, a list of addresses can be provided which will be tried in turn. Alternatively as a convenience, if a host and service name are provided instead of a list of addresses, these will be resolved using the underlying loop's C method into the list of addresses. When attempting to connect to any among a list of addresses, there may be failures among the first attempts, before a valid connection is made. For example, the resolver may have returned some IPv6 addresses, but only IPv4 routes are valid on the system. In this case, the first C syscall will fail. This isn't yet a fatal error, if there are more addresses to try, perhaps some IPv4 ones. For this reason, it is possible that the operation eventually succeeds even though some system calls initially fail. To be aware of individual failures, the optional C callback can be used. This will be invoked on each individual C or C failure, which may be useful for debugging or logging. Because this module simply uses the C resolver, it will be fully IPv6-aware if the underlying platform's resolver is. This allows programs to be fully IPv6-capable. In plain address mode, the C<%params> hash takes the following keys: =over 8 =item addrs => ARRAY Reference to an array of (possibly-multiple) address structures to attempt to connect to. Each should be in the layout described for C. Such a layout is returned by the C named resolver. =item addr => HASH or ARRAY Shortcut for passing a single address to connect to; it may be passed directly with this key, instead of in another array on its own. This should be in a format recognised by L's C method. This example shows how to use the C functions to construct one for TCP port 8001 on address 10.0.0.1: $loop->connect( addr => { family => "inet", socktype => "stream", port => 8001, ip => "10.0.0.1", }, ... ); This example shows another way to connect to a UNIX socket at F. $loop->connect( addr => { family => "unix", socktype => "stream", path => "echo.sock", }, ... ); =item local_addrs => ARRAY =item local_addr => HASH or ARRAY Optional. Similar to the C or C parameters, these specify a local address or set of addresses to C the socket to before Cing it. =back When performing the resolution step too, the C or C keys are ignored, and instead the following keys are taken: =over 8 =item host => STRING =item service => STRING The hostname and service name to connect to. =item local_host => STRING =item local_service => STRING Optional. The hostname and/or service name to C the socket to locally before connecting to the peer. =item family => INT =item socktype => INT =item protocol => INT =item flags => INT Optional. Other arguments to pass along with C and C to the C call. =item socktype => STRING Optionally may instead be one of the values C<'stream'>, C<'dgram'> or C<'raw'> to stand for C, C or C. This utility is provided to allow the caller to avoid a separate C only for importing these constants. =back It is necessary to pass the C hint to the resolver when resolving the host/service names into an address, as some OS's C functions require this hint. A warning is emitted if neither C nor C hint is defined when performing a C lookup. To avoid this warning while still specifying no particular C hint (perhaps to invoke some OS-specific behaviour), pass C<0> as the C value. In either case, it also accepts the following arguments: =over 8 =item handle => IO::Async::Handle Optional. If given a L object or a subclass (such as L or L its handle will be set to the newly-connected socket on success, and that handle used as the result of the future instead. =item on_fail => CODE Optional. After an individual C or C syscall has failed, this callback is invoked to inform of the error. It is passed the name of the syscall that failed, the arguments that were passed to it, and the error it generated. I.e. $on_fail->( "socket", $family, $socktype, $protocol, $! ); $on_fail->( "bind", $sock, $address, $! ); $on_fail->( "connect", $sock, $address, $! ); Because of the "try all" nature when given a list of multiple addresses, this callback may be invoked multiple times, even before an eventual success. =back This method accepts an C parameter; see the C section below. =head2 $loop->connect( %params ) When not returning a future, additional parameters can be given containing the continuations to invoke on success or failure. =over 8 =item on_connected => CODE A continuation that is invoked on a successful C call to a valid socket. It will be passed the connected socket handle, as an C object. $on_connected->( $handle ) =item on_stream => CODE An alternative to C, a continuation that is passed an instance of L when the socket is connected. This is provided as a convenience for the common case that a Stream object is required as the transport for a Protocol object. $on_stream->( $stream ) =item on_socket => CODE Similar to C, but constructs an instance of L. This is most useful for C or C sockets. $on_socket->( $socket ) =item on_connect_error => CODE A continuation that is invoked after all of the addresses have been tried, and none of them succeeded. It will be passed the most significant error that occurred, and the name of the operation it occurred in. Errors from the C syscall are considered most significant, then C, then finally C. $on_connect_error->( $syscall, $! ) =item on_resolve_error => CODE A continuation that is invoked when the name resolution attempt fails. This is invoked in the same way as the C continuation for the C method. =back =cut sub connect { my $self = shift; my ( %params ) = @_; my $extensions; if( $extensions = delete $params{extensions} and @$extensions ) { my ( $ext, @others ) = @$extensions; my $method = "${ext}_connect"; # TODO: Try to 'require IO::Async::$ext' $self->can( $method ) or croak "Extension method '$method' is not available"; return $self->$method( %params, ( @others ? ( extensions => \@others ) : () ), ); } my $handle = $params{handle}; my $on_done; # Legacy callbacks if( my $on_connected = delete $params{on_connected} ) { $on_done = $on_connected; } elsif( my $on_stream = delete $params{on_stream} ) { defined $handle and croak "Cannot pass 'on_stream' with a handle object as well"; require IO::Async::Stream; # TODO: It doesn't make sense to put a SOCK_DGRAM in an # IO::Async::Stream but currently we don't detect this $handle = IO::Async::Stream->new; $on_done = $on_stream; } elsif( my $on_socket = delete $params{on_socket} ) { defined $handle and croak "Cannot pass 'on_socket' with a handle object as well"; require IO::Async::Socket; $handle = IO::Async::Socket->new; $on_done = $on_socket; } elsif( !defined wantarray ) { croak "Expected 'on_connected' or 'on_stream' callback or to return a Future"; } my $on_connect_error; if( $on_connect_error = $params{on_connect_error} ) { # OK } elsif( !defined wantarray ) { croak "Expected 'on_connect_error' callback"; } my $on_resolve_error; if( $on_resolve_error = $params{on_resolve_error} ) { # OK } elsif( !defined wantarray and exists $params{host} || exists $params{local_host} ) { croak "Expected 'on_resolve_error' callback or to return a Future"; } my $connector = $self->{connector} ||= $self->__new_feature( "IO::Async::Internals::Connector" ); my $future = $connector->connect( %params ); $future = $future->then( sub { $handle->set_handle( shift ); return Future->new->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; } =head2 $loop->listen( %params ) ==> $listener This method sets up a listening socket and arranges for an acceptor callback to be invoked each time a new connection is accepted on the socket. Internally it creates an instance of L and adds it to the Loop if not given one in the arguments. Addresses may be given directly, or they may be looked up using the system's name resolver, or a socket handle may be given directly. If multiple addresses are given, or resolved from the service and hostname, then each will be attempted in turn until one succeeds. In named resolver mode, the C<%params> hash takes the following keys: =over 8 =item service => STRING The service name to listen on. =item host => STRING The hostname to listen on. Optional. Will listen on all addresses if not supplied. =item family => INT =item socktype => INT =item protocol => INT =item flags => INT Optional. Other arguments to pass along with C and C to the C call. =item socktype => STRING Optionally may instead be one of the values C<'stream'>, C<'dgram'> or C<'raw'> to stand for C, C or C. This utility is provided to allow the caller to avoid a separate C only for importing these constants. =back It is necessary to pass the C hint to the resolver when resolving the host/service names into an address, as some OS's C functions require this hint. A warning is emitted if neither C nor C hint is defined when performing a C lookup. To avoid this warning while still specifying no particular C hint (perhaps to invoke some OS-specific behaviour), pass C<0> as the C value. In plain address mode, the C<%params> hash takes the following keys: =over 8 =item addrs => ARRAY Reference to an array of (possibly-multiple) address structures to attempt to listen on. Each should be in the layout described for C. Such a layout is returned by the C named resolver. =item addr => ARRAY Shortcut for passing a single address to listen on; it may be passed directly with this key, instead of in another array of its own. This should be in a format recognised by L's C method. See also the C section. =back In direct socket handle mode, the following keys are taken: =over 8 =item handle => IO The listening socket handle. =back In either case, the following keys are also taken: =over 8 =item on_fail => CODE Optional. A callback that is invoked if a syscall fails while attempting to create a listening sockets. It is passed the name of the syscall that failed, the arguments that were passed to it, and the error generated. I.e. $on_fail->( "socket", $family, $socktype, $protocol, $! ); $on_fail->( "sockopt", $sock, $optname, $optval, $! ); $on_fail->( "bind", $sock, $address, $! ); $on_fail->( "listen", $sock, $queuesize, $! ); =item queuesize => INT Optional. The queue size to pass to the C calls. If not supplied, then 3 will be given instead. =item reuseaddr => BOOL Optional. If true or not supplied then the C socket option will be set. To prevent this, pass a false value such as 0. =item v6only => BOOL Optional. If defined, sets or clears the C socket option on C sockets. This option disables the ability of C socket to accept connections from C addresses. Not all operating systems allow this option to be disabled. =back An alternative which gives more control over the listener, is to create the C object directly and add it explicitly to the Loop. This method accepts an C parameter; see the C 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 syscall are considered most significant, then C, then C, then finally C. =item on_resolve_error => CODE A continuation that is invoked when the name resolution attempt fails. This is invoked in the same way as the C continuation for the C method. =back =cut sub listen { my $self = shift; my ( %params ) = @_; my $remove_on_error; my $listener = $params{listener} ||= do { $remove_on_error++; require IO::Async::Listener; # Our wrappings of these don't want $listener my %listenerparams; for (qw( on_accept on_stream on_socket )) { next unless exists $params{$_}; croak "Cannot ->listen with '$_' and 'listener'" if $params{listener}; my $code = delete $params{$_}; $listenerparams{$_} = sub { shift; goto &$code; }; } my $listener = IO::Async::Listener->new( %listenerparams ); $self->add( $listener ); $listener }; my $extensions; if( $extensions = delete $params{extensions} and @$extensions ) { my ( $ext, @others ) = @$extensions; # We happen to know we break older IO::Async::SSL if( $ext eq "SSL" and $IO::Async::SSL::VERSION < '0.12001' ) { croak "IO::Async::SSL version too old; need at least 0.12_001; found $IO::Async::SSL::VERSION"; } my $method = "${ext}_listen"; # TODO: Try to 'require IO::Async::$ext' $self->can( $method ) or croak "Extension method '$method' is not available"; my $f = $self->$method( %params, ( @others ? ( extensions => \@others ) : () ), ); $f->on_fail( sub { $self->remove( $listener ) } ) if $remove_on_error; return $f; } my $on_notifier = delete $params{on_notifier}; # optional my $on_listen_error = delete $params{on_listen_error}; my $on_resolve_error = delete $params{on_resolve_error}; # Shortcut if( $params{addr} and not $params{addrs} ) { $params{addrs} = [ delete $params{addr} ]; } my $f; if( my $handle = delete $params{handle} ) { $f = $self->_listen_handle( $listener, $handle, %params ); } elsif( my $addrs = delete $params{addrs} ) { $on_listen_error or defined wantarray or croak "Expected 'on_listen_error' or to return a Future"; $f = $self->_listen_addrs( $listener, $addrs, %params ); } elsif( defined $params{service} ) { $on_listen_error or defined wantarray or croak "Expected 'on_listen_error' or to return a Future"; $on_resolve_error or defined wantarray or croak "Expected 'on_resolve_error' or to return a Future"; $f = $self->_listen_hostservice( $listener, delete $params{host}, delete $params{service}, %params ); } else { croak "Expected either 'service' or 'addrs' or 'addr' arguments"; } $f->on_done( $on_notifier ) if $on_notifier; if( my $on_listen = $params{on_listen} ) { $f->on_done( sub { $on_listen->( shift->read_handle ) } ); } $f->on_fail( sub { my ( $message, $how, @rest ) = @_; $on_listen_error->( @rest ) if $on_listen_error and $how eq "listen"; $on_resolve_error->( @rest ) if $on_resolve_error and $how eq "resolve"; }); $f->on_fail( sub { $self->remove( $listener ) } ) if $remove_on_error; return $f; } 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 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 but provided here as a utility for programs to obtain the time current used by C 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 block. The return value will be used as the C code from the child if it returns (or 255 if it returned C or thows an exception). =item on_exit => CODE A optional continuation to be called when the child processes exits. It will be invoked in the following way: $on_exit->( $pid, $exitcode ) The second argument is passed the plain perl C<$?> value. This key is optional; if not supplied, the calling code should install a handler using the C method. =item keep_signals => BOOL Optional boolean. If missing or false, any CODE references in the C<%SIG> hash will be removed and restored back to C in the child process. If true, no adjustment of the C<%SIG> hash will be performed. =back =cut sub fork { my $self = shift; my %params = @_; HAVE_POSIX_FORK or croak "POSIX fork() is not available"; my $code = $params{code} or croak "Expected 'code' as a CODE reference"; my $kid = fork; defined $kid or croak "Cannot fork() - $!"; if( $kid == 0 ) { unless( $params{keep_signals} ) { foreach( keys %SIG ) { next if m/^__(WARN|DIE)__$/; $SIG{$_} = "DEFAULT" if ref $SIG{$_} eq "CODE"; } } 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 argument, and its return value will be available to the C callback. It is called inside an C block; if it fails the exception will be caught. =item context => "scalar" | "list" | "void" Optional. Gives the calling context that C is invoked in. Defaults to C if not supplied. =item on_joined => CODE Callback to invoke when the thread function returns or throws an exception. If it returned, this callback will be invoked with its result $on_joined->( return => @result ) If it threw an exception the callback is invoked with the value of C<$@> $on_joined->( died => $! ) =back =cut # It is basically impossible to have any semblance of order on global # destruction, and even harder again to rely on when threads are going to be # terminated and joined. Instead of ensuring we join them all, just detach any # we no longer care about at END time my %threads_to_detach; # {$tid} = $thread_weakly END { $_ and $_->detach for values %threads_to_detach; } sub create_thread { my $self = shift; my %params = @_; HAVE_THREADS or croak "Threads are not available"; eval { require threads } or croak "This Perl does not support threads"; my $code = $params{code} or croak "Expected 'code' as a CODE reference"; my $on_joined = $params{on_joined} or croak "Expected 'on_joined' as a CODE reference"; my $threadwatches = $self->{threadwatches}; unless( $self->{thread_join_pipe} ) { ( my $rd, $self->{thread_join_pipe} ) = IO::Async::OS->pipepair or croak "Cannot pipepair - $!"; $self->{thread_join_pipe}->autoflush(1); $self->watch_io( handle => $rd, on_read_ready => sub { sysread $rd, my $buffer, 8192 or return; # There's a race condition here in that we might have read from # the pipe after the returning thread has written to it but before # it has returned. We'll grab the actual $thread object and # forcibly ->join it here to ensure we wait for its result. foreach my $tid ( unpack "N*", $buffer ) { my ( $thread, $on_joined ) = @{ delete $threadwatches->{$tid} } or die "ARGH: Can't find threadwatch for tid $tid\n"; $on_joined->( $thread->join ); delete $threads_to_detach{$tid}; } } ); } my $wr = $self->{thread_join_pipe}; my $context = $params{context} || "scalar"; my ( $thread ) = threads->create( sub { my ( @ret, $died ); eval { $context eq "list" ? ( @ret = $code->() ) : $context eq "scalar" ? ( $ret[0] = $code->() ) : $code->(); 1; } or $died = $@; $wr->syswrite( pack "N", threads->tid ); return died => $died if $died; return return => @ret; } ); $threadwatches->{$thread->tid} = [ $thread, $on_joined ]; weaken( $threads_to_detach{$thread->tid} = $thread ); return $thread->tid; } =head1 LOW-LEVEL METHODS As C is an abstract base class, specific subclasses of it are required to implement certain methods that form the base level of functionality. They are not recommended for applications to use; see instead the various event objects or higher level methods listed above. These methods should be considered as part of the interface contract required to implement a C subclass. =cut =head2 IO::Async::Loop->API_VERSION This method will be called by the magic constructor on the class before it is constructed, to ensure that the specific implementation will support the required API. This method should return the API version that the loop implementation supports. The magic constructor will use that class, provided it declares a version at least as new as the version documented here. The current API version is C<0.49>. This method may be implemented using C; e.g use constant API_VERSION => '0.49'; =cut =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 or C instead of using this method. =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'"; 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. The C<%params> hash takes the following keys: =over 8 =item handle => IO The IO handle to remove the watch for. =item on_read_ready => BOOL If true, remove the watch for read-readiness. =item on_write_ready => BOOL If true, remove the watch for write-readiness. =back Either or both callbacks may be removed at once. It is not an error to attempt to remove a callback that is not present. If both callbacks were provided to the C method and only one is removed by this method, the other shall remain. =cut sub __unwatch_io { my $self = shift; my %params = @_; my $handle = delete $params{handle} or croak "Expected 'handle'"; my $watch = $self->{iowatches}->{$handle->fileno} or return; if( delete $params{on_read_ready} ) { undef $watch->[1]; } if( delete $params{on_write_ready} ) { undef $watch->[2]; } if( delete $params{on_hangup} ) { $self->_CAN_ON_HANGUP or croak "Cannot watch_io for 'on_hangup' in ".ref($self); undef $watch->[3]; } if( not $watch->[1] and not $watch->[2] and not $watch->[3] ) { delete $self->{iowatches}->{$handle->fileno}; } keys %params and croak "Unrecognised keys for ->unwatch_io - " . join( ", ", keys %params ); } =head2 $loop->watch_signal( $signal, $code ) This method adds a new signal handler to watch the given signal. =over 8 =item $signal The name of the signal to watch to. This should be a bare name like C. =item $code A CODE reference to the handling callback. =back There can only be one callback per signal name. Registering a new one will remove an existing one. Applications should use a C object, or call C instead of using this method. This and C are optional; a subclass may implement neither, or both. If it implements neither then signal handling will be performed by the base class using a self-connected pipe to interrupt the main IO blocking. =cut sub watch_signal { my $self = shift; my ( $signal, $code ) = @_; HAVE_SIGNALS or croak "This OS cannot ->watch_signal"; IO::Async::OS->loop_watch_signal( $self, $signal, $code ); } =head2 $loop->unwatch_signal( $signal ) This method removes the signal callback for the given signal. =over 8 =item $signal The name of the signal to watch to. This should be a bare name like C. =back =cut sub unwatch_signal { my $self = shift; my ( $signal ) = @_; HAVE_SIGNALS or croak "This OS cannot ->unwatch_signal"; IO::Async::OS->loop_unwatch_signal( $self, $signal ); } =head2 $id = $loop->watch_time( %args ) This method installs a callback which will be called at the specified time. The time may either be specified as an absolute value (the C key), or as a delay from the time it is installed (the C key). The returned C<$id> value can be used to identify the timer in case it needs to be cancelled by the C method. Note that this value may be an object reference, so if it is stored, it should be released after it has been fired or cancelled, so the object itself can be freed. The C<%params> hash takes the following keys: =over 8 =item at => NUM The absolute system timestamp to run the event. =item after => NUM The delay after now at which to run the event, if C is not supplied. A zero or negative delayed timer should be executed as soon as possible; the next time the C method is invoked. =item now => NUM The time to consider as now if calculating an absolute time based on C; defaults to C if not specified. =item code => CODE CODE reference to the continuation to run at the allotted time. =back Either one of C or C is required. For more powerful timer functionality as a C (so it can be used as a child within another Notifier), see instead the L object and its subclasses. These C<*_time> methods are optional; a subclass may implement neither or both of them. If it implements neither, then the base class will manage a queue of timer events. This queue should be handled by the C method implemented by the subclass, using the C<_adjust_timeout> and C<_manage_queues> methods. This is the newer version of the API, replacing C. It is unspecified how this method pair interacts with the older C triplet. =cut sub watch_time { my $self = shift; my %args = @_; # Renamed args if( exists $args{after} ) { $args{delay} = delete $args{after}; } elsif( exists $args{at} ) { $args{time} = delete $args{at}; } else { croak "Expected one of 'at' or 'after'"; } if( $self->{old_timer} ) { $self->enqueue_timer( %args ); } else { my $timequeue = $self->{timequeue} ||= $self->__new_feature( "IO::Async::Internals::TimeQueue" ); my $time = $self->_build_time( %args ); my $code = $args{code}; $timequeue->enqueue( time => $time, code => $code ); } } =head2 $loop->unwatch_time( $id ) Removes a timer callback previously created by C. This is the newer version of the API, replacing C. It is unspecified how this method pair interacts with the older C triplet. =cut sub unwatch_time { my $self = shift; my ( $id ) = @_; if( $self->{old_timer} ) { $self->cancel_timer( $id ); } else { my $timequeue = $self->{timequeue} ||= $self->__new_feature( "IO::Async::Internals::TimeQueue" ); $timequeue->cancel( $id ); } } sub _build_time { my $self = shift; my %params = @_; my $time; if( exists $params{time} ) { $time = $params{time}; } elsif( exists $params{delay} ) { my $now = exists $params{now} ? $params{now} : $self->time; $time = $now + $params{delay}; } else { croak "Expected either 'time' or 'delay' keys"; } return $time; } =head2 $id = $loop->enqueue_timer( %params ) An older version of C. This method should not be used in new code but is retained for legacy purposes. For simple watch/unwatch behaviour use instead the new C method; though note it has differently-named arguments. For requeueable timers, consider using an L or L instead. =cut sub enqueue_timer { my $self = shift; my ( %params ) = @_; # Renamed args $params{after} = delete $params{delay} if exists $params{delay}; $params{at} = delete $params{time} if exists $params{time}; my $code = $params{code}; return [ $self->watch_time( %params ), $code ]; } =head2 $loop->cancel_timer( $id ) An older version of C. This method should not be used in new code but is retained for legacy purposes. =cut sub cancel_timer { my $self = shift; my ( $id ) = @_; $self->unwatch_time( $id->[0] ); } =head2 $newid = $loop->requeue_timer( $id, %params ) Reschedule an existing timer, moving it to a new time. The old timer is removed and will not be invoked. The C<%params> hash takes the same keys as C, except for the C argument. The requeue operation may be implemented as a cancel + enqueue, which may mean the ID changes. Be sure to store the returned C<$newid> value if it is required. This method should not be used in new code but is retained for legacy purposes. For requeueable, consider using an L or L instead. =cut sub requeue_timer { my $self = shift; my ( $id, %params ) = @_; $self->unwatch_time( $id->[0] ); return $self->enqueue_timer( %params, code => $id->[1] ); } =head2 $id = $loop->watch_idle( %params ) This method installs a callback which will be called at some point in the near future. The C<%params> hash takes the following keys: =over 8 =item when => STRING Specifies the time at which the callback will be invoked. See below. =item code => CODE CODE reference to the continuation to run at the allotted time. =back The C parameter defines the time at which the callback will later be invoked. Must be one of the following values: =over 8 =item later Callback is invoked after the current round of IO events have been processed by the loop's underlying C method. If a new idle watch is installed from within a C callback, the installed one will not be invoked during this round. It will be deferred for the next time C is called, after any IO events have been handled. =back If there are pending idle handlers, then the C method will use a zero timeout; it will return immediately, having processed any IO events and idle handlers. The returned C<$id> value can be used to identify the idle handler in case it needs to be removed, by calling the C method. Note this value may be a reference, so if it is stored it should be released after the callback has been invoked or cancled, so the referrant itself can be freed. This and C are optional; a subclass may implement neither, or both. If it implements neither then idle handling will be performed by the base class, using the C<_adjust_timeout> and C<_manage_queues> methods. =cut sub watch_idle { my $self = shift; my %params = @_; my $code = delete $params{code}; ref $code or croak "Expected 'code' to be a reference"; my $when = delete $params{when} or croak "Expected 'when'"; # Future-proofing for other idle modes $when eq "later" or croak "Expected 'when' to be 'later'"; my $deferrals = $self->{deferrals}; push @$deferrals, $code; return \$deferrals->[-1]; } =head2 $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. This and C are optional; a subclass may implement neither, or both. If it implements neither then child watching will be performed by using C to install a C handler, which will use C to look for exited child processes. If both a PID-specific and an all-process watch are installed, there is no ordering guarantee as to which will be called first. =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 or other packages. They are intended to provide extra functionality that easily integrates with the rest of the code. Certain base methods take an C parameter; an ARRAY reference containing a list of extension names. If such a list is passed to a method, it will immediately call a method whose name is that of the base method, prefixed by the first extension name in the list, separated by C<_>. If the C list contains more extension names, it will be passed the remaining ones in another C parameter. For example, $loop->connect( extensions => [qw( FOO BAR )], %args ) will become $loop->FOO_connect( extensions => [qw( BAR )], %args ) This is provided so that extension modules, such as L can easily be invoked indirectly, by passing extra arguments to C methods or similar, without needing every module to be aware of the C extension. This functionality is generic and not limited to C; other extensions may also use it. The following methods take an C parameter: $loop->connect $loop->listen If an extension C method is invoked, it will be passed a C parameter even if one was not provided to the original C<< $loop->listen >> call, and it will not receive any of the C event callbacks. It should use the C parameter on the C object. =cut =head1 STALL WATCHDOG A well-behaved C program should spend almost all of its time blocked on input using the underlying C instance. The stall watchdog is an optional debugging feature to help detect CPU spinlocks and other bugs, where control is not returned to the loop every so often. If the watchdog is enabled and an event handler consumes more than a given amount of real time before returning to the event loop, it will be interrupted by printing a stack trace and terminating the program. The watchdog is only in effect while the loop itself is not blocking; it won't fail simply because the loop instance is waiting for input or timers. It is implemented using C, so if enabled, this signal will no longer be available to user code. (Though in any case, most uses of C and C are better served by one of the L subclasses). The following environment variables control its behaviour. =over 4 =item IO_ASYNC_WATCHDOG => BOOL Enables the stall watchdog if set to a non-zero value. =item IO_ASYNC_WATCHDOG_INTERVAL => INT Watchdog interval, in seconds, to pass to the C call. Defaults to 10 seconds. =item IO_ASYNC_WATCHDOG_SIGABRT => BOOL If enabled, the watchdog signal handler will raise a C, which usually has the effect of breaking out of a running program in debuggers such as F. If not set then the process is terminated by throwing an exception with C. =back =cut =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Signal.pm000444001750001750 546212227104373 15615 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2009-2011 -- leonerd@leonerd.org.uk package IO::Async::Signal; use strict; use warnings; use base qw( IO::Async::Notifier ); our $VERSION = '0.61'; use Carp; =head1 NAME C - event callback on receipt of a POSIX signal =head1 SYNOPSIS use IO::Async::Signal; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $signal = IO::Async::Signal->new( name => "HUP", on_receipt => sub { print "I caught SIGHUP\n"; }, ); $loop->add( $signal ); $loop->run; =head1 DESCRIPTION This subclass of L invokes its callback when a particular POSIX signal is received. Multiple objects can be added to a C that all watch for the same signal. The callback functions will all be invoked, in no particular order. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_receipt Invoked when the signal is received. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item name => STRING The name of the signal to watch. This should be a bare name like C. Can only be given at construction time. =item on_receipt => CODE CODE reference for the C event. =back Once constructed, the C will need to be added to the C before it will work. =cut sub _init { my $self = shift; my ( $params ) = @_; my $name = delete $params->{name} or croak "Expected 'name'"; $name =~ s/^SIG//; # Trim a leading "SIG" $self->{name} = $name; $self->SUPER::_init( $params ); } sub configure { my $self = shift; my %params = @_; if( exists $params{on_receipt} ) { $self->{on_receipt} = delete $params{on_receipt}; undef $self->{cb}; # Will be lazily constructed when needed if( my $loop = $self->loop ) { $self->_remove_from_loop( $loop ); $self->_add_to_loop( $loop ); } } unless( $self->can_event( 'on_receipt' ) ) { croak 'Expected either a on_receipt callback or an ->on_receipt method'; } $self->SUPER::configure( %params ); } sub _add_to_loop { my $self = shift; my ( $loop ) = @_; $self->{cb} ||= $self->make_event_cb( 'on_receipt' ); $self->{id} = $loop->attach_signal( $self->{name}, $self->{cb} ); } sub _remove_from_loop { my $self = shift; my ( $loop ) = @_; $loop->detach_signal( $self->{name}, $self->{id} ); undef $self->{id}; } sub notifier_name { my $self = shift; if( length( my $name = $self->SUPER::notifier_name ) ) { return $name; } return $self->{name}; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Handle.pm000444001750001750 3532212227104373 15611 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2006-2013 -- leonerd@leonerd.org.uk package IO::Async::Handle; use strict; use warnings; use base qw( IO::Async::Notifier ); our $VERSION = '0.61'; use Carp; use IO::Handle; # give methods to bare IO handles use Future; use IO::Async::OS; =head1 NAME C - event callbacks for a non-blocking file descriptor =head1 SYNOPSIS This class is likely not to be used directly, because subclasses of it exist to handle more specific cases. Here is an example of how it would be used to watch a listening socket for new connections. In real code, it is likely that the C<< Loop->listen >> method would be used instead. use IO::Socket::INET; use IO::Async::Handle; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $socket = IO::Socket::INET->new( LocalPort => 1234, Listen => 1 ); my $handle = IO::Async::Handle->new( handle => $socket, on_read_ready => sub { my $new_client = $socket->accept; ... }, ); $loop->add( $handle ); For most other uses with sockets, pipes or other filehandles that carry a byte stream, the L class is likely to be more suitable. For non-stream sockets, see L. =head1 DESCRIPTION This subclass of L allows non-blocking IO on filehandles. It provides event handlers for when the filehandle is read- or write-ready. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_read_ready Invoked when the read handle becomes ready for reading. =head2 on_write_ready Invoked when the write handle becomes ready for writing. =head2 on_closed Optional. Invoked when the handle becomes closed. This handler is invoked before the filehandles are closed and the Handle removed from its containing Loop. The C will still return the containing Loop object. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item read_handle => IO =item write_handle => IO The reading and writing IO handles. Each must implement the C method. Primarily used for passing C / C; see the SYNOPSIS section of C for an example. =item handle => IO The IO handle for both reading and writing; instead of passing each separately as above. Must implement C method in way that C does. =item on_read_ready => CODE =item on_write_ready => CODE =item on_closed => CODE CODE references for event handlers. =item want_readready => BOOL =item want_writeready => BOOL If present, enable or disable read- or write-ready notification as per the C and C methods. =back It is required that a matching C or C are available for any handle that is provided; either passed as a callback CODE reference or as an overridden the method. I.e. if only a C is given, then C can be absent. If C is used as a shortcut, then both read and write-ready callbacks or methods are required. If no IO handles are provided at construction time, the object is still created but will not yet be fully-functional as a Handle. IO handles can be assigned later using the C or C methods, or by C. This may be useful when constructing an object to represent a network connection, before the C has actually been performed yet. =cut sub configure { my $self = shift; my %params = @_; if( exists $params{on_read_ready} ) { $self->{on_read_ready} = delete $params{on_read_ready}; undef $self->{cb_r}; $self->_watch_read(0), $self->_watch_read(1) if $self->want_readready; } if( exists $params{on_write_ready} ) { $self->{on_write_ready} = delete $params{on_write_ready}; undef $self->{cb_w}; $self->_watch_write(0), $self->_watch_write(1) if $self->want_writeready; } if( exists $params{on_closed} ) { $self->{on_closed} = delete $params{on_closed}; } # '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 =cut =head2 $handle->set_handles( %params ) Sets new reading or writing filehandles. Equivalent to calling the C method with the same parameters. =cut sub set_handles { my $self = shift; my %params = @_; $self->configure( exists $params{read_handle} ? ( read_handle => $params{read_handle} ) : (), exists $params{write_handle} ? ( write_handle => $params{write_handle} ) : (), ); } =head2 $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 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 event, nor remove the object from the Loop if there is still one open handle in the object. Only when both handles are closed, will C be fired, and the object removed. =cut sub close_read { my $self = shift; $self->want_readready( 0 ); my $read_handle = delete $self->{read_handle}; $read_handle->close if defined $read_handle; $self->_closed if !$self->{write_handle}; } sub close_write { my $self = shift; $self->want_writeready( 0 ); my $write_handle = delete $self->{write_handle}; $write_handle->close if defined $write_handle; $self->_closed if !$self->{read_handle}; } =head2 $future = $handle->new_close_future Returns a new L object which will become done when the handle is closed. Cancelling the C<$future> will remove this notification ability but will not otherwise affect the C<$handle>. =cut sub new_close_future { my $self = shift; push @{ $self->{close_futures} }, my $future = $self->loop->new_future; $future->on_cancel( $self->_capture_weakself( sub { my $self = shift or return; my $future = shift; @{ $self->{close_futures} } = grep { $_ != $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 and C properties, which define whether the object is interested in knowing about read- or write-readiness on the underlying file handle. =cut sub want_readready { my $self = shift; if( @_ ) { my ( $new ) = @_; $new = !!$new; return $new if !$new == !$self->{want_readready}; # compare bools if( $new ) { defined $self->read_handle or croak 'Cannot want_readready in a Handle with no read_handle'; } my $old = $self->{want_readready}; $self->{want_readready} = $new; $self->_watch_read( $new ); return $old; } else { return $self->{want_readready}; } } sub want_writeready { my $self = shift; if( @_ ) { my ( $new ) = @_; $new = !!$new; return $new if !$new == !$self->{want_writeready}; # compare bools if( $new ) { defined $self->write_handle or croak 'Cannot want_writeready in a Handle with no write_handle'; } my $old = $self->{want_writeready}; $self->{want_writeready} = $new; $self->_watch_write( $new ); return $old; } else { return $self->{want_writeready}; } } =head2 $handle->socket( $ai ) Convenient shortcut to creating a socket handle, as given by an addrinfo structure, and setting it as the read and write handle for the object. C<$ai> may be either a C or C reference of the same form as given to L's C method. This method returns nothing if it succeeds, or throws an exception if it fails. =cut sub socket { my $self = shift; my ( $ai ) = @_; # TODO: Something about closing the old one? my ( $family, $socktype, $protocol ) = IO::Async::OS->extract_addrinfo( $ai ); my $sock = IO::Async::OS->socket( $family, $socktype, $protocol ); $self->set_handle( $sock ); } =head2 $handle->bind( $ai ) Convenient shortcut to creating a socket handle and Cing it to the address as given by an addrinfo structure, and setting it as the read and write handle for the object. C<$ai> may be either a C or C reference of the same form as given to L's C method. This method returns nothing if it succeeds, or throws an exception if it fails. =cut sub bind { my $self = shift; my ( $ai ) = @_; $self->socket( $ai ); my $addr = ( IO::Async::OS->extract_addrinfo( $ai ) )[3]; $self->read_handle->bind( $addr ) or croak "Cannot bind - $!"; } =head2 $future = $handle->connect( %args ) A convenient wrapper for calling the C method on the underlying L object. =cut sub connect { my $self = shift; my %args = @_; my $loop = $self->loop or croak "Cannot ->connect a Handle that is not in a Loop"; return $self->loop->connect( %args, handle => $self ); } =head1 SEE ALSO =over 4 =item * L - Supply object methods for I/O handles =back =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Stream.pm000444001750001750 12131512227104373 15667 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2006-2013 -- leonerd@leonerd.org.uk package IO::Async::Stream; use strict; use warnings; use 5.010; # // our $VERSION = '0.61'; 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 ); # Tuneable from outside # Not yet documented our $READLEN = 8192; our $WRITELEN = 8192; # Indicies in writequeue elements use constant WQ_DATA => 0; use constant WQ_WRITELEN => 1; use constant WQ_ON_WRITE => 2; use constant WQ_ON_FLUSH => 3; use constant WQ_WATCHING => 4; # Indicies into readqueue elements use constant RQ_ONREAD => 0; use constant RQ_FUTURE => 1; # Bitfields in the want flags use constant WANT_READ_FOR_READ => 0x01; use constant WANT_READ_FOR_WRITE => 0x02; use constant WANT_WRITE_FOR_READ => 0x04; use constant WANT_WRITE_FOR_WRITE => 0x08; use constant WANT_ANY_READ => WANT_READ_FOR_READ |WANT_READ_FOR_WRITE; use constant WANT_ANY_WRITE => WANT_WRITE_FOR_READ|WANT_WRITE_FOR_WRITE; =head1 NAME C - event callbacks and write bufering for a stream filehandle =head1 SYNOPSIS use IO::Async::Stream; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $stream = IO::Async::Stream->new( read_handle => \*STDIN, write_handle => \*STDOUT, on_read => sub { my ( $self, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*\n)// ) { print "Received a line $1"; } if( $eof ) { print "EOF; last partial line is $$buffref\n"; } return 0; } ); $loop->add( $stream ); $stream->write( "An initial line here\n" ); =head1 DESCRIPTION This subclass of L contains a filehandle that represents a byte-stream. It provides buffering for both incoming and outgoing data. It invokes the C handler when new data is read from the filehandle. Data may be written to the filehandle by calling the C method. For implementing real network protocols that are based on messages sent over a byte-stream (such as a TCP socket), it may be more appropriate to use a subclass of L. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 $ret = on_read \$buffer, $eof Invoked when more data is available in the internal receiving buffer. The first argument is a reference to a plain perl string. The code should inspect and remove any data it likes, but is not required to remove all, or indeed any of the data. Any data remaining in the buffer will be preserved for the next call, the next time more data is received from the handle. In this way, it is easy to implement code that reads records of some form when completed, but ignores partially-received records, until all the data is present. If the handler 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 code may also dynamically replace itself with a new callback by returning a CODE reference instead of C<0> or C<1>. The original callback or method that the object first started with may be restored by returning C. Whenever the callback is changed in this way, the new code is called again; even if the read buffer is currently empty. See the examples at the end of this documentation for more detail. The C method can be used to insert new, temporary handlers that take precedence over the global C handler. This event is only used if there are no further pending handlers created by C. =head2 on_read_eof Optional. Invoked when the read handle indicates an end-of-file (EOF) condition. If there is any data in the buffer still to be processed, the C event will be invoked first, before this one. =head2 on_write_eof Optional. Invoked when the write handle indicates an end-of-file (EOF) condition. Note that this condition can only be detected after a C syscall returns the C error. If there is no data pending to be written then it will not be detected yet. =head2 on_read_error $errno Optional. Invoked when the C method on the read handle fails. =head2 on_write_error $errno Optional. Invoked when the C method on the write handle fails. The C and C handlers are passed the value of C<$!> at the time the error 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 method is called instead. =head2 on_read_high_watermark $length =head2 on_read_low_watermark $length Optional. Invoked when the read buffer grows larger than the high watermark or smaller than the low watermark respectively. These are edge-triggered events; they will only be triggered once per crossing, not continuously while the buffer remains above or below the given limit. If these event handlers are not defined, the default behaviour is to disable read-ready notifications if the read buffer grows larger than the high watermark (so as to avoid it growing arbitrarily if nothing is consuming it), and re-enable notifications again once something has read enough to cause it to drop. If these events are overridden, the overriding code will have to perform this behaviour if required, by using $self->want_readready_for_read(...) =head2 on_outgoing_empty Optional. Invoked when the writing data buffer becomes empty. =head2 on_writeable_start =head2 on_writeable_stop Optional. These two events inform when the filehandle becomes writeable, and when it stops being writeable. C is invoked by the C event if previously it was known to be not writeable. C is invoked after a C operation fails with C or C. These two events track the writeability state, and ensure that only state change cause events to be invoked. A stream starts off being presumed writeable, so the first of these events to be observed will be C. =cut sub _init { my $self = shift; $self->{writequeue} = []; # Queue of ARRAYs of [ $data, $on_write, $on_flush ] $self->{readqueue} = []; # Queue of ARRAYs of [ CODE, $readfuture ] $self->{writeable} = 1; # "innocent until proven guilty" (by means of EAGAIN) $self->{readbuff} = ""; $self->{reader} = "_sysread"; $self->{writer} = "_syswrite"; $self->{read_len} = $READLEN; $self->{write_len} = $WRITELEN; $self->{want} = WANT_READ_FOR_READ; $self->{close_on_read_eof} = 1; } =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item read_handle => IO The IO handle to read from. Must implement C and C methods. =item write_handle => IO The IO handle to write to. Must implement C and C methods. =item handle => IO Shortcut to specifying the same IO handle for both of the above. =item on_read => CODE =item on_read_error => CODE =item on_outgoing_empty => CODE =item on_write_error => CODE =item on_writeable_start => CODE =item on_writeable_stop => CODE CODE references for event handlers. =item autoflush => BOOL Optional. If true, the C method will attempt to write data to the operating system immediately, without waiting for the loop to indicate the filehandle is write-ready. This is useful, for example, on streams that should contain up-to-date logging or console information. It currently defaults to false for any file handle, but future versions of C may enable this by default on STDOUT and STDERR. =item read_len => INT Optional. Sets the buffer size for C calls. Defaults to 8 KiBytes. =item 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. =item write_len => INT Optional. Sets the buffer size for C calls. Defaults to 8 KiBytes. =item write_all => BOOL Optional. Analogous to the C option, but for writing. When C is enabled, this option only affects deferred writing if the initial attempt failed due to buffer space. =item read_high_watermark => INT =item read_low_watermark => INT Optional. If defined, gives a way to implement flow control or other behaviours that depend on the size of Stream's read buffer. If after more data is read from the underlying filehandle the read buffer is now larger than the high watermark, the C event is triggered (which, by default, will disable read-ready notifications and pause reading from the filehandle). If after data is consumed by an C handler the read buffer is now smaller than the low watermark, the C event is triggered (which, by default, will re-enable read-ready notifications and resume reading from the filehandle). For to be possible, the read handler would have to be one added by the C method or one of the Future-returning C methods. By default these options are not defined, so this behaviour will not happen. C may not be set to a larger value than C, but it may be set to a smaller value, creating a hysteresis region. If either option is defined then both must be. If these options are used with the default event handlers, be careful not to cause deadlocks by having a high watermark sufficiently low that a single C invocation might not consider it finished yet. =item reader => STRING|CODE =item writer => STRING|CODE Optional. If defined, gives the name of a method or a CODE reference to use to implement the actual reading from or writing to the filehandle. These will be invoked as $stream->reader( $read_handle, $buffer, $len ) $stream->writer( $write_handle, $buffer, $len ) Each is expected to modify the passed buffer; C by appending to it, C by removing a prefix from it. Each is expected to return a true value on success, zero on EOF, or C with C<$!> set for errors. If not provided, they will be substituted by implenentations using C and C on the underlying handle, respectively. =item close_on_read_eof => BOOL Optional. Usually true, but if set to a false value then the stream will not be Cd when an EOF condition occurs on read. This is normally not useful as at that point the underlying stream filehandle is no longer useable, but it may be useful for reading regular files, or interacting with TTY devices. =item encoding => STRING If supplied, sets the name of encoding of the underlying stream. If an encoding is set, then the C method will expect to receive Unicode strings and encodes them into bytes, and incoming bytes will be decoded into Unicode strings for the C event. If an encoding is not supplied then C and C will work in byte strings. I in order to handle reads of UTF-8 content or other multibyte encodings, the code implementing the C event uses a feature of L; the C flag. While this flag has existed for a while and is used by the C<:encoding> PerlIO layer itself for similar purposes, the flag is not officially documented by the C module. In principle this undocumented feature could be subject to change, in practice I believe it to be reasonably stable. This note applies only to the C event; data written using the C method does not rely on any undocumented features of C. =back If a read handle is given, it is required that either an C callback reference is configured, or that the object provides an C method. It is optional whether either is true for C; if neither is supplied then no action will be taken when the writing buffer becomes empty. An C handler may be supplied even if no read handle is yet given, to be used when a read handle is eventually provided by the C method. This condition is checked at the time the object is added to a Loop; it is allowed to create a C object with a read handle but without a C handler, provided that one is later given using C before the stream is added to its containing Loop, either directly or by being a child of another Notifier already in a Loop, or added to one. =cut sub configure { my $self = shift; my %params = @_; for (qw( on_read on_outgoing_empty on_read_eof on_write_eof on_read_error on_write_error on_writeable_start on_writeable_stop autoflush read_len read_all write_len write_all on_read_high_watermark on_read_low_watermark reader writer close_on_read_eof )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } if( exists $params{read_high_watermark} or exists $params{read_low_watermark} ) { my $high = delete $params{read_high_watermark} // $self->{read_high_watermark}; my $low = delete $params{read_low_watermark} // $self->{read_low_watermark}; croak "Cannot set read_low_watermark without read_high_watermark" if defined $low and !defined $high; croak "Cannot set read_high_watermark without read_low_watermark" if defined $high and !defined $low; croak "Cannot set read_low_watermark higher than read_high_watermark" if defined $low and defined $high and $low > $high; $self->{read_high_watermark} = $high; $self->{read_low_watermark} = $low; # TODO: reassert levels if we've moved them } if( exists $params{encoding} ) { my $encoding = delete $params{encoding}; my $obj = find_encoding( $encoding ); defined $obj or croak "Cannot handle an encoding of '$encoding'"; $self->{encoding} = $obj; } $self->SUPER::configure( %params ); if( $self->loop and $self->read_handle ) { $self->can_event( "on_read" ) or croak 'Expected either an on_read callback or to be able to ->on_read'; } } 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 =cut =head2 $stream->want_readready_for_read( $set ) =head2 $stream->want_readready_for_write( $set ) Mutators for the C property on L, which control whether the C or C behaviour should be continued once the filehandle becomes ready for read. Normally, C is always true (though the read watermark behaviour can modify it), and C is not used. However, if a custom C function is provided, it may find this useful for being invoked again if it cannot proceed with a write operation until the filehandle becomes readable (such as during transport negotiation or SSL key management, for example). =cut sub want_readready_for_read { my $self = shift; my ( $set ) = @_; $set ? ( $self->{want} |= WANT_READ_FOR_READ ) : ( $self->{want} &= ~WANT_READ_FOR_READ ); $self->want_readready( $self->{want} & WANT_ANY_READ ) if $self->read_handle; } sub want_readready_for_write { my $self = shift; my ( $set ) = @_; $set ? ( $self->{want} |= WANT_READ_FOR_WRITE ) : ( $self->{want} &= ~WANT_READ_FOR_WRITE ); $self->want_readready( $self->{want} & WANT_ANY_READ ) if $self->read_handle; } =head2 $stream->want_writeready_for_write( $set ) =head2 $stream->want_writeready_for_read( $set ) Mutators for the C property on L, which control whether the C or C behaviour should be continued once the filehandle becomes ready for write. Normally, C is managed by the C method and associated flushing, and C is not used. However, if a custom C function is provided, it may find this useful for being invoked again if it cannot proceed with a read operation until the filehandle becomes writable (such as during transport negotiation or SSL key management, for example). =cut sub want_writeready_for_write { my $self = shift; my ( $set ) = @_; $set ? ( $self->{want} |= WANT_WRITE_FOR_WRITE ) : ( $self->{want} &= ~WANT_WRITE_FOR_WRITE ); $self->want_writeready( $self->{want} & WANT_ANY_WRITE ) if $self->write_handle; } sub want_writeready_for_read { my $self = shift; my ( $set ) = @_; $set ? ( $self->{want} |= WANT_WRITE_FOR_READ ) : ( $self->{want} &= ~WANT_WRITE_FOR_READ ); $self->want_writeready( $self->{want} & WANT_ANY_WRITE ) if $self->write_handle; } # FUNCTION not method sub _nonfatal_error { my ( $errno ) = @_; return $errno == EAGAIN || $errno == EWOULDBLOCK || $errno == EINTR; } sub _is_empty { my $self = shift; return !@{ $self->{writequeue} }; } =head2 $stream->close A synonym for C. This should not be used when the deferred wait behaviour is required, as the behaviour of C may change in a future version of C. Instead, call C 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 on the underlying IO handles, and removes the stream from its containing loop. If the write buffer still contains data, then this is deferred until the buffer is empty. This is intended for "write-then-close" one-shot streams. $stream->write( "Here is my final data\n" ); $stream->close_when_empty; Because of this deferred nature, it may not be suitable for error handling. See instead the C method. =cut sub close_when_empty { my $self = shift; return $self->SUPER::close if $self->_is_empty; $self->{stream_closing} = 1; } =head2 $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; 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 parameter. If the C option is set, this method will try immediately to write the data to the underlying filehandle. If this completes successfully then it will have been written by the time this method returns. If it fails to write completely, then the data is queued as if C were not set, and will be flushed as normal. C<$data> can either be a plain string, a L, or a CODE reference. If it is a plain string it is written immediately. If it is not, its value will be used to generate more C<$data> values, eventually leading to strings to be written. If C<$data> is a C, the Stream will wait until it is ready, and take the single value it yields. If C<$data> is a CODE reference, it will be repeatedly invoked to generate new values. Each time the filehandle is ready to write more data to it, the function is invoked. Once the function has finished generating data it should return undef. The function is passed the Stream object as its first argument. It is allowed that Cs yield CODE references, or CODE references return Cs, as well as plain strings. For example, to stream the contents of an existing opened filehandle: open my $fileh, "<", $path or die "Cannot open $path - $!"; $stream->write( sub { my ( $stream ) = @_; sysread $fileh, my $buffer, 8192 or return; return $buffer; } ); Takes the following optional named parameters in C<%params>: =over 8 =item write_len => INT Overrides the C parameter for the data written by this call. =item on_write => CODE A CODE reference which will be invoked after every successful C operation on the underlying filehandle. It will be passed the number of bytes that were written by this call, which may not be the entire length of the buffer - if it takes more than one C operation to empty the buffer then this callback will be invoked multiple times. $on_write->( $stream, $len ) =item on_flush => CODE A CODE reference which will be invoked once the data queued by this C call has been flushed. This will be invoked even if the buffer itself is not yet empty; if more data has been queued since the call. $on_flush->( $stream ) =back If the object is not yet a member of a loop and doesn't yet have a C, then calls to the C method will simply queue the data and return. It will be flushed when the object is added to the loop. If C<$data> is a defined but empty string, the write is still queued, and the C continuation will be invoked, if supplied. This can be used to obtain a marker, to invoke some code once the output queue has been flushed up to this point. =head2 $f = $stream->write( ... ) If called in non-void context, this method returns a L which will complete (with no value) when the write operation has been flushed. This may be used as an alternative to, or combined with, the C callback. =cut sub _syswrite { my $self = shift; my ( $handle, undef, $len ) = @_; my $written = $handle->syswrite( $_[1], $len ); return $written if !$written; # zero or undef substr( $_[1], 0, $written ) = ""; return $written; } sub _flush_one_write { my $self = shift; my $writequeue = $self->{writequeue}; my $head; while( $head = $writequeue->[0] and ref $head->[WQ_DATA] ) { if( ref $head->[WQ_DATA] eq "CODE" ) { my $data = $head->[WQ_DATA]->( $self ); if( !defined $data ) { $head->[WQ_ON_FLUSH]->( $self ) if $head->[WQ_ON_FLUSH]; shift @$writequeue; return 1; } if( !ref $data and my $encoding = $self->{encoding} ) { $data = $encoding->encode( $data ); } unshift @$writequeue, my $new = [ $data ]; $new->[$_] = $head->[$_] for WQ_WRITELEN, WQ_ON_WRITE; # not ON_FLUSH next; } elsif( blessed $head->[WQ_DATA] and $head->[WQ_DATA]->isa( "Future" ) ) { my $f = $head->[WQ_DATA]; if( !$f->is_ready ) { return 0 if $head->[WQ_WATCHING]; $f->on_ready( sub { $self->_flush_one_write } ); $head->[WQ_WATCHING]++; return 0; } my $data = $f->get; if( !ref $data and my $encoding = $self->{encoding} ) { $data = $encoding->encode( $data ); } $head->[WQ_DATA] = $data; next; } else { die "Unsure what to do with reference ".ref($head->[WQ_DATA])." in write queue"; } } my $second; while( $second = $writequeue->[1] and !ref $second->[WQ_DATA] and $head->[WQ_WRITELEN] == $second->[WQ_WRITELEN] and !$head->[WQ_ON_WRITE] and !$second->[WQ_ON_WRITE] and !$head->[WQ_ON_FLUSH] ) { $head->[WQ_DATA] .= $second->[WQ_DATA]; $head->[WQ_ON_WRITE] = $second->[WQ_ON_WRITE]; $head->[WQ_ON_FLUSH] = $second->[WQ_ON_FLUSH]; splice @$writequeue, 1, 1, (); } die "TODO: head data does not contain a plain string" if ref $head->[WQ_DATA]; my $writer = $self->{writer}; my $len = $self->$writer( $self->write_handle, $head->[WQ_DATA], $head->[WQ_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 => ); } $self->maybe_invoke_event( on_write_error => $errno ) or $self->close_now; return 0; } if( my $on_write = $head->[WQ_ON_WRITE] ) { $on_write->( $self, $len ); } if( !length $head->[WQ_DATA] ) { $head->[WQ_ON_FLUSH]->( $self ) if $head->[WQ_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 $f; if( defined wantarray ) { my $orig_on_flush = $on_flush; $f = $self->loop->new_future; $on_flush = sub { $f->done; $orig_on_flush->( @_ ) if $orig_on_flush; }; } push @{ $self->{writequeue} }, [ $data, $params{write_len} // $self->{write_len}, $on_write, $on_flush ]; 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 ) = @_; my $readqueue = $self->{readqueue}; my $ret; if( $readqueue->[0] and my $on_read = $readqueue->[0][RQ_ONREAD] ) { $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] = [ $ret ]; 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} } ) { $_->[RQ_FUTURE]->fail( "read failed: $errno", sysread => $errno ) if $_->[RQ_FUTURE]; } undef @{ $self->{readqueue} }; return; } 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} } ) { $_->[RQ_FUTURE]->done( undef ) if $_->[RQ_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 handler to the end of the queue. This queue, if non-empty, is used to provide C event handling code in preference to using the object's main event handler or method. New handlers can be supplied at any time, and they will be used in first-in first-out (FIFO) order. As with the main C event handler, each can return a (defined) boolean to indicate if they wish to be invoked again or not, another C reference to replace themself with, or C to indicate it is now complete and should be removed. When a temporary handler returns C it is shifted from the queue and the next one, if present, is invoked instead. If there are no more then the object's main handler is invoked instead. =cut sub push_on_read { my $self = shift; my ( $on_read, %args ) = @_; # %args undocumented for internal use push @{ $self->{readqueue} }, [ $on_read, $args{future} ]; # TODO: Should this always defer? 1 while length $self->{readbuff} and $self->_flush_one_read( 0 ); } =head1 FUTURE-RETURNING READ METHODS The following methods all return a L which will become ready when enough data has been read by the Stream into its buffer. At this point, the data is removed from the buffer and given to the C object to complete it. my $f = $stream->read_... my ( $string ) = $f->get; Unlike the C event handlers, these methods don't allow for access to "partial" results; they only provide the final result once it is ready. If a C is cancelled before it completes it is removed from the read queue without consuming any data; i.e. each C atomically either completes or is cancelled. Since it is possible to use a readable C entirely using these C-returning methods instead of the C event, it may be useful to configure a trivial return-false event handler to keep it from consuming any input, and to allow it to be added to a C in the first place. my $stream = IO::Async::Stream->new( on_read => sub { 0 }, ... ); $loop->add( $stream ); my $f = $stream->read_... If a read EOF or error condition happens while there are read Cs pending, they are all completed. In the case of a read EOF, they are done with C; in the case of a read error they are failed using the C<$!> error value as the failure. $f->fail( $message, sysread => $! ) If a read EOF condition happens to the currently-processing read C, it will return a partial result. The calling code can detect this by the fact that the returned data is not complete according to the specification (too short in C's case, or lacking the ending pattern in C's case). Additionally, each C will yield the C<$eof> value in its results. my ( $string, $eof ) = $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 $f = $stream->read_atmost( $len ) =head2 $f = $stream->read_exactly( $len ) Completes the C when the read buffer contains C<$len> or more characters of input. C will also complete after the first invocation of C, even if fewer characters are available, whereas C will wait until at least C<$len> are available. =cut sub read_atmost { my $self = shift; my ( $len ) = @_; my $f = $self->_read_future; $self->push_on_read( sub { my ( undef, $buffref, $eof ) = @_; return undef if $f->is_cancelled; $f->done( substr( $$buffref, 0, $len, "" ), $eof ); return undef; }, future => $f ); return $f; } sub read_exactly { my $self = shift; my ( $len ) = @_; my $f = $self->_read_future; $self->push_on_read( sub { my ( undef, $buffref, $eof ) = @_; return undef if $f->is_cancelled; return 0 unless $eof or length $$buffref >= $len; $f->done( substr( $$buffref, 0, $len, "" ), $eof ); return undef; }, future => $f ); return $f; } =head2 $f = $stream->read_until( $end ) Completes the C when the read buffer contains a match for C<$end>, which may either be a plain string or a compiled C reference. Yields the prefix of the buffer before 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 $f = $stream->read_until_eof Completes the C when the stream is eventually closed at EOF, and yields all of the data that was available. =cut sub read_until_eof { my $self = shift; my $f = $self->_read_future; $self->push_on_read( sub { my ( undef, $buffref, $eof ) = @_; return undef if $f->is_cancelled; return 0 unless $eof; $f->done( $$buffref, $eof ); $$buffref = ""; return undef; }, future => $f ); return $f; } =head1 UTILITY CONSTRUCTORS =cut =head2 $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 object preconfigured with the correct C, C or both. =cut sub new_for_stdin { shift->new( read_handle => \*STDIN, @_ ) } sub new_for_stdout { shift->new( write_handle => \*STDOUT, @_ ) } sub new_for_stdio { shift->new( read_handle => \*STDIN, write_handle => \*STDOUT, @_ ) } =head2 $future = $stream->connect( %args ) A convenient wrapper for calling the C method on the underlying L object, passing the C hint as C if not otherwise supplied. =cut sub connect { my $self = shift; return $self->SUPER::connect( socktype => "stream", @_ ); } =head1 EXAMPLES =head2 A line-based C method The following C method accepts incoming C<\n>-terminated lines and prints them to the program's C stream. sub on_read { my $self = shift; my ( $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*\n)// ) { print "Received a line: $1"; } return 0; } Because a reference to the buffer itself is passed, it is simple to use a C regular expression on the scalar it points at, to both check if data is ready (i.e. a whole line), and to remove it from the buffer. 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. For implementing real network protocols that are based on lines of text it may be more appropriate to use a subclass of L. =head2 Reading binary data This C method accepts incoming records in 16-byte chunks, printing each one. sub on_read { my ( $self, $buffref, $eof ) = @_; if( length $$buffref >= 16 ) { my $record = substr( $$buffref, 0, 16, "" ); print "Received a 16-byte record: $record\n"; return 1; } if( $eof and length $$buffref ) { print "EOF: a partial record still exists\n"; } return 0; } The 4-argument form of C extracts the 16-byte record from the buffer and assigns it to the C<$record> variable, if there was enough data in the buffer to extract it. A lot of protocols use a fixed-size header, followed by a variable-sized body of data, whose size is given by one of the fields of the header. The following C method extracts messages in such a protocol. sub on_read { my ( $self, $buffref, $eof ) = @_; return 0 unless length $$buffref >= 8; # "N n n" consumes 8 bytes my ( $len, $x, $y ) = unpack $$buffref, "N n n"; return 0 unless length $$buffref >= 8 + $len; substr( $$buffref, 0, 8, "" ); my $data = substr( $$buffref, 0, $len, "" ); print "A record with values x=$x y=$y\n"; return 1; } In this example, the header is Ced first, to extract the body length, and then the body is extracted. If the buffer does not have enough data yet for a complete message then C<0> is returned, and the buffer is left unmodified for next time. Only when there are enough bytes in total does it use C to remove them. =head2 Dynamic replacement of C Consider the following protocol (inspired by IMAP), which consists of C<\n>-terminated lines that may have an optional data block attached. The presence of such a data block, as well as its size, is indicated by the line prefix. sub on_read { my $self = shift; my ( $buffref, $eof ) = @_; if( $$buffref =~ s/^DATA (\d+):(.*)\n// ) { my $length = $1; my $line = $2; return sub { my $self = shift; my ( $buffref, $eof ) = @_; return 0 unless length $$buffref >= $length; # Take and remove the data from the buffer my $data = substr( $$buffref, 0, $length, "" ); print "Received a line $line with some data ($data)\n"; return undef; # Restore the original method } } elsif( $$buffref =~ s/^LINE:(.*)\n// ) { my $line = $1; print "Received a line $line with no data\n"; return 1; } else { print STDERR "Unrecognised input\n"; # Handle it somehow } } In the case where trailing data is supplied, a new temporary C callback is provided in a closure. This closure captures the C<$length> variable so it knows how much data to expect. It also captures the C<$line> variable so it can use it in the event report. When this method has finished reading the data, it reports the event, then restores the original method by returning C. =head1 SEE ALSO =over 4 =item * L - Supply object methods for I/O handles =back =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Timer.pm000444001750001750 705112227104373 15454 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2009-2012 -- leonerd@leonerd.org.uk package IO::Async::Timer; use strict; use warnings; use base qw( IO::Async::Notifier ); our $VERSION = '0.61'; use Carp; =head1 NAME C - base class for Notifiers that use timed delays =head1 DESCRIPTION This module provides a subclass of L for implementing notifiers that use timed delays. For specific implementations, see one of the subclasses: =over 8 =item * L - event callback at a fixed future time =item * L - event callback after a fixed delay =item * L - event callback at regular intervals =back =cut =head1 CONSTRUCTOR =cut =head2 $timer = IO::Async::Timer->new( %args ) Constructs a particular subclass of C object, and returns it. This constructor is provided for backward compatibility to older code which doesn't use the subclasses. New code should directly construct a subclass instead. =over 8 =item mode => STRING The type of timer to create. Currently the only allowed mode is C but more types may be added in the future. =back Once constructed, the C will need to be added to the C before it will work. It will also need to be started by the C method. =cut sub new { my $class = shift; my %args = @_; if( my $mode = delete $args{mode} ) { # Might define some other modes later $mode eq "countdown" or croak "Expected 'mode' to be 'countdown'"; require IO::Async::Timer::Countdown; return IO::Async::Timer::Countdown->new( %args ); } return $class->SUPER::new( %args ); } sub _add_to_loop { my $self = shift; $self->start if delete $self->{pending}; } sub _remove_from_loop { my $self = shift; $self->stop; } =head1 METHODS =cut =head2 $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 but there is a start pending, this will cancel it. =cut sub stop { my $self = shift; if( $self->{pending} ) { delete $self->{pending}; return; } return if !$self->is_running; my $loop = $self->loop or croak "Cannot stop a Timer that is not in a Loop"; defined $self->{id} or return; # nothing to do but no error $loop->unwatch_time( $self->{id} ); undef $self->{id}; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Future.pm000444001750001750 371012227104373 15644 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2013 -- leonerd@leonerd.org.uk package IO::Async::Future; use strict; use warnings; our $VERSION = '0.61'; use base qw( Future ); Future->VERSION( '0.05' ); # to respect subclassing =head1 NAME C - use L with L =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 stores a reference to the L instance that created it, allowing the C method to block until the Future is ready. These objects should not be constructed directly; instead the C method on the containing Loop should be used. For a full description on how to use Futures, see the L documentation. =cut =head1 CONSTRUCTORS New C objects should be constructed by using the following methods on the C. For more detail see the L documentation. =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 object. =cut sub loop { my $self = shift; return $self->{loop}; } sub await { my $self = shift; $self->{loop}->loop_once; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Protocol.pm000444001750001750 1320412227104373 16212 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011 -- leonerd@leonerd.org.uk package IO::Async::Protocol; use strict; use warnings; our $VERSION = '0.61'; use base qw( IO::Async::Notifier ); use Carp; =head1 NAME C - base class for transport-based protocols =head1 DESCRIPTION This subclass of L provides storage for a L object, to act as a transport for some protocol. It contains an instance of the transport object, which it adds as a child notifier, allowing a level of independence from the actual transport being used. For example, a stream may actually be an L to allow the protocol to be used over SSL. This class is not intended to be used directly, instead, see one of the subclasses =over 4 =item L - base class for stream-based protocols =back =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_closed Optional. Invoked when the transport handle becomes closed. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item transport => IO::Async::Handle The C to delegate communications to. =item on_closed => CODE CODE reference for the C event. =back When a new C object is given, it will be configured by calling the C method, then added as a child notifier. If a different transport object was already configured, this will first be removed and deconfigured using the C. =cut sub configure { my $self = shift; my %params = @_; for (qw( on_closed )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } if( exists $params{transport} ) { my $transport = delete $params{transport}; if( $self->{transport} ) { $self->remove_child( $self->transport ); $self->teardown_transport( $self->transport ); } $self->{transport} = $transport; if( $transport ) { $self->setup_transport( $self->transport ); $self->add_child( $self->transport ); } } $self->SUPER::configure( %params ); } =head1 METHODS =cut =head2 $transport = $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 for the Protocol. Takes the following named arguments: =over 8 =item socktype => STRING or INT Required. Identifies the socket type, and the type of continuation that will be used. If this value is C<"stream"> or C then C continuation will be used; otherwise C will be used. =item on_connected => CODE Optional. If supplied, will be invoked once the connection has been established. $on_connected->( $protocol ) =item transport => IO::Async::Handle Optional. If this is provided, it will immediately be configured as the transport (by calling C), and the C callback will be invoked. This is provided as a convenient shortcut. =back Other arguments will be passed to the underlying C C call. =cut sub connect { my $self = shift; my %args = @_; my $on_connected = delete $args{on_connected}; if( my $transport = $args{transport} ) { $self->configure( transport => $transport ); $on_connected->( $self ) if $on_connected; return; } my $socktype = $args{socktype} or croak "Expected socktype"; my $on_transport = do { no warnings 'numeric'; $socktype eq "stream" || $socktype == Socket::SOCK_STREAM() } ? "on_stream" : "on_socket"; my $loop = $self->loop or croak "Cannot ->connect a ".ref($self)." that is not in a Loop"; $loop->connect( %args, socktype => "stream", $on_transport => sub { my ( $transport ) = @_; $self->configure( transport => $transport ); $on_connected->( $self ) if $on_connected; }, ); } =head1 TRANSPORT DELEGATION The following methods are delegated to the transport object close =cut sub close { shift->transport->close } =head1 SUBCLASS METHODS C is a base class provided so that specific subclasses of it provide more specific behaviour. The base class provides a number of methods that subclasses may wish to override. If a subclass implements any of these, be sure to invoke the superclass method at some point within the code. =cut =head2 $protocol->setup_transport( $transport ) Called by C when a new C object is given, this method should perform whatever setup is required to wire the new transport object into the protocol object; typically by setting up event handlers. =cut sub setup_transport { my $self = shift; my ( $transport ) = @_; $transport->configure( on_closed => $self->_capture_weakself( sub { my $self = shift or return; my ( $transport ) = @_; $self->maybe_invoke_event( on_closed => ); $self->configure( transport => undef ); } ), ); } =head2 $protocol->teardown_transport( $transport ) The reverse of C; called by C when a previously set-up transport object is about to be replaced. =cut sub teardown_transport { my $self = shift; my ( $transport ) = @_; $transport->configure( on_closed => undef, ); } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Resolver.pm000444001750001750 4716512227104373 16227 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2007-2013 -- leonerd@leonerd.org.uk package IO::Async::Resolver; use strict; use warnings; use base qw( IO::Async::Function ); our $VERSION = '0.61'; # 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 - performing name resolutions asynchronously =head1 SYNOPSIS This object is used indirectly via an C: 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 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 object that wraps the normal (blocking) functions. In this case, name resolutions will be performed asynchronously from the rest of the program, but will likely be done by a single background worker process, so will be processed in the order they were requested; a single slow lookup will hold up the queue of other requests behind it. To mitigate this, multiple worker processes can be used; see the C argument to the constructor. The C parameter for the underlying C object is set to a default of 30 seconds, and C is set to 0. This ensures that there are no spare processes sitting idle during the common case of no outstanding requests. =cut sub _init { my $self = shift; my ( $params ) = @_; $self->SUPER::_init( @_ ); $params->{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 =cut =head2 $loop->resolve( %params ) ==> @result Performs a single name resolution operation, as given by the keys in the hash. The C<%params> hash keys the following keys: =over 8 =item type => STRING Name of the resolution operation to perform. See BUILT-IN RESOLVERS for the list of available operations. =item data => ARRAY Arguments to pass to the resolver function. Exact meaning depends on the specific function chosen by the C; see BUILT-IN RESOLVERS. =item timeout => NUMBER Optional. Timeout in seconds, after which the resolver operation will abort with a timeout exception. If not supplied, a default of 10 seconds will apply. =back =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'"; # Legacy if( $type eq "getaddrinfo" ) { warnings::warnif( deprecated => "getaddrinfo resolver will be changed in a future release to be the same as getaddrinfo_hash; please update your code to call it specifically" ); $type = "getaddrinfo_array"; } 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; } =head2 $resolver->getaddrinfo( %args ) ==> @addrs A shortcut wrapper around the C resolver, taking its arguments in a more convenient form. =over 8 =item host => STRING =item service => STRING The host and service names to look up. At least one must be provided. =item family => INT or STRING =item socktype => INT or STRING =item protocol => INT Hint values used to filter the results. =item flags => INT Flags to control the C function. See the C constants in L's C function for more detail. =item passive => BOOL If true, sets the C flag. This is provided as a convenience to avoid the caller from having to import the C constant from C. =item timeout => NUMBER Time in seconds after which to abort the lookup with a C exception =back On success, the future will yield the result as a list of HASH references; each containing one result. Each result will contain fields called C, C, C and C. If requested by C then the C field will also be present. As a specific optimisation, this method will try to perform a lookup of numeric values synchronously, rather than asynchronously, if it looks likely to succeed. Specifically, if the service name is entirely numeric, and the hostname looks like an IPv4 or IPv6 string, a synchronous lookup will first be performed using the C flag. If this gives an C error, then the lookup is performed asynchronously instead. =head2 $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->new->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; } =head2 $resolver->getnameinfo( %args ) ==> ( $host, $service ) A shortcut wrapper around the C resolver, taking its arguments in a more convenient form. =over 8 =item addr => STRING The packed socket address to look up. =item flags => INT Flags to control the C function. See the C constants in L's C for more detail. =item numerichost => BOOL =item numericserv => BOOL =item dgram => BOOL If true, set the C, C or C flags. =item numeric => BOOL If true, sets both C and C flags. =item timeout => NUMBER Time in seconds after which to abort the lookup with a C exception =back As a specific optimisation, this method will try to perform a lookup of numeric values synchronously, rather than asynchronously, if both the C and C flags are given. =head2 $future = $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->new->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; } =head1 FUNCTIONS =cut =head2 register_resolver( $name, $code ) Registers a new named resolver function that can be called by the C method. All named resolvers must be registered before the object is constructed. =over 8 =item $name The name of the resolver function; must be a plain string. This name will be used by the C argument to the C method, to identify it. =item $code A CODE reference to the resolver function body. It will be called in list context, being passed the list of arguments given in the C argument to the C method. The returned list will be passed to the C callback. If the code throws an exception at call time, it will be passed to the C continuation. If it returns normally, the list of values it returns will be passed to C. =back =cut # Plain function, not a method sub register_resolver { my ( $name, $code ) = @_; croak "Cannot register new resolver methods once the resolver has been started" if $started; croak "Already have a resolver method called '$name'" if exists $METHODS{$name}; $METHODS{$name} = $code; } =head1 BUILT-IN RESOLVERS The following resolver names are implemented by the same-named perl function, taking and returning a list of values exactly as the perl function does: getpwnam getpwuid getgrnam getgrgid getservbyname getservbyport gethostbyname gethostbyaddr getnetbyname getnetbyaddr getprotobyname getprotobynumber =cut # Now register the inbuilt methods register_resolver getpwnam => sub { my @r = getpwnam( $_[0] ) or die "$!\n"; @r }; register_resolver getpwuid => sub { my @r = getpwuid( $_[0] ) or die "$!\n"; @r }; register_resolver getgrnam => sub { my @r = getgrnam( $_[0] ) or die "$!\n"; @r }; register_resolver getgrgid => sub { my @r = getgrgid( $_[0] ) or die "$!\n"; @r }; register_resolver getservbyname => sub { my @r = getservbyname( $_[0], $_[1] ) or die "$!\n"; @r }; register_resolver getservbyport => sub { my @r = getservbyport( $_[0], $_[1] ) or die "$!\n"; @r }; register_resolver gethostbyname => sub { my @r = gethostbyname( $_[0] ) or die "$!\n"; @r }; register_resolver gethostbyaddr => sub { my @r = gethostbyaddr( $_[0], $_[1] ) or die "$!\n"; @r }; register_resolver getnetbyname => sub { my @r = getnetbyname( $_[0] ) or die "$!\n"; @r }; register_resolver getnetbyaddr => sub { my @r = getnetbyaddr( $_[0], $_[1] ) or die "$!\n"; @r }; register_resolver getprotobyname => sub { my @r = getprotobyname( $_[0] ) or die "$!\n"; @r }; register_resolver getprotobynumber => sub { my @r = getprotobynumber( $_[0] ) or die "$!\n"; @r }; =pod The following three resolver names are implemented using the L module. getaddrinfo_hash getaddrinfo_array getnameinfo The C resolver takes arguments in a hash of name/value pairs and returns a list of hash structures, as the C function does. For neatness it takes all its arguments as named values; taking the host and service names from arguments called C and C respectively; all the remaining arguments are passed into the hints hash. The C resolver behaves more like the C version of the function. It takes hints in a flat list, and mangles the result of the function, so that the returned value is more useful to the caller. It splits up the list of 5-tuples into a list of ARRAY refs, where each referenced array contains one of the tuples of 5 values. As an extra convenience to the caller, both resolvers will also accept plain string names for the C argument, converting C and possibly C into the appropriate C value, and for the C argument, converting C, C or C into the appropriate C value. For backward-compatibility with older code, the resolver name C is currently aliased to C; but any code that wishes to rely on the array-like nature of its arguments and return values, should request it specifically by name, as this alias will be changed in a later version of C. The C resolver returns its result in the same form as C. Because this module simply uses the system's C resolver, it will be fully IPv6-aware if the underlying platform's resolver is. This allows programs to be fully IPv6-capable. =cut register_resolver getaddrinfo_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 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 =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Socket.pm000444001750001750 2045712227104373 15651 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2011 -- leonerd@leonerd.org.uk package IO::Async::Socket; use strict; use warnings; our $VERSION = '0.61'; use base qw( IO::Async::Handle ); use Errno qw( EAGAIN EWOULDBLOCK EINTR ); use Carp; =head1 NAME C - event callbacks and send buffering for a socket filehandle =head1 SYNOPSIS use IO::Async::Socket; use IO::Async::Loop; my $loop = IO::Async::Loop->new; $loop->connect( host => "some.host.here", service => "echo", socktype => 'dgram', on_connected => sub { my ( $sock ) = @_; my $socket = IO::Async::Socket->new( handle => $sock, 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->send( "A TEST DATAGRAM" ); }, on_resolve_error => sub { die "Cannot resolve - $_[0]\n"; }, on_connect_error => sub { die "Cannot connect\n"; }, ); $loop->run; =head1 DESCRIPTION This subclass of L contains a socket filehandle. It provides a queue of outgoing data. It invokes the C handler when new data is received from the filehandle. Data may be sent to the filehandle by calling the C method. It is primarily intended for C or C sockets; for C sockets an instance of L is probably more appropriate. =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_recv $data, $addr Invoke on receipt of a packet, datagram, or stream segment. The C handler is invoked once for each packet, datagram, or stream segment that is received. It is passed the data itself, and the sender's address. =head2 on_recv_error $errno Optional. Invoked when the C method on the receiving handle fails. =head2 on_send_error $errno Optional. Invoked when the C method on the sending handle fails. The C and C handlers are passed the value of C<$!> at the time the error 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 method is called instead. =head2 on_outgoing_empty Optional. Invoked when the sending data buffer becomes empty. =cut sub _init { my $self = shift; $self->{recv_len} = 65536; $self->SUPER::_init( @_ ); } =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item read_handle => IO The IO handle to receive from. Must implement C and C methods. =item write_handle => IO The IO handle to send to. Must implement C and C methods. =item handle => IO Shortcut to specifying the same IO handle for both of the above. =item on_recv => CODE =item on_recv_error => CODE =item on_outgoing_empty => CODE =item on_send_error => CODE =item autoflush => BOOL Optional. If true, the C method will atempt to send data to the operating system immediately, without waiting for the loop to indicate the filehandle is write-ready. =item recv_len => INT Optional. Sets the buffer size for C calls. Defaults to 64 KiB. =item recv_all => BOOL Optional. If true, repeatedly call C when the receiving handle first becomes read-ready. By default this is turned off, meaning at most one fixed-size buffer is received. If there is still more data in the kernel's buffer, the handle will stil be readable, and will be received from again. This behaviour allows multiple streams and sockets to be multiplexed simultaneously, meaning that a large bulk transfer on one cannot starve other filehandles of processing time. Turning this option on may improve bulk data transfer rate, at the risk of delaying or stalling processing on other filehandles. =item send_all => INT Optional. Analogous to the C option, but for sending. When C is enabled, this option only affects deferred sending if the initial attempt failed. =back The condition requiring an C handler is checked at the time the object is added to a Loop; it is allowed to create a C object with a read handle but without a C handler, provided that one is later given using C before the stream is added to its containing Loop, either directly or by being a child of another Notifier already in a Loop, or added to one. =cut sub configure { my $self = shift; my %params = @_; for (qw( on_recv on_outgoing_empty on_recv_error on_send_error recv_len recv_all send_all autoflush )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } $self->SUPER::configure( %params ); if( $self->loop and defined $self->read_handle ) { $self->can_event( "on_recv" ) or croak 'Expected either an on_recv callback or to be able to ->on_recv'; } } sub _add_to_loop { my $self = shift; if( defined $self->read_handle ) { $self->can_event( "on_recv" ) or croak 'Expected either an on_recv callback or to be able to ->on_recv'; } $self->SUPER::_add_to_loop( @_ ); } =head1 METHODS =cut =head2 $socket->send( $data, $flags, $addr ) This method adds a segment of data to be sent, or sends it immediately, according to the C parameter. C<$flags> and C<$addr> are optional. If the C option is set, this method will try immediately to send the data to the underlying filehandle, optionally using the given flags and destination address. If this completes successfully then it will have been sent by the time this method returns. If it fails to send, then the data is queued as if C were not set, and will be flushed as normal. =cut sub send { my $self = shift; my ( $data, $flags, $addr ) = @_; croak "Cannot send data to a Socket with no write_handle" unless my $handle = $self->write_handle; my $sendqueue = $self->{sendqueue} ||= []; push @$sendqueue, [ $data, $flags, $addr ]; if( $self->{autoflush} ) { while( @$sendqueue ) { my ( $data, $flags, $addr ) = @{ $sendqueue->[0] }; my $len = $handle->send( $data, $flags, $addr ); last if !$len; # stop on any errors and defer back to the non-autoflush path shift @$sendqueue; } if( !@$sendqueue ) { $self->want_writeready( 0 ); return; } } $self->want_writeready( 1 ); } sub on_read_ready { my $self = shift; my $handle = $self->read_handle; while(1) { my $addr = $handle->recv( my $data, $self->{recv_len} ); if( !defined $addr ) { return if $! == EAGAIN || $! == EWOULDBLOCK || $! == EINTR; my $errno = $!; $self->maybe_invoke_event( on_recv_error => $errno ) or $self->close; return; } if( !length $data ) { $self->close; return; } $self->invoke_event( on_recv => $data, $addr ); last unless $self->{recv_all}; } } sub on_write_ready { my $self = shift; my $handle = $self->write_handle; my $sendqueue = $self->{sendqueue}; while( $sendqueue and @$sendqueue ) { my ( $data, $flags, $addr ) = @{ shift @$sendqueue }; my $len = $handle->send( $data, $flags, $addr ); if( !defined $len ) { return if $! == EAGAIN || $! == EWOULDBLOCK || $! == EINTR; my $errno = $!; $self->maybe_invoke_event( on_send_error => $errno ) or $self->close; return; } if( $len == 0 ) { $self->close; return; } last unless $self->{send_all}; } if( !$sendqueue or !@$sendqueue ) { $self->want_writeready( 0 ); $self->maybe_invoke_event( on_outgoing_empty => ); } } =head1 SEE ALSO =over 4 =item * L - Supply object methods for I/O handles =back =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/PID.pm000444001750001750 712712227104373 15014 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2011 -- leonerd@leonerd.org.uk package IO::Async::PID; use strict; use warnings; use base qw( IO::Async::Notifier ); our $VERSION = '0.61'; use Carp; =head1 NAME C - event callback on exit of a child process =head1 SYNOPSIS use IO::Async::PID; use POSIX qw( WEXITSTATUS ); use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $kid = $loop->fork( code => sub { print "Child sleeping..\n"; sleep 10; print "Child exiting\n"; return 20; }, ); print "Child process $kid started\n"; my $pid = IO::Async::PID->new( pid => $kid, on_exit => sub { my ( $self, $exitcode ) = @_; printf "Child process %d exited with status %d\n", $self->pid, WEXITSTATUS($exitcode); }, ); $loop->add( $pid ); $loop->run; =head1 DESCRIPTION This subclass of L invokes its callback when a process exits. For most use cases, a L object provides more control of setting up the process, connecting filehandles to it, sending data to and receiving data from it. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_exit $exitcode Invoked when the watched process exits. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item pid => INT The process ID to watch. Must be given before the object has been added to the containing C object. =item on_exit => CODE CODE reference for the C event. =back Once the C continuation has been invoked, the C object is removed from the containing C 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 =cut 0x55AA; IO-Async-0.61/lib/IO/Async/File.pm000444001750001750 1152612227104373 15275 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2012 -- leonerd@leonerd.org.uk package IO::Async::File; use 5.010; # // use strict; use warnings; our $VERSION = '0.61'; use base qw( IO::Async::Timer::Periodic ); use Carp; use File::stat; # No point watching blksize or blocks my @STATS = qw( dev ino mode nlink uid gid rdev size atime mtime ctime ); =head1 NAME C - watch a file for changes =head1 SYNOPSIS use IO::Async::File; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $file = IO::Async::File->new( filename => "config.ini", on_mtime_changed => sub { my ( $self ) = @_; print STDERR "Config file has changed\n"; reload_config( $self->handle ); } ); $loop->add( $file ); $loop->run; =head1 DESCRIPTION This subclass of L watches an open filehandle or named filesystem entity for changes in its C fields. It invokes various events when the values of these fields change. It is most often used to watch a file for size changes; for this task see also L. While called "File", it is not required that the watched filehandle be a regular file. It is possible to watch anything that C may be called on, such as directories or other filesystem entities. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters. =head2 on_dev_changed $new_dev, $old_dev =head2 on_ino_changed $new_ino, $old_ino =head2 ... =head2 on_ctime_changed $new_ctime, $old_ctime Invoked when each of the individual C fields have changed. All the C fields are supported apart from C and C. Each is passed the new and old values of the field. =head2 on_devino_changed $new_stat, $old_stat Invoked when either of the C or C fields have changed. It is passed two L instances containing the complete old and new C fields. This can be used to observe when a named file is renamed; it will not be observed to happen on opened filehandles. =head2 on_stat_changed $new_stat, $old_stat Invoked when any of the C fields have changed. It is passed two L instances containing the old and new C fields. =cut =head1 PARAMETERS The following named parameters may be passed to C or C. =over 8 =item handle => IO The opened filehandle to watch for C changes if C is not supplied. =item filename => STRING Optional. If supplied, watches the named file rather than the filehandle given in C. The file will be opened for reading and then watched for renames. If the file is renamed, the new filename is opened and tracked similarly after closing the previous file. =item interval => NUM Optional. The interval in seconds to poll the filehandle using C looking for size changes. A default of 2 seconds will be applied if not defined. =back =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 _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 parameter, or opened from the C parameter. =cut sub handle { my $self = shift; return $self->{handle}; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Notifier.pm000444001750001750 5354112227104373 16200 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2006-2011 -- leonerd@leonerd.org.uk package IO::Async::Notifier; use strict; use warnings; our $VERSION = '0.61'; use Carp; use Scalar::Util qw( weaken ); # Perl 5.8.4 cannot do trampolines by modiying @_ then goto &$code use constant HAS_BROKEN_TRAMPOLINES => ( $] == "5.008004" ); our $DEBUG = $ENV{IO_ASYNC_DEBUG} || 0; =head1 NAME C - base class for C 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 program uses. It provides the lowest level of integration with a C container, and a facility to collect Notifiers together, in a tree structure, where any Notifier can contain a collection of children. Normally, objects in this class would not be directly used by an end program, as it performs no actual IO work, and generates no actual events. These are all left to the various subclasses, such as: =over 4 =item * L - event callbacks for a non-blocking file descriptor =item * L - event callbacks and write bufering for a stream filehandle =item * L - event callbacks and send buffering for a socket filehandle =item * L - handle a serial pipeline of requests / responses (EXPERIMENTAL) =item * L - base class for Notifiers that use timed delays =item * L - event callback on receipt of a POSIX signal =item * L - event callback on exit of a child process =item * L - start and manage a child process =back For more detail, see the SYNOPSIS section in one of the above. One case where this object class would be used, is when a library wishes to provide a sub-component which consists of multiple other C subclasses, such as Cs and C, but no particular object is suitable to be the root of a tree. In this case, a plain C object can be used as the tree root, and all the other notifiers added as children of it. =cut =head1 AS A MIXIN Rather than being used as a subclass this package also supports being used as a non-principle superclass for an object, as a mix-in. It still provides methods and satisfies an C test, even though the constructor is not directly called. This simply requires that the object be based on a normal blessed hash reference and include C somewhere in its C<@ISA> list. The methods in this class all use only keys in the hash prefixed by C<"IO_Async_Notifier__"> for namespace purposes. This is intended mainly for defining a subclass of some other object that is also an C, suitable to be added to an C. package SomeEventSource::Async; use base qw( SomeEventSource IO::Async::Notifier ); sub _add_to_loop { my $self = shift; my ( $loop ) = @_; # Code here to set up event handling on $loop that may be required } sub _remove_from_loop { my $self = shift; my ( $loop ) = @_; # Code here to undo the event handling set up above } Since all the methods documented here will be available, the implementation may wish to use the C and C or C methods to implement its own event callbacks. =cut =head1 PARAMETERS A specific subclass of C defines named parameters that control its behaviour. These may be passed to the C constructor, or to the C method. The documentation on each specific subclass will give details on the parameters that exist, and their uses. Some parameters may only support being set once at construction time, or only support being changed if the object is in a particular state. The following parameters are supported by all Notifiers: =over 8 =item notifier_name => STRING Optional string used to identify this particular Notifier. This value will be returned by the C method. =back =cut =head1 CONSTRUCTOR =cut =head2 $notifier = IO::Async::Notifier->new( %params ) This function returns a new instance of a C object with the given initial values of the named parameters. Up until C version 0.19, this module used to implement the IO handle features now found in the C subclass. Code that needs to use any of C, C, C, C or C should use L instead. =cut sub new { my $class = shift; my %params = @_; my $self = bless {}, $class; $self->_init( \%params ); $self->configure( %params ); return $self; } =head1 METHODS =cut =head2 $notifier->configure( %params ) Adjust the named parameters of the C as given by the C<%params> hash. =cut # for subclasses to override and call down to sub configure { my $self = shift; my %params = @_; foreach (qw( notifier_name )) { $self->{"IO_Async_Notifier__$_"} = delete $params{$_} if exists $params{$_}; } # We don't recognise any configure keys at this level if( keys %params ) { my $class = ref $self; croak "Unrecognised configuration keys for $class - " . join( " ", keys %params ); } } =head2 $loop = $notifier->loop Returns the C 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} || ""; } =head1 CHILD NOTIFIERS During the execution of a program, it may be the case that certain IO handles cause other handles to be created; for example, new sockets that have been Ced from a listening socket. To facilitate these, a notifier may contain child notifier objects, that are automatically added to or removed from the C that manages their parent. =cut =head2 $parent = $notifier->parent Returns the parent of the notifier, or C if does not have one. =cut sub parent { my $self = shift; return $self->{IO_Async_Notifier__parent}; } =head2 @children = $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 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. It is passed a reference to the HASH storing the constructor arguments. This method may initialise internal details of the Notifier as required, possibly by using parameters from the HASH. If any parameters are construction-only they should be Cd from the hash. =cut sub _init { # empty default } =head2 $notifier->configure( %params ) This method is called by the constructor to set the initial values of named parameters, and by users of the object to adjust the values once constructed. This method should C from the C<%params> hash any keys it has dealt with, then pass the remaining ones to the C. The base class implementation will throw an exception if there are any unrecognised keys remaining. =cut =head2 $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. This should be protected against by the code body. $other_object->{on_event} = $notifier->_capture_weakself( sub { my $notifier = shift or return; my ( @event_args ) = @_; ... } ); For stand-alone generic implementation of this behaviour, see also L and C. =cut sub _capture_weakself { my $self = shift; my ( $code ) = @_; # actually bare method names work too if( !ref $code ) { my $class = ref $self; # Don't save this coderef, or it will break dynamic method dispatch, # which means code reloading, dynamic replacement, or other funky # techniques stop working $self->can( $code ) or croak qq(Can't locate object method "$code" via package "$class"); } weaken $self; return sub { my $cv = ref( $code ) ? $code : $self->can( $code ); if( HAS_BROKEN_TRAMPOLINES ) { return $cv->( $self, @_ ); } else { unshift @_, $self; goto &$cv; } }; } =head2 $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 reference if the object can perform the given event name, either by a configured C reference parameter, or by implementing a method. If the object is unable to handle this event, C is returned. =cut sub can_event { my $self = shift; my ( $event_name ) = @_; return $self->{$event_name} || $self->can( $event_name ); } =head2 $callback = $notifier->make_event_cb( $event_name ) Returns a C reference which, when invoked, will execute the given event handler. Event handlers may either be subclass methods, or parameters given to the C or C method. The event handler can be passed extra arguments by giving them to the C reference; the first parameter received will be a reference to the notifier itself. This is stored weakly in the closure, so it is safe to store the resulting C reference in the object itself without causing a reference cycle. =cut sub make_event_cb { my $self = shift; my ( $event_name ) = @_; my $code = $self->can_event( $event_name ) or croak "$self cannot handle $event_name event"; my $caller = caller; return $self->_capture_weakself( !$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 but will return C if the object cannot handle the named event, rather than throwing an exception. =cut sub maybe_make_event_cb { my $self = shift; my ( $event_name ) = @_; my $code = $self->can_event( $event_name ) or return undef; my $caller = caller; return $self->_capture_weakself( !$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 or C method. Returns whatever the underlying method or CODE reference returned. =cut sub invoke_event { my $self = shift; my ( $event_name, @args ) = @_; my $code = $self->can_event( $event_name ) or croak "$self cannot handle $event_name event"; $self->_debug_printf_event( scalar caller, $event_name ) if $DEBUG; return $code->( $self, @args ); } =head2 $retref = $notifier->maybe_invoke_event( $event_name, @args ) Similar to C but will return C if the object cannot handle the name event, rather than throwing an exception. In order to distinguish this from an event-handling function that simply returned C, if the object does handle the event, the list that it returns will be returned in an ARRAY reference. =cut sub maybe_invoke_event { my $self = shift; my ( $event_name, @args ) = @_; my $code = $self->can_event( $event_name ) or return undef; $self->_debug_printf_event( scalar caller, $event_name ) if $DEBUG; return [ $code->( $self, @args ) ]; } =head1 DEBUGGING SUPPORT The following methods and behaviours are still experimental and may change or even be removed in future. Debugging support is enabled by an environment variable called C having a true value. When debugging is enabled, the C and C methods (and their C variants) are altered such that when the event is fired, a debugging line is printed, using the C method. This identifes the name of the event. By default, the line is only printed if the caller of one of these methods is the same package as the object is blessed into, allowing it to print the events of the most-derived class, without the extra verbosity of the lower-level events of its parent class used to create it. All calls regardless of caller can be printed by setting a number greater than 1 as the value of C. =cut =head2 $notifier->debug_printf( $format, @args ) Conditionally print a debugging message to C if debugging is enabled. If such a message is printed, it will be printed using C using the given format and arguments. The message will be prefixed with 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 parameter has that name appended in braces. For example, invoking $stream->debug_printf( "EVENT on_read" ) On an C instance reading and writing a file descriptor whose C is 4, which is a child of an C, will produce a line of output: [Ia:Stream{rw=4}<-IaP:Stream] EVENT on_read =cut sub debug_printf { $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; printf STDERR "[%s] $format\n", join("<-", @id), @args; } sub _debug_printf_event { my $self = shift; my ( $caller, $event_name ) = @_; my $class = ref $self; if( $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" ) ); } } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/MergePoint.pm000444001750001750 444412227104373 16450 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2007,2009 -- leonerd@leonerd.org.uk package IO::Async::MergePoint; use strict; use warnings; our $VERSION = '0.61'; use Carp; use base qw( Async::MergePoint ); carp "This module is deprecated; use Async::MergePoint instead"; =head1 NAME C - resynchronise diverged control flow =head1 SYNOPSIS This module as now been moved to its own dist of L. It is kept here as a trivial subclass for backward compatibility. Eventually this subclass may be removed. Any code using C should instead use L. use Async::MergePoint; my $merge = Async::MergePoint->new( needs => [ "leaves", "water" ], on_finished => sub { my %items = @_; # Make tea using $items{leaves} and $items{water} } ); Kettle->boil( on_boiled => sub { $merge->done( "water", $_[0] ) } ); Cupboard->get_tea_leaves( on_fetched => sub { $merge->done( "leaves", $_[0] ) } ); =head1 DESCRIPTION Often in program logic, multiple different steps need to be taken that are independent of each other, but their total result is needed before the next step can be taken. In synchonous code, the usual approach is to do them sequentially. An C-based program could do this, but if each step involves some IO idle time, better overall performance can often be gained by running the steps in parallel. A L object can then be used to wait for all of the steps to complete, before passing the combined result of each step on to the next stage. A merge point maintains a set of outstanding operations it is waiting on; these are arbitrary string values provided at the object's construction. Each time the C method is called, the named item is marked as being complete. When all of the required items are so marked, the C continuation is invoked. When an item is marked as complete, a value can also be provided, which would contain the results of that step. The C callback is passed a hash (in list form, rather than by reference) of the collected item values. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Loop000755001750001750 012227104373 14607 5ustar00leoleo000000000000IO-Async-0.61/lib/IO/Async/Loop/Select.pm000444001750001750 1561712227104373 16553 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2007-2013 -- leonerd@leonerd.org.uk package IO::Async::Loop::Select; use strict; use warnings; our $VERSION = '0.61'; use constant API_VERSION => '0.49'; use base qw( IO::Async::Loop ); use IO::Async::OS; use Carp; # select() on most platforms claims that ISREG files are always read- and # write-ready, but not on MSWin32. We need to fake this use constant FAKE_ISREG_READY => IO::Async::OS->HAVE_FAKE_ISREG_READY; # select() on most platforms indicates write-ready when connect() fails, but # not on MSWin32. Have to pull from evec in that case use constant SELECT_CONNECT_EVEC => IO::Async::OS->HAVE_SELECT_CONNECT_EVEC; use constant _CAN_WATCHDOG => 1; use constant WATCHDOG_ENABLE => IO::Async::Loop->WATCHDOG_ENABLE; =head1 NAME C - use C with C =head1 SYNOPSIS Normally an instance of this class would not be directly constructed by a program. It may however, be useful for runinng L with an existing program already using a C-based event loop, a pair of methods C and C can be called immediately before and after a C call, setting the bits that the Loop is interested in. It will also adjust the C<$timeout> value if appropriate, reducing it if the next event timeout the Loop requires is sooner than the current value. =over 8 =item \$readvec =item \$writevec =item \$exceptvec Scalar references to the reading, writing and exception bitvectors =item \$timeout Scalar reference to the timeout value =back =cut sub pre_select { my $self = shift; my ( $readref, $writeref, $exceptref, $timeref ) = @_; # BITWISE operations $$readref |= $self->{rvec}; $$writeref |= $self->{wvec}; $$exceptref |= $self->{evec}; $self->_adjust_timeout( $timeref ); $$timeref = 0 if FAKE_ISREG_READY and length $self->{avec}; # Round up to nearest millisecond if( $$timeref ) { my $mils = $$timeref * 1000; my $fraction = $mils - int $mils; $$timeref += ( 1 - $fraction ) / 1000 if $fraction; } return; } =head2 $loop->post_select( $readvec, $writevec, $exceptvec ) This method checks the returned bitvectors from a C syscall, performs it, then calls C to process the result. It returns the total number of callbacks invoked by the C method, or C if the underlying C syscall returned an error. =cut sub loop_once { my $self = shift; my ( $timeout ) = @_; my ( $rvec, $wvec, $evec ) = ('') x 3; $self->pre_select( \$rvec, \$wvec, \$evec, \$timeout ); 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 - OO interface to select system call =back =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Loop/Poll.pm000444001750001750 1753612227104373 16244 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2007-2013 -- leonerd@leonerd.org.uk package IO::Async::Loop::Poll; use strict; use warnings; our $VERSION = '0.61'; 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 ); # IO::Poll version 0.05 contain a bug whereby the ->remove method doesn't # properly clean up all the references to the handles. If the version we're # using is in this range, we have to clean it up ourselves. use constant IO_POLL_REMOVE_BUG => ( $IO::Poll::VERSION == '0.05' ); # Only Linux, or FreeBSD 8.0 and above, are known always to be able to report # EOF conditions on filehandles using POLLHUP use constant _CAN_ON_HANGUP => ( $^O eq "linux" ) || ( $^O eq "freebsd" and do { no warnings 'numeric'; (POSIX::uname)[2] >= 8.0 } ); # poll() on most platforms claims that ISREG files are always read- and # write-ready, but not on MSWin32. We need to fake this use constant FAKE_ISREG_READY => IO::Async::OS->HAVE_FAKE_ISREG_READY; # poll() on most platforms indicates POLLOUT when connect() fails, but not on # MSWin32. Have to poll also for POLLPRI in that case use constant POLL_CONNECT_POLLPRI => IO::Async::OS->HAVE_POLL_CONNECT_POLLPRI; use constant _CAN_WATCHDOG => 1; use constant WATCHDOG_ENABLE => IO::Async::Loop->WATCHDOG_ENABLE; =head1 NAME C - use C with C =head1 SYNOPSIS Normally an instance of this class would not be directly constructed by a program. It may however, be useful for runinng L with an existing program already using an C object. use IO::Poll; use IO::Async::Loop::Poll; my $poll = IO::Poll->new; my $loop = IO::Async::Loop::Poll->new( poll => $poll ); $loop->add( ... ); while(1) { my $timeout = ... my $ret = $poll->poll( $timeout ); $loop->post_poll; } =head1 DESCRIPTION This subclass of C uses an C object to perform read-ready and write-ready tests. To integrate with existing code that uses an C, a C can be called immediately after the C method on the contained C object. The appropriate mask bits are maintained on the C object when notifiers are added or removed from the set, or when they change their C status. The C method inspects the result bits and invokes the C or C methods on the notifiers. =cut =head1 CONSTRUCTOR =cut =head2 $loop = IO::Async::Loop::Poll->new( %args ) This function returns a new instance of a C object. It takes the following named arguments: =over 8 =item C The C object to use for notification. Optional; if a value is not given, a new C object will be constructed. =back =cut sub new { my $class = shift; my ( %args ) = @_; my $poll = delete $args{poll}; $poll ||= IO::Poll->new; my $self = $class->__new( %args ); $self->{poll} = $poll; return $self; } =head1 METHODS =cut =head2 $count = $loop->post_poll( $poll ) This method checks the returned event list from a C call, and calls any of the notification methods or callbacks that are appropriate. It returns the total number of callbacks that were invoked; that is, the total number of C and C callbacks for C, and C event callbacks. =over 8 =item $poll Reference to the C object =back =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->events( $watch->[0] ); 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 method on the stored C object, passing in the value of C<$timeout>, and then runs the C method on itself. It returns the total number of callbacks invoked by the C method, or C if the underlying C method returned an error. =cut sub loop_once { my $self = shift; my ( $timeout ) = @_; $self->_adjust_timeout( \$timeout ); $timeout = 0 if FAKE_ISREG_READY and keys %{ $self->{fake_isreg} }; # Round up to nearest millisecond if( $timeout ) { my $mils = $timeout * 1000; my $fraction = $mils - int $mils; $timeout += ( 1 - $fraction ) / 1000 if $fraction; } 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; } sub watch_io { my $self = shift; my %params = @_; $self->__watch_io( %params ); my $poll = $self->{poll}; my $handle = $params{handle}; my $curmask = $poll->mask( $handle ) || 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}{$handle->fileno} = $mask; } $poll->mask( $handle, $mask ) if $mask != $curmask; } sub unwatch_io { my $self = shift; my %params = @_; $self->__unwatch_io( %params ); # Guard for global destruction my $poll = $self->{poll} or return; my $handle = $params{handle}; my $curmask = $poll->mask( $handle ) || 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}; } } $poll->mask( $handle, $mask ) if $mask != $curmask; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Protocol000755001750001750 012227104373 15477 5ustar00leoleo000000000000IO-Async-0.61/lib/IO/Async/Protocol/LineStream.pm000444001750001750 465612227104373 20250 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010 -- leonerd@leonerd.org.uk package IO::Async::Protocol::LineStream; use strict; use warnings; our $VERSION = '0.61'; use base qw( IO::Async::Protocol::Stream ); use Carp; =head1 NAME C - stream-based protocols using lines of text =head1 SYNOPSIS Most likely this class will be subclassed to implement a particular network protocol. package Net::Async::HelloWorld; use strict; use warnings; use base qw( IO::Async::Protocol::LineStream ); sub on_read_line { my $self = shift; my ( $line ) = @_; if( $line =~ m/^HELLO (.*)/ ) { my $name = $1; $self->invoke_event( on_hello => $name ); } } sub send_hello { my $self = shift; my ( $name ) = @_; $self->write_line( "HELLO $name" ); } This small example elides such details as error handling, which a real protocol implementation would be likely to contain. =head1 DESCRIPTION =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_read_line $line Invoked when a new complete line of input is received. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item on_read_line => CODE CODE reference for the C event. =back =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 =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Protocol/Stream.pm000444001750001750 1236612227104373 17455 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2013 -- leonerd@leonerd.org.uk package IO::Async::Protocol::Stream; use strict; use warnings; our $VERSION = '0.61'; use base qw( IO::Async::Protocol ); use Carp; =head1 NAME C - base class for stream-based protocols =head1 SYNOPSIS Most likely this class will be subclassed to implement a particular network protocol. package Net::Async::HelloWorld; use strict; use warnings; use base qw( IO::Async::Protocol::Stream ); sub on_read { my $self = shift; my ( $buffref, $eof ) = @_; return 0 unless $$buffref =~ s/^(.*)\n//; my $line = $1; if( $line =~ m/^HELLO (.*)/ ) { my $name = $1; $self->invoke_event( on_hello => $name ); } return 1; } sub send_hello { my $self = shift; my ( $name ) = @_; $self->write( "HELLO $name\n" ); } This small example elides such details as error handling, which a real protocol implementation would be likely to contain. =head1 DESCRIPTION This subclass of L is intended to stand as a base class for implementing stream-based protocols. It provides an interface similar to L, primarily, a C method and an C event handler. It contains an instance of an C object which it uses for actual communication, rather than being a subclass of it, allowing a level of independence from the actual stream being used. For example, the stream may actually be an L to allow the protocol to be used over SSL. As with C, it is required that by the time the protocol object is added to a Loop, that it either has an C method, or has been configured with an C callback handler. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 $ret = on_read \$buffer, $eof =head2 on_read_eof =head2 on_write_eof The event handlers are invoked identically to C. =head2 on_closed The C handler is optional, but if provided, will be invoked after the stream is closed by either side (either because the C method has been invoked on it, or on an incoming EOF). =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item on_read => CODE =item on_read_eof => CODE =item on_write_eof => CODE CODE references for the events. =item handle => IO A shortcut for the common case where the transport only needs to be a plain C object. If this argument is provided without a C object, a new C object will be built around the given IO handle, and used as the transport. =back =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 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 for the Protocol. Calls C C with C set to C<"stream">. =cut sub connect { my $self = shift; $self->SUPER::connect( @_, socktype => "stream", ); } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Internals000755001750001750 012227104373 15635 5ustar00leoleo000000000000IO-Async-0.61/lib/IO/Async/Internals/TimeQueue.pm000444001750001750 631512227104373 20240 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2006-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; IO-Async-0.61/lib/IO/Async/Internals/Connector.pm000444001750001750 1624212227104373 20307 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2008-2013 -- leonerd@leonerd.org.uk package # hide from CPAN IO::Async::Internals::Connector; use strict; use warnings; our $VERSION = '0.61'; 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->new->fail( 1 ); } if( $localaddr and not $sock->bind( $localaddr ) ) { $binderr = $!; $on_fail->( "bind", $sock, $localaddr, $! ) if $on_fail; return Future->new->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->new->done( $sock ); } elsif( $! != EINPROGRESS and !CONNECT_EWOULDLBOCK || $! != POSIX::EWOULDBLOCK ) { $connecterr = $!; $on_fail->( "connect", $sock, $peeraddr, $! ) if $on_fail; return Future->new->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->or_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 ) ->and_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; IO-Async-0.61/lib/IO/Async/Timer000755001750001750 012227104373 14756 5ustar00leoleo000000000000IO-Async-0.61/lib/IO/Async/Timer/Absolute.pm000444001750001750 542512227104373 17235 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2010-2011 -- leonerd@leonerd.org.uk package IO::Async::Timer::Absolute; use strict; use warnings; use base qw( IO::Async::Timer ); our $VERSION = '0.61'; use Carp; =head1 NAME C - event callback at a fixed future time =head1 SYNOPSIS use IO::Async::Timer::Absolute; use POSIX qw( mktime ); use IO::Async::Loop; my $loop = IO::Async::Loop->new; my @time = gmtime; my $timer = IO::Async::Timer::Absolute->new( time => mktime( 0, 0, 0, $time[4]+1, $time[5], $time[6] ), on_expire => sub { print "It's midnight\n"; $loop->stop; }, ); $loop->add( $timer ); $loop->run; =head1 DESCRIPTION This subclass of L implements one-shot events at a fixed time in the future. The object waits for a given timestamp, and invokes its callback at that point in the future. For a C object that waits for a delay relative to the time it is started, see instead L. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_expire Invoked when the timer expires. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item on_expire => CODE CODE reference for the C event. =item time => NUM The epoch time at which the timer will expire. =back Once constructed, the timer object will need to be added to the C before it will work. Unlike other timers, it does not make sense to C this object, because its expiry time is absolute, and not relative to the time it is started. =cut sub configure { my $self = shift; my %params = @_; if( exists $params{on_expire} ) { my $on_expire = delete $params{on_expire}; ref $on_expire or croak "Expected 'on_expire' as a reference"; $self->{on_expire} = $on_expire; undef $self->{cb}; # Will be lazily constructed when needed } if( exists $params{time} ) { my $time = delete $params{time}; $self->stop if $self->is_running; $self->{time} = $time; $self->start if !$self->is_running; } unless( $self->can_event( 'on_expire' ) ) { croak 'Expected either a on_expire callback or an ->on_expire method'; } $self->SUPER::configure( %params ); } sub _make_cb { my $self = shift; return $self->_capture_weakself( sub { my $self = shift or return; undef $self->{id}; $self->invoke_event( "on_expire" ); } ); } sub _make_enqueueargs { my $self = shift; return at => $self->{time}; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Timer/Periodic.pm000444001750001750 1433512227104373 17235 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2009-2012 -- leonerd@leonerd.org.uk package IO::Async::Timer::Periodic; use strict; use warnings; use base qw( IO::Async::Timer ); our $VERSION = '0.61'; use Carp; =head1 NAME C - event callback at regular intervals =head1 SYNOPSIS use IO::Async::Timer::Periodic; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $timer = IO::Async::Timer::Periodic->new( interval => 60, on_tick => sub { print "You've had a minute\n"; }, ); $timer->start; $loop->add( $timer ); $loop->run; =head1 DESCRIPTION This subclass of L implements repeating events at regular clock intervals. The timing may or may not be subject to how long it takes the callback to execute. Iterations may be rescheduled runs at fixed regular intervals beginning at the time the timer was started, or by a fixed delay after the previous code has finished executing. For a C object that only runs a callback once, after a given delay, see instead L. A Countdown timer can also be used to create repeating events that fire at a fixed delay after the previous event has finished processing. See als the examples in C. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_tick Invoked on each interval of the timer. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item on_tick => CODE CODE reference for the C event. =item interval => NUM The interval in seconds between invocations of the callback or method. Cannot be changed if the timer is running. =item first_interval => NUM Optional. If defined, the interval in seconds after calling the C method before the first invocation of the callback or method. Thereafter, the regular C will be used. If not supplied, the first interval will be the same as the others. Even if this value is zero, the first invocation will be made asynchronously, by the containing C object, and not synchronously by the C method itself. =item reschedule => STRING Optional. Must be one of C, C or C. Defines the algorithm used to reschedule the next invocation. C schedules each iteration at the fixed interval from the previous iteration's schedule time, ensuring a regular repeating event. C schedules similarly to C, but skips over times that have already passed. This matters if the duration is particularly short and there's a possibility that times may be missed, or if the entire process is stopped and resumed by C or similar. C schedules each iteration at the fixed interval from the time that the previous iteration's event handler returns. This allows it to slowly drift over time and become desynchronised with other events of the same interval or multiples/fractions of it. =back Once constructed, the timer object will need to be added to the C before it will work. It will also need to be started by the C method. =cut sub _init { my $self = shift; $self->SUPER::_init( @_ ); $self->{reschedule} = "hard"; } sub configure { my $self = shift; my %params = @_; if( exists $params{on_tick} ) { my $on_tick = delete $params{on_tick}; ref $on_tick or croak "Expected 'on_tick' as a reference"; $self->{on_tick} = $on_tick; undef $self->{cb}; # Will be lazily constructed when needed } if( exists $params{interval} ) { $self->is_running and croak "Cannot configure 'interval' of a running timer\n"; my $interval = delete $params{interval}; $interval > 0 or croak "Expected a 'interval' as a positive number"; $self->{interval} = $interval; } if( exists $params{first_interval} ) { $self->is_running and croak "Cannot configure 'first_interval' of a running timer\n"; my $first_interval = delete $params{first_interval}; $first_interval >= 0 or croak "Expected a 'first_interval' as a non-negative number"; $self->{first_interval} = $first_interval; } if( exists $params{reschedule} ) { my $resched = delete $params{reschedule} || "hard"; grep { $_ eq $resched } qw( hard skip drift ) or croak "Expected 'reschedule' to be one of hard, skip, drift"; $self->{reschedule} = $resched; } unless( $self->can_event( 'on_tick' ) ) { croak 'Expected either a on_tick callback or an ->on_tick method'; } $self->SUPER::configure( %params ); } sub _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}; $self->invoke_event( on_tick => ); # detect ->stop $self->start if defined $self->{next_time}; } ); } sub _make_enqueueargs { my $self = shift; return at => $self->{next_time}; } =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/Timer/Countdown.pm000444001750001750 1462612227104373 17462 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2009-2012 -- leonerd@leonerd.org.uk package IO::Async::Timer::Countdown; use strict; use warnings; use base qw( IO::Async::Timer ); our $VERSION = '0.61'; use Carp; =head1 NAME C - event callback after a fixed delay =head1 SYNOPSIS use IO::Async::Timer::Countdown; use IO::Async::Loop; my $loop = IO::Async::Loop->new; my $timer = IO::Async::Timer::Countdown->new( delay => 10, on_expire => sub { print "Sorry, your time's up\n"; $loop->stop; }, ); $timer->start; $loop->add( $timer ); $loop->run; =head1 DESCRIPTION This subclass of L implements one-shot fixed delays. The object implements a countdown timer, which invokes its callback after the given period from when it was started. After it has expired the Timer may be started again, when it will wait the same period then invoke the callback again. A timer that is currently running may be stopped or reset. For a C object that repeatedly runs a callback at regular intervals, see instead L. For a C that invokes its callback at a fixed time in the future, see L. =cut =head1 EVENTS The following events are invoked, either using subclass methods or CODE references in parameters: =head2 on_expire Invoked when the timer expires. =cut =head1 PARAMETERS The following named parameters may be passed to C or C: =over 8 =item on_expire => CODE CODE reference for the C event. =item 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". =item remove_on_expire => BOOL Optional. If true, remove this timer object from its parent notifier or containing loop when it expires. Defaults to false. =back Once constructed, the timer object will need to be added to the C before it will work. It will also need to be started by the C method. =cut sub configure { my $self = shift; my %params = @_; foreach (qw( remove_on_expire )) { $self->{$_} = delete $params{$_} if exists $params{$_}; } if( exists $params{on_expire} ) { my $on_expire = delete $params{on_expire}; ref $on_expire or croak "Expected 'on_expire' as a reference"; $self->{on_expire} = $on_expire; undef $self->{cb}; # Will be lazily constructed when needed } if( exists $params{delay} ) { $self->is_running and croak "Cannot configure 'delay' of a running timer\n"; my $delay = delete $params{delay}; $delay >= 0 or croak "Expected a 'delay' as a non-negative number"; $self->{delay} = $delay; } unless( $self->can_event( 'on_expire' ) ) { croak 'Expected either a on_expire callback or an ->on_expire method'; } $self->SUPER::configure( %params ); } =head1 METHODS =cut =head2 $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 method restarts a running countdown timer back to its full period, it can be used to implement a watchdog timer. This is a timer which will not expire provided the method is called at least as often as it is configured. If the method fails to be called, the timer will eventually expire and run its callback. For example, to expire an accepted connection after 30 seconds of inactivity: ... on_accept => sub { my ( $newclient ) = @_; my $watchdog = IO::Async::Timer::Countdown->new( delay => 30, on_expire => sub { my $self = shift; my $stream = $self->parent; $stream->close; }, ); my $stream = IO::Async::Stream->new( handle => $newclient, on_read => sub { my ( $self, $buffref, $eof ) = @_; $watchdog->reset; ... }, on_closed => sub { $watchdog->stop; }, ) ); $stream->add_child( $watchdog ); $watchdog->start; $loop->add( $watchdog ); } Rather than setting up a lexical variable to store the Stream so that the Timer's C closure can call C on it, the parent/child relationship between the two Notifier objects is used. At the time the Timer C closure is invoked, it will have been added as a child notifier of the Stream; this means the Timer's C method will return the Stream Notifier. This enables it to call C without needing to capture a lexical variable, which would create a cyclic reference. =head2 Fixed-Delay Repeating Timer The C event fires a fixed delay after the C method has begun the countdown. The C method can be invoked again at some point during the C handling code, to create a timer that invokes its code regularly a fixed delay after the previous invocation has finished. This creates an arrangement similar to an L, except that it will wait until the previous invocation has indicated it is finished, before starting the countdown for the next call. my $timer = IO::Async::Timer::Countdown->new( delay => 60, on_expire => sub { my $self = shift; start_some_operation( on_complete => sub { $self->start }, ); }, ); $timer->start; $loop->add( $timer ); This example invokes the C function 60 seconds after the previous iteration has indicated it has finished. =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/OS000755001750001750 012227104373 14217 5ustar00leoleo000000000000IO-Async-0.61/lib/IO/Async/OS/MSWin32.pm000444001750001750 532612227104373 16062 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2012-2013 -- leonerd@leonerd.org.uk package IO::Async::OS::MSWin32; use strict; use warnings; our $VERSION = '0.61'; 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; use constant HAVE_SELECT_CONNECT_EVEC => 1; use constant HAVE_POLL_CONNECT_POLLPRI => 1; use constant HAVE_CONNECT_EWOULDBLOCK => 1; use constant HAVE_RENAME_OPEN_FILES => 0; # poll(2) on Windows is emulated by wrapping select(2) anyway, so we might as # well try the Select loop first use constant LOOP_BUILTIN_CLASSES => qw( Select Poll ); # CORE::fork() does not provide full POSIX semantics use constant HAVE_POSIX_FORK => 0; # Windows does not have signals, and SIGCHLD is not available use constant HAVE_SIGNALS => 0; =head1 NAME C - operating system abstractions on C for C =head1 DESCRIPTION This module contains OS support code for C. See instead L. =cut # Win32's pipes don't actually work with select(). We'll have to create # sockets instead sub pipepair { shift->socketpair( 'inet', 'stream' ); } # Win32 doesn't have a socketpair(). We'll fake one up sub socketpair { my $self = shift; my ( $family, $socktype, $proto ) = @_; $family = $self->getfamilybyname( $family ) || AF_INET; # SOCK_STREAM is the most likely $socktype = $self->getsocktypebyname( $socktype ) || SOCK_STREAM; $proto ||= 0; $family == AF_INET or croak "Cannot emulate ->socketpair except on AF_INET"; my $Stmp = $self->socket( $family, $socktype ) or return; $Stmp->bind( pack_sockaddr_in( 0, INADDR_LOOPBACK ) ) or return; my $S1 = $self->socket( $family, $socktype ) or return; my $S2; if( $socktype == SOCK_STREAM ) { $Stmp->listen( 1 ) or return; $S1->connect( getsockname $Stmp ) or return; $S2 = $Stmp->accept or return; # There's a bug in IO::Socket here, in that $S2 's ->socktype won't # yet be set. We can apply a horribly hacky fix here # defined $S2->socktype and $S2->socktype == $socktype or # ${*$S2}{io_socket_type} = $socktype; # But for now we'll skip the test for it instead } elsif( $socktype == SOCK_DGRAM ) { $S2 = $Stmp; $S1->connect( getsockname $S2 ) or return; $S2->connect( getsockname $S1 ) or return; } else { croak "Unrecognised socktype $socktype"; } return ( $S1, $S2 ); }; =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/lib/IO/Async/OS/cygwin.pm000444001750001750 140512227104373 16212 0ustar00leoleo000000000000# You may distribute under the terms of either the GNU General Public License # or the Artistic License (the same terms as Perl itself) # # (C) Paul Evans, 2013 -- leonerd@leonerd.org.uk package IO::Async::OS::cygwin; use strict; use warnings; our $VERSION = '0.61'; 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; =head1 NAME C - operating system abstractions on C for C =head1 DESCRIPTION This module contains OS support code for C. See instead L. =cut =head1 AUTHOR Paul Evans =cut 0x55AA; IO-Async-0.61/examples000755001750001750 012227104373 13362 5ustar00leoleo000000000000IO-Async-0.61/examples/whoami-server.pl000444001750001750 236612227104373 16653 0ustar00leoleo000000000000#!/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_resolve_error => sub { die "Cannot resolve - $_[0]\n"; }, on_listen_error => sub { die "Cannot listen\n"; }, ); $loop->run; IO-Async-0.61/examples/readwrite-futures.pl000444001750001750 60212227104373 17513 0ustar00leoleo000000000000#!/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; IO-Async-0.61/examples/tail-logfile.pl000444001750001750 112712227104373 16425 0ustar00leoleo000000000000#!/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; IO-Async-0.61/examples/netcat-client.pl000444001750001750 321212227104373 16604 0ustar00leoleo000000000000#!/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', on_connected => sub { $socket = shift }, on_resolve_error => sub { die "Cannot resolve - $_[0]\n" }, on_connect_error => sub { die "Cannot connect\n" }, ); $loop->loop_once until defined $socket; # $socket is just an IO::Socket reference my $peeraddr = $socket->peerhost . ":" . $socket->peerport; print STDERR "Connected to $peeraddr\n"; # We need to create a cross-connected pair of Streams. Can't do that # easily without a temporary variable my ( $socketstream, $stdiostream ); $socketstream = IO::Async::Stream->new( handle => $socket, on_read => sub { my ( undef, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*)$CRLF// ) { $stdiostream->write( $1 . "\n" ); } return 0; }, on_closed => sub { print STDERR "Closed connection to $peeraddr\n"; $stdiostream->close_when_empty; }, ); $loop->add( $socketstream ); $stdiostream = IO::Async::Stream->new_for_stdio( on_read => sub { my ( undef, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*)\n// ) { $socketstream->write( $1 . $CRLF ); } return 0; }, on_closed => sub { $socketstream->close_when_empty; }, ); $loop->add( $stdiostream ); $loop->await_all( $socketstream->new_close_future, $stdiostream->new_close_future ); IO-Async-0.61/examples/tcp-proxy.pl000444001750001750 401112227104373 16015 0ustar00leoleo000000000000#!/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', on_resolve_error => sub { die "Cannot resolve - $_[0]\n"; }, on_listen_error => sub { die "Cannot listen\n"; }, ); $loop->run; package ProxyListener; use base qw( IO::Async::Listener ); sub on_stream { my $self = shift; my ( $stream1 ) = @_; # $socket is just an IO::Socket reference my $socket1 = $stream1->read_handle; my $peeraddr = $socket1->peerhost . ":" . $socket1->peerport; print STDERR "Accepted new connection from $peeraddr\n"; $loop->connect( host => $CONNECT_HOST, service => $CONNECT_PORT, on_stream => sub { my ( $stream2 ) = @_; $stream1->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; # Just copy all the data $stream2->write( $$buffref ); $$buffref = ""; return 0; }, on_closed => sub { $stream2->close_when_empty; print STDERR "Connection from $peeraddr closed\n"; }, ); $stream2->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; # Just copy all the data $stream1->write( $$buffref ); $$buffref = ""; return 0; }, on_closed => sub { $stream1->close_when_empty; print STDERR "Connection to $CONNECT_HOST:$CONNECT_PORT closed\n"; }, ); $loop->add( $stream1 ); $loop->add( $stream2 ); }, on_resolve_error => sub { print STDERR "Cannot resolve - $_[0]\n"; }, on_connect_error => sub { print STDERR "Cannot connect\n"; }, ); } IO-Async-0.61/examples/chat-server.pl000444001750001750 254312227104373 16303 0ustar00leoleo000000000000#!/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_resolve_error => sub { die "Cannot resolve - $_[0]\n"; }, on_listen_error => sub { die "Cannot listen\n"; }, ); $loop->run; package ChatListener; use base qw( IO::Async::Listener ); my @clients; sub on_stream { my $self = shift; my ( $stream ) = @_; # $socket is just an IO::Socket reference my $socket = $stream->read_handle; my $peeraddr = $socket->peerhost . ":" . $socket->peerport; # Inform the others $_->write( "$peeraddr joins\n" ) for @clients; $stream->configure( on_read => sub { my ( $self, $buffref, $eof ) = @_; while( $$buffref =~ s/^(.*\n)// ) { # eat a line from the stream input # Reflect it to all but the stream who wrote it $_ == $self or $_->write( "$peeraddr: $1" ) for @clients; } return 0; }, on_closed => sub { my ( $self ) = @_; @clients = grep { $_ != $self } @clients; # Inform the others $_->write( "$peeraddr leaves\n" ) for @clients; }, ); $loop->add( $stream ); push @clients, $stream; } IO-Async-0.61/examples/echo-server.pl000444001750001750 250612227104373 16301 0ustar00leoleo000000000000#!/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_resolve_error => sub { die "Cannot resolve - $_[0]\n"; }, on_listen_error => sub { die "Cannot listen\n"; }, ); $loop->run; IO-Async-0.61/t000755001750001750 012227104373 12007 5ustar00leoleo000000000000IO-Async-0.61/t/19test.t000444001750001750 304712227104373 13466 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/21stream-4encoding.t000444001750001750 617212227104373 15645 0ustar00leoleo000000000000#!/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->new->done( "\x{10a}" ), on_flush => sub { $flushed++ } ); wait_for { $flushed }; is( read_data( $rd ), "\xc4\x8a", 'UTF-8 bytes written by ->write Future' ); $flushed = 0; my $once = 0; $stream->write( sub { $once++ ? undef : "\x{10b}" }, on_flush => sub { $flushed++ } ); wait_for { $flushed }; is( read_data( $rd ), "\xc4\x8b", 'UTF-8 bytes written by ->write CODE' ); $loop->remove( $stream ); } done_testing; IO-Async-0.61/t/13loop-poll-idle.t000444001750001750 16412227104373 15306 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Poll', 'idle' ); IO-Async-0.61/t/02os.t000444001750001750 1300212227104373 13130 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; 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' ); } 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' ); } done_testing; IO-Async-0.61/t/42function.t000444001750001750 2505112227104373 14347 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use IO::Async::Test; use Test::More; use Test::Fatal; use Test::Refcount; 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 $function = IO::Async::Function->new( code => sub { die shift }, ); $loop->add( $function ); my $err; $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' ); $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\n", "2\n" ], '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\n", "1\n" ], '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 ); } done_testing; IO-Async-0.61/t/15loop-select-control.t000444001750001750 17112227104373 16362 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Select', 'control' ); IO-Async-0.61/t/35loop-openchild.t000444001750001750 254412227104373 15422 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/34process-handles.t000444001750001750 3044112227104373 15614 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/00use.t000444001750001750 143712227104373 13272 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/19loop-future.t000444001750001750 405112227104373 14764 0ustar00leoleo000000000000#!/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' ); } # 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( $future->failure, "Timeout", '$future failed with "Timeout" for timeout_future' ); # Check that ->cancel does not crash $loop->timeout_future( after => 1 * AUT )->cancel; } done_testing; IO-Async-0.61/t/20handle.t000444001750001750 2434712227104373 13760 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use IO::Async::Test; use Test::More; use Test::Fatal; 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" } ); 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' ); } done_testing; package TestHandle; use base qw( IO::Async::Handle ); sub on_read_ready { $sub_readready = 1 } sub on_write_ready { $sub_writeready = 1 } IO-Async-0.61/t/32loop-spawnchild-setup.t000444001750001750 2747012227104373 16771 0ustar00leoleo000000000000#!/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 ; return 0 }, exitstatus => 0, dollarat => ''; my $buffer; $ret = read_timeout( $my_r, $buffer, 6, 0.1 ); is( $ret, 6, '$my_r->read after pipe quad to fd0/fd1' ); is( $buffer, "HELLO\n", '$buffer after pipe quad to fd0/fd1' ); } { # Try to swap two filehandles and cause a dup2() collision my @fhA = IO::Async::OS->pipepair or die "Cannot pipepair - $!"; my @fhB = IO::Async::OS->pipepair or die "Cannot pipepair - $!"; my $filenoA = $fhA[1]->fileno; my $filenoB = $fhB[1]->fileno; TEST "fd swap", setup => [ "fd$filenoA" => $fhB[1], "fd$filenoB" => $fhA[1], ], code => sub { $fhA[1]->print( "FHA" ); $fhA[1]->autoflush(1); $fhB[1]->print( "FHB" ); $fhB[1]->autoflush(1); return 0; }, exitstatus => 0; my $buffer; read_timeout( $fhA[0], $buffer, 3, 0.1 ); is( $buffer, "FHB", '$buffer [A] after dup2() swap' ); read_timeout( $fhB[0], $buffer, 3, 0.1 ); is( $buffer, "FHA", '$buffer [B] after dup2() swap' ); } TEST "stdout close", setup => [ stdout => [ 'close' ] ], code => sub { print "test"; }, exitstatus => 255, dollarbang => EBADF, dollarat => ''; TEST "stdout close shortcut", setup => [ stdout => 'close' ], code => sub { print "test"; }, exitstatus => 255, dollarbang => EBADF, dollarat => ''; { my $name = tmpnam; END { unlink $name if defined $name and -f $name } TEST "stdout open", setup => [ stdout => [ 'open', '>', $name ] ], code => sub { print "test"; }, exitstatus => 1, dollarat => ''; ok( -f $name, 'tmpnam file exists after stdout open' ); open( my $tmpfh, "<", $name ) or die "Cannot open '$name' for reading - $!"; undef $buffer; $ret = read_timeout( $tmpfh, $buffer, 4, 0.1 ); is( $ret, 4, '$tmpfh->read after stdout open' ); is( $buffer, 'test', '$buffer after stdout open' ); TEST "stdout open append", setup => [ stdout => [ 'open', '>>', $name ] ], code => sub { print "value"; }, exitstatus => 1, dollarat => ''; seek( $tmpfh, 0, 0 ); undef $buffer; $ret = read_timeout( $tmpfh, $buffer, 9, 0.1 ); is( $ret, 9, '$tmpfh->read after stdout open append' ); is( $buffer, 'testvalue', '$buffer after stdout open append' ); } $ENV{TESTKEY} = "parent value"; TEST "environment is preserved", setup => [], code => sub { return $ENV{TESTKEY} eq "parent value" ? 0 : 1 }, exitstatus => 0, dollarat => ''; TEST "environment is overwritten", setup => [ env => { TESTKEY => "child value" } ], code => sub { return $ENV{TESTKEY} eq "child value" ? 0 : 1 }, exitstatus => 0, dollarat => ''; SKIP: { # Some of the CPAN smoke testers might run test scripts under modified nice # anyway. We'd better get our starting value to check for difference, not # absolute my $prio_now = getpriority(0,0); # If it's already quite high, we don't want to hit the limit and be # clamped. Just skip the tests if it's too high before we start. skip "getpriority is already above 15, so I won't try renicing upwards", 3 if $prio_now > 15; TEST "nice works", setup => [ nice => 3 ], code => sub { return getpriority(0,0) == $prio_now + 3 ? 0 : 1 }, exitstatus => 0, dollarat => ''; } TEST "chdir works", setup => [ chdir => "/" ], code => sub { return getcwd eq "/" ? 0 : 1 }, exitstatus => 0, dollarat => ''; done_testing; IO-Async-0.61/t/27file.t000444001750001750 516412227104373 13427 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/13loop-select-idle.t000444001750001750 16612227104373 15621 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Select', 'idle' ); IO-Async-0.61/t/40channel.t000444001750001750 1011412227104373 14122 0ustar00leoleo000000000000#!/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 { 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' ); } done_testing; IO-Async-0.61/t/60protocol.t000444001750001750 645512227104373 14352 0ustar00leoleo000000000000#!/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 ); } IO-Async-0.61/t/36loop-runchild.t000444001750001750 1133012227104373 15277 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/28filestream.t000444001750001750 1667412227104373 14674 0ustar00leoleo000000000000#!/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; } IO-Async-0.61/t/61protocol-stream.t000444001750001750 1344412227104373 15660 0ustar00leoleo000000000000#!/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; } IO-Async-0.61/t/30loop-fork.t000444001750001750 350512227104373 14407 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/24listener.t000444001750001750 1730412227104373 14351 0ustar00leoleo000000000000#!/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; { 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' ); } { 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; package TestListener; use base qw( IO::Async::Listener ); sub on_accept { ( undef, $sub_newclient ) = @_ } IO-Async-0.61/t/22timer-absolute.t000444001750001750 617612227104373 15443 0ustar00leoleo000000000000#!/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 } IO-Async-0.61/t/38loop-thread.t000444001750001750 231512227104373 14723 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/11loop-select-timer.t000444001750001750 16712227104373 16023 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Select', 'timer' ); IO-Async-0.61/t/14loop-select-child.t000444001750001750 16712227104373 15771 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Select', 'child' ); IO-Async-0.61/t/62protocol-linestream.t000444001750001750 510112227104373 16500 0ustar00leoleo000000000000#!/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]; } IO-Async-0.61/t/52loop-listen.t000444001750001750 1216012227104373 14765 0ustar00leoleo000000000000#!/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, Listen => 1, ) and next; $badport = $port; $failure = $!; last; } SKIP: { skip "No bind()-failing ports found", 6 unless defined $badport; my $failop; my $failerr; my @error; # We need to capture the Listener object before failure, so we can assert # it gets removed from the Loop again afterwards my $listener; no warnings 'redefine'; my $add = IO::Async::Loop->can( "add" ); local *IO::Async::Loop::add = sub { $listener = $_[1]; $add->( @_ ); }; $loop->listen( family => "inet", socktype => "stream", host => "localhost", service => $badport, on_resolve_error => sub { die "Test died early - resolve error $_[0]\n"; }, on_listen => sub { die "Test died early - listen on port $badport actually succeeded\n"; }, on_accept => sub { "DUMMY" }, # really hope this doesn't happen ;) on_fail => sub { $failop = shift; $failerr = pop; }, on_listen_error => sub { @error = @_; }, ); ok( defined $listener, 'Managed to capture listener being added to Loop' ); wait_for { @error }; is( $failop, "bind", '$failop is bind' ); is( "$failerr", $failure, "\$failerr is '$failure'" ); is( $error[0], "bind", '$error[0] is bind' ); is( "$error[1]", $failure, "\$error[1] is '$failure'" ); ok( defined $listener, '$listener defined after bind failure' ); ok( !$listener->loop, '$listener not in loop after bind failure' ); } done_testing; IO-Async-0.61/t/05notifier-child.t000444001750001750 567312227104373 15411 0ustar00leoleo000000000000#!/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 $parent = TestNotifier->new( varref => \my $parent_in_loop ); my $child = TestNotifier->new( varref => \my $child_in_loop ); 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' ); ok( !$parent_in_loop, '$parent not yet in loop' ); ok( !$child_in_loop, '$child not yet in loop' ); my @children; @children = $parent->children; is( scalar @children, 1, '@children after add_child' ); is( $children[0], $child, '$children[0] after add_child' ); undef @children; # for refcount 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' ); @children = $parent->children; is( scalar @children, 0, '@children after remove_child' ); undef @children; # for refcount my $loop = IO::Async::Loop->new; $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 ); @children = $parent->children; is( scalar @children, 1, '@children after removal from loop' ); undef @children; # for refcount 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' ); done_testing; package TestNotifier; use base qw( IO::Async::Notifier ); sub new { my $self = shift->SUPER::new; my %params = @_; $self->{varref} = $params{varref}; return $self; } sub _add_to_loop { my $self = shift; ${ $self->{varref} } = 1; } sub _remove_from_loop { my $self = shift; ${ $self->{varref} } = 0; } IO-Async-0.61/t/23signal.t000444001750001750 556012227104373 13761 0ustar00leoleo000000000000#!/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++ } IO-Async-0.61/t/25socket.t000444001750001750 2013112227104373 14005 0ustar00leoleo000000000000#!/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 { } IO-Async-0.61/t/51loop-connect.t000444001750001750 2354512227104373 15130 0ustar00leoleo000000000000#!/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( scalar $future->failure, '$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; IO-Async-0.61/t/31loop-spawnchild.t000444001750001750 1406512227104373 15626 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/15loop-poll-control.t000444001750001750 16712227104373 16056 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Poll', 'control' ); IO-Async-0.61/t/11loop-poll-timer.t000444001750001750 16512227104373 15510 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Poll', 'timer' ); IO-Async-0.61/t/37loop-child-root.t000444001750001750 357712227104373 15532 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/10loop-select-io.t000444001750001750 16412227104373 15306 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Select', 'io' ); IO-Async-0.61/t/26pid.t000444001750001750 363212227104373 13261 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/StupidLoop.pm000444001750001750 15512227104373 14565 0ustar00leoleo000000000000package t::StupidLoop; use strict; use base qw( IO::Async::Loop ); sub new { return bless {}, shift; } 1; IO-Async-0.61/t/33process.t000444001750001750 1571312227104373 14204 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/53loop-extend.t000444001750001750 460412227104373 14743 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/22timer-countdown.t000444001750001750 1332412227104373 15656 0ustar00leoleo000000000000#!/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 } IO-Async-0.61/t/12loop-select-signal.t000444001750001750 33212227104373 16153 0ustar00leoleo000000000000#!/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' ); IO-Async-0.61/t/21stream-1read.t000444001750001750 3461412227104373 15011 0ustar00leoleo000000000000#!/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 } # 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; } IO-Async-0.61/t/21stream-2write.t000444001750001750 2505612227104373 15231 0ustar00leoleo000000000000#!/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++ }, ); $stream->write( "Junk" ); $loop->add( $stream ); $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' ); } # 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 ); $stream->write( "hello" ); wait_for { defined $write_errno }; cmp_ok( $write_errno, "==", ECONNRESET, 'errno 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; IO-Async-0.61/t/18loop-select-legacy.t000444001750001750 756412227104373 16206 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/01timequeue.t000444001750001750 522412227104373 14500 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/99pod.t000444001750001750 25712227104373 13261 0ustar00leoleo000000000000#!/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(); IO-Async-0.61/t/10loop-poll-io.t000444001750001750 16212227104373 14773 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Poll', 'io' ); IO-Async-0.61/t/14loop-poll-child.t000444001750001750 16512227104373 15456 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use IO::Async::LoopTests; run_tests( 'IO::Async::Loop::Poll', 'child' ); IO-Async-0.61/t/41routine.t000444001750001750 1571112227104373 14210 0ustar00leoleo000000000000#!/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" ); $calls->send( [ 1, 2, 3 ] ); my $result; $returns->recv( on_recv => sub { $result = $_[1]; } ); wait_for { defined $result }; 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" ); } } 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; $out1->recv( on_recv => sub { $status = ${$_[1]} } ); wait_for { defined $status }; is( $status, "Ready +", '$status midway through Routine' ); $in2->send( [ 10, 20 ] ); my $result; $out2->recv( on_recv => sub { $result = ${$_[1]} } ); wait_for { defined $result }; is( $result, 30, '$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 $result; $channel->recv( on_recv => sub { $result = $_[1] } ); wait_for { defined $result }; 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; IO-Async-0.61/t/04notifier.t000444001750001750 1057612227104373 14345 0ustar00leoleo000000000000#!/usr/bin/perl use strict; use warnings; use Test::More; use Test::Fatal; use Test::Refcount; use IO::Async::Loop; use IO::Async::Notifier; my $loop = IO::Async::Loop->new; is_refcount( $loop, 2, '$loop has refcount 2 initially' ); is_deeply( [ $loop->notifiers ], [], '$loop->notifiers empty' ); 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' ); 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( 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( !exception { $notifier->configure; }, '$notifier->configure no params succeeds' ); ok( exception { $notifier->configure( oranges => 1 ) }, '$notifier->configure an unrecognised parameter fails' ); 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' ); undef @args; is_refcount( $loop, 2, '$loop has refcount 2 finally' ); is_oneref( $notifier, '$notifier has refcount 1 finally' ); undef $loop; my @subargs; $notifier = TestNotifier->new; $mref = $notifier->_capture_weakself( 'frobnicate' ); is_oneref( $notifier, '$notifier has refcount 1 after _capture_weakself on named method' ); $mref->( 456 ); is_deeply( \@subargs, [ $notifier, 456 ], '@subargs after invoking $mref on named method' ); { undef @subargs; my @newargs; no warnings 'redefine'; local *TestNotifier::frobnicate = sub { @newargs = @_; }; $mref->( 321 ); is_deeply( \@subargs, [], '@subargs empty after TestNotifier::frobnicate replacement' ); is_deeply( \@newargs, [ $notifier, 321 ], '@newargs after TestNotifier::frobnicate replacement' ); } undef @subargs; ok( exception { $notifier->_capture_weakself( 'cannotdo' ) }, '$notifier->_capture_weakself on unknown method name fails' ); $notifier->invoke_event( 'frobnicate', 78 ); is_deeply( \@subargs, [ $notifier, 78 ], '@subargs after ->invoke_event' ); undef @subargs; is_deeply( $notifier->maybe_invoke_event( 'frobnicate', 'a'..'c' ), [ $notifier, 'a'..'c' ], 'return value from ->maybe_invoke_event' ); is( $notifier->maybe_invoke_event( 'mangle' ), undef, 'return value from ->maybe_invoke_event on missing event' ); undef @subargs; my $cb = $notifier->make_event_cb( 'frobnicate' ); is( ref $cb, "CODE", '->make_event_cb returns a CODE reference' ); is_oneref( $notifier, '$notifier has refcount 1 after ->make_event_cb' ); $cb->( 90 ); is_deeply( \@subargs, [ $notifier, 90 ], '@subargs after ->make_event_cb->()' ); isa_ok( $notifier->maybe_make_event_cb( 'frobnicate' ), "CODE", '->maybe_make_event_cb yields CODE ref' ); is( $notifier->maybe_make_event_cb( 'mangle' ), undef, '->maybe_make_event_cb on missing event yields undef' ); undef @subargs; is_oneref( $notifier, '$notifier has refcount 1 finally' ); done_testing; package TestNotifier; use base qw( IO::Async::Notifier ); sub frobnicate { @subargs = @_ } IO-Async-0.61/t/06notifier-mixin.t000444001750001750 211712227104373 15441 0ustar00leoleo000000000000#!/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 } IO-Async-0.61/t/50resolver.t000444001750001750 2225112227104373 14361 0ustar00leoleo000000000000#!/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( $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( $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' ); } done_testing; IO-Async-0.61/t/22timer-periodic.t000444001750001750 1137612227104373 15441 0ustar00leoleo000000000000#!/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 ); } ## Subclass my $sub_tick = 0; { my $timer = TestTimer->new( interval => 2 * AUT, ); ok( defined $timer, 'subclass $timer defined' ); isa_ok( $timer, "IO::Async::Timer", 'subclass $timer isa IO::Async::Timer' ); is_oneref( $timer, 'subclass $timer has refcount 1 initially' ); $loop->add( $timer ); is_refcount( $timer, 2, 'subclass $timer has refcount 2 after adding to Loop' ); $timer->start; is_refcount( $timer, 2, 'subclass $timer has refcount 2 after starting' ); ok( $timer->is_running, 'Started subclass Timer is running' ); time_about( sub { wait_for { $sub_tick == 1 } }, 2, 'subclass Timer works' ); is_refcount( $timer, 2, 'subclass $timer has refcount 2 before removing from Loop' ); $loop->remove( $timer ); is_oneref( $timer, 'subclass $timer has refcount 1 after removing from Loop' ); } done_testing; package TestTimer; use base qw( IO::Async::Timer::Periodic ); sub on_tick { $sub_tick++ } IO-Async-0.61/t/63handle-connect.t000444001750001750 351412227104373 15367 0ustar00leoleo000000000000#!/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->failure 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->failure and $f->get; ok( defined $handle->read_handle, '$handle->read_handle defined after ->connect host/service' ); is( $handle->read_handle->peerport, $listensock->sockport, '$handle->read_handle->peerport after ->connect host/service' ); $listensock->accept; # drop it $loop->remove( $handle ); } done_testing; IO-Async-0.61/t/03loop-magic.t000444001750001750 215312227104373 14524 0ustar00leoleo000000000000#!/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' ); is( IO::Async::Loop->new, $loop, 'IO::Async::Loop->new again yields same loop' ); { local $ENV{IO_ASYNC_LOOP} = "t::StupidLoop"; undef $IO::Async::Loop::ONE_TRUE_LOOP; $loop = IO::Async::Loop->new; isa_ok( $loop, "t::StupidLoop", 'Magic constructor obeys $ENV{IO_ASYNC_LOOP}' ); } { local $IO::Async::Loop::LOOP = "t::StupidLoop"; undef $IO::Async::Loop::ONE_TRUE_LOOP; $loop = IO::Async::Loop->new; isa_ok( $loop, "t::StupidLoop", 'Magic constructor obeys $IO::Async::Loop::LOOP' ); } { local $IO::Async::Loop::LOOP = "Select"; undef $IO::Async::Loop::ONE_TRUE_LOOP; $loop = IO::Async::Loop->new; isa_ok( $loop, "IO::Async::Loop::Select", 'Magic constructor expands unqualified package names' ); } done_testing; IO-Async-0.61/t/21stream-3split.t000444001750001750 1012212227104373 15217 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/12loop-poll-signal.t000444001750001750 33012227104373 15640 0ustar00leoleo000000000000#!/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' ); IO-Async-0.61/t/18loop-poll-legacy.t000444001750001750 436212227104373 15666 0ustar00leoleo000000000000#!/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; IO-Async-0.61/t/TimeAbout.pm000444001750001750 146412227104373 14400 0ustar00leoleo000000000000package 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;