diff options
Diffstat (limited to 'lib')
36 files changed, 16527 insertions, 0 deletions
diff --git a/lib/IO/Async.pm b/lib/IO/Async.pm new file mode 100644 index 0000000..bc2d196 --- /dev/null +++ b/lib/IO/Async.pm @@ -0,0 +1,366 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2008-2013 -- leonerd@leonerd.org.uk + +package IO::Async; + +use strict; +use warnings; + +# This package contains no code other than a declaration of the version. +# It is provided simply to keep CPAN happy: +# cpan -i IO::Async + +our $VERSION = '0.67'; + +=head1 NAME + +C<IO::Async> - Asynchronous event-driven programming + +=head1 SYNOPSIS + + use IO::Async::Stream; + use IO::Async::Loop; + + my $loop = IO::Async::Loop->new; + + $loop->connect( + host => "some.other.host", + service => 12345, + socktype => 'stream', + + on_stream => sub { + my ( $stream ) = @_; + + $stream->configure( + on_read => sub { + my ( $self, $buffref, $eof ) = @_; + + while( $$buffref =~ s/^(.*\n)// ) { + print "Received a line $1"; + } + + return 0; + } + ); + + $stream->write( "An initial line here\n" ); + + $loop->add( $stream ); + }, + + on_resolve_error => sub { die "Cannot resolve - $_[-1]\n"; }, + on_connect_error => sub { die "Cannot connect - $_[0] failed $_[-1]\n"; }, + ); + + $loop->run; + +=head1 DESCRIPTION + +This collection of modules allows programs to be written that perform +asynchronous filehandle IO operations. A typical program using them would +consist of a single subclass of L<IO::Async::Loop> to act as a container of +other objects, which perform the actual IO work required by the program. As +well as IO handles, the loop also supports timers and signal handlers, and +includes more higher-level functionality built on top of these basic parts. + +Because there are a lot of classes in this collection, the following overview +gives a brief description of each. + +=head2 Notifiers + +The base class of all the event handling subclasses is L<IO::Async::Notifier>. +It does not perform any IO operations itself, but instead acts as a base class +to build the specific IO functionality upon. It can also coordinate a +collection of other Notifiers contained within it, forming a tree structure. + +The following sections describe particular types of Notifier. + +=head2 File Handle IO + +An L<IO::Async::Handle> object is a Notifier that represents a single IO handle +being managed. While in most cases it will represent a single filehandle, such +as a socket (for example, an L<IO::Socket::INET> connection), it is possible +to have separate reading and writing handles (most likely for a program's +C<STDIN> and C<STDOUT> streams, or a pair of pipes connected to a child +process). + +The L<IO::Async::Stream> class is a subclass of L<IO::Async::Handle> which +maintains internal incoming and outgoing data buffers. In this way, it +implements bidirectional buffering of a byte stream, such as a TCP socket. The +class automatically handles reading of incoming data into the incoming buffer, +and writing of the outgoing buffer. Methods or callbacks are used to inform +when new incoming data is available, or when the outgoing buffer is empty. + +While stream-based sockets can be handled using using C<IO::Async::Stream>, +datagram or raw sockets do not provide a bytestream. For these, the +L<IO::Async::Socket> class is another subclass of L<IO::Async::Handle> which +maintains an outgoing packet queue, and informs of packet receipt using a +callback or method. + +The L<IO::Async::Listener> class is another subclass of L<IO::Async::Handle> +which facilitates the use of C<listen(2)>-mode sockets. When a new connection +is available on the socket it will C<accept(2)> it and pass the new client +socket to its callback function. + +=head2 Timers + +An L<IO::Async::Timer::Absolute> object represents a timer that expires at a +given absolute time in the future. + +An L<IO::Async::Timer::Countdown> object represents a count time timer, which +will invoke a callback after a given delay. It can be stopped and restarted. + +An L<IO::Async::Timer::Periodic> object invokes a callback at regular intervals +from its initial start time. It is reliable and will not drift due to the time +taken to run the callback. + +The L<IO::Async::Loop> also supports methods for managing timed events on a +lower level. Events may be absolute, or relative in time to the time they are +installed. + +=head2 Signals + +An L<IO::Async::Signal> object represents a POSIX signal, which will invoke a +callback when the given signal is received by the process. Multiple objects +watching the same signal can be used; they will all invoke in no particular +order. + +=head2 Processes Management + +An L<IO::Async::PID> object invokes its event when a given child process +exits. An L<IO::Async::Process> object can start a new child process running +either a given block of code, or executing a given command, set up pipes on +its filehandles, write to or read from these pipes, and invoke its event when +the child process exits. + +=head2 Loops + +The L<IO::Async::Loop> object class represents an abstract collection of +L<IO::Async::Notifier> objects, and manages the actual filehandle IO +watchers, timers, signal handlers, and other functionality. It performs all +of the abstract collection management tasks, and leaves the actual OS +interactions to a particular subclass for the purpose. + +L<IO::Async::Loop::Poll> uses an L<IO::Poll> object for this test. + +L<IO::Async::Loop::Select> uses the C<select(2)> syscall. + +Other subclasses of loop may appear on CPAN under their own dists; see the +L</SEE ALSO> section below for more detail. + +As well as these general-purpose classes, the L<IO::Async::Loop> constructor +also supports looking for OS-specific subclasses, in case a more efficient +implementation exists for the specific OS it runs on. + +=head2 Child Processes + +The L<IO::Async::Loop> object provides a number of methods to facilitate the +running of child processes. C<spawn_child> is primarily a wrapper around the +typical C<fork(2)>/C<exec(2)> style of starting child processes, and +C<run_child> provide a method similar to perl's C<readpipe> (which is used +to implement backticks C<``>). + +=head2 File Change Watches + +The L<IO::Async::File> object observes changes to C<stat(2)> properties of a +file, directory, or other filesystem object. It invokes callbacks when +properties change. This is used by L<IO::Async::FileStream> which presents +the same events as a C<IO::Async::Stream> but operates on a regular file on +the filesystem, observing it for updates. + +=head2 Asynchronous Co-routines and Functions + +The C<IO::Async> framework generally provides mechanisms for multiplexing IO +tasks between different handles, so there aren't many occasions when it is +necessary to run code in another thread or process. Two cases where this does +become useful are when: + +=over 4 + +=item * + +A large amount of computationally-intensive work needs to be performed. + +=item * + +An OS or library-level function needs to be called, that will block, and +no asynchronous version is supplied. + +=back + +For these cases, an instance of L<IO::Async::Function> can be used around +a code block, to execute it in a worker child process or set of processes. +The code in the sub-process runs isolated from the main program, communicating +only by function call arguments and return values. This can be used to solve +problems involving state-less library functions. + +An L<IO::Async::Routine> object wraps a code block running in a separate +process to form a kind of co-routine. Communication with it happens via +L<IO::Async::Channel> objects. It can be used to solve any sort of problem +involving keeping a possibly-stateful co-routine running alongside the rest of +an asynchronous program. + +=head2 Futures + +An L<IO::Async::Future> object represents a single outstanding action that is +yet to complete, such as a name resolution operation or a socket connection. +It stands in contrast to a C<IO::Async::Notifier>, which is an object that +represents an ongoing source of activity, such as a readable filehandle of +bytes or a POSIX signal. + +Futures are a recent addition to the C<IO::Async> API and details are still +subject to change and experimentation. + +In general, methods that support Futures return a new Future object to +represent the outstanding operation. If callback functions are supplied as +well, these will be fired in addition to the Future object becoming ready. Any +failures that are reported will, in general, use the same conventions for the +Future's C<fail> arguments to relate it to the legacy C<on_error>-style +callbacks. + + $on_NAME_error->( $message, @argmuents ) + + $f->fail( $message, NAME, @arguments ) + +where C<$message> is a message intended for humans to read (so that this is +the message displayed by C<< $f->get >> if the failure is not otherwise +caught), C<NAME> is the name of the failing operation. If the failure is due +to a failed system call, the value of C<$!> will be the final argument. The +message should not end with a linefeed. + +=head2 Networking + +The L<IO::Async::Loop> provides several methods for performing network-based +tasks. Primarily, the C<connect> and C<listen> methods allow the creation of +client or server network sockets. Additionally, the C<resolve> method allows +the use of the system's name resolvers in an asynchronous way, to resolve +names into addresses, or vice versa. These methods are fully IPv6-capable if +the underlying operating system is. + +=head2 Protocols + +The L<IO::Async::Protocol> class provides storage for a L<IO::Async::Handle> +object, to act as a transport for some protocol. It allows a level of +independence from the actual transport being for that protocol, allowing it to +be easily reused. The L<IO::Async::Protocol::Stream> subclass provides further +support for protocols based on stream connections, such as TCP sockets. + +=head1 TODO + +This collection of modules is still very much in development. As a result, +some of the potentially-useful parts or features currently missing are: + +=over 4 + +=item * + +Consider further ideas on Solaris' I<ports>, BSD's I<Kevents> and anything that +might be useful on Win32. + +=item * + +Consider some form of persistent object wrapper in the form of an +C<IO::Async::Object>, based on C<IO::Async::Routine>. + +=item * + +C<IO::Async::Protocol::Datagram> + +=item * + +Support for watching filesystem entries for change. Extract logic from +C<IO::Async::File> and define a Loop watch/unwatch method pair. + +=item * + +Define more C<Future>-returning methods. Consider also one-shot Futures on +things like C<IO::Async::Process> exits, or C<IO::Async::Handle> close. + +=back + +=head1 SUPPORT + +Bugs may be reported via RT at + + https://rt.cpan.org/Public/Dist/Display.html?Name=IO-Async + +Support by IRC may also be found on F<irc.perl.org> in the F<#io-async> +channel. + +=cut + +=head1 SEE ALSO + +As well as the two loops supplied in this distribution, many more exist on +CPAN. At the time of writing this includes: + +=over 4 + +=item * + +L<IO::Async::Loop::AnyEvent> - use IO::Async with AnyEvent + +=item * + +L<IO::Async::Loop::Epoll> - use IO::Async with epoll on Linux + +=item * + +L<IO::Async::Loop::Event> - use IO::Async with Event + +=item * + +L<IO::Async::Loop::EV> - use IO::Async with EV + +=item * + +L<IO::Async::Loop::Glib> - use IO::Async with Glib or GTK + +=item * + +L<IO::Async::Loop::KQueue> - use IO::Async with kqueue + +=item * + +L<IO::Async::Loop::Mojo> - use IO::Async with Mojolicious + +=item * + +L<IO::Async::Loop::POE> - use IO::Async with POE + +=item * + +L<IO::Async::Loop::Ppoll> - use IO::Async with ppoll(2) + +=back + +Additionally, some other event loops or modules also support being run on top +of C<IO::Async>: + +=over 4 + +=item * + +L<AnyEvent::Impl::IOAsync> - AnyEvent adapter for IO::Async + +=item * + +L<Gungho::Engine::IO::Async> - IO::Async Engine + +=item * + +L<POE::Loop::IO_Async> - IO::Async event loop support for POE + +=back + +=cut + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Channel.pm b/lib/IO/Async/Channel.pm new file mode 100644 index 0000000..6e638f9 --- /dev/null +++ b/lib/IO/Async/Channel.pm @@ -0,0 +1,471 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2011-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Channel; + +use strict; +use warnings; +use base qw( IO::Async::Notifier ); + +our $VERSION = '0.67'; + +use Carp; + +use IO::Async::Stream; + +=head1 NAME + +C<IO::Async::Channel> - pass values into or out from an L<IO::Async::Routine> + +=head1 DESCRIPTION + +A C<IO::Async::Channel> object allows Perl values to be passed into or out of +an L<IO::Async::Routine>. It is intended to be used primarily with a Routine +object rather than independently. For more detail and examples on how to use +this object see also the documentation for L<IO::Async::Routine>. + +A Channel object is shared between the main process of the program and the +process running within the Routine. In the main process it will be used in +asynchronous mode, and in the Routine process it will be used in synchronous +mode. In asynchronous mode all methods return immediately and use +C<IO::Async>-style futures or callback functions. In synchronous within the +Routine process the methods block until they are ready and may be used for +flow-control within the routine. Alternatively, a Channel may be shared +between two different Routine objects, and not used directly by the +controlling program. + +The channel itself represents a FIFO of Perl reference values. New values may +be put into the channel by the C<send> method in either mode. Values may be +retrieved from it by the C<recv> method. Values inserted into the Channel are +snapshot by the C<send> method. Any changes to referred variables will not be +observed by the other end of the Channel after the C<send> method returns. + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 codec => STR + +Gives the name of the encoding method used to represent values over the +channel. + +By default this will be C<Storable>, to use the core L<Storable> module. As +this only supports references, to pass a single scalar value, C<send> a SCALAR +reference to it, and dereference the result of C<recv>. + +If the L<Sereal::Encoder> and L<Sereal::Decoder> modules are installed, this +can be set to C<Sereal> instead, and will use those to perform the encoding +and decoding. This optional dependency may give higher performance than using +C<Storable>. + +=cut + +=head1 CONSTRUCTOR + +=cut + +=head2 $channel = IO::Async::Channel->new + +Returns a new C<IO::Async::Channel> object. This object reference itself +should be shared by both sides of a C<fork()>ed process. After C<fork()> the +two C<setup_*> methods may be used to configure the object for operation on +either end. + +While this object does in fact inherit from L<IO::Async::Notifier>, it should +not be added to a Loop object directly; event management will be handled by +its containing C<IO::Async::Routine> object. + +=cut + +=head1 METHODS + +The following methods documented with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +=head2 $channel->configure( %params ) + +Similar to the standard C<configure> method on C<IO::Async::Notifier>, this is +used to change details of the Channel's operation. + +=over 4 + +=item on_recv => CODE + +May only be set on an async mode channel. If present, will be invoked whenever +a new value is received, rather than using the C<recv> method. + + $on_recv->( $channel, $data ) + +=item on_eof => CODE + +May only be set on an async mode channel. If present, will be invoked when the +channel gets closed by the peer. + + $on_eof->( $channel ) + +=back + +=cut + +sub _init +{ + my $self = shift; + my ( $params ) = @_; + + $params->{codec} //= "Storable"; + + $self->SUPER::_init( $params ); +} + +sub configure +{ + my $self = shift; + my %params = @_; + + foreach (qw( on_recv on_eof )) { + next unless exists $params{$_}; + $self->{mode} and $self->{mode} eq "async" or + croak "Can only configure $_ in async mode"; + + $self->{$_} = delete $params{$_}; + $self->_build_stream; + } + + if( my $codec = delete $params{codec} ) { + ( $self->can( "_make_codec_$codec" ) or croak "Unrecognised codec name '$codec'" ) + ->( $self ); + } + + $self->SUPER::configure( %params ); +} + +sub _make_codec_Storable +{ + my $self = shift; + + require Storable; + + $self->{encode} = \&Storable::freeze; + $self->{decode} = \&Storable::thaw; +} + +sub _make_codec_Sereal +{ + my $self = shift; + + require Sereal::Encoder; + require Sereal::Decoder; + + my $encoder = Sereal::Encoder->new; + $self->{encode} = sub { $encoder->encode( $_[0] ) }; + + my $decoder = Sereal::Decoder->new; + $self->{decode} = sub { $decoder->decode( $_[0] ) }; +} + +=head2 $channel->send( $data ) + +Pushes the data stored in the given Perl reference into the FIFO of the +Channel, where it can be received by the other end. When called on a +synchronous mode Channel this method may block if a C<write()> call on the +underlying filehandle blocks. When called on an asynchronous mode channel this +method will not block. + +=cut + +sub send +{ + my $self = shift; + my ( $data ) = @_; + + $self->send_frozen( $self->{encode}->( $data ) ); +} + +=head2 $channel->send_frozen( $record ) + +A variant of the C<send> method; this method pushes the byte record given. +This should be the result of a call to C<Storable::freeze()>. + +=cut + +sub send_frozen +{ + my $self = shift; + my ( $record ) = @_; + + my $bytes = pack( "I", length $record ) . $record; + + defined $self->{mode} or die "Cannot ->send without being set up"; + + return $self->_send_sync( $bytes ) if $self->{mode} eq "sync"; + return $self->_send_async( $bytes ) if $self->{mode} eq "async"; +} + +=head2 $data = $channel->recv + +When called on a synchronous mode Channel this method will block until a Perl +reference value is available from the other end and then return it. If the +Channel is closed this method will return C<undef>. Since only references may +be passed and all Perl references are true the truth of the result of this +method can be used to detect that the channel is still open and has not yet +been closed. + +=head2 $data = $channel->recv->get + +When called on an asynchronous mode Channel this method returns a future which +will eventually yield the next Perl reference value that becomes available +from the other end. If the Channel is closed, the future will fail with an +C<eof> failure. + +=head2 $channel->recv( %args ) + +When not returning a future, takes the following named arguments: + +=over 8 + +=item on_recv => CODE + +Called when a new Perl reference value is available. Will be passed the +Channel object and the reference data. + + $on_recv->( $channel, $data ) + +=item on_eof => CODE + +Called if the Channel was closed before a new value was ready. Will be passed +the Channel object. + + $on_eof->( $channel ) + +=back + +=cut + +sub recv +{ + my $self = shift; + + defined $self->{mode} or die "Cannot ->recv without being set up"; + + return $self->_recv_sync( @_ ) if $self->{mode} eq "sync"; + return $self->_recv_async( @_ ) if $self->{mode} eq "async"; +} + +=head2 $channel->close + +Closes the channel. Causes a pending C<recv> on the other end to return undef +or the queued C<on_eof> callbacks to be invoked. + +=cut + +sub close +{ + my $self = shift; + + return $self->_close_sync if $self->{mode} eq "sync"; + return $self->_close_async if $self->{mode} eq "async"; +} + +# Leave this undocumented for now +sub setup_sync_mode +{ + my $self = shift; + ( $self->{fh} ) = @_; + + $self->{mode} = "sync"; + + # Since we're communicating binary structures and not Unicode text we need to + # enable binmode + binmode $self->{fh}; + + $self->{fh}->autoflush(1); +} + +sub _read_exactly +{ + $_[1] = ""; + + while( length $_[1] < $_[2] ) { + my $n = read( $_[0], $_[1], $_[2]-length $_[1], length $_[1] ); + defined $n or return undef; + $n or return ""; + } + + return $_[2]; +} + +sub _recv_sync +{ + my $self = shift; + + my $n = _read_exactly( $self->{fh}, my $lenbuffer, 4 ); + defined $n or die "Cannot read - $!"; + length $n or return undef; + + my $len = unpack( "I", $lenbuffer ); + + $n = _read_exactly( $self->{fh}, my $record, $len ); + defined $n or die "Cannot read - $!"; + length $n or return undef; + + return $self->{decode}->( $record ); +} + +sub _send_sync +{ + my $self = shift; + my ( $bytes ) = @_; + $self->{fh}->print( $bytes ); +} + +sub _close_sync +{ + my $self = shift; + $self->{fh}->close; +} + +# Leave this undocumented for now +sub setup_async_mode +{ + my $self = shift; + my %args = @_; + + exists $args{$_} and $self->{$_} = delete $args{$_} for qw( read_handle write_handle ); + + keys %args and croak "Unrecognised keys for setup_async_mode: " . join( ", ", keys %args ); + + $self->{mode} = "async"; +} + +sub _build_stream +{ + my $self = shift; + return $self->{stream} ||= do { + $self->{on_result_queue} = []; + + my $stream = IO::Async::Stream->new( + read_handle => $self->{read_handle}, + write_handle => $self->{write_handle}, + autoflush => 1, + on_read => $self->_capture_weakself( '_on_stream_read' ) + ); + + $self->add_child( $stream ); + + $stream; + }; +} + +sub _send_async +{ + my $self = shift; + my ( $bytes ) = @_; + $self->_build_stream->write( $bytes ); +} + +sub _recv_async +{ + my $self = shift; + my %args = @_; + + my $on_recv = $args{on_recv}; + my $on_eof = $args{on_eof}; + + my $stream = $self->_build_stream; + + my $f; + $f = $stream->loop->new_future unless !defined wantarray; + + push @{ $self->{on_result_queue} }, sub { + my ( $self, $type, $result ) = @_; + if( $type eq "recv" ) { + $f->done( $result ) if $f and !$f->is_cancelled; + $on_recv->( $self, $result ) if $on_recv; + } + else { + $f->fail( "EOF waiting for Channel recv", eof => ) if $f and !$f->is_cancelled; + $on_eof->( $self ) if $on_eof; + } + }; + + return $f; +} + +sub _close_async +{ + my $self = shift; + if( my $stream = $self->{stream} ) { + $stream->close_when_empty; + } + else { + $_ and $_->close for $self->{read_handle}, $self->{write_handle}; + } + + undef $_ for $self->{read_handle}, $self->{write_handle}; +} + +sub _on_stream_read +{ + my $self = shift or return; + my ( $stream, $buffref, $eof ) = @_; + + if( $eof ) { + while( my $on_result = shift @{ $self->{on_result_queue} } ) { + $on_result->( $self, eof => ); + } + $self->{on_eof}->( $self ) if $self->{on_eof}; + return; + } + + return 0 unless length( $$buffref ) >= 4; + my $len = unpack( "I", $$buffref ); + return 0 unless length( $$buffref ) >= 4 + $len; + + my $record = $self->{decode}->( substr( $$buffref, 4, $len ) ); + substr( $$buffref, 0, 4 + $len ) = ""; + + if( my $on_result = shift @{ $self->{on_result_queue} } ) { + $on_result->( $self, recv => $record ); + } + else { + $self->{on_recv}->( $self, $record ); + } + + return 1; +} + +sub _extract_read_handle +{ + my $self = shift; + + return undef if !$self->{mode}; + + croak "Cannot extract filehandle" if $self->{mode} ne "async"; + $self->{mode} = "dead"; + + return $self->{read_handle}; +} + +sub _extract_write_handle +{ + my $self = shift; + + return undef if !$self->{mode}; + + croak "Cannot extract filehandle" if $self->{mode} ne "async"; + $self->{mode} = "dead"; + + return $self->{write_handle}; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/ChildManager.pm b/lib/IO/Async/ChildManager.pm new file mode 100644 index 0000000..48ac108 --- /dev/null +++ b/lib/IO/Async/ChildManager.pm @@ -0,0 +1,705 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2007-2014 -- leonerd@leonerd.org.uk + +package IO::Async::ChildManager; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +# Not a notifier + +use IO::Async::Stream; + +use IO::Async::OS; + +use Carp; +use Scalar::Util qw( weaken ); + +use POSIX qw( _exit dup dup2 nice ); + +use constant LENGTH_OF_I => length( pack( "I", 0 ) ); + +=head1 NAME + +C<IO::Async::ChildManager> - facilitates the execution of child processes + +=head1 SYNOPSIS + +This object is used indirectly via an C<IO::Async::Loop>: + + use IO::Async::Loop; + + my $loop = IO::Async::Loop->new; + + ... + + $loop->run_child( + command => "/bin/ps", + + on_finish => sub { + my ( $pid, $exitcode, $stdout, $stderr ) = @_; + my $status = ( $exitcode >> 8 ); + print "ps [PID $pid] exited with status $status\n"; + }, + ); + + $loop->open_child( + command => [ "/bin/ping", "-c4", "some.host" ], + + stdout => { + on_read => sub { + my ( $stream, $buffref, $eof ) = @_; + while( $$buffref =~ s/^(.*)\n// ) { + print "PING wrote: $1\n"; + } + return 0; + }, + }, + + on_finish => sub { + my ( $pid, $exitcode ) = @_; + my $status = ( $exitcode >> 8 ); + ... + }, + ); + + my ( $pipeRd, $pipeWr ) = IO::Async::OS->pipepair; + $loop->spawn_child( + command => "/usr/bin/my-command", + + setup => [ + stdin => [ "open", "<", "/dev/null" ], + stdout => $pipeWr, + stderr => [ "open", ">>", "/var/log/mycmd.log" ], + chdir => "/", + ] + + on_exit => sub { + my ( $pid, $exitcode ) = @_; + my $status = ( $exitcode >> 8 ); + print "Command exited with status $status\n"; + }, + ); + + $loop->spawn_child( + code => sub { + do_something; # executes in a child process + return 1; + }, + + on_exit => sub { + my ( $pid, $exitcode, $dollarbang, $dollarat ) = @_; + my $status = ( $exitcode >> 8 ); + print "Child process exited with status $status\n"; + print " OS error was $dollarbang, exception was $dollarat\n"; + }, + ); + +=head1 DESCRIPTION + +This module extends the functionality of the containing C<IO::Async::Loop> to +manage the execution of child processes. It acts as a central point to store +PID values of currently-running children, and to call the appropriate +continuation handler code when the process terminates. It provides useful +wrapper methods that set up filehandles and other child process details, and +to capture the child process's STDOUT and STDERR streams. + +=cut + +# Writing to variables of $> and $) have tricky ways to obtain error results +sub setuid +{ + my ( $uid ) = @_; + + $> = $uid; my $saved_errno = $!; + $> == $uid and return 1; + + $! = $saved_errno; + return undef; +} + +sub setgid +{ + my ( $gid ) = @_; + + $) = $gid; my $saved_errno = $!; + $) == $gid and return 1; + + $! = $saved_errno; + return undef; +} + +sub setgroups +{ + my @groups = @_; + + my $gid = $)+0; + # Put the primary GID as the first group in the supplementary list, because + # some operating systems ignore this position, expecting it to indeed be + # the primary GID. + # See + # https://rt.cpan.org/Ticket/Display.html?id=65127 + @groups = grep { $_ != $gid } @groups; + + $) = "$gid $gid " . join " ", @groups; my $saved_errno = $!; + + # No easy way to detect success or failure. Just check that we have all and + # only the right groups + my %gotgroups = map { $_ => 1 } split ' ', "$)"; + + $! = $saved_errno; + $gotgroups{$_}-- or return undef for @groups; + keys %gotgroups or return undef; + + return 1; +} + +# Internal constructor +sub new +{ + my $class = shift; + my ( %params ) = @_; + + my $loop = delete $params{loop} or croak "Expected a 'loop'"; + + my $self = bless { + loop => $loop, + }, $class; + + weaken( $self->{loop} ); + + return $self; +} + +=head1 METHODS + +When active, the following methods are available on the containing C<Loop> +object. + +=cut + +=head2 $pid = $loop->spawn_child( %params ) + +This method creates a new child process to run a given code block or command. +The C<%params> hash takes the following keys: + +=over 8 + +=item command => ARRAY or STRING + +Either a reference to an array containing the command and its arguments, or a +plain string containing the command. This value is passed into perl's +C<exec> function. + +=item code => CODE + +A block of code to execute in the child process. It will be called in scalar +context inside an C<eval> block. + +=item setup => ARRAY + +A reference to an array which gives file descriptors to set up in the child +process before running the code or command. See below. + +=item on_exit => CODE + +A continuation to be called when the child processes exits. It will be invoked +in the following way: + + $on_exit->( $pid, $exitcode, $dollarbang, $dollarat ) + +The second argument is passed the plain perl C<$?> value. + +=back + +Exactly one of the C<command> or C<code> keys must be specified. + +If the C<command> key is used, the given array or string is executed using the +C<exec> function. + +If the C<code> key is used, the return value will be used as the C<exit(2)> +code from the child if it returns (or 255 if it returned C<undef> or thows an +exception). + + Case | ($exitcode >> 8) | $dollarbang | $dollarat + --------------+------------------------+-------------+---------- + exec succeeds | exit code from program | 0 | "" + exec fails | 255 | $! | "" + $code returns | return value | $! | "" + $code dies | 255 | $! | $@ + +It is usually more convenient to use the C<open_child> method in simple cases +where an external program is being started in order to interact with it via +file IO, or even C<run_child> when only the final result is required, rather +than interaction while it is running. + +=cut + +sub spawn_child +{ + my $self = shift; + my %params = @_; + + my $command = delete $params{command}; + my $code = delete $params{code}; + my $setup = delete $params{setup}; + my $on_exit = delete $params{on_exit}; + + if( %params ) { + croak "Unrecognised options to spawn: " . join( ",", keys %params ); + } + + defined $command and defined $code and + croak "Cannot pass both 'command' and 'code' to spawn"; + + defined $command or defined $code or + croak "Must pass one of 'command' or 'code' to spawn"; + + my @setup = defined $setup ? $self->_check_setup_and_canonicise( $setup ) : (); + + my $loop = $self->{loop}; + + my ( $readpipe, $writepipe ); + + { + # Ensure it's FD_CLOEXEC - this is a bit more portable than manually + # fiddling with F_GETFL and F_SETFL (e.g. MSWin32) + local $^F = -1; + + ( $readpipe, $writepipe ) = IO::Async::OS->pipepair or croak "Cannot pipe() - $!"; + } + + if( defined $command ) { + my @command = ref( $command ) ? @$command : ( $command ); + + $code = sub { + no warnings; + exec( @command ); + return; + }; + } + + my $kid = $loop->fork( + code => sub { + # Child + close( $readpipe ); + $self->_spawn_in_child( $writepipe, $code, \@setup ); + }, + ); + + # Parent + close( $writepipe ); + return $self->_spawn_in_parent( $readpipe, $kid, $on_exit ); +} + +=head2 C<setup> array + +This array gives a list of file descriptor operations to perform in the child +process after it has been C<fork(2)>ed from the parent, before running the code +or command. It consists of name/value pairs which are ordered; the operations +are performed in the order given. + +=over 8 + +=item fdI<n> => ARRAY + +Gives an operation on file descriptor I<n>. The first element of the array +defines the operation to be performed: + +=over 4 + +=item [ 'close' ] + +The file descriptor will be closed. + +=item [ 'dup', $io ] + +The file descriptor will be C<dup2(2)>ed from the given IO handle. + +=item [ 'open', $mode, $file ] + +The file descriptor will be opened from the named file in the given mode. The +C<$mode> string should be in the form usually given to the C<open> function; +such as '<' or '>>'. + +=item [ 'keep' ] + +The file descriptor will not be closed; it will be left as-is. + +=back + +A non-reference value may be passed as a shortcut, where it would contain the +name of the operation with no arguments (i.e. for the C<close> and C<keep> +operations). + +=item IO => ARRAY + +Shortcut for passing C<fdI<n>>, where I<n> is the fileno of the IO +reference. In this case, the key must be a reference that implements the +C<fileno> method. This is mostly useful for + + $handle => 'keep' + +=item fdI<n> => IO + +A shortcut for the C<dup> case given above. + +=item stdin => ... + +=item stdout => ... + +=item stderr => ... + +Shortcuts for C<fd0>, C<fd1> and C<fd2> respectively. + +=item env => HASH + +A reference to a hash to set as the child process's environment. + +Note that this will entirely set a new environment, completely replacing the +existing one. If you want to simply add new keys or change the values of some +keys without removing the other existing ones, you can simply copy C<%ENV> +into the hash before setting new keys: + + env => { + %ENV, + ANOTHER => "key here", + } + +=item nice => INT + +Change the child process's scheduling priority using C<POSIX::nice>. + +=item chdir => STRING + +Change the child process's working directory using C<chdir>. + +=item setuid => INT + +=item setgid => INT + +Change the child process's effective UID or GID. + +=item setgroups => ARRAY + +Change the child process's groups list, to those groups whose numbers are +given in the ARRAY reference. + +On most systems, only the privileged superuser change user or group IDs. +C<IO::Async> will B<NOT> check before detaching the child process whether +this is the case. + +If setting both the primary GID and the supplementary groups list, it is +suggested to set the primary GID first. Moreover, some operating systems may +require that the supplementary groups list contains the primary GID. + +=back + +If no directions for what to do with C<stdin>, C<stdout> and C<stderr> are +given, a default of C<keep> is implied. All other file descriptors will be +closed, unless a C<keep> operation is given for them. + +If C<setuid> is used, be sure to place it after any other operations that +might require superuser privileges, such as C<setgid> or opening special +files. + +=cut + +sub _check_setup_and_canonicise +{ + my $self = shift; + my ( $setup ) = @_; + + ref $setup eq "ARRAY" or croak "'setup' must be an ARRAY reference"; + + return () if !@$setup; + + my @setup; + + my $has_setgroups; + + foreach my $i ( 0 .. $#$setup / 2 ) { + my ( $key, $value ) = @$setup[$i*2, $i*2 + 1]; + + # Rewrite stdin/stdout/stderr + $key eq "stdin" and $key = "fd0"; + $key eq "stdout" and $key = "fd1"; + $key eq "stderr" and $key = "fd2"; + + # Rewrite other filehandles + ref $key and eval { $key->fileno; 1 } and $key = "fd" . $key->fileno; + + if( $key =~ m/^fd(\d+)$/ ) { + my $fd = $1; + my $ref = ref $value; + + if( !$ref ) { + $value = [ $value ]; + } + elsif( $ref eq "ARRAY" ) { + # Already OK + } + elsif( $ref eq "GLOB" or eval { $value->isa( "IO::Handle" ) } ) { + $value = [ 'dup', $value ]; + } + else { + croak "Unrecognised reference type '$ref' for file descriptor $fd"; + } + + my $operation = $value->[0]; + grep { $_ eq $operation } qw( open close dup keep ) or + croak "Unrecognised operation '$operation' for file descriptor $fd"; + } + elsif( $key eq "env" ) { + ref $value eq "HASH" or croak "Expected HASH reference for 'env' setup key"; + } + elsif( $key eq "nice" ) { + $value =~ m/^\d+$/ or croak "Expected integer for 'nice' setup key"; + } + elsif( $key eq "chdir" ) { + # This isn't a purely watertight test, but it does guard against + # silly things like passing a reference - directories such as + # ARRAY(0x12345) are unlikely to exist + -d $value or croak "Working directory '$value' does not exist"; + } + elsif( $key eq "setuid" ) { + $value =~ m/^\d+$/ or croak "Expected integer for 'setuid' setup key"; + } + elsif( $key eq "setgid" ) { + $value =~ m/^\d+$/ or croak "Expected integer for 'setgid' setup key"; + $has_setgroups and carp "It is suggested to 'setgid' before 'setgroups'"; + } + elsif( $key eq "setgroups" ) { + ref $value eq "ARRAY" or croak "Expected ARRAY reference for 'setgroups' setup key"; + m/^\d+$/ or croak "Expected integer in 'setgroups' array" for @$value; + $has_setgroups = 1; + } + else { + croak "Unrecognised setup operation '$key'"; + } + + push @setup, $key => $value; + } + + return @setup; +} + +sub _spawn_in_parent +{ + my $self = shift; + my ( $readpipe, $kid, $on_exit ) = @_; + + my $loop = $self->{loop}; + + # We need to wait for both the errno pipe to close, and for waitpid + # to give us an exit code. We'll form two closures over these two + # variables so we can cope with those happening in either order + + my $dollarbang; + my ( $dollarat, $length_dollarat ); + my $exitcode; + my $pipeclosed = 0; + + $loop->add( IO::Async::Stream->new( + notifier_name => "statuspipe,kid=$kid", + + read_handle => $readpipe, + + on_read => sub { + my ( $self, $buffref, $eof ) = @_; + + if( !defined $dollarbang ) { + if( length( $$buffref ) >= 2 * LENGTH_OF_I ) { + ( $dollarbang, $length_dollarat ) = unpack( "II", $$buffref ); + substr( $$buffref, 0, 2 * LENGTH_OF_I, "" ); + return 1; + } + } + elsif( !defined $dollarat ) { + if( length( $$buffref ) >= $length_dollarat ) { + $dollarat = substr( $$buffref, 0, $length_dollarat, "" ); + return 1; + } + } + + if( $eof ) { + $dollarbang = 0 if !defined $dollarbang; + if( !defined $length_dollarat ) { + $length_dollarat = 0; + $dollarat = ""; + } + + $pipeclosed = 1; + + if( defined $exitcode ) { + local $! = $dollarbang; + $on_exit->( $kid, $exitcode, $!, $dollarat ); + } + } + + return 0; + } + ) ); + + $loop->watch_child( $kid => sub { + ( my $kid, $exitcode ) = @_; + + if( $pipeclosed ) { + local $! = $dollarbang; + $on_exit->( $kid, $exitcode, $!, $dollarat ); + } + } ); + + return $kid; +} + +sub _spawn_in_child +{ + my $self = shift; + my ( $writepipe, $code, $setup ) = @_; + + my $exitvalue = eval { + # Map of which handles will be in use by the end + my %fd_in_use = ( 0 => 1, 1 => 1, 2 => 1 ); # Keep STDIN, STDOUT, STDERR + + # Count of how many times we'll need to use the current handles. + my %fds_refcount = %fd_in_use; + + # To dup2() without clashes we might need to temporarily move some handles + my %dup_from; + + my $max_fd = 0; + my $writepipe_clashes = 0; + + if( @$setup ) { + # The writepipe might be in the way of a setup filedescriptor. If it + # is we'll have to dup2 it out of the way then close the original. + foreach my $i ( 0 .. $#$setup/2 ) { + my ( $key, $value ) = @$setup[$i*2, $i*2 + 1]; + $key =~ m/^fd(\d+)$/ or next; + my $fd = $1; + + $max_fd = $fd if $fd > $max_fd; + $writepipe_clashes = 1 if $fd == fileno $writepipe; + + my ( $operation, @params ) = @$value; + + $operation eq "close" and do { + delete $fd_in_use{$fd}; + delete $fds_refcount{$fd}; + }; + + $operation eq "dup" and do { + $fd_in_use{$fd} = 1; + + my $fileno = fileno $params[0]; + # Keep a count of how many times it will be dup'ed from so we + # can close it once we've finished + $fds_refcount{$fileno}++; + + $dup_from{$fileno} = $fileno; + }; + + $operation eq "keep" and do { + $fds_refcount{$fd} = 1; + }; + } + } + + foreach ( IO::Async::OS->potentially_open_fds ) { + next if $fds_refcount{$_}; + next if $_ == fileno $writepipe; + POSIX::close( $_ ); + } + + if( @$setup ) { + if( $writepipe_clashes ) { + $max_fd++; + + dup2( fileno $writepipe, $max_fd ) or die "Cannot dup2(writepipe to $max_fd) - $!\n"; + undef $writepipe; + open( $writepipe, ">&=$max_fd" ) or die "Cannot fdopen($max_fd) as writepipe - $!\n"; + } + + foreach my $i ( 0 .. $#$setup/2 ) { + my ( $key, $value ) = @$setup[$i*2, $i*2 + 1]; + + if( $key =~ m/^fd(\d+)$/ ) { + my $fd = $1; + my( $operation, @params ) = @$value; + + $operation eq "dup" and do { + my $from = fileno $params[0]; + + if( $from != $fd ) { + if( exists $dup_from{$fd} ) { + defined( $dup_from{$fd} = dup( $fd ) ) or die "Cannot dup($fd) - $!"; + } + + my $real_from = $dup_from{$from}; + + POSIX::close( $fd ); + dup2( $real_from, $fd ) or die "Cannot dup2($real_from to $fd) - $!\n"; + } + + $fds_refcount{$from}--; + if( !$fds_refcount{$from} and !$fd_in_use{$from} ) { + POSIX::close( $from ); + delete $dup_from{$from}; + } + }; + + $operation eq "open" and do { + my ( $mode, $filename ) = @params; + open( my $fh, $mode, $filename ) or die "Cannot open('$mode', '$filename') - $!\n"; + + my $from = fileno $fh; + dup2( $from, $fd ) or die "Cannot dup2($from to $fd) - $!\n"; + + close $fh; + }; + } + elsif( $key eq "env" ) { + %ENV = %$value; + } + elsif( $key eq "nice" ) { + nice( $value ) or die "Cannot nice($value) - $!"; + } + elsif( $key eq "chdir" ) { + chdir( $value ) or die "Cannot chdir('$value') - $!"; + } + elsif( $key eq "setuid" ) { + setuid( $value ) or die "Cannot setuid('$value') - $!"; + } + elsif( $key eq "setgid" ) { + setgid( $value ) or die "Cannot setgid('$value') - $!"; + } + elsif( $key eq "setgroups" ) { + setgroups( @$value ) or die "Cannot setgroups() - $!"; + } + } + } + + $code->(); + }; + + my $writebuffer = ""; + $writebuffer .= pack( "I", $!+0 ); + $writebuffer .= pack( "I", length( $@ ) ) . $@; + + syswrite( $writepipe, $writebuffer ); + + return $exitvalue; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Debug.pm b/lib/IO/Async/Debug.pm new file mode 100644 index 0000000..b23db0e --- /dev/null +++ b/lib/IO/Async/Debug.pm @@ -0,0 +1,98 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2015 -- leonerd@leonerd.org.uk + +package IO::Async::Debug; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +our $DEBUG = $ENV{IO_ASYNC_DEBUG} || 0; +our $DEBUG_FD = $ENV{IO_ASYNC_DEBUG_FD}; +our $DEBUG_FILE = $ENV{IO_ASYNC_DEBUG_FILE}; +our $DEBUG_FH; +our %DEBUG_FLAGS = map { $_ => 1 } split m/,/, $ENV{IO_ASYNC_DEBUG_FLAGS} // ""; + +=head1 NAME + +C<IO::Async::Debug> - debugging control and support for L<IO::Async> + +=head1 DESCRIPTION + +The following methods and behaviours are still experimental and may change or +even be removed in future. + +Debugging support is enabled by an environment variable called +C<IO_ASYNC_DEBUG> having a true value. + +When debugging is enabled, the C<make_event_cb> and C<invoke_event> methods +on L<IO::Async::Notifier> (and their C<maybe_> variants) are altered such that +when the event is fired, a debugging line is printed, using the C<debug_printf> +method. This identifes the name of the event. + +By default, the line is only printed if the caller of one of these methods is +the same package as the object is blessed into, allowing it to print the +events of the most-derived class, without the extra verbosity of the +lower-level events of its parent class used to create it. All calls regardless +of caller can be printed by setting a number greater than 1 as the value of +C<IO_ASYNC_DEBUG>. + +By default the debugging log goes to C<STDERR>, but two other environment +variables can redirect it. If C<IO_ASYNC_DEBUG_FILE> is set, it names a file +which will be opened for writing, and logging written into it. Otherwise, if +C<IO_ASYNC_DEBUG_FD> is set, it gives a file descriptor number that logging +should be written to. If opening the named file or file descriptor fails then +the log will be written to C<STDERR> as normal. + +Extra debugging flags can be set in a comma-separated list in an environment +variable called C<IO_ASYNC_DEBUG_FLAGS>. The presence of these flags can cause +extra information to be written to the log. Full details on these flags will +be documented by the implementing classes. Typically these flags take the form +of one or more capital letters indicating the class, followed by one or more +lowercase letters enabling some particular feature within that class. + +=cut + +sub logf +{ + my ( $fmt, @args ) = @_; + + $DEBUG_FH ||= do { + my $fh; + if( $DEBUG_FILE ) { + open $fh, ">", $DEBUG_FILE or undef $fh; + } + elsif( $DEBUG_FD ) { + $fh = IO::Handle->new; + $fh->fdopen( $DEBUG_FD, "w" ) or undef $fh; + } + $fh ||= \*STDERR; + $fh->autoflush; + $fh; + }; + + printf $DEBUG_FH $fmt, @args; +} + +sub log_hexdump +{ + my ( $bytes ) = @_; + + foreach my $chunk ( $bytes =~ m/(.{1,16})/sg ) { + my $chunk_hex = join " ", map { sprintf "%02X", ord $_ } split //, $chunk; + ( my $chunk_safe = $chunk ) =~ s/[^\x20-\x7e]/./g; + + logf " | %-48s | %-16s |\n", $chunk_hex, $chunk_safe; + } +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/File.pm b/lib/IO/Async/File.pm new file mode 100644 index 0000000..cbb3604 --- /dev/null +++ b/lib/IO/Async/File.pm @@ -0,0 +1,219 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2012 -- leonerd@leonerd.org.uk + +package IO::Async::File; + +use 5.010; # // +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Timer::Periodic ); + +use Carp; +use File::stat; + +# No point watching blksize or blocks +my @STATS = qw( dev ino mode nlink uid gid rdev size atime mtime ctime ); + +=head1 NAME + +C<IO::Async::File> - watch a file for changes + +=head1 SYNOPSIS + + use IO::Async::File; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my $file = IO::Async::File->new( + filename => "config.ini", + on_mtime_changed => sub { + my ( $self ) = @_; + print STDERR "Config file has changed\n"; + reload_config( $self->handle ); + } + ); + + $loop->add( $file ); + + $loop->run; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Notifier> watches an open filehandle or named +filesystem entity for changes in its C<stat()> fields. It invokes various +events when the values of these fields change. It is most often used to watch +a file for size changes; for this task see also L<IO::Async::FileStream>. + +While called "File", it is not required that the watched filehandle be a +regular file. It is possible to watch anything that C<stat(2)> may be called +on, such as directories or other filesystem entities. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters. + +=head2 on_dev_changed $new_dev, $old_dev + +=head2 on_ino_changed $new_ino, $old_ino + +=head2 ... + +=head2 on_ctime_changed $new_ctime, $old_ctime + +Invoked when each of the individual C<stat()> fields have changed. All the +C<stat()> fields are supported apart from C<blocks> and C<blksize>. Each is +passed the new and old values of the field. + +=head2 on_devino_changed $new_stat, $old_stat + +Invoked when either of the C<dev> or C<ino> fields have changed. It is passed +two L<File::stat> instances containing the complete old and new C<stat()> +fields. This can be used to observe when a named file is renamed; it will not +be observed to happen on opened filehandles. + +=head2 on_stat_changed $new_stat, $old_stat + +Invoked when any of the C<stat()> fields have changed. It is passed two +L<File::stat> instances containing the old and new C<stat()> fields. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>. + +=head2 handle => IO + +The opened filehandle to watch for C<stat()> changes if C<filename> is not +supplied. + +=head2 filename => STRING + +Optional. If supplied, watches the named file rather than the filehandle given +in C<handle>. The file will be opened for reading and then watched for +renames. If the file is renamed, the new filename is opened and tracked +similarly after closing the previous file. + +=head2 interval => NUM + +Optional. The interval in seconds to poll the filehandle using C<stat(2)> +looking for size changes. A default of 2 seconds will be applied if not +defined. + +=cut + +sub _init +{ + my $self = shift; + my ( $params ) = @_; + + $params->{interval} ||= 2; + + $self->SUPER::_init( $params ); + + $self->start; +} + +sub configure +{ + my $self = shift; + my %params = @_; + + if( exists $params{filename} ) { + my $filename = delete $params{filename}; + $self->{filename} = $filename; + $self->_reopen_file; + } + elsif( exists $params{handle} ) { + $self->{handle} = delete $params{handle}; + $self->{last_stat} = stat $self->{handle}; + } + + foreach ( @STATS, "devino", "stat" ) { + $self->{"on_${_}_changed"} = delete $params{"on_${_}_changed"} if exists $params{"on_${_}_changed"}; + } + + $self->SUPER::configure( %params ); +} + +sub _add_to_loop +{ + my $self = shift; + + if( !defined $self->{filename} and !defined $self->{handle} ) { + croak "IO::Async::File needs either a filename or a handle"; + } + + return $self->SUPER::_add_to_loop( @_ ); +} + +sub _reopen_file +{ + my $self = shift; + + my $path = $self->{filename}; + + open $self->{handle}, "<", $path or croak "Cannot open $path for reading - $!"; + + $self->{last_stat} = stat $self->{handle}; +} + +sub on_tick +{ + my $self = shift; + + my $old = $self->{last_stat}; + my $new = stat( $self->{filename} // $self->{handle} ); + + my $any_changed; + foreach my $stat ( @STATS ) { + next if $old->$stat == $new->$stat; + + $any_changed++; + $self->maybe_invoke_event( "on_${stat}_changed", $new->$stat, $old->$stat ); + } + + if( $old->dev != $new->dev or $old->ino != $new->ino ) { + $self->maybe_invoke_event( on_devino_changed => $new, $old ); + $self->_reopen_file; + } + + if( $any_changed ) { + $self->maybe_invoke_event( on_stat_changed => $new, $old ); + $self->{last_stat} = $new; + } +} + +=head1 METHODS + +=cut + +=head2 $handle = $file->handle + +Returns the filehandle currently associated with the instance; either the one +passed to the C<handle> parameter, or opened from the C<filename> parameter. + +=cut + +sub handle +{ + my $self = shift; + return $self->{handle}; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/FileStream.pm b/lib/IO/Async/FileStream.pm new file mode 100644 index 0000000..96778c9 --- /dev/null +++ b/lib/IO/Async/FileStream.pm @@ -0,0 +1,413 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2011-2012 -- leonerd@leonerd.org.uk + +package IO::Async::FileStream; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Stream ); + +use IO::Async::File; + +use Carp; +use Fcntl qw( SEEK_SET SEEK_CUR ); + +=head1 NAME + +C<IO::Async::FileStream> - read the tail of a file + +=head1 SYNOPSIS + + use IO::Async::FileStream; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + open my $logh, "<", "var/logs/daemon.log" or + die "Cannot open logfile - $!"; + + my $filestream = IO::Async::FileStream->new( + read_handle => $logh, + + on_initial => sub { + my ( $self ) = @_; + $self->seek_to_last( "\n" ); + }, + + on_read => sub { + my ( $self, $buffref ) = @_; + + while( $$buffref =~ s/^(.*\n)// ) { + print "Received a line $1"; + } + + return 0; + }, + ); + + $loop->add( $filestream ); + + $loop->run; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Stream> allows reading the end of a regular file +which is being appended to by some other process. It invokes the C<on_read> +event when more data has been added to the file. + +This class provides an API identical to C<IO::Async::Stream> when given a +C<read_handle>; it should be treated similarly. In particular, it can be given +an C<on_read> handler, or subclassed to provide an C<on_read> method, or even +used as the C<transport> for an C<IO::Async::Protocol::Stream> object. + +It will not support writing. + +To watch a file, directory, or other filesystem entity for updates of other +properties, such as C<mtime>, see also L<IO::Async::File>. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters. + +Because this is a subclass of L<IO::Async::Stream> in read-only mode, all the +events supported by C<Stream> relating to the read handle are supported here. +This is not a full list; see also the documentation relating to +C<IO::Async::Stream>. + +=head2 $ret = on_read \$buffer, $eof + +Invoked when more data is available in the internal receiving buffer. + +Note that C<$eof> only indicates that all the data currently available in the +file has now been read; in contrast to a regular C<IO::Async::Stream>, this +object will not stop watching after this condition. Instead, it will continue +watching the file for updates. + +=head2 on_truncated + +Invoked when the file size shrinks. If this happens, it is presumed that the +file content has been replaced. Reading will then commence from the start of +the file. + +=head2 on_initial $size + +Invoked the first time the file is looked at. It is passed the initial size of +the file. The code implementing this method can use the C<seek> or +C<seek_to_last> methods to set the initial read position in the file to skip +over some initial content. + +This method may be useful to skip initial content in the file, if the object +should only respond to new content added after it was created. + +=cut + +sub _init +{ + my $self = shift; + my ( $params ) = @_; + + $self->SUPER::_init( $params ); + + $params->{close_on_read_eof} = 0; + + $self->{last_size} = undef; + + $self->add_child( $self->{file} = IO::Async::File->new( + on_devino_changed => $self->_replace_weakself( 'on_devino_changed' ), + on_size_changed => $self->_replace_weakself( 'on_size_changed' ), + ) ); +} + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>, in +addition to the parameters relating to reading supported by +C<IO::Async::Stream>. + +=head2 filename => STRING + +Optional. If supplied, watches the named file rather than the filehandle given +in C<read_handle>. The file will be opened by the constructor, and then +watched for renames. If the file is renamed, the new filename is opened and +tracked similarly after closing the previous file. + +=head2 interval => NUM + +Optional. The interval in seconds to poll the filehandle using C<stat(2)> +looking for size changes. A default of 2 seconds will be applied if not +defined. + +=cut + +sub configure +{ + my $self = shift; + my %params = @_; + + foreach (qw( on_truncated on_initial )) { + $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + foreach (qw( interval )) { + $self->{file}->configure( $_ => delete $params{$_} ) if exists $params{$_}; + } + if( exists $params{filename} ) { + $self->{file}->configure( filename => delete $params{filename} ); + $params{read_handle} = $self->{file}->handle; + } + elsif( exists $params{handle} or exists $params{read_handle} ) { + my $handle = delete $params{handle} // delete $params{read_handle}; + $self->{file}->configure( handle => $handle ); + $params{read_handle} = $self->{file}->handle; + } + + croak "Cannot have a write_handle in a ".ref($self) if defined $params{write_handle}; + + $self->SUPER::configure( %params ); + + if( $self->read_handle and !defined $self->{last_size} ) { + my $size = (stat $self->read_handle)[7]; + + $self->{last_size} = $size; + + local $self->{running_initial} = 1; + $self->maybe_invoke_event( on_initial => $size ); + } +} + +=head1 METHODS + +=cut + +# Replace IO::Async::Handle's implementation +sub _watch_read +{ + my $self = shift; + my ( $want ) = @_; + + if( $want ) { + $self->{file}->start if !$self->{file}->is_running; + } + else { + $self->{file}->stop; + } +} + +sub _watch_write +{ + my $self = shift; + my ( $want ) = @_; + + croak "Cannot _watch_write in " . ref($self) if $want; +} + +sub on_devino_changed +{ + my $self = shift or return; + + $self->{renamed} = 1; + $self->debug_printf( "read tail of old file" ); + $self->read_more; +} + +sub on_size_changed +{ + my $self = shift or return; + my ( $size ) = @_; + + if( $size < $self->{last_size} ) { + $self->maybe_invoke_event( on_truncated => ); + $self->{last_pos} = 0; + } + + $self->{last_size} = $size; + + $self->debug_printf( "read_more" ); + $self->read_more; +} + +sub read_more +{ + my $self = shift; + + sysseek( $self->read_handle, $self->{last_pos}, SEEK_SET ) if defined $self->{last_pos}; + + $self->on_read_ready; + + $self->{last_pos} = sysseek( $self->read_handle, 0, SEEK_CUR ); # == systell + + if( $self->{last_pos} < $self->{last_size} ) { + $self->loop->later( sub { $self->read_more } ); + } + elsif( $self->{renamed} ) { + $self->debug_printf( "reopening for rename" ); + + $self->{last_size} = 0; + + if( $self->{last_pos} ) { + $self->maybe_invoke_event( on_truncated => ); + $self->{last_pos} = 0; + $self->loop->later( sub { $self->read_more } ); + } + + $self->configure( read_handle => $self->{file}->handle ); + undef $self->{renamed}; + } +} + +sub write +{ + carp "Cannot ->write from a ".ref($_[0]); +} + +=head2 $filestream->seek( $offset, $whence ) + +Callable only during the C<on_initial> event. Moves the read position in the +filehandle to the given offset. C<$whence> is interpreted as for C<sysseek>, +should be either C<SEEK_SET>, C<SEEK_CUR> or C<SEEK_END>. Will be set to +C<SEEK_SET> if not provided. + +Normally this would be used to seek to the end of the file, for example + + on_initial => sub { + my ( $self, $filesize ) = @_; + $self->seek( $filesize ); + } + +=cut + +sub seek +{ + my $self = shift; + my ( $offset, $whence ) = @_; + + $self->{running_initial} or croak "Cannot ->seek except during on_initial"; + + defined $whence or $whence = SEEK_SET; + + sysseek( $self->read_handle, $offset, $whence ); +} + +=head2 $success = $filestream->seek_to_last( $str_pattern, %opts ) + +Callable only during the C<on_initial> event. Attempts to move the read +position in the filehandle to just after the last occurance of a given match. +C<$str_pattern> may be a literal string or regexp pattern. + +Returns a true value if the seek was successful, or false if not. Takes the +following named arguments: + +=over 8 + +=item blocksize => INT + +Optional. Read the file in blocks of this size. Will take a default of 8KiB if +not defined. + +=item horizon => INT + +Optional. Give up looking for a match after this number of bytes. Will take a +default value of 4 times the blocksize if not defined. + +To force it to always search through the entire file contents, set this +explicitly to C<0>. + +=back + +Because regular file reading happens synchronously, this entire method +operates entirely synchronously. If the file is very large, it may take a +while to read back through the entire contents. While this is happening no +other events can be invoked in the process. + +When looking for a string or regexp match, this method appends the +previously-read buffer to each block read from the file, in case a match +becomes split across two reads. If C<blocksize> is reduced to a very small +value, take care to ensure it isn't so small that a match may not be noticed. + +This is most likely useful for seeking after the last complete line in a +line-based log file, to commence reading from the end, while still managing to +capture any partial content that isn't yet a complete line. + + on_initial => sub { + my $self = shift; + $self->seek_to_last( "\n" ); + } + +=cut + +sub seek_to_last +{ + my $self = shift; + my ( $str_pattern, %opts ) = @_; + + $self->{running_initial} or croak "Cannot ->seek_to_last except during on_initial"; + + my $offset = $self->{last_size}; + + my $blocksize = $opts{blocksize} || 8192; + + defined $opts{horizon} or $opts{horizon} = $blocksize * 4; + my $horizon = $opts{horizon} ? $offset - $opts{horizon} : 0; + $horizon = 0 if $horizon < 0; + + my $re = ref $str_pattern ? $str_pattern : qr/\Q$str_pattern\E/; + + my $prev = ""; + while( $offset > $horizon ) { + my $len = $blocksize; + $len = $offset if $len > $offset; + $offset -= $len; + + sysseek( $self->read_handle, $offset, SEEK_SET ); + sysread( $self->read_handle, my $buffer, $blocksize ); + + # TODO: If $str_pattern is a plain string this could be more efficient + # using rindex + if( () = ( $buffer . $prev ) =~ m/$re/sg ) { + # $+[0] will be end of last match + my $pos = $offset + $+[0]; + $self->seek( $pos ); + return 1; + } + + $prev = $buffer; + } + + $self->seek( $horizon ); + return 0; +} + +=head1 TODO + +=over 4 + +=item * + +Move the actual file update watching code into C<IO::Async::Loop>, possibly as +a new watch/unwatch method pair C<watch_file>. + +=item * + +Consider if a construction-time parameter of C<seek_to_end> or C<seek_to_last> +might be neater than a small code block in C<on_initial>, if that turns out to +be the only or most common form of use. + +=back + +=cut + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Function.pm b/lib/IO/Async/Function.pm new file mode 100644 index 0000000..adaf396 --- /dev/null +++ b/lib/IO/Async/Function.pm @@ -0,0 +1,667 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2011-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Function; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Notifier ); +use IO::Async::Timer::Countdown; + +use Carp; + +use Storable qw( freeze ); + +=head1 NAME + +C<IO::Async::Function> - call a function asynchronously + +=head1 SYNOPSIS + + use IO::Async::Function; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my $function = IO::Async::Function->new( + code => sub { + my ( $number ) = @_; + return is_prime( $number ); + }, + ); + + $loop->add( $function ); + + $function->call( + args => [ 123454321 ], + )->on_done( sub { + my $isprime = shift; + print "123454321 " . ( $isprime ? "is" : "is not" ) . " a prime number\n"; + })->on_fail( sub { + print STDERR "Cannot determine if it's prime - $_[0]\n"; + })->get; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Notifier> wraps a function body in a collection +of worker processes, to allow it to execute independently of the main process. +The object acts as a proxy to the function, allowing invocations to be made by +passing in arguments, and invoking a continuation in the main process when the +function returns. + +The object represents the function code itself, rather than one specific +invocation of it. It can be called multiple times, by the C<call> method. +Multiple outstanding invocations can be called; they will be dispatched in +the order they were queued. If only one worker process is used then results +will be returned in the order they were called. If multiple are used, then +each request will be sent in the order called, but timing differences between +each worker may mean results are returned in a different order. + +Since the code block will be called multiple times within the same child +process, it must take care not to modify any of its state that might affect +subsequent calls. Since it executes in a child process, it cannot make any +modifications to the state of the parent program. Therefore, all the data +required to perform its task must be represented in the call arguments, and +all of the result must be represented in the return values. + +The Function object is implemented using an L<IO::Async::Routine> with two +L<IO::Async::Channel> objects to pass calls into and results out from it. + +The C<IO::Async> framework generally provides mechanisms for multiplexing IO +tasks between different handles, so there aren't many occasions when such an +asynchronous function is necessary. Two cases where this does become useful +are: + +=over 4 + +=item 1. + +When a large amount of computationally-intensive work needs to be performed +(for example, the C<is_prime> test in the example in the C<SYNOPSIS>). + +=item 2. + +When a blocking OS syscall or library-level function needs to be called, and +no nonblocking or asynchronous version is supplied. This is used by +C<IO::Async::Resolver>. + +=back + +This object is ideal for representing "pure" functions; that is, blocks of +code which have no stateful effect on the process, and whose result depends +only on the arguments passed in. For a more general co-routine ability, see +also L<IO::Async::Routine>. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 code => CODE + +The body of the function to execute. + +=head2 model => "fork" | "thread" + +Optional. Requests a specific C<IO::Async::Routine> model. If not supplied, +leaves the default choice up to Routine. + +=head2 min_workers => INT + +=head2 max_workers => INT + +The lower and upper bounds of worker processes to try to keep running. The +actual number running at any time will be kept somewhere between these bounds +according to load. + +=head2 max_worker_calls => INT + +Optional. If provided, stop a worker process after it has processed this +number of calls. (New workers may be started to replace stopped ones, within +the bounds given above). + +=head2 idle_timeout => NUM + +Optional. If provided, idle worker processes will be shut down after this +amount of time, if there are more than C<min_workers> of them. + +=head2 exit_on_die => BOOL + +Optional boolean, controls what happens after the C<code> throws an +exception. If missing or false, the worker will continue running to process +more requests. If true, the worker will be shut down. A new worker might be +constructed by the C<call> method to replace it, if necessary. + +=head2 setup => ARRAY + +Optional array reference. Specifies the C<setup> key to pass to the underlying +L<IO::Async::Process> when setting up new worker processes. + +=cut + +sub _init +{ + my $self = shift; + $self->SUPER::_init( @_ ); + + $self->{min_workers} = 1; + $self->{max_workers} = 8; + + $self->{workers} = {}; # {$id} => IaFunction:Worker + + $self->{pending_queue} = []; +} + +sub configure +{ + my $self = shift; + my %params = @_; + + my %worker_params; + foreach (qw( model exit_on_die max_worker_calls )) { + $self->{$_} = $worker_params{$_} = delete $params{$_} if exists $params{$_}; + } + + if( keys %worker_params ) { + foreach my $worker ( $self->_worker_objects ) { + $worker->configure( %worker_params ); + } + } + + if( exists $params{idle_timeout} ) { + my $timeout = delete $params{idle_timeout}; + if( !$timeout ) { + $self->remove_child( delete $self->{idle_timer} ) if $self->{idle_timer}; + } + elsif( my $idle_timer = $self->{idle_timer} ) { + $idle_timer->configure( delay => $timeout ); + } + else { + $self->{idle_timer} = IO::Async::Timer::Countdown->new( + delay => $timeout, + on_expire => $self->_capture_weakself( sub { + my $self = shift or return; + my $workers = $self->{workers}; + + # Shut down atmost one idle worker, starting from the highest + # ID. Since we search from lowest to assign work, this tries + # to ensure we'll shut down the least useful ones first, + # keeping more useful ones in memory (page/cache warmth, etc..) + foreach my $id ( reverse sort keys %$workers ) { + next if $workers->{$id}{busy}; + + $workers->{$id}->stop; + last; + } + + # Still more? + $self->{idle_timer}->start if $self->workers_idle > $self->{min_workers}; + } ), + ); + $self->add_child( $self->{idle_timer} ); + } + } + + foreach (qw( min_workers max_workers )) { + $self->{$_} = delete $params{$_} if exists $params{$_}; + # TODO: something about retuning + } + + my $need_restart; + + foreach (qw( code setup )) { + $need_restart++, $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + $self->SUPER::configure( %params ); + + if( $need_restart and $self->loop ) { + $self->stop; + $self->start; + } +} + +sub _add_to_loop +{ + my $self = shift; + $self->SUPER::_add_to_loop( @_ ); + + $self->start; +} + +sub _remove_from_loop +{ + my $self = shift; + + $self->stop; + + $self->SUPER::_remove_from_loop( @_ ); +} + +=head1 METHODS + +The following methods documented with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +=head2 $function->start + +Start the worker processes + +=cut + +sub start +{ + my $self = shift; + + $self->_new_worker for 1 .. $self->{min_workers}; +} + +=head2 $function->stop + +Stop the worker processes + +=cut + +sub stop +{ + my $self = shift; + + $self->{stopping} = 1; + foreach my $worker ( $self->_worker_objects ) { + $worker->stop; + } +} + +=head2 $function->restart + +Gracefully stop and restart all the worker processes. + +=cut + +sub restart +{ + my $self = shift; + + $self->stop; + $self->start; +} + +=head2 @result = $function->call( %params )->get + +Schedules an invocation of the contained function to be executed on one of the +worker processes. If a non-busy worker is available now, it will be called +immediately. If not, it will be queued and sent to the next free worker that +becomes available. + +The request will already have been serialised by the marshaller, so it will be +safe to modify any referenced data structures in the arguments after this call +returns. + +The C<%params> hash takes the following keys: + +=over 8 + +=item args => ARRAY + +A reference to the array of arguments to pass to the code. + +=back + +=head2 $function->call( %params ) + +When not returning a future, the C<on_result>, C<on_return> and C<on_error> +arguments give continuations to handle successful results or failure. + +=over 8 + +=item on_result => CODE + +A continuation that is invoked when the code has been executed. If the code +returned normally, it is called as: + + $on_result->( 'return', @values ) + +If the code threw an exception, or some other error occured such as a closed +connection or the process died, it is called as: + + $on_result->( 'error', $exception_name ) + +=item on_return => CODE and on_error => CODE + +An alternative to C<on_result>. Two continuations to use in either of the +circumstances given above. They will be called directly, without the leading +'return' or 'error' value. + +=back + +=cut + +sub call +{ + my $self = shift; + my %params = @_; + + # TODO: possibly just queue this? + $self->loop or croak "Cannot ->call on a Function not yet in a Loop"; + + my $args = delete $params{args}; + ref $args eq "ARRAY" or croak "Expected 'args' to be an array"; + + my ( $on_done, $on_fail ); + if( defined $params{on_result} ) { + my $on_result = delete $params{on_result}; + ref $on_result or croak "Expected 'on_result' to be a reference"; + + $on_done = $self->_capture_weakself( sub { + my $self = shift or return; + $self->debug_printf( "CONT on_result return" ); + $on_result->( return => @_ ); + } ); + $on_fail = $self->_capture_weakself( sub { + my $self = shift or return; + my ( $err, @values ) = @_; + $self->debug_printf( "CONT on_result error" ); + $on_result->( error => @values ); + } ); + } + elsif( defined $params{on_return} and defined $params{on_error} ) { + my $on_return = delete $params{on_return}; + ref $on_return or croak "Expected 'on_return' to be a reference"; + my $on_error = delete $params{on_error}; + ref $on_error or croak "Expected 'on_error' to be a reference"; + + $on_done = $self->_capture_weakself( sub { + my $self = shift or return; + $self->debug_printf( "CONT on_return" ); + $on_return->( @_ ); + } ); + $on_fail = $self->_capture_weakself( sub { + my $self = shift or return; + $self->debug_printf( "CONT on_error" ); + $on_error->( @_ ); + } ); + } + elsif( !defined wantarray ) { + croak "Expected either 'on_result' or 'on_return' and 'on_error' keys, or to return a Future"; + } + + my $request = freeze( $args ); + + my $future; + if( my $worker = $self->_get_worker ) { + $self->debug_printf( "CALL" ); + $future = $self->_call_worker( $worker, $request ); + } + else { + $self->debug_printf( "QUEUE" ); + push @{ $self->{pending_queue} }, my $wait_f = $self->loop->new_future; + + $future = $wait_f->then( sub { + my ( $self, $worker ) = @_; + $self->_call_worker( $worker, $request ); + }); + } + + $future->on_done( $on_done ) if $on_done; + $future->on_fail( $on_fail ) if $on_fail; + + return $future if defined wantarray; + + # Caller is not going to keep hold of the Future, so we have to ensure it + # stays alive somehow + $self->adopt_future( $future->else( sub { Future->done } ) ); +} + +sub _worker_objects +{ + my $self = shift; + return values %{ $self->{workers} }; +} + +=head2 $count = $function->workers + +Returns the total number of worker processes available + +=cut + +sub workers +{ + my $self = shift; + return scalar keys %{ $self->{workers} }; +} + +=head2 $count = $function->workers_busy + +Returns the number of worker processes that are currently busy + +=cut + +sub workers_busy +{ + my $self = shift; + return scalar grep { $_->{busy} } $self->_worker_objects; +} + +=head2 $count = $function->workers_idle + +Returns the number of worker processes that are currently idle + +=cut + +sub workers_idle +{ + my $self = shift; + return scalar grep { !$_->{busy} } $self->_worker_objects; +} + +sub _new_worker +{ + my $self = shift; + + my $worker = IO::Async::Function::Worker->new( + ( map { $_ => $self->{$_} } qw( model code setup exit_on_die ) ), + max_calls => $self->{max_worker_calls}, + + on_finish => $self->_capture_weakself( sub { + my $self = shift or return; + my ( $worker ) = @_; + + return if $self->{stopping}; + + $self->_new_worker if $self->workers < $self->{min_workers}; + + $self->_dispatch_pending; + } ), + ); + + $self->add_child( $worker ); + + return $self->{workers}{$worker->id} = $worker; +} + +sub _get_worker +{ + my $self = shift; + + foreach ( sort keys %{ $self->{workers} } ) { + return $self->{workers}{$_} if !$self->{workers}{$_}{busy}; + } + + if( $self->workers < $self->{max_workers} ) { + return $self->_new_worker; + } + + return undef; +} + +sub _call_worker +{ + my $self = shift; + my ( $worker, $type, $args ) = @_; + + my $future = $worker->call( $type, $args ); + + if( $self->workers_idle == 0 ) { + $self->{idle_timer}->stop if $self->{idle_timer}; + } + + return $future; +} + +sub _dispatch_pending +{ + my $self = shift; + + while( my $next = shift @{ $self->{pending_queue} } ) { + my $worker = $self->_get_worker or return; + + next if $next->is_cancelled; + + $self->debug_printf( "UNQUEUE" ); + $next->done( $self, $worker ); + return; + } + + if( $self->workers_idle > $self->{min_workers} ) { + $self->{idle_timer}->start if $self->{idle_timer} and !$self->{idle_timer}->is_running; + } +} + +package # hide from indexer + IO::Async::Function::Worker; + +use base qw( IO::Async::Routine ); + +use IO::Async::Channel; + +sub new +{ + my $class = shift; + my %params = @_; + + my $arg_channel = IO::Async::Channel->new; + my $ret_channel = IO::Async::Channel->new; + + my $code = delete $params{code}; + $params{code} = sub { + while( my $args = $arg_channel->recv ) { + my @ret; + my $ok = eval { @ret = $code->( @$args ); 1 }; + + if( $ok ) { + $ret_channel->send( [ r => @ret ] ); + } + else { + chomp( my $e = "$@" ); + $ret_channel->send( [ e => $e, error => ] ); + } + } + }; + + my $worker = $class->SUPER::new( + %params, + channels_in => [ $arg_channel ], + channels_out => [ $ret_channel ], + ); + + $worker->{arg_channel} = $arg_channel; + $worker->{ret_channel} = $ret_channel; + + return $worker; +} + +sub configure +{ + my $self = shift; + my %params = @_; + + exists $params{$_} and $self->{$_} = delete $params{$_} for qw( exit_on_die max_calls ); + + $self->SUPER::configure( %params ); +} + +sub stop +{ + my $worker = shift; + $worker->{arg_channel}->close; + + if( my $function = $worker->parent ) { + delete $function->{workers}{$worker->id}; + + if( $worker->{busy} ) { + $worker->{remove_on_idle}++; + } + else { + $function->remove_child( $worker ); + } + } +} + +sub call +{ + my $worker = shift; + my ( $args ) = @_; + + $worker->{arg_channel}->send_frozen( $args ); + + $worker->{busy} = 1; + $worker->{max_calls}--; + + return $worker->{ret_channel}->recv->then( + # on recv + $worker->_capture_weakself( sub { + my ( $worker, $result ) = @_; + my ( $type, @values ) = @$result; + + $worker->stop if !$worker->{max_calls} or + $worker->{exit_on_die} && $type eq "e"; + + if( $type eq "r" ) { + return Future->done( @values ); + } + elsif( $type eq "e" ) { + return Future->fail( @values ); + } + else { + die "Unrecognised type from worker - $type\n"; + } + } ), + # on EOF + $worker->_capture_weakself( sub { + my ( $worker ) = @_; + + $worker->stop; + + return Future->fail( "closed", "closed" ); + } ) + )->on_ready( $worker->_capture_weakself( sub { + my ( $worker, $f ) = @_; + $worker->{busy} = 0; + + my $function = $worker->parent; + $function->_dispatch_pending if $function; + + $function->remove_child( $worker ) if $function and $worker->{remove_on_idle}; + })); +} + +=head1 NOTES + +For the record, 123454321 is 11111 * 11111, a square number, and therefore not +prime. + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Future.pm b/lib/IO/Async/Future.pm new file mode 100644 index 0000000..5bf8395 --- /dev/null +++ b/lib/IO/Async/Future.pm @@ -0,0 +1,150 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2013 -- leonerd@leonerd.org.uk + +package IO::Async::Future; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( Future ); +Future->VERSION( '0.05' ); # to respect subclassing + +use Carp; + +=head1 NAME + +C<IO::Async::Future> - use L<Future> with L<IO::Async> + +=head1 SYNOPSIS + + use IO::Async::Loop; + + my $loop = IO::Async::Loop->new; + + my $future = $loop->new_future; + + $loop->watch_time( after => 3, code => sub { $future->done( "Done" ) } ); + + print $future->get, "\n"; + +=head1 DESCRIPTION + +This subclass of L<Future> stores a reference to the L<IO::Async::Loop> +instance that created it, allowing the C<await> method to block until the +Future is ready. These objects should not be constructed directly; instead +the C<new_future> method on the containing Loop should be used. + +For a full description on how to use Futures, see the L<Future> documentation. + +=cut + +=head1 CONSTRUCTORS + +New C<IO::Async::Future> objects should be constructed by using the following +methods on the C<Loop>. For more detail see the L<IO::Async::Loop> +documentation. + +=head2 $future = $loop->new_future + +Returns a new pending Future. + +=head2 $future = $loop->delay_future( %args ) + +Returns a new Future that will become done at a given time. + +=head2 $future = $loop->timeout_future( %args ) + +Returns a new Future that will become failed at a given time. + +=cut + +sub new +{ + my $proto = shift; + my $self = $proto->SUPER::new; + + if( ref $proto ) { + $self->{loop} = $proto->{loop}; + } + else { + $self->{loop} = shift; + } + + return $self; +} + +=head1 METHODS + +=cut + +=head2 $loop = $future->loop + +Returns the underlying C<IO::Async::Loop> object. + +=cut + +sub loop +{ + my $self = shift; + return $self->{loop}; +} + +sub await +{ + my $self = shift; + $self->{loop}->loop_once; +} + +=head2 $future->done_later( @result ) + +A shortcut to calling the C<done> method in a C<later> idle watch on the +underlying Loop object. Ensures that a returned Future object is not ready +immediately, but will wait for the next IO round. + +Like C<done>, returns C<$future> itself to allow easy chaining. + +=cut + +sub done_later +{ + my $self = shift; + my @result = @_; + + $self->loop->later( sub { $self->done( @result ) } ); + + return $self; +} + +=head2 $future->fail_later( $exception, @details ) + +A shortcut to calling the C<fail> method in a C<later> idle watch on the +underlying Loop object. Ensures that a returned Future object is not ready +immediately, but will wait for the next IO round. + +Like C<fail>, returns C<$future> itself to allow easy chaining. + +=cut + +sub fail_later +{ + my $self = shift; + my ( $exception, @details ) = @_; + + $exception or croak "Expected a true exception"; + + $self->loop->later( sub { $self->fail( $exception, @details ) } ); + + return $self; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Handle.pm b/lib/IO/Async/Handle.pm new file mode 100644 index 0000000..201d900 --- /dev/null +++ b/lib/IO/Async/Handle.pm @@ -0,0 +1,687 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2006-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Handle; + +use strict; +use warnings; +use base qw( IO::Async::Notifier ); + +our $VERSION = '0.67'; + +use Carp; + +use IO::Handle; # give methods to bare IO handles + +use Future; +use Future::Utils qw( try_repeat ); + +use IO::Async::OS; + +=head1 NAME + +C<IO::Async::Handle> - event callbacks for a non-blocking file descriptor + +=head1 SYNOPSIS + +This class is likely not to be used directly, because subclasses of it exist +to handle more specific cases. Here is an example of how it would be used to +watch a listening socket for new connections. In real code, it is likely that +the C<< Loop->listen >> method would be used instead. + + use IO::Socket::INET; + use IO::Async::Handle; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my $socket = IO::Socket::INET->new( LocalPort => 1234, Listen => 1 ); + + my $handle = IO::Async::Handle->new( + handle => $socket, + + on_read_ready => sub { + my $new_client = $socket->accept; + ... + }, + ); + + $loop->add( $handle ); + +For most other uses with sockets, pipes or other filehandles that carry a byte +stream, the L<IO::Async::Stream> class is likely to be more suitable. For +non-stream sockets, see L<IO::Async::Socket>. + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Notifier> allows non-blocking IO on filehandles. +It provides event handlers for when the filehandle is read- or write-ready. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters: + +=head2 on_read_ready + +Invoked when the read handle becomes ready for reading. + +=head2 on_write_ready + +Invoked when the write handle becomes ready for writing. + +=head2 on_closed + +Optional. Invoked when the handle becomes closed. + +This handler is invoked before the filehandles are closed and the Handle +removed from its containing Loop. The C<loop> will still return the containing +Loop object. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 read_handle => IO + +=head2 write_handle => IO + +The reading and writing IO handles. Each must implement the C<fileno> method. +Primarily used for passing C<STDIN> / C<STDOUT>; see the SYNOPSIS section of +C<IO::Async::Stream> for an example. + +=head2 handle => IO + +The IO handle for both reading and writing; instead of passing each separately +as above. Must implement C<fileno> method in way that C<IO::Handle> does. + +=head2 read_fileno => INT + +=head2 write_fileno => INT + +File descriptor numbers for reading and writing. If these are given as an +alternative to C<read_handle> or C<write_handle> then a new C<IO::Handle> +instance will be constructed around each. + +=head2 on_read_ready => CODE + +=head2 on_write_ready => CODE + +=head2 on_closed => CODE + +CODE references for event handlers. + +=head2 want_readready => BOOL + +=head2 want_writeready => BOOL + +If present, enable or disable read- or write-ready notification as per the +C<want_readready> and C<want_writeready> methods. + +It is required that a matching C<on_read_ready> or C<on_write_ready> are +available for any handle that is provided; either passed as a callback CODE +reference or as an overridden the method. I.e. if only a C<read_handle> is +given, then C<on_write_ready> can be absent. If C<handle> is used as a +shortcut, then both read and write-ready callbacks or methods are required. + +If no IO handles are provided at construction time, the object is still +created but will not yet be fully-functional as a Handle. IO handles can be +assigned later using the C<set_handle> or C<set_handles> methods, or by +C<configure>. This may be useful when constructing an object to represent a +network connection, before the C<connect(2)> has actually been performed yet. + +=cut + +sub configure +{ + my $self = shift; + my %params = @_; + + if( exists $params{on_read_ready} ) { + $self->{on_read_ready} = delete $params{on_read_ready}; + undef $self->{cb_r}; + + $self->_watch_read(0), $self->_watch_read(1) if $self->want_readready; + } + + if( exists $params{on_write_ready} ) { + $self->{on_write_ready} = delete $params{on_write_ready}; + undef $self->{cb_w}; + + $self->_watch_write(0), $self->_watch_write(1) if $self->want_writeready; + } + + if( exists $params{on_closed} ) { + $self->{on_closed} = delete $params{on_closed}; + } + + if( defined $params{read_fileno} and defined $params{write_fileno} and + $params{read_fileno} == $params{write_fileno} ) { + $params{handle} = IO::Handle->new_from_fd( $params{read_fileno}, "r+" ); + + delete $params{read_fileno}; + delete $params{write_fileno}; + } + else { + $params{read_handle} = IO::Handle->new_from_fd( delete $params{read_fileno}, "r" ) + if defined $params{read_fileno}; + + $params{write_handle} = IO::Handle->new_from_fd( delete $params{write_fileno}, "w" ) + if defined $params{write_fileno}; + } + + # 'handle' is a shortcut for setting read_ and write_ + if( exists $params{handle} ) { + $params{read_handle} = $params{handle}; + $params{write_handle} = $params{handle}; + delete $params{handle}; + } + + if( exists $params{read_handle} ) { + my $read_handle = delete $params{read_handle}; + + if( defined $read_handle ) { + if( !defined eval { $read_handle->fileno } ) { + croak 'Expected that read_handle can ->fileno'; + } + + unless( $self->can_event( 'on_read_ready' ) ) { + croak 'Expected either a on_read_ready callback or an ->on_read_ready method'; + } + + my @layers = PerlIO::get_layers( $read_handle ); + if( grep m/^encoding\(/, @layers or grep m/^utf8$/, @layers ) { + # Only warn for now, because if it's UTF-8 by default but only + # passes ASCII then all will be well + carp "Constructing a ".ref($self)." with an encoding-enabled handle may not read correctly"; + } + } + + $self->{read_handle} = $read_handle; + + $self->want_readready( defined $read_handle ); + + # In case someone has reopened the filehandles during an on_closed handler + undef $self->{handle_closing}; + } + + if( exists $params{write_handle} ) { + my $write_handle = delete $params{write_handle}; + + if( defined $write_handle ) { + if( !defined eval { $write_handle->fileno } ) { + croak 'Expected that write_handle can ->fileno'; + } + + unless( $self->can_event( 'on_write_ready' ) ) { + # This used not to be fatal. Make it just a warning for now. + carp 'A write handle was provided but neither a on_write_ready callback nor an ->on_write_ready method were. Perhaps you mean \'read_handle\' instead?'; + } + } + + $self->{write_handle} = $write_handle; + + # In case someone has reopened the filehandles during an on_closed handler + undef $self->{handle_closing}; + } + + if( exists $params{want_readready} ) { + $self->want_readready( delete $params{want_readready} ); + } + + if( exists $params{want_writeready} ) { + $self->want_writeready( delete $params{want_writeready} ); + } + + $self->SUPER::configure( %params ); +} + +# We'll be calling these any of three times +# adding to/removing from loop +# caller en/disables readiness checking +# changing filehandle + +sub _watch_read +{ + my $self = shift; + my ( $want ) = @_; + + my $loop = $self->loop or return; + my $fh = $self->read_handle or return; + + if( $want ) { + $self->{cb_r} ||= $self->make_event_cb( 'on_read_ready' ); + + $loop->watch_io( + handle => $fh, + on_read_ready => $self->{cb_r}, + ); + } + else { + $loop->unwatch_io( + handle => $fh, + on_read_ready => 1, + ); + } +} + +sub _watch_write +{ + my $self = shift; + my ( $want ) = @_; + + my $loop = $self->loop or return; + my $fh = $self->write_handle or return; + + if( $want ) { + $self->{cb_w} ||= $self->make_event_cb( 'on_write_ready' ); + + $loop->watch_io( + handle => $fh, + on_write_ready => $self->{cb_w}, + ); + } + else { + $loop->unwatch_io( + handle => $fh, + on_write_ready => 1, + ); + } +} + +sub _add_to_loop +{ + my $self = shift; + my ( $loop ) = @_; + + $self->_watch_read(1) if $self->want_readready; + $self->_watch_write(1) if $self->want_writeready; +} + +sub _remove_from_loop +{ + my $self = shift; + my ( $loop ) = @_; + + $self->_watch_read(0); + $self->_watch_write(0); +} + +sub notifier_name +{ + my $self = shift; + if( length( my $name = $self->SUPER::notifier_name ) ) { + return $name; + } + + my $r = $self->read_fileno; + my $w = $self->write_fileno; + return "rw=$r" if defined $r and defined $w and $r == $w; + return "r=$r,w=$w" if defined $r and defined $w; + return "r=$r" if defined $r; + return "w=$w" if defined $w; + return "no"; +} + +=head1 METHODS + +The following methods documented with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +=head2 $handle->set_handles( %params ) + +Sets new reading or writing filehandles. Equivalent to calling the +C<configure> method with the same parameters. + +=cut + +sub set_handles +{ + my $self = shift; + my %params = @_; + + $self->configure( + exists $params{read_handle} ? ( read_handle => $params{read_handle} ) : (), + exists $params{write_handle} ? ( write_handle => $params{write_handle} ) : (), + ); +} + +=head2 $handle->set_handle( $fh ) + +Shortcut for + + $handle->configure( handle => $fh ) + +=cut + +sub set_handle +{ + my $self = shift; + my ( $fh ) = @_; + + $self->configure( handle => $fh ); +} + +=head2 $handle->close + +This method calls C<close> on the underlying IO handles. This method will then +remove the handle from its containing loop. + +=cut + +sub close +{ + my $self = shift; + + # Prevent infinite loops if there's two crosslinked handles + return if $self->{handle_closing}; + $self->{handle_closing} = 1; + + $self->want_readready( 0 ); + $self->want_writeready( 0 ); + + my $read_handle = delete $self->{read_handle}; + $read_handle->close if defined $read_handle; + + my $write_handle = delete $self->{write_handle}; + $write_handle->close if defined $write_handle; + + $self->_closed; +} + +sub _closed +{ + my $self = shift; + + $self->maybe_invoke_event( on_closed => ); + if( $self->{close_futures} ) { + $_->done for @{ $self->{close_futures} }; + } + $self->remove_from_parent; +} + +=head2 $handle->close_read + +=head2 $handle->close_write + +Closes the underlying read or write handle, and deconfigures it from the +object. Neither of these methods will invoke the C<on_closed> event, nor +remove the object from the Loop if there is still one open handle in the +object. Only when both handles are closed, will C<on_closed> be fired, and the +object removed. + +=cut + +sub close_read +{ + my $self = shift; + + $self->want_readready( 0 ); + + my $read_handle = delete $self->{read_handle}; + $read_handle->close if defined $read_handle; + + $self->_closed if !$self->{write_handle}; +} + +sub close_write +{ + my $self = shift; + + $self->want_writeready( 0 ); + + my $write_handle = delete $self->{write_handle}; + $write_handle->close if defined $write_handle; + + $self->_closed if !$self->{read_handle}; +} + +=head2 $handle->new_close_future->get + +Returns a new L<IO::Async::Future> object which will become done when the +handle is closed. Cancelling the C<$future> will remove this notification +ability but will not otherwise affect the C<$handle>. + +=cut + +sub new_close_future +{ + my $self = shift; + + push @{ $self->{close_futures} }, my $future = $self->loop->new_future; + $future->on_cancel( + $self->_capture_weakself( sub { + my $self = shift or return; + my $future = shift; + + @{ $self->{close_futures} } = grep { $_ != $future } @{ $self->{close_futures} }; + }) + ); + + return $future; +} + +=head2 $handle = $handle->read_handle + +=head2 $handle = $handle->write_handle + +These accessors return the underlying IO handles. + +=cut + +sub read_handle +{ + my $self = shift; + return $self->{read_handle}; +} + +sub write_handle +{ + my $self = shift; + return $self->{write_handle}; +} + +=head2 $fileno = $handle->read_fileno + +=head2 $fileno = $handle->write_fileno + +These accessors return the file descriptor numbers of the underlying IO +handles. + +=cut + +sub read_fileno +{ + my $self = shift; + my $handle = $self->read_handle or return undef; + return $handle->fileno; +} + +sub write_fileno +{ + my $self = shift; + my $handle = $self->write_handle or return undef; + return $handle->fileno; +} + +=head2 $value = $handle->want_readready + +=head2 $oldvalue = $handle->want_readready( $newvalue ) + +=head2 $value = $handle->want_writeready + +=head2 $oldvalue = $handle->want_writeready( $newvalue ) + +These are the accessor for the C<want_readready> and C<want_writeready> +properties, which define whether the object is interested in knowing about +read- or write-readiness on the underlying file handle. + +=cut + +sub want_readready +{ + my $self = shift; + if( @_ ) { + my ( $new ) = @_; + + $new = !!$new; + return $new if !$new == !$self->{want_readready}; # compare bools + + if( $new ) { + defined $self->read_handle or + croak 'Cannot want_readready in a Handle with no read_handle'; + } + + my $old = $self->{want_readready}; + $self->{want_readready} = $new; + + $self->_watch_read( $new ); + + return $old; + } + else { + return $self->{want_readready}; + } +} + +sub want_writeready +{ + my $self = shift; + if( @_ ) { + my ( $new ) = @_; + + $new = !!$new; + return $new if !$new == !$self->{want_writeready}; # compare bools + + if( $new ) { + defined $self->write_handle or + croak 'Cannot want_writeready in a Handle with no write_handle'; + } + + my $old = $self->{want_writeready}; + $self->{want_writeready} = $new; + + $self->_watch_write( $new ); + + return $old; + } + else { + return $self->{want_writeready}; + } +} + +=head2 $handle->socket( $ai ) + +Convenient shortcut to creating a socket handle, as given by an addrinfo +structure, and setting it as the read and write handle for the object. + +C<$ai> may be either a C<HASH> or C<ARRAY> reference of the same form as given +to L<IO::Async::OS>'s C<extract_addrinfo> method. + +This method returns nothing if it succeeds, or throws an exception if it +fails. + +=cut + +sub socket +{ + my $self = shift; + my ( $ai ) = @_; + + # TODO: Something about closing the old one? + + my ( $family, $socktype, $protocol ) = IO::Async::OS->extract_addrinfo( $ai ); + + my $sock = IO::Async::OS->socket( $family, $socktype, $protocol ); + $self->set_handle( $sock ); +} + +=head2 $handle = $handle->bind( %args )->get + +Performs a C<getaddrinfo> resolver operation with the C<passive> flag set, +and then attempts to bind a socket handle of any of the return values. + +=head2 $handle = $handle->bind( $ai )->get + +When invoked with a single argument, this method is a convenient shortcut to +creating a socket handle and C<bind()>ing it to the address as given by an +addrinfo structure, and setting it as the read and write handle for the +object. + +C<$ai> may be either a C<HASH> or C<ARRAY> reference of the same form as given +to L<IO::Async::OS>'s C<extract_addrinfo> method. + +The returned future returns the handle object itself for convenience. + +=cut + +sub bind +{ + my $self = shift; + + if( @_ == 1 ) { + my ( $ai ) = @_; + + $self->socket( $ai ); + my $addr = ( IO::Async::OS->extract_addrinfo( $ai ) )[3]; + + $self->read_handle->bind( $addr ) or + return Future->fail( "Cannot bind - $!", bind => $self->read_handle, $addr, $! ); + + return Future->done( $self ); + } + + $self->loop->resolver->getaddrinfo( passive => 1, @_ )->then( sub { + my @addrs = @_; + + try_repeat { + my $ai = shift; + + $self->bind( $ai ); + } foreach => \@addrs, + until => sub { shift->is_done }; + }); +} + +=head2 $handle = $handle->connect( %args )->get + +A convenient wrapper for calling the C<connect> method on the underlying +L<IO::Async::Loop> object. + +=cut + +sub connect +{ + my $self = shift; + my %args = @_; + + my $loop = $self->loop or croak "Cannot ->connect a Handle that is not in a Loop"; + + return $self->loop->connect( %args, handle => $self ); +} + +=head1 SEE ALSO + +=over 4 + +=item * + +L<IO::Handle> - Supply object methods for I/O handles + +=back + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Internals/Connector.pm b/lib/IO/Async/Internals/Connector.pm new file mode 100644 index 0000000..57029ef --- /dev/null +++ b/lib/IO/Async/Internals/Connector.pm @@ -0,0 +1,243 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2008-2013 -- leonerd@leonerd.org.uk + +package # hide from CPAN + IO::Async::Internals::Connector; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use Scalar::Util qw( weaken ); + +use POSIX qw( EINPROGRESS ); +use Socket qw( SOL_SOCKET SO_ERROR ); + +use Future; +use Future::Utils 0.18 qw( try_repeat_until_success ); + +use IO::Async::OS; + +use Carp; + +use constant CONNECT_EWOULDLBOCK => IO::Async::OS->HAVE_CONNECT_EWOULDBLOCK; + +# Internal constructor +sub new +{ + my $class = shift; + my ( %params ) = @_; + + my $loop = delete $params{loop} or croak "Expected a 'loop'"; + + my $self = bless {}, $class; + weaken( $self->{loop} = $loop ); + + return $self; +} + +## Utility function +sub _get_sock_err +{ + my ( $sock ) = @_; + + my $err = $sock->getsockopt( SOL_SOCKET, SO_ERROR ); + + if( defined $err ) { + # 0 means no error, but is still defined + return undef if !$err; + + $! = $err; + return $!; + } + + # It seems we can't call getsockopt to query SO_ERROR. We'll try getpeername + if( defined getpeername( $sock ) ) { + return undef; + } + + my $peername_errno = $!+0; + my $peername_errstr = "$!"; + + # Not connected so we know this ought to fail + if( read( $sock, my $buff, 1 ) ) { + # That was most unexpected. getpeername fails because we're not + # connected, yet read succeeds. + warn "getpeername fails with $peername_errno ($peername_errstr) but read is successful\n"; + warn "Please see http://rt.cpan.org/Ticket/Display.html?id=38382\n"; + + $! = $peername_errno; + return $!; + } + + return $!; +} + +sub _connect_addresses +{ + my $self = shift; + my ( $addrlist, $on_fail ) = @_; + + my $loop = $self->{loop}; + + my ( $connecterr, $binderr, $socketerr ); + + my $future = try_repeat_until_success { + my $addr = shift; + my ( $family, $socktype, $protocol, $localaddr, $peeraddr ) = + @{$addr}{qw( family socktype protocol localaddr peeraddr )}; + + my $sock = IO::Async::OS->socket( $family, $socktype, $protocol ); + + if( !$sock ) { + $socketerr = $!; + $on_fail->( "socket", $family, $socktype, $protocol, $! ) if $on_fail; + return Future->fail( 1 ); + } + + if( $localaddr and not $sock->bind( $localaddr ) ) { + $binderr = $!; + $on_fail->( "bind", $sock, $localaddr, $! ) if $on_fail; + return Future->fail( 1 ); + } + + $sock->blocking( 0 ); + + # TODO: $sock->connect returns success masking EINPROGRESS + my $ret = connect( $sock, $peeraddr ); + if( $ret ) { + # Succeeded already? Dubious, but OK. Can happen e.g. with connections to + # localhost, or UNIX sockets, or something like that. + return Future->done( $sock ); + } + elsif( $! != EINPROGRESS and !CONNECT_EWOULDLBOCK || $! != POSIX::EWOULDBLOCK ) { + $connecterr = $!; + $on_fail->( "connect", $sock, $peeraddr, $! ) if $on_fail; + return Future->fail( 1 ); + } + + # Else + my $f = $loop->new_future; + $loop->watch_io( + handle => $sock, + on_write_ready => sub { + $loop->unwatch_io( handle => $sock, on_write_ready => 1 ); + + my $err = _get_sock_err( $sock ); + + return $f->done( $sock ) if !$err; + + $connecterr = $!; + $on_fail->( "connect", $sock, $peeraddr, $err ) if $on_fail; + return $f->fail( 1 ); + }, + ); + $f->on_cancel( + sub { $loop->unwatch_io( handle => $sock, on_write_ready => 1 ); } + ); + return $f; + } foreach => $addrlist; + + return $future->else( sub { + return $future->new->fail( "connect: $connecterr", connect => connect => $connecterr ) + if $connecterr; + return $future->new->fail( "bind: $binderr", connect => bind => $binderr ) + if $binderr; + return $future->new->fail( "socket: $socketerr", connect => socket => $socketerr ) + if $socketerr; + # If it gets this far then something went wrong + die 'Oops; $loop->connect failed but no error cause was found'; + } ); +} + +sub connect +{ + my $self = shift; + my ( %params ) = @_; + + my $loop = $self->{loop}; + + my $on_fail = $params{on_fail}; + + my %gai_hints; + exists $params{$_} and $gai_hints{$_} = $params{$_} for qw( family socktype protocol flags ); + + if( exists $params{host} or exists $params{local_host} or exists $params{local_port} ) { + # We'll be making a ->getaddrinfo call + defined $gai_hints{socktype} or defined $gai_hints{protocol} or + carp "Attempting to ->connect without either 'socktype' or 'protocol' hint is not portable"; + } + + my $peeraddrfuture; + if( exists $params{host} and exists $params{service} ) { + my $host = $params{host} or croak "Expected 'host'"; + my $service = $params{service} or croak "Expected 'service'"; + + $peeraddrfuture = $loop->resolver->getaddrinfo( + host => $host, + service => $service, + %gai_hints, + ); + } + elsif( exists $params{addrs} or exists $params{addr} ) { + $peeraddrfuture = $loop->new_future->done( exists $params{addrs} ? @{ $params{addrs} } : ( $params{addr} ) ); + } + else { + croak "Expected 'host' and 'service' or 'addrs' or 'addr' arguments"; + } + + my $localaddrfuture; + if( defined $params{local_host} or defined $params{local_service} ) { + # Empty is fine on either of these + my $host = $params{local_host}; + my $service = $params{local_service}; + + $localaddrfuture = $loop->resolver->getaddrinfo( + host => $host, + service => $service, + %gai_hints, + ); + } + elsif( exists $params{local_addrs} or exists $params{local_addr} ) { + $localaddrfuture = $loop->new_future->done( exists $params{local_addrs} ? @{ $params{local_addrs} } : ( $params{local_addr} ) ); + } + else { + $localaddrfuture = $loop->new_future->done( {} ); + } + + return Future->needs_all( $peeraddrfuture, $localaddrfuture ) + ->then( sub { + my @peeraddrs = $peeraddrfuture->get; + my @localaddrs = $localaddrfuture->get; + + my @addrs; + + foreach my $local ( @localaddrs ) { + my ( $l_family, $l_socktype, $l_protocol, $l_addr ) = + IO::Async::OS->extract_addrinfo( $local, 'local_addr' ); + foreach my $peer ( @peeraddrs ) { + my ( $p_family, $p_socktype, $p_protocol, $p_addr ) = + IO::Async::OS->extract_addrinfo( $peer ); + + next if $l_family and $p_family and $l_family != $p_family; + next if $l_socktype and $p_socktype and $l_socktype != $p_socktype; + next if $l_protocol and $p_protocol and $l_protocol != $p_protocol; + + push @addrs, { + family => $l_family || $p_family, + socktype => $l_socktype || $p_socktype, + protocol => $l_protocol || $p_protocol, + localaddr => $l_addr, + peeraddr => $p_addr, + }; + } + } + + return $self->_connect_addresses( \@addrs, $on_fail ); + } ); +} + +0x55AA; diff --git a/lib/IO/Async/Internals/TimeQueue.pm b/lib/IO/Async/Internals/TimeQueue.pm new file mode 100644 index 0000000..4278fbd --- /dev/null +++ b/lib/IO/Async/Internals/TimeQueue.pm @@ -0,0 +1,205 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2006-2012 -- leonerd@leonerd.org.uk + +package # hide from CPAN + IO::Async::Internals::TimeQueue; + +use strict; +use warnings; + +use Carp; + +use Time::HiRes qw( time ); + +BEGIN { + my @methods = qw( next_time _enqueue cancel _fire ); + if( eval { require Heap::Fibonacci } ) { + unshift our @ISA, "Heap::Fibonacci"; + require Heap::Elem; + no strict 'refs'; + *$_ = \&{"HEAP_$_"} for @methods; + } + else { + no strict 'refs'; + *$_ = \&{"ARRAY_$_"} for "new", @methods; + } +} + +# High-level methods + +sub enqueue +{ + my $self = shift; + my ( %params ) = @_; + + my $code = delete $params{code}; + ref $code or croak "Expected 'code' to be a reference"; + + defined $params{time} or croak "Expected 'time'"; + my $time = $params{time}; + + $self->_enqueue( $time, $code ); +} + +sub fire +{ + my $self = shift; + my ( %params ) = @_; + + my $now = exists $params{now} ? $params{now} : time; + $self->_fire( $now ); +} + +# Implementation using a Perl array + +use constant { + TIME => 0, + CODE => 1, +}; + +sub ARRAY_new +{ + my $class = shift; + return bless [], $class; +} + +sub ARRAY_next_time +{ + my $self = shift; + return @$self ? $self->[0]->[TIME] : undef; +} + +sub ARRAY__enqueue +{ + my $self = shift; + my ( $time, $code ) = @_; + + # TODO: This could be more efficient maybe using a binary search + my $idx = 0; + $idx++ while $idx < @$self and $self->[$idx][TIME] <= $time; + splice @$self, $idx, 0, ( my $elem = [ $time, $code ]); + + return $elem; +} + +sub ARRAY_cancel +{ + my $self = shift; + my ( $id ) = @_; + + @$self = grep { $_ != $id } @$self; +} + +sub ARRAY__fire +{ + my $self = shift; + my ( $now ) = @_; + + my $count = 0; + + while( @$self ) { + last if( $self->[0]->[TIME] > $now ); + + my $top = shift @$self; + + $top->[CODE]->(); + $count++; + } + + return $count; +} + +# Implementation using Heap::Fibonacci + +sub HEAP_next_time +{ + my $self = shift; + + my $top = $self->top; + + return defined $top ? $top->time : undef; +} + +sub HEAP__enqueue +{ + my $self = shift; + my ( $time, $code ) = @_; + + my $elem = IO::Async::Internals::TimeQueue::Elem->new( $time, $code ); + $self->add( $elem ); + + return $elem; +} + +sub HEAP_cancel +{ + my $self = shift; + my ( $id ) = @_; + + $self->delete( $id ); +} + +sub HEAP__fire +{ + my $self = shift; + my ( $now ) = @_; + + my $count = 0; + + while( defined( my $top = $self->top ) ) { + last if( $top->time > $now ); + + $self->extract_top; + + $top->code->(); + $count++; + } + + return $count; +} + +package # hide from CPAN + IO::Async::Internals::TimeQueue::Elem; + +use strict; +our @ISA = qw( Heap::Elem ); + +sub new +{ + my $self = shift; + my $class = ref $self || $self; + + my ( $time, $code ) = @_; + + my $new = $class->SUPER::new( + time => $time, + code => $code, + ); + + return $new; +} + +sub time +{ + my $self = shift; + return $self->val->{time}; +} + +sub code +{ + my $self = shift; + return $self->val->{code}; +} + +# This only uses methods so is transparent to HASH or ARRAY +sub cmp +{ + my $self = shift; + my $other = shift; + + $self->time <=> $other->time; +} + +0x55AA; diff --git a/lib/IO/Async/Listener.pm b/lib/IO/Async/Listener.pm new file mode 100644 index 0000000..277a9ab --- /dev/null +++ b/lib/IO/Async/Listener.pm @@ -0,0 +1,549 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2008-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Listener; + +use strict; +use warnings; +use base qw( IO::Async::Handle ); + +our $VERSION = '0.67'; + +use IO::Async::Handle; +use IO::Async::OS; + +use Errno qw( EAGAIN EWOULDBLOCK ); + +use Socket qw( sockaddr_family SOL_SOCKET SO_ACCEPTCONN SO_TYPE ); + +use Carp; + +=head1 NAME + +C<IO::Async::Listener> - listen on network sockets for incoming connections + +=head1 SYNOPSIS + + use IO::Async::Listener; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my $listener = IO::Async::Listener->new( + on_stream => sub { + my ( undef, $stream ) = @_; + + $stream->configure( + on_read => sub { + my ( $self, $buffref, $eof ) = @_; + $self->write( $$buffref ); + $$buffref = ""; + return 0; + }, + ); + + $loop->add( $stream ); + }, + ); + + $loop->add( $listener ); + + $listener->listen( + service => "echo", + socktype => 'stream', + )->get; + + $loop->run; + +This object can also be used indirectly via an C<IO::Async::Loop>: + + use IO::Async::Stream; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + $loop->listen( + service => "echo", + socktype => 'stream', + + on_stream => sub { + ... + }, + )->get; + + $loop->run; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Handle> adds behaviour which watches a socket in +listening mode, to accept incoming connections on them. + +A Listener can be constructed and given a existing socket in listening mode. +Alternatively, the Listener can construct a socket by calling the C<listen> +method. Either a list of addresses can be provided, or a service name can be +looked up using the underlying loop's C<resolve> method. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters: + +=head2 on_accept $clientsocket | $handle + +Invoked whenever a new client connects to the socket. + +If neither C<handle_constructor> nor C<handle_class> parameters are set, this +will be invoked with the new client socket directly. If a handle constructor +or class are set, this will be invoked with the newly-constructed handle, +having the new socket already configured onto it. + +=head2 on_stream $stream + +An alternative to C<on_accept>, this an instance of L<IO::Async::Stream> when +a new client connects. This is provided as a convenience for the common case +that a Stream object is required as the transport for a Protocol object. + +This is now vaguely deprecated in favour of using C<on_accept> with a handle +constructor or class. + +=head2 on_socket $socket + +Similar to C<on_stream>, but constructs an instance of L<IO::Async::Socket>. +This is most useful for C<SOCK_DGRAM> or C<SOCK_RAW> sockets. + +This is now vaguely deprecated in favour of using C<on_accept> with a handle +constructor or class. + +=head2 on_accept_error $socket, $errno + +Optional. Invoked if the C<accept> syscall indicates an error (other than +C<EAGAIN> or C<EWOULDBLOCK>). If not provided, failures of C<accept> will +be passed to the main C<on_error> handler. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 on_accept => CODE + +=head2 on_stream => CODE + +=head2 on_socket => CODE + +CODE reference for the event handlers. Because of the mutually-exclusive +nature of their behaviour, only one of these may be set at a time. Setting one +will remove the other two. + +=head2 handle => IO + +The IO handle containing an existing listen-mode socket. + +=head2 handle_constructor => CODE + +Optional. If defined, gives a CODE reference to be invoked every time a new +client socket is accepted from the listening socket. It is passed the listener +object itself, and is expected to return a new instance of +C<IO::Async::Handle> or a subclass, used to wrap the new client socket. + + $handle = $handle_constructor->( $listener ) + +This can also be given as a subclass method + + $handle = $listener->handle_constructor() + +=head2 handle_class => STRING + +Optional. If defined and C<handle_constructor> isn't, then new wrapper handles +are constructed by invoking the C<new> method on the given class name, passing +in no additional parameters. + + $handle = $handle_class->new() + +This can also be given as a subclass method + + $handle = $listener->handle_class->new + +=head2 acceptor => STRING|CODE + +Optional. If defined, gives the name of a method or a CODE reference to use to +implement the actual accept behaviour. This will be invoked as: + + ( $accepted ) = $listener->acceptor( $socket )->get + + ( $handle ) = $listener->acceptor( $socket, handle => $handle )->get + +It is invoked with the listening socket as its its argument, and optionally +an C<IO::Async::Handle> instance as a named parameter, and is expected to +return a C<Future> that will eventually yield the newly-accepted socket or +handle instance, if such was provided. + +=cut + +sub _init +{ + my $self = shift; + $self->SUPER::_init( @_ ); + + $self->{acceptor} = "_accept"; +} + +my @acceptor_events = qw( on_accept on_stream on_socket ); + +sub configure +{ + my $self = shift; + my %params = @_; + + if( grep exists $params{$_}, @acceptor_events ) { + grep( defined $_, @params{@acceptor_events} ) <= 1 or + croak "Can only set at most one of 'on_accept', 'on_stream' or 'on_socket'"; + + # Don't exists-test, so we'll clear the other two + $self->{$_} = delete $params{$_} for @acceptor_events; + } + + croak "Cannot set 'on_read_ready' on a Listener" if exists $params{on_read_ready}; + + if( exists $params{handle} ) { + my $handle = delete $params{handle}; + # Sanity check it - it may be a bare GLOB ref, not an IO::Socket-derived handle + defined getsockname( $handle ) or croak "IO handle $handle does not have a sockname"; + + # So now we know it's at least some kind of socket. Is it listening? + # SO_ACCEPTCONN would tell us, but not all OSes implement it. Since it's + # only a best-effort sanity check, we won't mind if the OS doesn't. + my $acceptconn = getsockopt( $handle, SOL_SOCKET, SO_ACCEPTCONN ); + !defined $acceptconn or unpack( "I", $acceptconn ) or croak "Socket is not accepting connections"; + + # This is a bit naughty but hopefully nobody will mind... + bless $handle, "IO::Socket" if ref( $handle ) eq "GLOB"; + + $self->SUPER::configure( read_handle => $handle ); + } + + unless( grep $self->can_event( $_ ), @acceptor_events ) { + croak "Expected to be able to 'on_accept', 'on_stream' or 'on_socket'"; + } + + foreach (qw( acceptor handle_constructor handle_class )) { + $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + if( keys %params ) { + croak "Cannot pass though configuration keys to underlying Handle - " . join( ", ", keys %params ); + } +} + +sub on_read_ready +{ + my $self = shift; + + my $socket = $self->read_handle; + + my $on_done; + my %acceptor_params; + + if( $on_done = $self->can_event( "on_stream" ) ) { + # TODO: It doesn't make sense to put a SOCK_DGRAM in an + # IO::Async::Stream but currently we don't detect this + require IO::Async::Stream; + $acceptor_params{handle} = IO::Async::Stream->new; + } + elsif( $on_done = $self->can_event( "on_socket" ) ) { + require IO::Async::Socket; + $acceptor_params{handle} = IO::Async::Socket->new; + } + # on_accept needs to be last in case of multiple layers of subclassing + elsif( $on_done = $self->can_event( "on_accept" ) ) { + my $handle; + + # Test both params before moving on to either method + if( my $constructor = $self->{handle_constructor} ) { + $handle = $self->{handle_constructor}->( $self ); + } + elsif( my $class = $self->{handle_class} ) { + $handle = $class->new; + } + elsif( $self->can( "handle_constructor" ) ) { + $handle = $self->handle_constructor; + } + elsif( $self->can( "handle_class" ) ) { + $handle = $self->handle_class->new; + } + + $acceptor_params{handle} = $handle if $handle; + } + else { + die "ARG! Missing on_accept,on_stream,on_socket!"; + } + + my $acceptor = $self->acceptor; + my $f = $self->$acceptor( $socket, %acceptor_params )->on_done( sub { + my ( $result ) = @_ or return; # false-alarm + $on_done->( $self, $result ); + })->on_fail( sub { + my ( $message, $name, @args ) = @_; + if( $name eq "accept" ) { + my ( $socket, $dollarbang ) = @args; + $self->maybe_invoke_event( on_accept_error => $socket, $dollarbang ) or + $self->invoke_error( "accept() failed - $dollarbang", accept => $socket, $dollarbang ); + } + }); + + # Caller is not going to keep hold of the Future, so we have to ensure it + # stays alive somehow + $self->adopt_future( $f->else( sub { Future->done } ) ); +} + +sub _accept +{ + my $self = shift; + my ( $listen_sock, %params ) = @_; + + my $accepted = $listen_sock->accept; + + if( defined $accepted ) { + $accepted->blocking( 0 ); + if( my $handle = $params{handle} ) { + $handle->set_handle( $accepted ); + return Future->done( $handle ); + } + else { + return Future->done( $accepted ); + } + } + elsif( $! == EAGAIN or $! == EWOULDBLOCK ) { + return Future->done; + } + else { + return Future->fail( "Cannot accept() - $!", accept => $listen_sock, $! ); + } +} + +=head1 METHODS + +The following methods documented with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +=head2 $acceptor = $listener->acceptor + +Returns the currently-set C<acceptor> method name or code reference. This may +be of interest to Loop C<listen> extension methods that wish to extend or wrap +it. + +=cut + +sub acceptor +{ + my $self = shift; + return $self->{acceptor}; +} + +sub is_listening +{ + my $self = shift; + + return ( defined $self->sockname ); +} + +=head2 $name = $listener->sockname + +Returns the C<sockname> of the underlying listening socket + +=cut + +sub sockname +{ + my $self = shift; + + my $handle = $self->read_handle or return undef; + return $handle->sockname; +} + +=head2 $family = $listener->family + +Returns the socket address family of the underlying listening socket + +=cut + +sub family +{ + my $self = shift; + + my $sockname = $self->sockname or return undef; + return sockaddr_family( $sockname ); +} + +=head2 $socktype = $listener->socktype + +Returns the socket type of the underlying listening socket + +=cut + +sub socktype +{ + my $self = shift; + + my $handle = $self->read_handle or return undef; + return $handle->sockopt(SO_TYPE); +} + +=head2 $listener->listen( %params ) + +This method sets up a listening socket and arranges for the acceptor callback +to be invoked each time a new connection is accepted on the socket. + +Most parameters given to this method are passed into the C<listen> method of +the L<IO::Async::Loop> object. In addition, the following arguments are also +recognised directly: + +=over 8 + +=item on_listen => CODE + +Optional. A callback that is invoked when the listening socket is ready. +Similar to that on the underlying loop method, except it is passed the +listener object itself. + + $on_listen->( $listener ) + +=back + +=cut + +sub listen +{ + my $self = shift; + my ( %params ) = @_; + + my $loop = $self->loop; + defined $loop or croak "Cannot listen when not a member of a Loop"; # TODO: defer? + + if( my $on_listen = delete $params{on_listen} ) { + $params{on_listen} = sub { $on_listen->( $self ) }; + } + + $loop->listen( listener => $self, %params ); +} + +=head1 EXAMPLES + +=head2 Listening on UNIX Sockets + +The C<handle> argument can be passed an existing socket already in listening +mode, making it possible to listen on other types of socket such as UNIX +sockets. + + use IO::Async::Listener; + use IO::Socket::UNIX; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my $listener = IO::Async::Listener->new( + on_stream => sub { + my ( undef, $stream ) = @_; + + $stream->configure( + on_read => sub { + my ( $self, $buffref, $eof ) = @_; + $self->write( $$buffref ); + $$buffref = ""; + return 0; + }, + ); + + $loop->add( $stream ); + }, + ); + + $loop->add( $listener ); + + my $socket = IO::Socket::UNIX->new( + Local => "echo.sock", + Listen => 1, + ) or die "Cannot make UNIX socket - $!\n"; + + $listener->listen( + handle => $socket, + ); + + $loop->run; + +=head2 Passing Plain Socket Addresses + +The C<addr> or C<addrs> parameters should contain a definition of a plain +socket address in a form that the L<IO::Async::OS> C<extract_addrinfo> +method can use. + +This example shows how to listen on TCP port 8001 on address 10.0.0.1: + + $listener->listen( + addr => { + family => "inet", + socktype => "stream", + port => 8001, + ip => "10.0.0.1", + }, + ... + ); + +This example shows another way to listen on a UNIX socket, similar to the +earlier example: + + $listener->listen( + addr => { + family => "unix", + socktype => "stream", + path => "echo.sock", + }, + ... + ); + +=head2 Using A Kernel-Assigned Port Number + +Rather than picking a specific port number, is it possible to ask the kernel +to assign one arbitrarily that is currently free. This can be done by +requesting port number 0 (which is actually the default if no port number is +otherwise specified). To determine which port number the kernel actually +picked, inspect the C<sockport> accessor on the actual socket filehandle. + +Either use the L<Future> returned by the C<listen> method: + + $listener->listen( + addr => { family => "inet" }, + )->on_done( sub { + my ( $listener ) = @_; + my $socket = $listener->read_handle; + + say "Now listening on port ", $socket->sockport; + }); + +Or pass an C<on_listen> continuation: + + $listener->listen( + addr => { family => "inet" }, + + on_listen => sub { + my ( $listener ) = @_; + my $socket = $listener->read_handle; + + say "Now listening on port ", $socket->sockport; + }, + ); + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Loop.pm b/lib/IO/Async/Loop.pm new file mode 100644 index 0000000..e510c64 --- /dev/null +++ b/lib/IO/Async/Loop.pm @@ -0,0 +1,2781 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2007-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Loop; + +use strict; +use warnings; +use 5.010; + +our $VERSION = '0.67'; + +# When editing this value don't forget to update the docs below +use constant NEED_API_VERSION => '0.33'; + +# Base value but some classes might override +use constant _CAN_ON_HANGUP => 0; + +# Most Loop implementations do not accurately handle sub-second timers. +# This only matters for unit tests +use constant _CAN_SUBSECOND_ACCURATELY => 0; + +# Does the loop implementation support IO_ASYNC_WATCHDOG? +use constant _CAN_WATCHDOG => 0; + +# Watchdog configuration constants +use constant WATCHDOG_ENABLE => $ENV{IO_ASYNC_WATCHDOG}; +use constant WATCHDOG_INTERVAL => $ENV{IO_ASYNC_WATCHDOG_INTERVAL} || 10; +use constant WATCHDOG_SIGABRT => $ENV{IO_ASYNC_WATCHDOG_SIGABRT}; + +use Carp; + +use IO::Socket (); # empty import +use Time::HiRes qw(); # empty import +use POSIX qw( WNOHANG ); +use Scalar::Util qw( refaddr weaken ); +use Socket qw( SO_REUSEADDR AF_INET6 IPPROTO_IPV6 IPV6_V6ONLY ); + +use IO::Async::OS; + +use constant HAVE_SIGNALS => IO::Async::OS->HAVE_SIGNALS; +use constant HAVE_POSIX_FORK => IO::Async::OS->HAVE_POSIX_FORK; +use constant HAVE_THREADS => IO::Async::OS->HAVE_THREADS; + +# Never sleep for more than 1 second if a signal proxy is registered, to avoid +# a borderline race condition. +# There is a race condition in perl involving signals interacting with XS code +# that implements blocking syscalls. There is a slight chance a signal will +# arrive in the XS function, before the blocking itself. Perl will not run our +# (safe) deferred signal handler in this case. To mitigate this, if we have a +# signal proxy, we'll adjust the maximal timeout. The signal handler will be +# run when the XS function returns. +our $MAX_SIGWAIT_TIME = 1; + +# Also, never sleep for more than 1 second if the OS does not support signals +# and we have child watches registered (so we must use waitpid() polling) +our $MAX_CHILDWAIT_TIME = 1; + +# Maybe our calling program will have a suggested hint of a specific Loop +# class or list of classes to use +our $LOOP; + +# Undocumented; used only by the test scripts. +# Setting this value true will avoid the IO::Async::Loop::$^O candidate in the +# magic constructor +our $LOOP_NO_OS; + +# SIGALRM handler for watchdog +$SIG{ALRM} = sub { + # There are two extra frames here; this one and the signal handler itself + local $Carp::CarpLevel = $Carp::CarpLevel + 2; + if( WATCHDOG_SIGABRT ) { + print STDERR Carp::longmess( "Watchdog timeout" ); + kill ABRT => $$; + } + else { + Carp::confess( "Watchdog timeout" ); + } +} if WATCHDOG_ENABLE; + +$SIG{PIPE} = "IGNORE" if ( $SIG{PIPE} // "" ) eq "DEFAULT"; + +=head1 NAME + +C<IO::Async::Loop> - core loop of the C<IO::Async> framework + +=head1 SYNOPSIS + + use IO::Async::Stream; + use IO::Async::Timer::Countdown; + + use IO::Async::Loop; + + my $loop = IO::Async::Loop->new; + + $loop->add( IO::Async::Timer::Countdown->new( + delay => 10, + on_expire => sub { print "10 seconds have passed\n" }, + )->start ); + + $loop->add( IO::Async::Stream->new_for_stdin( + on_read => sub { + my ( $self, $buffref, $eof ) = @_; + + while( $$buffref =~ s/^(.*)\n// ) { + print "You typed a line $1\n"; + } + + return 0; + }, + ) ); + + $loop->run; + +=head1 DESCRIPTION + +This module provides an abstract class which implements the core loop of the +C<IO::Async> framework. Its primary purpose is to store a set of +L<IO::Async::Notifier> objects or subclasses of them. It handles all of the +lower-level set manipulation actions, and leaves the actual IO readiness +testing/notification to the concrete class that implements it. It also +provides other functionality such as signal handling, child process managing, +and timers. + +See also the two bundled Loop subclasses: + +=over 4 + +=item L<IO::Async::Loop::Select> + +=item L<IO::Async::Loop::Poll> + +=back + +Or other subclasses that may appear on CPAN which are not part of the core +C<IO::Async> distribution. + +=head2 Ignoring SIGPIPE + +Since version I<0.66> loading this module automatically ignores C<SIGPIPE>, as +it is highly unlikely that the default-terminate action is the best course of +action for an C<IO::Async>-based program to take. If at load time the handler +disposition is still set as C<DEFAULT>, it is set to ignore. If already +another handler has been placed there by the program code, it will be left +undisturbed. + +=cut + +# Internal constructor used by subclasses +sub __new +{ + my $class = shift; + + # Detect if the API version provided by the subclass is sufficient + $class->can( "API_VERSION" ) or + die "$class is too old for IO::Async $VERSION; it does not provide \->API_VERSION\n"; + + $class->API_VERSION >= NEED_API_VERSION or + die "$class is too old for IO::Async $VERSION; we need API version >= ".NEED_API_VERSION.", it provides ".$class->API_VERSION."\n"; + + WATCHDOG_ENABLE and !$class->_CAN_WATCHDOG and + warn "$class cannot implement IO_ASYNC_WATCHDOG\n"; + + my $self = bless { + notifiers => {}, # {nkey} = notifier + iowatches => {}, # {fd} = [ $on_read_ready, $on_write_ready, $on_hangup ] + sigattaches => {}, # {sig} => \@callbacks + childmanager => undef, + childwatches => {}, # {pid} => $code + threadwatches => {}, # {tid} => $code + timequeue => undef, + deferrals => [], + os => {}, # A generic scratchpad for IO::Async::OS to store whatever it wants + }, $class; + + # It's possible this is a specific subclass constructor. We still want the + # magic IO::Async::Loop->new constructor to yield this if it's the first + # one + our $ONE_TRUE_LOOP ||= $self; + + # Legacy support - temporary until all CPAN classes are updated; bump NEEDAPI version at that point + my $old_timer = $self->can( "enqueue_timer" ) != \&enqueue_timer; + if( $old_timer != ( $self->can( "cancel_timer" ) != \&cancel_timer ) ) { + die "$class should overload both ->enqueue_timer and ->cancel_timer, or neither"; + } + + if( $old_timer ) { + warnings::warnif( deprecated => "Enabling old_timer workaround for old loop class " . $class ); + } + + $self->{old_timer} = $old_timer; + + return $self; +} + +=head1 MAGIC CONSTRUCTOR + +=head2 $loop = IO::Async::Loop->new + +This function attempts to find a good subclass to use, then calls its +constructor. It works by making a list of likely candidate classes, then +trying each one in turn, C<require>ing the module then calling its C<new> +method. If either of these operations fails, the next subclass is tried. If +no class was successful, then an exception is thrown. + +The constructed object is cached, and will be returned again by a subsequent +call. The cache will also be set by a constructor on a specific subclass. This +behaviour makes it possible to simply use the normal constructor in a module +that wishes to interract with the main program's Loop, such as an integration +module for another event system. + +For example, the following two C<$loop> variables will refer to the same +object: + + use IO::Async::Loop; + use IO::Async::Loop::Poll; + + my $loop_poll = IO::Async::Loop::Poll->new; + + my $loop = IO::Async::Loop->new; + +While it is not advised to do so under normal circumstances, if the program +really wishes to construct more than one Loop object, it can call the +constructor C<really_new>, or invoke one of the subclass-specific constructors +directly. + +The list of candidates is formed from the following choices, in this order: + +=over 4 + +=item * $ENV{IO_ASYNC_LOOP} + +If this environment variable is set, it should contain a comma-separated list +of subclass names. These names may or may not be fully-qualified; if a name +does not contain C<::> then it will have C<IO::Async::Loop::> prepended to it. +This allows the end-user to specify a particular choice to fit the needs of +his use of a program using C<IO::Async>. + +=item * $IO::Async::Loop::LOOP + +If this scalar is set, it should contain a comma-separated list of subclass +names. These may or may not be fully-qualified, as with the above case. This +allows a program author to suggest a loop module to use. + +In cases where the module subclass is a hard requirement, such as GTK programs +using C<Glib>, it would be better to use the module specifically and invoke +its constructor directly. + +=item * IO::Async::OS->LOOP_PREFER_CLASSES + +The L<IO::Async::OS> hints module for the given OS is then consulted to see if +it suggests any other module classes specific to the given operating system. + +=item * $^O + +The module called C<IO::Async::Loop::$^O> is tried next. This allows specific +OSes, such as the ever-tricky C<MSWin32>, to provide an implementation that +might be more efficient than the generic ones, or even work at all. + +This option is now discouraged in favour of the C<IO::Async::OS> hint instead. +At some future point it may be removed entirely, given as currently only +C<linux> uses it. + +=item * Poll and Select + +Finally, if no other choice has been made by now, the built-in C<Poll> module +is chosen. This should always work, but in case it doesn't, the C<Select> +module will be chosen afterwards as a last-case attempt. If this also fails, +then the magic constructor itself will throw an exception. + +=back + +If any of the explicitly-requested loop types (C<$ENV{IO_ASYNC_LOOP}> or +C<$IO::Async::Loop::LOOP>) fails to load then a warning is printed detailing +the error. + +Implementors of new C<IO::Async::Loop> subclasses should see the notes about +C<API_VERSION> below. + +=cut + +sub __try_new +{ + my ( $class ) = @_; + + ( my $file = "$class.pm" ) =~ s{::}{/}g; + + eval { + local $SIG{__WARN__} = sub {}; + require $file; + } or return; + + my $self; + $self = eval { $class->new } and return $self; + + # Oh dear. We've loaded the code OK but for some reason the constructor + # wasn't happy. Being polite we ought really to unload the file again, + # but perl doesn't actually provide us a way to do this. + + return undef; +} + +sub new +{ + return our $ONE_TRUE_LOOP ||= shift->really_new; +} + +# Ensure that the loop is DESTROYed recursively at exit time, before GD happens +END { + undef our $ONE_TRUE_LOOP; +} + +sub really_new +{ + shift; # We're going to ignore the class name actually given + my $self; + + my @candidates; + + push @candidates, split( m/,/, $ENV{IO_ASYNC_LOOP} ) if defined $ENV{IO_ASYNC_LOOP}; + + push @candidates, split( m/,/, $LOOP ) if defined $LOOP; + + foreach my $class ( @candidates ) { + $class =~ m/::/ or $class = "IO::Async::Loop::$class"; + $self = __try_new( $class ) and return $self; + + my ( $topline ) = split m/\n/, $@; # Ignore all the other lines; they'll be require's verbose output + warn "Unable to use $class - $topline\n"; + } + + unless( $LOOP_NO_OS ) { + foreach my $class ( IO::Async::OS->LOOP_PREFER_CLASSES, "IO::Async::Loop::$^O" ) { + $class =~ m/::/ or $class = "IO::Async::Loop::$class"; + $self = __try_new( $class ) and return $self; + + # Don't complain about these ones + } + } + + return IO::Async::Loop->new_builtin; +} + +sub new_builtin +{ + shift; + my $self; + + foreach my $class ( IO::Async::OS->LOOP_BUILTIN_CLASSES ) { + $self = __try_new( "IO::Async::Loop::$class" ) and return $self; + } + + croak "Cannot find a suitable candidate class"; +} + +####################### +# Notifier management # +####################### + +=head1 NOTIFIER MANAGEMENT + +The following methods manage the collection of C<IO::Async::Notifier> objects. + +=cut + +=head2 $loop->add( $notifier ) + +This method adds another notifier object to the stored collection. The object +may be a C<IO::Async::Notifier>, or any subclass of it. + +When a notifier is added, any children it has are also added, recursively. In +this way, entire sections of a program may be written within a tree of +notifier objects, and added or removed on one piece. + +=cut + +sub add +{ + my $self = shift; + my ( $notifier ) = @_; + + if( defined $notifier->parent ) { + croak "Cannot add a child notifier directly - add its parent"; + } + + if( defined $notifier->loop ) { + croak "Cannot add a notifier that is already a member of a loop"; + } + + $self->_add_noparentcheck( $notifier ); +} + +sub _add_noparentcheck +{ + my $self = shift; + my ( $notifier ) = @_; + + my $nkey = refaddr $notifier; + + $self->{notifiers}->{$nkey} = $notifier; + + $notifier->__set_loop( $self ); + + $self->_add_noparentcheck( $_ ) for $notifier->children; + + return; +} + +=head2 $loop->remove( $notifier ) + +This method removes a notifier object from the stored collection, and +recursively and children notifiers it contains. + +=cut + +sub remove +{ + my $self = shift; + my ( $notifier ) = @_; + + if( defined $notifier->parent ) { + croak "Cannot remove a child notifier directly - remove its parent"; + } + + $self->_remove_noparentcheck( $notifier ); +} + +sub _remove_noparentcheck +{ + my $self = shift; + my ( $notifier ) = @_; + + my $nkey = refaddr $notifier; + + exists $self->{notifiers}->{$nkey} or croak "Notifier does not exist in collection"; + + delete $self->{notifiers}->{$nkey}; + + $notifier->__set_loop( undef ); + + $self->_remove_noparentcheck( $_ ) for $notifier->children; + + return; +} + +=head2 @notifiers = $loop->notifiers + +Returns a list of all the notifier objects currently stored in the Loop. + +=cut + +sub notifiers +{ + my $self = shift; + # Sort so the order remains stable under additions/removals + return map { $self->{notifiers}->{$_} } sort keys %{ $self->{notifiers} }; +} + +################### +# Looping support # +################### + +=head1 LOOPING CONTROL + +The following methods control the actual run cycle of the loop, and hence the +program. + +=cut + +=head2 $count = $loop->loop_once( $timeout ) + +This method performs a single wait loop using the specific subclass's +underlying mechanism. If C<$timeout> is undef, then no timeout is applied, and +it will wait until an event occurs. The intention of the return value is to +indicate the number of callbacks that this loop executed, though different +subclasses vary in how accurately they can report this. See the documentation +for this method in the specific subclass for more information. + +=cut + +sub loop_once +{ + my $self = shift; + my ( $timeout ) = @_; + + croak "Expected that $self overrides ->loop_once"; +} + +=head2 @result = $loop->run + +=head2 $result = $loop->run + +Runs the actual IO event loop. This method blocks until the C<stop> method is +called, and returns the result that was passed to C<stop>. In scalar context +only the first result is returned; the others will be discarded if more than +one value was provided. This method may be called recursively. + +This method is a recent addition and may not be supported by all the +C<IO::Async::Loop> subclasses currently available on CPAN. + +=cut + +sub run +{ + my $self = shift; + + local $self->{running} = 1; + local $self->{result} = []; + + while( $self->{running} ) { + $self->loop_once( undef ); + } + + return wantarray ? @{ $self->{result} } : $self->{result}[0]; +} + +=head2 $loop->stop( @result ) + +Stops the inner-most C<run> method currently in progress, causing it to return +the given C<@result>. + +This method is a recent addition and may not be supported by all the +C<IO::Async::Loop> subclasses currently available on CPAN. + +=cut + +sub stop +{ + my $self = shift; + + @{ $self->{result} } = @_; + undef $self->{running}; +} + +=head2 $loop->loop_forever + +A synonym for C<run>, though this method does not return a result. + +=cut + +sub loop_forever +{ + my $self = shift; + $self->run; + return; +} + +=head2 $loop->loop_stop + +A synonym for C<stop>, though this method does not pass any results. + +=cut + +sub loop_stop +{ + my $self = shift; + $self->stop; +} + +=head2 $loop->post_fork + +The base implementation of this method does nothing. It is provided in case +some Loop subclasses should take special measures after a C<fork()> system +call if the main body of the program should survive in both running processes. + +This may be required, for example, in a long-running server daemon that forks +multiple copies on startup after opening initial listening sockets. A loop +implementation that uses some in-kernel resource that becomes shared after +forking (for example, a Linux C<epoll> or a BSD C<kqueue> filehandle) would +need recreating in the new child process before the program can continue. + +=cut + +sub post_fork +{ + # empty +} + +########### +# Futures # +########### + +=head1 FUTURE SUPPORT + +The following methods relate to L<IO::Async::Future> objects. + +=cut + +=head2 $future = $loop->new_future + +Returns a new C<IO::Async::Future> instance with a reference to the Loop. + +=cut + +sub new_future +{ + my $self = shift; + require IO::Async::Future; + return IO::Async::Future->new( $self ); +} + +=head2 $loop->await( $future ) + +Blocks until the given future is ready, as indicated by its C<is_ready> method. +As a convenience it returns the future, to simplify code: + + my @result = $loop->await( $future )->get; + +=cut + +sub await +{ + my $self = shift; + my ( $future ) = @_; + + $self->loop_once until $future->is_ready; + + return $future; +} + +=head2 $loop->await_all( @futures ) + +Blocks until all the given futures are ready, as indicated by the C<is_ready> +method. Equivalent to calling C<await> on a C<< Future->wait_all >> except +that it doesn't create the surrounding future object. + +=cut + +sub _all_ready { $_->is_ready or return 0 for @_; return 1 } + +sub await_all +{ + my $self = shift; + my @futures = @_; + + $self->loop_once until _all_ready @futures; +} + +=head2 $loop->delay_future( %args )->get + +Returns a new C<IO::Async::Future> instance which will become done at a given +point in time. The C<%args> should contain an C<at> or C<after> key as per the +C<watch_time> method. The returned future may be cancelled to cancel the +timer. At the alloted time the future will succeed with an empty result list. + +=cut + +sub delay_future +{ + my $self = shift; + my %args = @_; + + my $future = $self->new_future; + my $id = $self->watch_time( %args, + code => sub { $future->done }, + ); + + $future->on_cancel( sub { shift->loop->unwatch_time( $id ) } ); + + return $future; +} + +=head2 $loop->timeout_future( %args )->get + +Returns a new C<IO::Async::Future> instance which will fail at a given point +in time. The C<%args> should contain an C<at> or C<after> key as per the +C<watch_time> method. The returned future may be cancelled to cancel the +timer. At the alloted time, the future will fail with the string C<"Timeout">. + +=cut + +sub timeout_future +{ + my $self = shift; + my %args = @_; + + my $future = $self->new_future; + my $id = $self->watch_time( %args, + code => sub { $future->fail( "Timeout" ) }, + ); + + $future->on_cancel( sub { shift->loop->unwatch_time( $id ) } ); + + return $future; +} + +############ +# Features # +############ + +=head1 FEATURES + +Most of the following methods are higher-level wrappers around base +functionality provided by the low-level API documented below. They may be +used by C<IO::Async::Notifier> subclasses or called directly by the program. + +The following methods documented with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +sub __new_feature +{ + my $self = shift; + my ( $classname ) = @_; + + ( my $filename = "$classname.pm" ) =~ s{::}{/}g; + require $filename; + + # These features aren't supposed to be "user visible", so if methods called + # on it carp or croak, the shortmess line ought to skip IO::Async::Loop and + # go on report its caller. To make this work, add the feature class to our + # @CARP_NOT list. + push our(@CARP_NOT), $classname; + + return $classname->new( loop => $self ); +} + +=head2 $id = $loop->attach_signal( $signal, $code ) + +This method adds a new signal handler to watch the given signal. The same +signal can be attached to multiple times; its callback functions will all be +invoked, in no particular order. + +The returned C<$id> value can be used to identify the signal handler in case +it needs to be removed by the C<detach_signal> method. Note that this value +may be an object reference, so if it is stored, it should be released after it +cancelled, so the object itself can be freed. + +=over 8 + +=item $signal + +The name of the signal to attach to. This should be a bare name like C<TERM>. + +=item $code + +A CODE reference to the handling callback. + +=back + +Attaching to C<SIGCHLD> is not recommended because of the way all child +processes use it to report their termination. Instead, the C<watch_child> +method should be used to watch for termination of a given child process. A +warning will be printed if C<SIGCHLD> is passed here, but in future versions +of C<IO::Async> this behaviour may be disallowed altogether. + +See also L<POSIX> for the C<SIGI<name>> constants. + +For a more flexible way to use signals from within Notifiers, see instead the +L<IO::Async::Signal> object. + +=cut + +sub attach_signal +{ + my $self = shift; + my ( $signal, $code ) = @_; + + HAVE_SIGNALS or croak "This OS cannot ->attach_signal"; + + if( $signal eq "CHLD" ) { + # We make special exception to allow $self->watch_child to do this + caller eq "IO::Async::Loop" or + carp "Attaching to SIGCHLD is not advised - use ->watch_child instead"; + } + + if( not $self->{sigattaches}->{$signal} ) { + my @attaches; + $self->watch_signal( $signal, sub { + foreach my $attachment ( @attaches ) { + $attachment->(); + } + } ); + $self->{sigattaches}->{$signal} = \@attaches; + } + + push @{ $self->{sigattaches}->{$signal} }, $code; + + return \$self->{sigattaches}->{$signal}->[-1]; +} + +=head2 $loop->detach_signal( $signal, $id ) + +Removes a previously-attached signal handler. + +=over 8 + +=item $signal + +The name of the signal to remove from. This should be a bare name like +C<TERM>. + +=item $id + +The value returned by the C<attach_signal> method. + +=back + +=cut + +sub detach_signal +{ + my $self = shift; + my ( $signal, $id ) = @_; + + HAVE_SIGNALS or croak "This OS cannot ->detach_signal"; + + # Can't use grep because we have to preserve the addresses + my $attaches = $self->{sigattaches}->{$signal} or return; + + for (my $i = 0; $i < @$attaches; ) { + $i++, next unless \$attaches->[$i] == $id; + + splice @$attaches, $i, 1, (); + } + + if( !@$attaches ) { + $self->unwatch_signal( $signal ); + delete $self->{sigattaches}->{$signal}; + } +} + +=head2 $loop->later( $code ) + +Schedules a code reference to be invoked as soon as the current round of IO +operations is complete. + +The code reference is never invoked immediately, though the loop will not +perform any blocking operations between when it is installed and when it is +invoked. It may call C<select>, C<poll> or equivalent with a zero-second +timeout, and process any currently-pending IO conditions before the code is +invoked, but it will not block for a non-zero amount of time. + +This method is implemented using the C<watch_idle> method, with the C<when> +parameter set to C<later>. It will return an ID value that can be passed to +C<unwatch_idle> if required. + +=cut + +sub later +{ + my $self = shift; + my ( $code ) = @_; + + return $self->watch_idle( when => 'later', code => $code ); +} + +=head2 $loop->spawn_child( %params ) + +This method creates a new child process to run a given code block or command. +For more detail, see the C<spawn_child> method on the +L<IO::Async::ChildManager> class. + +=cut + +sub spawn_child +{ + my $self = shift; + my %params = @_; + + my $childmanager = $self->{childmanager} ||= + $self->__new_feature( "IO::Async::ChildManager" ); + + $childmanager->spawn_child( %params ); +} + +=head2 $pid = $loop->open_child( %params ) + +This creates a new child process to run the given code block or command, and +attaches filehandles to it that the parent will watch. This method is a light +wrapper around constructing a new L<IO::Async::Process> object, provided +largely for backward compatibility. New code ought to construct such an object +directly, as it may provide more features than are available here. + +The C<%params> hash takes the following keys: + +=over 8 + +=item command => ARRAY or STRING + +=item code => CODE + +The command or code to run in the child process (as per the C<spawn> method) + +=item on_finish => CODE + +A continuation to be called when the child process exits and has closed all of +the filehandles that were set up for it. It will be invoked in the following +way: + + $on_finish->( $pid, $exitcode ) + +The second argument is passed the plain perl C<$?> value. + +=item on_error => CODE + +Optional continuation to be called when the child code block throws an +exception, or the command could not be C<exec(2)>ed. It will be invoked in the +following way (as per C<spawn>) + + $on_error->( $pid, $exitcode, $dollarbang, $dollarat ) + +If this continuation is not supplied, then C<on_finish> is used instead. The +value of C<$!> and C<$@> will not be reported. + +=item setup => ARRAY + +Optional reference to an array to pass to the underlying C<spawn> method. + +=back + +In addition, the hash takes keys that define how to set up file descriptors in +the child process. (If the C<setup> array is also given, these operations will +be performed after those specified by C<setup>.) + +=over 8 + +=item fdI<n> => HASH + +A hash describing how to set up file descriptor I<n>. The hash may contain one +of the following sets of keys: + +=over 4 + +=item on_read => CODE + +The child will be given the writing end of a pipe. The reading end will be +wrapped by an C<IO::Async::Stream> using this C<on_read> callback function. + +=item from => STRING + +The child will be given the reading end of a pipe. The string given by the +C<from> parameter will be written to the child. When all of the data has been +written the pipe will be closed. + +=back + +=item stdin => ... + +=item stdout => ... + +=item stderr => ... + +Shortcuts for C<fd0>, C<fd1> and C<fd2> respectively. + +=back + +=cut + +sub open_child +{ + my $self = shift; + my %params = @_; + + my $on_finish = delete $params{on_finish}; + ref $on_finish or croak "Expected 'on_finish' to be a reference"; + $params{on_finish} = sub { + my ( $process, $exitcode ) = @_; + $on_finish->( $process->pid, $exitcode ); + }; + + if( my $on_error = delete $params{on_error} ) { + ref $on_error or croak "Expected 'on_error' to be a reference"; + + $params{on_exception} = sub { + my ( $process, $exception, $errno, $exitcode ) = @_; + # Swap order + $on_error->( $process->pid, $exitcode, $errno, $exception ); + }; + } + + $params{on_exit} and croak "Cannot pass 'on_exit' parameter through ChildManager->open"; + + require IO::Async::Process; + my $process = IO::Async::Process->new( %params ); + + $self->add( $process ); + + return $process->pid; +} + +=head2 $pid = $loop->run_child( %params ) + +This creates a new child process to run the given code block or command, +capturing its STDOUT and STDERR streams. When the process exits, a +continuation is invoked being passed the exitcode, and content of the streams. + +=over 8 + +=item command => ARRAY or STRING + +=item code => CODE + +The command or code to run in the child process (as per the C<spawn_child> +method) + +=item on_finish => CODE + +A continuation to be called when the child process exits and closed its STDOUT +and STDERR streams. It will be invoked in the following way: + + $on_finish->( $pid, $exitcode, $stdout, $stderr ) + +The second argument is passed the plain perl C<$?> value. + +=item stdin => STRING + +Optional. String to pass in to the child process's STDIN stream. + +=item setup => ARRAY + +Optional reference to an array to pass to the underlying C<spawn> method. + +=back + +This method is intended mainly as an IO::Async-compatible replacement for the +perl C<readpipe> function (`backticks`), allowing it to replace + + my $output = `command here`; + +with + + $loop->run_child( + command => "command here", + on_finish => sub { + my ( undef, $exitcode, $output ) = @_; + ... + } + ); + +=cut + +sub run_child +{ + my $self = shift; + my %params = @_; + + my $on_finish = delete $params{on_finish}; + ref $on_finish or croak "Expected 'on_finish' to be a reference"; + + my $stdout; + my $stderr; + + my %subparams; + + if( my $child_stdin = delete $params{stdin} ) { + ref $child_stdin and croak "Expected 'stdin' not to be a reference"; + $subparams{stdin} = { from => $child_stdin }; + } + + $subparams{code} = delete $params{code}; + $subparams{command} = delete $params{command}; + $subparams{setup} = delete $params{setup}; + + croak "Unrecognised parameters " . join( ", ", keys %params ) if keys %params; + + require IO::Async::Process; + my $process = IO::Async::Process->new( + %subparams, + stdout => { into => \$stdout }, + stderr => { into => \$stderr }, + + on_finish => sub { + my ( $process, $exitcode ) = @_; + $on_finish->( $process->pid, $exitcode, $stdout, $stderr ); + }, + ); + + $self->add( $process ); + + return $process->pid; +} + +=head2 $loop->resolver + +Returns the internally-stored L<IO::Async::Resolver> object, used for name +resolution operations by the C<resolve>, C<connect> and C<listen> methods. + +=cut + +sub resolver +{ + my $self = shift; + + return $self->{resolver} ||= do { + require IO::Async::Resolver; + my $resolver = IO::Async::Resolver->new; + $self->add( $resolver ); + $resolver; + } +} + +=head2 $loop->set_resolver( $resolver ) + +Sets the internally-stored L<IO::Async::Resolver> object. In most cases this +method should not be required, but it may be used to provide an alternative +resolver for special use-cases. + +=cut + +sub set_resolver +{ + my $self = shift; + my ( $resolver ) = @_; + + $resolver->can( $_ ) or croak "Resolver is unsuitable as it does not implement $_" + for qw( resolve getaddrinfo getnameinfo ); + + $self->{resolver} = $resolver; + + $self->add( $resolver ); +} + +=head2 @result = $loop->resolve( %params )->get + +This method performs a single name resolution operation. It uses an +internally-stored C<IO::Async::Resolver> object. For more detail, see the +C<resolve> method on the L<IO::Async::Resolver> class. + +=cut + +sub resolve +{ + my $self = shift; + my ( %params ) = @_; + + $self->resolver->resolve( %params ); +} + +=head2 $handle|$socket = $loop->connect( %params )->get + +This method performs a non-blocking connection to a given address or set of +addresses, returning a L<IO::Async::Future> which represents the operation. On +completion, the future will yield the connected socket handle, or the given +L<IO::Async::Handle> object. + +There are two modes of operation. Firstly, a list of addresses can be provided +which will be tried in turn. Alternatively as a convenience, if a host and +service name are provided instead of a list of addresses, these will be +resolved using the underlying loop's C<resolve> method into the list of +addresses. + +When attempting to connect to any among a list of addresses, there may be +failures among the first attempts, before a valid connection is made. For +example, the resolver may have returned some IPv6 addresses, but only IPv4 +routes are valid on the system. In this case, the first C<connect(2)> syscall +will fail. This isn't yet a fatal error, if there are more addresses to try, +perhaps some IPv4 ones. + +For this reason, it is possible that the operation eventually succeeds even +though some system calls initially fail. To be aware of individual failures, +the optional C<on_fail> callback can be used. This will be invoked on each +individual C<socket(2)> or C<connect(2)> failure, which may be useful for +debugging or logging. + +Because this module simply uses the C<getaddrinfo> resolver, it will be fully +IPv6-aware if the underlying platform's resolver is. This allows programs to +be fully IPv6-capable. + +In plain address mode, the C<%params> hash takes the following keys: + +=over 8 + +=item addrs => ARRAY + +Reference to an array of (possibly-multiple) address structures to attempt to +connect to. Each should be in the layout described for C<addr>. Such a layout +is returned by the C<getaddrinfo> named resolver. + +=item addr => HASH or ARRAY + +Shortcut for passing a single address to connect to; it may be passed directly +with this key, instead of in another array on its own. This should be in a +format recognised by L<IO::Async::OS>'s C<extract_addrinfo> method. + +This example shows how to use the C<Socket> functions to construct one for TCP +port 8001 on address 10.0.0.1: + + $loop->connect( + addr => { + family => "inet", + socktype => "stream", + port => 8001, + ip => "10.0.0.1", + }, + ... + ); + +This example shows another way to connect to a UNIX socket at F<echo.sock>. + + $loop->connect( + addr => { + family => "unix", + socktype => "stream", + path => "echo.sock", + }, + ... + ); + +=item local_addrs => ARRAY + +=item local_addr => HASH or ARRAY + +Optional. Similar to the C<addrs> or C<addr> parameters, these specify a local +address or set of addresses to C<bind(2)> the socket to before +C<connect(2)>ing it. + +=back + +When performing the resolution step too, the C<addrs> or C<addr> keys are +ignored, and instead the following keys are taken: + +=over 8 + +=item host => STRING + +=item service => STRING + +The hostname and service name to connect to. + +=item local_host => STRING + +=item local_service => STRING + +Optional. The hostname and/or service name to C<bind(2)> the socket to locally +before connecting to the peer. + +=item family => INT + +=item socktype => INT + +=item protocol => INT + +=item flags => INT + +Optional. Other arguments to pass along with C<host> and C<service> to the +C<getaddrinfo> call. + +=item socktype => STRING + +Optionally may instead be one of the values C<'stream'>, C<'dgram'> or +C<'raw'> to stand for C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_RAW>. This +utility is provided to allow the caller to avoid a separate C<use Socket> only +for importing these constants. + +=back + +It is necessary to pass the C<socktype> hint to the resolver when resolving +the host/service names into an address, as some OS's C<getaddrinfo> functions +require this hint. A warning is emitted if neither C<socktype> nor C<protocol> +hint is defined when performing a C<getaddrinfo> lookup. To avoid this warning +while still specifying no particular C<socktype> hint (perhaps to invoke some +OS-specific behaviour), pass C<0> as the C<socktype> value. + +In either case, it also accepts the following arguments: + +=over 8 + +=item handle => IO::Async::Handle + +Optional. If given a L<IO::Async::Handle> object or a subclass (such as +L<IO::Async::Stream> or L<IO::Async::Socket> its handle will be set to the +newly-connected socket on success, and that handle used as the result of the +future instead. + +=item on_fail => CODE + +Optional. After an individual C<socket(2)> or C<connect(2)> syscall has failed, +this callback is invoked to inform of the error. It is passed the name of the +syscall that failed, the arguments that were passed to it, and the error it +generated. I.e. + + $on_fail->( "socket", $family, $socktype, $protocol, $! ); + + $on_fail->( "bind", $sock, $address, $! ); + + $on_fail->( "connect", $sock, $address, $! ); + +Because of the "try all" nature when given a list of multiple addresses, this +callback may be invoked multiple times, even before an eventual success. + +=back + +This method accepts an C<extensions> parameter; see the C<EXTENSIONS> section +below. + +=head2 $loop->connect( %params ) + +When not returning a future, additional parameters can be given containing the +continuations to invoke on success or failure. + +=over 8 + +=item on_connected => CODE + +A continuation that is invoked on a successful C<connect(2)> call to a valid +socket. It will be passed the connected socket handle, as an C<IO::Socket> +object. + + $on_connected->( $handle ) + +=item on_stream => CODE + +An alternative to C<on_connected>, a continuation that is passed an instance +of L<IO::Async::Stream> when the socket is connected. This is provided as a +convenience for the common case that a Stream object is required as the +transport for a Protocol object. + + $on_stream->( $stream ) + +=item on_socket => CODE + +Similar to C<on_stream>, but constructs an instance of L<IO::Async::Socket>. +This is most useful for C<SOCK_DGRAM> or C<SOCK_RAW> sockets. + + $on_socket->( $socket ) + +=item on_connect_error => CODE + +A continuation that is invoked after all of the addresses have been tried, and +none of them succeeded. It will be passed the most significant error that +occurred, and the name of the operation it occurred in. Errors from the +C<connect(2)> syscall are considered most significant, then C<bind(2)>, then +finally C<socket(2)>. + + $on_connect_error->( $syscall, $! ) + +=item on_resolve_error => CODE + +A continuation that is invoked when the name resolution attempt fails. This is +invoked in the same way as the C<on_error> continuation for the C<resolve> +method. + +=back + +=cut + +sub connect +{ + my $self = shift; + my ( %params ) = @_; + + my $extensions; + if( $extensions = delete $params{extensions} and @$extensions ) { + my ( $ext, @others ) = @$extensions; + + my $method = "${ext}_connect"; + # TODO: Try to 'require IO::Async::$ext' + + $self->can( $method ) or croak "Extension method '$method' is not available"; + + return $self->$method( + %params, + ( @others ? ( extensions => \@others ) : () ), + ); + } + + my $handle = $params{handle}; + + my $on_done; + # Legacy callbacks + if( my $on_connected = delete $params{on_connected} ) { + $on_done = $on_connected; + } + elsif( my $on_stream = delete $params{on_stream} ) { + defined $handle and croak "Cannot pass 'on_stream' with a handle object as well"; + + require IO::Async::Stream; + # TODO: It doesn't make sense to put a SOCK_DGRAM in an + # IO::Async::Stream but currently we don't detect this + $handle = IO::Async::Stream->new; + $on_done = $on_stream; + } + elsif( my $on_socket = delete $params{on_socket} ) { + defined $handle and croak "Cannot pass 'on_socket' with a handle object as well"; + + require IO::Async::Socket; + $handle = IO::Async::Socket->new; + $on_done = $on_socket; + } + elsif( !defined wantarray ) { + croak "Expected 'on_connected' or 'on_stream' callback or to return a Future"; + } + + my $on_connect_error; + if( $on_connect_error = $params{on_connect_error} ) { + # OK + } + elsif( !defined wantarray ) { + croak "Expected 'on_connect_error' callback"; + } + + my $on_resolve_error; + if( $on_resolve_error = $params{on_resolve_error} ) { + # OK + } + elsif( !defined wantarray and exists $params{host} || exists $params{local_host} ) { + croak "Expected 'on_resolve_error' callback or to return a Future"; + } + + my $connector = $self->{connector} ||= $self->__new_feature( "IO::Async::Internals::Connector" ); + + my $future = $connector->connect( %params ); + + $future = $future->then( sub { + $handle->set_handle( shift ); + return Future->done( $handle ) + }) if $handle; + + $future->on_done( $on_done ) if $on_done; + $future->on_fail( sub { + $on_connect_error->( @_[2,3] ) if $on_connect_error and $_[1] eq "connect"; + $on_resolve_error->( $_[2] ) if $on_resolve_error and $_[1] eq "resolve"; + } ); + + return $future if defined wantarray; + + # Caller is not going to keep hold of the Future, so we have to ensure it + # stays alive somehow + $future->on_ready( sub { undef $future } ); # intentional cycle +} + +=head2 $listener = $loop->listen( %params )->get + +This method sets up a listening socket and arranges for an acceptor callback +to be invoked each time a new connection is accepted on the socket. Internally +it creates an instance of L<IO::Async::Listener> and adds it to the Loop if +not given one in the arguments. + +Addresses may be given directly, or they may be looked up using the system's +name resolver, or a socket handle may be given directly. + +If multiple addresses are given, or resolved from the service and hostname, +then each will be attempted in turn until one succeeds. + +In named resolver mode, the C<%params> hash takes the following keys: + +=over 8 + +=item service => STRING + +The service name to listen on. + +=item host => STRING + +The hostname to listen on. Optional. Will listen on all addresses if not +supplied. + +=item family => INT + +=item socktype => INT + +=item protocol => INT + +=item flags => INT + +Optional. Other arguments to pass along with C<host> and C<service> to the +C<getaddrinfo> call. + +=item socktype => STRING + +Optionally may instead be one of the values C<'stream'>, C<'dgram'> or +C<'raw'> to stand for C<SOCK_STREAM>, C<SOCK_DGRAM> or C<SOCK_RAW>. This +utility is provided to allow the caller to avoid a separate C<use Socket> only +for importing these constants. + +=back + +It is necessary to pass the C<socktype> hint to the resolver when resolving +the host/service names into an address, as some OS's C<getaddrinfo> functions +require this hint. A warning is emitted if neither C<socktype> nor C<protocol> +hint is defined when performing a C<getaddrinfo> lookup. To avoid this warning +while still specifying no particular C<socktype> hint (perhaps to invoke some +OS-specific behaviour), pass C<0> as the C<socktype> value. + +In plain address mode, the C<%params> hash takes the following keys: + +=over 8 + +=item addrs => ARRAY + +Reference to an array of (possibly-multiple) address structures to attempt to +listen on. Each should be in the layout described for C<addr>. Such a layout +is returned by the C<getaddrinfo> named resolver. + +=item addr => ARRAY + +Shortcut for passing a single address to listen on; it may be passed directly +with this key, instead of in another array of its own. This should be in a +format recognised by L<IO::Async::OS>'s C<extract_addrinfo> method. See also +the C<EXAMPLES> section. + +=back + +In direct socket handle mode, the following keys are taken: + +=over 8 + +=item handle => IO + +The listening socket handle. + +=back + +In either case, the following keys are also taken: + +=over 8 + +=item on_fail => CODE + +Optional. A callback that is invoked if a syscall fails while attempting to +create a listening sockets. It is passed the name of the syscall that failed, +the arguments that were passed to it, and the error generated. I.e. + + $on_fail->( "socket", $family, $socktype, $protocol, $! ); + + $on_fail->( "sockopt", $sock, $optname, $optval, $! ); + + $on_fail->( "bind", $sock, $address, $! ); + + $on_fail->( "listen", $sock, $queuesize, $! ); + +=item queuesize => INT + +Optional. The queue size to pass to the C<listen(2)> calls. If not supplied, +then 3 will be given instead. + +=item reuseaddr => BOOL + +Optional. If true or not supplied then the C<SO_REUSEADDR> socket option will +be set. To prevent this, pass a false value such as 0. + +=item v6only => BOOL + +Optional. If defined, sets or clears the C<IPV6_V6ONLY> socket option on +C<PF_INET6> sockets. This option disables the ability of C<PF_INET6> socket to +accept connections from C<AF_INET> addresses. Not all operating systems allow +this option to be disabled. + +=back + +An alternative which gives more control over the listener, is to create the +C<IO::Async::Listener> object directly and add it explicitly to the Loop. + +This method accepts an C<extensions> parameter; see the C<EXTENSIONS> section +below. + +=head2 $loop->listen( %params ) + +When not returning a future, additional parameters can be given containing the +continuations to invoke on success or failure. + +=over 8 + +=item on_notifier => CODE + +Optional. A callback that is invoked when the Listener object is ready to +receive connections. The callback is passed the Listener object itself. + + $on_notifier->( $listener ) + +If this callback is required, it may instead be better to construct the +Listener object directly. + +=item on_listen => CODE + +Optional. A callback that is invoked when the listening socket is ready. +Typically this would be used in the name resolver case, in order to inspect +the socket's sockname address, or otherwise inspect the filehandle. + + $on_listen->( $socket ) + +=item on_listen_error => CODE + +A continuation this is invoked after all of the addresses have been tried, and +none of them succeeded. It will be passed the most significant error that +occurred, and the name of the operation it occurred in. Errors from the +C<listen(2)> syscall are considered most significant, then C<bind(2)>, then +C<sockopt(2)>, then finally C<socket(2)>. + +=item on_resolve_error => CODE + +A continuation that is invoked when the name resolution attempt fails. This is +invoked in the same way as the C<on_error> continuation for the C<resolve> +method. + +=back + +=cut + +sub listen +{ + my $self = shift; + my ( %params ) = @_; + + my $remove_on_error; + my $listener = $params{listener} ||= do { + $remove_on_error++; + + require IO::Async::Listener; + + # Our wrappings of these don't want $listener + my %listenerparams; + for (qw( on_accept on_stream on_socket )) { + next unless exists $params{$_}; + croak "Cannot ->listen with '$_' and 'listener'" if $params{listener}; + + my $code = delete $params{$_}; + $listenerparams{$_} = sub { + shift; + goto &$code; + }; + } + + my $listener = IO::Async::Listener->new( %listenerparams ); + $self->add( $listener ); + $listener + }; + + my $extensions; + if( $extensions = delete $params{extensions} and @$extensions ) { + my ( $ext, @others ) = @$extensions; + + # We happen to know we break older IO::Async::SSL + if( $ext eq "SSL" and $IO::Async::SSL::VERSION < '0.12001' ) { + croak "IO::Async::SSL version too old; need at least 0.12_001; found $IO::Async::SSL::VERSION"; + } + + my $method = "${ext}_listen"; + # TODO: Try to 'require IO::Async::$ext' + + $self->can( $method ) or croak "Extension method '$method' is not available"; + + my $f = $self->$method( + %params, + ( @others ? ( extensions => \@others ) : () ), + ); + $f->on_fail( sub { $self->remove( $listener ) } ) if $remove_on_error; + + return $f; + } + + my $on_notifier = delete $params{on_notifier}; # optional + + my $on_listen_error = delete $params{on_listen_error}; + my $on_resolve_error = delete $params{on_resolve_error}; + + # Shortcut + if( $params{addr} and not $params{addrs} ) { + $params{addrs} = [ delete $params{addr} ]; + } + + my $f; + if( my $handle = delete $params{handle} ) { + $f = $self->_listen_handle( $listener, $handle, %params ); + } + elsif( my $addrs = delete $params{addrs} ) { + $on_listen_error or defined wantarray or + croak "Expected 'on_listen_error' or to return a Future"; + $f = $self->_listen_addrs( $listener, $addrs, %params ); + } + elsif( defined $params{service} ) { + $on_listen_error or defined wantarray or + croak "Expected 'on_listen_error' or to return a Future"; + $on_resolve_error or defined wantarray or + croak "Expected 'on_resolve_error' or to return a Future"; + $f = $self->_listen_hostservice( $listener, delete $params{host}, delete $params{service}, %params ); + } + else { + croak "Expected either 'service' or 'addrs' or 'addr' arguments"; + } + + $f->on_done( $on_notifier ) if $on_notifier; + if( my $on_listen = $params{on_listen} ) { + $f->on_done( sub { $on_listen->( shift->read_handle ) } ); + } + $f->on_fail( sub { + my ( $message, $how, @rest ) = @_; + $on_listen_error->( @rest ) if $on_listen_error and $how eq "listen"; + $on_resolve_error->( @rest ) if $on_resolve_error and $how eq "resolve"; + }); + $f->on_fail( sub { $self->remove( $listener ) } ) if $remove_on_error; + + return $f if defined wantarray; + + # Caller is not going to keep hold of the Future, so we have to ensure it + # stays alive somehow + $f->on_ready( sub { undef $f } ); # intentional cycle +} + +sub _listen_handle +{ + my $self = shift; + my ( $listener, $handle, %params ) = @_; + + $listener->configure( handle => $handle ); + return $self->new_future->done( $listener ); +} + +sub _listen_addrs +{ + my $self = shift; + my ( $listener, $addrs, %params ) = @_; + + my $queuesize = $params{queuesize} || 3; + + my $on_fail = $params{on_fail}; + !defined $on_fail or ref $on_fail or croak "Expected 'on_fail' to be a reference"; + + my $reuseaddr = 1; + $reuseaddr = 0 if defined $params{reuseaddr} and not $params{reuseaddr}; + + my $v6only = $params{v6only}; + + my ( $listenerr, $binderr, $sockopterr, $socketerr ); + + foreach my $addr ( @$addrs ) { + my ( $family, $socktype, $proto, $address ) = IO::Async::OS->extract_addrinfo( $addr ); + + my $sock; + + unless( $sock = IO::Async::OS->socket( $family, $socktype, $proto ) ) { + $socketerr = $!; + $on_fail->( socket => $family, $socktype, $proto, $! ) if $on_fail; + next; + } + + if( $reuseaddr ) { + unless( $sock->sockopt( SO_REUSEADDR, 1 ) ) { + $sockopterr = $!; + $on_fail->( sockopt => $sock, SO_REUSEADDR, 1, $! ) if $on_fail; + next; + } + } + + if( defined $v6only and $family == AF_INET6 ) { + unless( $sock->setsockopt( IPPROTO_IPV6, IPV6_V6ONLY, $v6only ) ) { + $sockopterr = $!; + $on_fail->( sockopt => $sock, IPV6_V6ONLY, $v6only, $! ) if $on_fail; + next; + } + } + + unless( $sock->bind( $address ) ) { + $binderr = $!; + $on_fail->( bind => $sock, $address, $! ) if $on_fail; + next; + } + + unless( $sock->listen( $queuesize ) ) { + $listenerr = $!; + $on_fail->( listen => $sock, $queuesize, $! ) if $on_fail; + next; + } + + return $self->_listen_handle( $listener, $sock, %params ); + } + + my $f = $self->new_future; + return $f->fail( "Cannot listen() - $listenerr", listen => listen => $listenerr ) if $listenerr; + return $f->fail( "Cannot bind() - $binderr", listen => bind => $binderr ) if $binderr; + return $f->fail( "Cannot setsockopt() - $sockopterr", listen => sockopt => $sockopterr ) if $sockopterr; + return $f->fail( "Cannot socket() - $socketerr", listen => socket => $socketerr ) if $socketerr; + die 'Oops; $loop->listen failed but no error cause was found'; +} + +sub _listen_hostservice +{ + my $self = shift; + my ( $listener, $host, $service, %params ) = @_; + + $host ||= ""; + defined $service or $service = ""; # might be 0 + + my %gai_hints; + exists $params{$_} and $gai_hints{$_} = $params{$_} for qw( family socktype protocol flags ); + + defined $gai_hints{socktype} or defined $gai_hints{protocol} or + carp "Attempting to ->listen without either 'socktype' or 'protocol' hint is not portable"; + + $self->resolver->getaddrinfo( + host => $host, + service => $service, + passive => 1, + %gai_hints, + )->then( sub { + my @addrs = @_; + $self->_listen_addrs( $listener, \@addrs, %params ); + }); +} + +=head1 OS ABSTRACTIONS + +Because the Magic Constructor searches for OS-specific subclasses of the Loop, +several abstractions of OS services are provided, in case specific OSes need +to give different implementations on that OS. + +=cut + +=head2 $signum = $loop->signame2num( $signame ) + +Legacy wrappers around L<IO::Async::OS> functions. + +=cut + +sub signame2num { shift; IO::Async::OS->signame2num( @_ ) } + +=head2 $time = $loop->time + +Returns the current UNIX time in fractional seconds. This is currently +equivalent to C<Time::HiRes::time> but provided here as a utility for +programs to obtain the time current used by C<IO::Async> for its own timing +purposes. + +=cut + +sub time +{ + my $self = shift; + return Time::HiRes::time; +} + +=head2 $pid = $loop->fork( %params ) + +This method creates a new child process to run a given code block, returning +its process ID. + +=over 8 + +=item code => CODE + +A block of code to execute in the child process. It will be called in scalar +context inside an C<eval> block. The return value will be used as the +C<exit(2)> code from the child if it returns (or 255 if it returned C<undef> or +thows an exception). + +=item on_exit => CODE + +A optional continuation to be called when the child processes exits. It will +be invoked in the following way: + + $on_exit->( $pid, $exitcode ) + +The second argument is passed the plain perl C<$?> value. + +This key is optional; if not supplied, the calling code should install a +handler using the C<watch_child> method. + +=item keep_signals => BOOL + +Optional boolean. If missing or false, any CODE references in the C<%SIG> hash +will be removed and restored back to C<DEFAULT> in the child process. If true, +no adjustment of the C<%SIG> hash will be performed. + +=back + +=cut + +sub fork +{ + my $self = shift; + my %params = @_; + + HAVE_POSIX_FORK or croak "POSIX fork() is not available"; + + my $code = $params{code} or croak "Expected 'code' as a CODE reference"; + + my $kid = fork; + defined $kid or croak "Cannot fork() - $!"; + + if( $kid == 0 ) { + unless( $params{keep_signals} ) { + foreach( keys %SIG ) { + next if m/^__(WARN|DIE)__$/; + $SIG{$_} = "DEFAULT" if ref $SIG{$_} eq "CODE"; + } + } + + my $exitvalue = eval { $code->() }; + + defined $exitvalue or $exitvalue = -1; + + POSIX::_exit( $exitvalue ); + } + + if( defined $params{on_exit} ) { + $self->watch_child( $kid => $params{on_exit} ); + } + + return $kid; +} + +=head2 $tid = $loop->create_thread( %params ) + +This method creates a new (non-detached) thread to run the given code block, +returning its thread ID. + +=over 8 + +=item code => CODE + +A block of code to execute in the thread. It is called in the context given by +the C<context> argument, and its return value will be available to the +C<on_joined> callback. It is called inside an C<eval> block; if it fails the +exception will be caught. + +=item context => "scalar" | "list" | "void" + +Optional. Gives the calling context that C<code> is invoked in. Defaults to +C<scalar> if not supplied. + +=item on_joined => CODE + +Callback to invoke when the thread function returns or throws an exception. +If it returned, this callback will be invoked with its result + + $on_joined->( return => @result ) + +If it threw an exception the callback is invoked with the value of C<$@> + + $on_joined->( died => $! ) + +=back + +=cut + +# It is basically impossible to have any semblance of order on global +# destruction, and even harder again to rely on when threads are going to be +# terminated and joined. Instead of ensuring we join them all, just detach any +# we no longer care about at END time +my %threads_to_detach; # {$tid} = $thread_weakly +END { + $_ and $_->detach for values %threads_to_detach; +} + +sub create_thread +{ + my $self = shift; + my %params = @_; + + HAVE_THREADS or croak "Threads are not available"; + + eval { require threads } or croak "This Perl does not support threads"; + + my $code = $params{code} or croak "Expected 'code' as a CODE reference"; + my $on_joined = $params{on_joined} or croak "Expected 'on_joined' as a CODE reference"; + + my $threadwatches = $self->{threadwatches}; + + unless( $self->{thread_join_pipe} ) { + ( my $rd, $self->{thread_join_pipe} ) = IO::Async::OS->pipepair or + croak "Cannot pipepair - $!"; + $self->{thread_join_pipe}->autoflush(1); + + $self->watch_io( + handle => $rd, + on_read_ready => sub { + sysread $rd, my $buffer, 8192 or return; + + # There's a race condition here in that we might have read from + # the pipe after the returning thread has written to it but before + # it has returned. We'll grab the actual $thread object and + # forcibly ->join it here to ensure we wait for its result. + + foreach my $tid ( unpack "N*", $buffer ) { + my ( $thread, $on_joined ) = @{ delete $threadwatches->{$tid} } + or die "ARGH: Can't find threadwatch for tid $tid\n"; + $on_joined->( $thread->join ); + delete $threads_to_detach{$tid}; + } + } + ); + } + + my $wr = $self->{thread_join_pipe}; + + my $context = $params{context} || "scalar"; + + my ( $thread ) = threads->create( + sub { + my ( @ret, $died ); + eval { + $context eq "list" ? ( @ret = $code->() ) : + $context eq "scalar" ? ( $ret[0] = $code->() ) : + $code->(); + 1; + } or $died = $@; + + $wr->syswrite( pack "N", threads->tid ); + + return died => $died if $died; + return return => @ret; + } + ); + + $threadwatches->{$thread->tid} = [ $thread, $on_joined ]; + weaken( $threads_to_detach{$thread->tid} = $thread ); + + return $thread->tid; +} + +=head1 LOW-LEVEL METHODS + +As C<IO::Async::Loop> is an abstract base class, specific subclasses of it are +required to implement certain methods that form the base level of +functionality. They are not recommended for applications to use; see instead +the various event objects or higher level methods listed above. + +These methods should be considered as part of the interface contract required +to implement a C<IO::Async::Loop> subclass. + +=cut + +=head2 IO::Async::Loop->API_VERSION + +This method will be called by the magic constructor on the class before it is +constructed, to ensure that the specific implementation will support the +required API. This method should return the API version that the loop +implementation supports. The magic constructor will use that class, provided +it declares a version at least as new as the version documented here. + +The current API version is C<0.49>. + +This method may be implemented using C<constant>; e.g + + use constant API_VERSION => '0.49'; + +=cut + +=head2 $loop->watch_io( %params ) + +This method installs callback functions which will be invoked when the given +IO handle becomes read- or write-ready. + +The C<%params> hash takes the following keys: + +=over 8 + +=item handle => IO + +The IO handle to watch. + +=item on_read_ready => CODE + +Optional. A CODE reference to call when the handle becomes read-ready. + +=item on_write_ready => CODE + +Optional. A CODE reference to call when the handle becomes write-ready. + +=back + +There can only be one filehandle of any given fileno registered at any one +time. For any one filehandle, there can only be one read-readiness and/or one +write-readiness callback at any one time. Registering a new one will remove an +existing one of that type. It is not required that both are provided. + +Applications should use a C<IO::Async::Handle> or C<IO::Async::Stream> instead +of using this method. + +If the filehandle does not yet have the C<O_NONBLOCK> flag set, it will be +enabled by this method. This will ensure that any subsequent C<sysread>, +C<syswrite>, or similar will not block on the filehandle. + +=cut + +# This class specifically does NOT implement this method, so that subclasses +# are forced to. The constructor will be checking.... +sub __watch_io +{ + my $self = shift; + my %params = @_; + + my $handle = delete $params{handle} or croak "Expected 'handle'"; + defined eval { $handle->fileno } or croak "Expected that 'handle' has defined ->fileno"; + + # Silent "upgrade" to O_NONBLOCK + $handle->blocking and $handle->blocking(0); + + my $watch = ( $self->{iowatches}->{$handle->fileno} ||= [] ); + + $watch->[0] = $handle; + + if( exists $params{on_read_ready} ) { + $watch->[1] = delete $params{on_read_ready}; + } + + if( exists $params{on_write_ready} ) { + $watch->[2] = delete $params{on_write_ready}; + } + + if( exists $params{on_hangup} ) { + $self->_CAN_ON_HANGUP or croak "Cannot watch_io for 'on_hangup' in ".ref($self); + $watch->[3] = delete $params{on_hangup}; + } + + keys %params and croak "Unrecognised keys for ->watch_io - " . join( ", ", keys %params ); +} + +=head2 $loop->unwatch_io( %params ) + +This method removes a watch on an IO handle which was previously installed by +C<watch_io>. + +The C<%params> hash takes the following keys: + +=over 8 + +=item handle => IO + +The IO handle to remove the watch for. + +=item on_read_ready => BOOL + +If true, remove the watch for read-readiness. + +=item on_write_ready => BOOL + +If true, remove the watch for write-readiness. + +=back + +Either or both callbacks may be removed at once. It is not an error to attempt +to remove a callback that is not present. If both callbacks were provided to +the C<watch_io> method and only one is removed by this method, the other shall +remain. + +=cut + +sub __unwatch_io +{ + my $self = shift; + my %params = @_; + + my $handle = delete $params{handle} or croak "Expected 'handle'"; + + my $watch = $self->{iowatches}->{$handle->fileno} or return; + + if( delete $params{on_read_ready} ) { + undef $watch->[1]; + } + + if( delete $params{on_write_ready} ) { + undef $watch->[2]; + } + + if( delete $params{on_hangup} ) { + $self->_CAN_ON_HANGUP or croak "Cannot watch_io for 'on_hangup' in ".ref($self); + undef $watch->[3]; + } + + if( not $watch->[1] and not $watch->[2] and not $watch->[3] ) { + delete $self->{iowatches}->{$handle->fileno}; + } + + keys %params and croak "Unrecognised keys for ->unwatch_io - " . join( ", ", keys %params ); +} + +=head2 $loop->watch_signal( $signal, $code ) + +This method adds a new signal handler to watch the given signal. + +=over 8 + +=item $signal + +The name of the signal to watch to. This should be a bare name like C<TERM>. + +=item $code + +A CODE reference to the handling callback. + +=back + +There can only be one callback per signal name. Registering a new one will +remove an existing one. + +Applications should use a C<IO::Async::Signal> object, or call +C<attach_signal> instead of using this method. + +This and C<unwatch_signal> are optional; a subclass may implement neither, or +both. If it implements neither then signal handling will be performed by the +base class using a self-connected pipe to interrupt the main IO blocking. + +=cut + +sub watch_signal +{ + my $self = shift; + my ( $signal, $code ) = @_; + + HAVE_SIGNALS or croak "This OS cannot ->watch_signal"; + + IO::Async::OS->loop_watch_signal( $self, $signal, $code ); +} + +=head2 $loop->unwatch_signal( $signal ) + +This method removes the signal callback for the given signal. + +=over 8 + +=item $signal + +The name of the signal to watch to. This should be a bare name like C<TERM>. + +=back + +=cut + +sub unwatch_signal +{ + my $self = shift; + my ( $signal ) = @_; + + HAVE_SIGNALS or croak "This OS cannot ->unwatch_signal"; + + IO::Async::OS->loop_unwatch_signal( $self, $signal ); +} + +=head2 $id = $loop->watch_time( %args ) + +This method installs a callback which will be called at the specified time. +The time may either be specified as an absolute value (the C<at> key), or +as a delay from the time it is installed (the C<after> key). + +The returned C<$id> value can be used to identify the timer in case it needs +to be cancelled by the C<unwatch_time> method. Note that this value may be +an object reference, so if it is stored, it should be released after it has +been fired or cancelled, so the object itself can be freed. + +The C<%params> hash takes the following keys: + +=over 8 + +=item at => NUM + +The absolute system timestamp to run the event. + +=item after => NUM + +The delay after now at which to run the event, if C<at> is not supplied. A +zero or negative delayed timer should be executed as soon as possible; the +next time the C<loop_once> method is invoked. + +=item now => NUM + +The time to consider as now if calculating an absolute time based on C<after>; +defaults to C<time()> if not specified. + +=item code => CODE + +CODE reference to the continuation to run at the allotted time. + +=back + +Either one of C<at> or C<after> is required. + +For more powerful timer functionality as a C<IO::Async::Notifier> (so it can +be used as a child within another Notifier), see instead the +L<IO::Async::Timer> object and its subclasses. + +These C<*_time> methods are optional; a subclass may implement neither or both +of them. If it implements neither, then the base class will manage a queue of +timer events. This queue should be handled by the C<loop_once> method +implemented by the subclass, using the C<_adjust_timeout> and +C<_manage_queues> methods. + +This is the newer version of the API, replacing C<enqueue_timer>. It is +unspecified how this method pair interacts with the older +C<enqueue/requeue/cancel_timer> triplet. + +=cut + +sub watch_time +{ + my $self = shift; + my %args = @_; + + # Renamed args + if( exists $args{after} ) { + $args{delay} = delete $args{after}; + } + elsif( exists $args{at} ) { + $args{time} = delete $args{at}; + } + else { + croak "Expected one of 'at' or 'after'"; + } + + if( $self->{old_timer} ) { + $self->enqueue_timer( %args ); + } + else { + my $timequeue = $self->{timequeue} ||= $self->__new_feature( "IO::Async::Internals::TimeQueue" ); + + my $time = $self->_build_time( %args ); + my $code = $args{code}; + + $timequeue->enqueue( time => $time, code => $code ); + } +} + +=head2 $loop->unwatch_time( $id ) + +Removes a timer callback previously created by C<watch_time>. + +This is the newer version of the API, replacing C<cancel_timer>. It is +unspecified how this method pair interacts with the older +C<enqueue/requeue/cancel_timer> triplet. + +=cut + +sub unwatch_time +{ + my $self = shift; + my ( $id ) = @_; + + if( $self->{old_timer} ) { + $self->cancel_timer( $id ); + } + else { + my $timequeue = $self->{timequeue} ||= $self->__new_feature( "IO::Async::Internals::TimeQueue" ); + + $timequeue->cancel( $id ); + } +} + +sub _build_time +{ + my $self = shift; + my %params = @_; + + my $time; + if( exists $params{time} ) { + $time = $params{time}; + } + elsif( exists $params{delay} ) { + my $now = exists $params{now} ? $params{now} : $self->time; + + $time = $now + $params{delay}; + } + else { + croak "Expected either 'time' or 'delay' keys"; + } + + return $time; +} + +=head2 $id = $loop->enqueue_timer( %params ) + +An older version of C<watch_time>. This method should not be used in new code +but is retained for legacy purposes. For simple watch/unwatch behaviour use +instead the new C<watch_time> method; though note it has differently-named +arguments. For requeueable timers, consider using an +L<IO::Async::Timer::Countdown> or L<IO::Async::Timer::Absolute> instead. + +=cut + +sub enqueue_timer +{ + my $self = shift; + my ( %params ) = @_; + + # Renamed args + $params{after} = delete $params{delay} if exists $params{delay}; + $params{at} = delete $params{time} if exists $params{time}; + + my $code = $params{code}; + return [ $self->watch_time( %params ), $code ]; +} + +=head2 $loop->cancel_timer( $id ) + +An older version of C<unwatch_time>. This method should not be used in new +code but is retained for legacy purposes. + +=cut + +sub cancel_timer +{ + my $self = shift; + my ( $id ) = @_; + $self->unwatch_time( $id->[0] ); +} + +=head2 $newid = $loop->requeue_timer( $id, %params ) + +Reschedule an existing timer, moving it to a new time. The old timer is +removed and will not be invoked. + +The C<%params> hash takes the same keys as C<enqueue_timer>, except for the +C<code> argument. + +The requeue operation may be implemented as a cancel + enqueue, which may +mean the ID changes. Be sure to store the returned C<$newid> value if it is +required. + +This method should not be used in new code but is retained for legacy +purposes. For requeueable, consider using an L<IO::Async::Timer::Countdown> or +L<IO::Async::Timer::Absolute> instead. + +=cut + +sub requeue_timer +{ + my $self = shift; + my ( $id, %params ) = @_; + + $self->unwatch_time( $id->[0] ); + return $self->enqueue_timer( %params, code => $id->[1] ); +} + +=head2 $id = $loop->watch_idle( %params ) + +This method installs a callback which will be called at some point in the near +future. + +The C<%params> hash takes the following keys: + +=over 8 + +=item when => STRING + +Specifies the time at which the callback will be invoked. See below. + +=item code => CODE + +CODE reference to the continuation to run at the allotted time. + +=back + +The C<when> parameter defines the time at which the callback will later be +invoked. Must be one of the following values: + +=over 8 + +=item later + +Callback is invoked after the current round of IO events have been processed +by the loop's underlying C<loop_once> method. + +If a new idle watch is installed from within a C<later> callback, the +installed one will not be invoked during this round. It will be deferred for +the next time C<loop_once> is called, after any IO events have been handled. + +=back + +If there are pending idle handlers, then the C<loop_once> method will use a +zero timeout; it will return immediately, having processed any IO events and +idle handlers. + +The returned C<$id> value can be used to identify the idle handler in case it +needs to be removed, by calling the C<unwatch_idle> method. Note this value +may be a reference, so if it is stored it should be released after the +callback has been invoked or cancled, so the referrant itself can be freed. + +This and C<unwatch_idle> are optional; a subclass may implement neither, or +both. If it implements neither then idle handling will be performed by the +base class, using the C<_adjust_timeout> and C<_manage_queues> methods. + +=cut + +sub watch_idle +{ + my $self = shift; + my %params = @_; + + my $code = delete $params{code}; + ref $code or croak "Expected 'code' to be a reference"; + + my $when = delete $params{when} or croak "Expected 'when'"; + + # Future-proofing for other idle modes + $when eq "later" or croak "Expected 'when' to be 'later'"; + + my $deferrals = $self->{deferrals}; + + push @$deferrals, $code; + return \$deferrals->[-1]; +} + +=head2 $loop->unwatch_idle( $id ) + +Cancels a previously-installed idle handler. + +=cut + +sub unwatch_idle +{ + my $self = shift; + my ( $id ) = @_; + + my $deferrals = $self->{deferrals}; + + my $idx; + \$deferrals->[$_] == $id and ( $idx = $_ ), last for 0 .. $#$deferrals; + + splice @$deferrals, $idx, 1, () if defined $idx; +} + +sub _reap_children +{ + my ( $childwatches ) = @_; + + while( 1 ) { + my $zid = waitpid( -1, WNOHANG ); + + # PIDs on MSWin32 can be negative + last if !defined $zid or $zid == 0 or $zid == -1; + my $status = $?; + + if( defined $childwatches->{$zid} ) { + $childwatches->{$zid}->( $zid, $status ); + delete $childwatches->{$zid}; + } + + if( defined $childwatches->{0} ) { + $childwatches->{0}->( $zid, $status ); + # Don't delete it + } + } +} + +=head2 $loop->watch_child( $pid, $code ) + +This method adds a new handler for the termination of the given child process +PID, or all child processes. + +=over 8 + +=item $pid + +The PID to watch. Will report on all child processes if this is 0. + +=item $code + +A CODE reference to the exit handler. It will be invoked as + + $code->( $pid, $? ) + +The second argument is passed the plain perl C<$?> value. + +=back + +After invocation, the handler for a PID-specific watch is automatically +removed. The all-child watch will remain until it is removed by +C<unwatch_child>. + +This and C<unwatch_child> are optional; a subclass may implement neither, or +both. If it implements neither then child watching will be performed by using +C<watch_signal> to install a C<SIGCHLD> handler, which will use C<waitpid> to +look for exited child processes. + +If both a PID-specific and an all-process watch are installed, there is no +ordering guarantee as to which will be called first. + +=cut + +sub watch_child +{ + my $self = shift; + my ( $pid, $code ) = @_; + + my $childwatches = $self->{childwatches}; + + croak "Already have a handler for $pid" if exists $childwatches->{$pid}; + + if( HAVE_SIGNALS and !$self->{childwatch_sigid} ) { + $self->{childwatch_sigid} = $self->attach_signal( + CHLD => sub { _reap_children( $childwatches ) } + ); + + # There's a chance the child has already exited + my $zid = waitpid( $pid, WNOHANG ); + if( defined $zid and $zid > 0 ) { + my $exitstatus = $?; + $self->later( sub { $code->( $pid, $exitstatus ) } ); + return; + } + } + + $childwatches->{$pid} = $code; +} + +=head2 $loop->unwatch_child( $pid ) + +This method removes a watch on an existing child process PID. + +=cut + +sub unwatch_child +{ + my $self = shift; + my ( $pid ) = @_; + + my $childwatches = $self->{childwatches}; + + delete $childwatches->{$pid}; + + if( HAVE_SIGNALS and !keys %$childwatches ) { + $self->detach_signal( CHLD => delete $self->{childwatch_sigid} ); + } +} + +=head1 METHODS FOR SUBCLASSES + +The following methods are provided to access internal features which are +required by specific subclasses to implement the loop functionality. The use +cases of each will be documented in the above section. + +=cut + +=head2 $loop->_adjust_timeout( \$timeout ) + +Shortens the timeout value passed in the scalar reference if it is longer in +seconds than the time until the next queued event on the timer queue. If there +are pending idle handlers, the timeout is reduced to zero. + +=cut + +sub _adjust_timeout +{ + my $self = shift; + my ( $timeref, %params ) = @_; + + $$timeref = 0, return if @{ $self->{deferrals} }; + + if( defined $self->{sigproxy} and !$params{no_sigwait} ) { + $$timeref = $MAX_SIGWAIT_TIME if !defined $$timeref or $$timeref > $MAX_SIGWAIT_TIME; + } + if( !HAVE_SIGNALS and keys %{ $self->{childwatches} } ) { + $$timeref = $MAX_CHILDWAIT_TIME if !defined $$timeref or $$timeref > $MAX_CHILDWAIT_TIME; + } + + my $timequeue = $self->{timequeue}; + return unless defined $timequeue; + + my $nexttime = $timequeue->next_time; + return unless defined $nexttime; + + my $now = exists $params{now} ? $params{now} : $self->time; + my $timer_delay = $nexttime - $now; + + if( $timer_delay < 0 ) { + $$timeref = 0; + } + elsif( !defined $$timeref or $timer_delay < $$timeref ) { + $$timeref = $timer_delay; + } +} + +=head2 $loop->_manage_queues + +Checks the timer queue for callbacks that should have been invoked by now, and +runs them all, removing them from the queue. It also invokes all of the +pending idle handlers. Any new idle handlers installed by these are not +invoked yet; they will wait for the next time this method is called. + +=cut + +sub _manage_queues +{ + my $self = shift; + + my $count = 0; + + my $timequeue = $self->{timequeue}; + $count += $timequeue->fire if $timequeue; + + my $deferrals = $self->{deferrals}; + $self->{deferrals} = []; + + foreach my $code ( @$deferrals ) { + $code->(); + $count++; + } + + my $childwatches = $self->{childwatches}; + if( !HAVE_SIGNALS and keys %$childwatches ) { + _reap_children( $childwatches ); + } + + return $count; +} + +=head1 EXTENSIONS + +An Extension is a Perl module that provides extra methods in the +C<IO::Async::Loop> or other packages. They are intended to provide extra +functionality that easily integrates with the rest of the code. + +Certain base methods take an C<extensions> parameter; an ARRAY reference +containing a list of extension names. If such a list is passed to a method, it +will immediately call a method whose name is that of the base method, prefixed +by the first extension name in the list, separated by C<_>. If the +C<extensions> list contains more extension names, it will be passed the +remaining ones in another C<extensions> parameter. + +For example, + + $loop->connect( + extensions => [qw( FOO BAR )], + %args + ) + +will become + + $loop->FOO_connect( + extensions => [qw( BAR )], + %args + ) + +This is provided so that extension modules, such as L<IO::Async::SSL> can +easily be invoked indirectly, by passing extra arguments to C<connect> methods +or similar, without needing every module to be aware of the C<SSL> extension. +This functionality is generic and not limited to C<SSL>; other extensions may +also use it. + +The following methods take an C<extensions> parameter: + + $loop->connect + $loop->listen + +If an extension C<listen> method is invoked, it will be passed a C<listener> +parameter even if one was not provided to the original C<< $loop->listen >> +call, and it will not receive any of the C<on_*> event callbacks. It should +use the C<acceptor> parameter on the C<listener> object. + +=cut + +=head1 STALL WATCHDOG + +A well-behaved C<IO::Async> program should spend almost all of its time +blocked on input using the underlying C<IO::Async::Loop> instance. The stall +watchdog is an optional debugging feature to help detect CPU spinlocks and +other bugs, where control is not returned to the loop every so often. + +If the watchdog is enabled and an event handler consumes more than a given +amount of real time before returning to the event loop, it will be interrupted +by printing a stack trace and terminating the program. The watchdog is only in +effect while the loop itself is not blocking; it won't fail simply because the +loop instance is waiting for input or timers. + +It is implemented using C<SIGALRM>, so if enabled, this signal will no longer +be available to user code. (Though in any case, most uses of C<alarm()> and +C<SIGALRM> are better served by one of the L<IO::Async::Timer> subclasses). + +The following environment variables control its behaviour. + +=over 4 + +=item IO_ASYNC_WATCHDOG => BOOL + +Enables the stall watchdog if set to a non-zero value. + +=item IO_ASYNC_WATCHDOG_INTERVAL => INT + +Watchdog interval, in seconds, to pass to the C<alarm(2)> call. Defaults to 10 +seconds. + +=item IO_ASYNC_WATCHDOG_SIGABRT => BOOL + +If enabled, the watchdog signal handler will raise a C<SIGABRT>, which usually +has the effect of breaking out of a running program in debuggers such as +F<gdb>. If not set then the process is terminated by throwing an exception with +C<die>. + +=back + +=cut + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Loop/Poll.pm b/lib/IO/Async/Loop/Poll.pm new file mode 100644 index 0000000..fb7bbf1 --- /dev/null +++ b/lib/IO/Async/Loop/Poll.pm @@ -0,0 +1,350 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2007-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Loop::Poll; + +use strict; +use warnings; + +our $VERSION = '0.67'; +use constant API_VERSION => '0.49'; + +use base qw( IO::Async::Loop ); + +use Carp; + +use IO::Poll qw( POLLIN POLLOUT POLLPRI POLLHUP POLLERR ); + +use Errno qw( EINTR ); +use Fcntl qw( S_ISREG ); + +# Only Linux, or FreeBSD 8.0 and above, are known always to be able to report +# EOF conditions on filehandles using POLLHUP +use constant _CAN_ON_HANGUP => + ( $^O eq "linux" ) || + ( $^O eq "freebsd" and do { no warnings 'numeric'; (POSIX::uname)[2] >= 8.0 } ); + +# poll() on most platforms claims that ISREG files are always read- and +# write-ready, but not on MSWin32. We need to fake this +use constant FAKE_ISREG_READY => IO::Async::OS->HAVE_FAKE_ISREG_READY; +# poll() on most platforms indicates POLLOUT when connect() fails, but not on +# MSWin32. Have to poll also for POLLPRI in that case +use constant POLL_CONNECT_POLLPRI => IO::Async::OS->HAVE_POLL_CONNECT_POLLPRI; + +use constant _CAN_WATCHDOG => 1; +use constant WATCHDOG_ENABLE => IO::Async::Loop->WATCHDOG_ENABLE; + +=head1 NAME + +C<IO::Async::Loop::Poll> - use C<IO::Async> with C<poll(2)> + +=head1 SYNOPSIS + +Normally an instance of this class would not be directly constructed by a +program. It may however, be useful for runinng L<IO::Async> with an existing +program already using an C<IO::Poll> object. + + use IO::Poll; + use IO::Async::Loop::Poll; + + my $poll = IO::Poll->new; + my $loop = IO::Async::Loop::Poll->new( poll => $poll ); + + $loop->add( ... ); + + while(1) { + my $timeout = ... + my $ret = $poll->poll( $timeout ); + $loop->post_poll; + } + +=head1 DESCRIPTION + +This subclass of C<IO::Async::Loop> uses the C<poll(2)> system call to perform +read-ready and write-ready tests. + +By default, this loop will use the underlying C<poll()> system call directly, +bypassing the usual L<IO::Poll> object wrapper around it because of a number +of bugs and design flaws in that class; namely + +=over 2 + +=item * + +L<https://rt.cpan.org/Ticket/Display.html?id=93107> - IO::Poll relies on +stable stringification of IO handles + +=item * + +L<https://rt.cpan.org/Ticket/Display.html?id=25049> - IO::Poll->poll() with no +handles always returns immediately + +=back + +However, to integrate with existing code that uses an C<IO::Poll> object, a +C<post_poll> can be called immediately after the C<poll> method that +C<IO::Poll> object. The appropriate mask bits are maintained on the +C<IO::Poll> object when notifiers are added or removed from the loop, or when +they change their C<want_*> status. The C<post_poll> method inspects the +result bits and invokes the C<on_read_ready> or C<on_write_ready> methods on +the notifiers. + +=cut + +=head1 CONSTRUCTOR + +=cut + +=head2 $loop = IO::Async::Loop::Poll->new( %args ) + +This function returns a new instance of a C<IO::Async::Loop::Poll> object. It +takes the following named arguments: + +=over 8 + +=item C<poll> + +The C<IO::Poll> object to use for notification. Optional; if a value is not +given, the underlying C<IO::Poll::_poll()> function is invoked directly, +outside of the object wrapping. + +=back + +=cut + +sub new +{ + my $class = shift; + my ( %args ) = @_; + + my $poll = delete $args{poll}; + + my $self = $class->__new( %args ); + + $self->{poll} = $poll; + $self->{pollmask} = {}; + + return $self; +} + +=head1 METHODS + +=cut + +=head2 $count = $loop->post_poll + +This method checks the returned event list from a C<IO::Poll::poll> call, +and calls any of the notification methods or callbacks that are appropriate. +It returns the total number of callbacks that were invoked; that is, the +total number of C<on_read_ready> and C<on_write_ready> callbacks for +C<watch_io>, and C<watch_time> event callbacks. + +=cut + +sub post_poll +{ + my $self = shift; + + my $iowatches = $self->{iowatches}; + my $poll = $self->{poll}; + + my $count = 0; + + alarm( IO::Async::Loop->WATCHDOG_INTERVAL ) if WATCHDOG_ENABLE; + + foreach my $fd ( keys %$iowatches ) { + my $watch = $iowatches->{$fd} or next; + + my $events = $poll ? $poll->events( $watch->[0] ) + : $self->{pollevents}{$fd}; + if( FAKE_ISREG_READY and $self->{fake_isreg}{$fd} ) { + $events |= $self->{fake_isreg}{$fd} & ( POLLIN|POLLOUT ); + } + + # We have to test separately because kernel doesn't report POLLIN when + # a pipe gets closed. + if( $events & (POLLIN|POLLHUP|POLLERR) ) { + $count++, $watch->[1]->() if defined $watch->[1]; + } + + if( $events & (POLLOUT|POLLPRI|POLLHUP|POLLERR) ) { + $count++, $watch->[2]->() if defined $watch->[2]; + } + + if( $events & (POLLHUP|POLLERR) ) { + $count++, $watch->[3]->() if defined $watch->[3]; + } + } + + # Since we have no way to know if the timeout occured, we'll have to + # attempt to fire any waiting timeout events anyway + $count += $self->_manage_queues; + + alarm( 0 ) if WATCHDOG_ENABLE; + + return $count; +} + +=head2 $count = $loop->loop_once( $timeout ) + +This method calls the C<poll> method on the stored C<IO::Poll> object, +passing in the value of C<$timeout>, and then runs the C<post_poll> method +on itself. It returns the total number of callbacks invoked by the +C<post_poll> method, or C<undef> if the underlying C<poll> method returned +an error. + +=cut + +sub loop_once +{ + my $self = shift; + my ( $timeout ) = @_; + + $self->_adjust_timeout( \$timeout ); + + $timeout = 0 if FAKE_ISREG_READY and keys %{ $self->{fake_isreg} }; + + # Round up to nearest millisecond + if( $timeout ) { + my $mils = $timeout * 1000; + my $fraction = $mils - int $mils; + $timeout += ( 1 - $fraction ) / 1000 if $fraction; + } + + if( my $poll = $self->{poll} ) { + my $pollret; + + # There is a bug in IO::Poll at least version 0.07, where poll with no + # registered masks returns immediately, rather than waiting for a timeout + # This has been reported: + # http://rt.cpan.org/Ticket/Display.html?id=25049 + if( $poll->handles ) { + $pollret = $poll->poll( $timeout ); + + if( ( $pollret == -1 and $! == EINTR ) or $pollret == 0 + and defined $self->{sigproxy} ) { + # A signal occured and we have a sigproxy. Allow one more poll call + # with zero timeout. If it finds something, keep that result. If it + # finds nothing, keep -1 + + # Preserve $! whatever happens + local $!; + + my $secondattempt = $poll->poll( 0 ); + $pollret = $secondattempt if $secondattempt > 0; + } + } + else { + # Workaround - we'll use select to fake a millisecond-accurate sleep + $pollret = select( undef, undef, undef, $timeout ); + } + + return undef unless defined $pollret; + return $self->post_poll; + } + else { + my $msec = defined $timeout ? $timeout * 1000 : -1; + my @pollmasks = %{ $self->{pollmask} }; + + my $pollret = IO::Poll::_poll( $msec, @pollmasks ); + if( $pollret == -1 and $! == EINTR or + $pollret == 0 and $self->{sigproxy} ) { + local $!; + + @pollmasks = %{ $self->{pollmask} }; + my $secondattempt = IO::Poll::_poll( $msec, @pollmasks ); + $pollret = $secondattempt if $secondattempt > 0; + } + + return undef unless defined $pollret; + + $self->{pollevents} = { @pollmasks }; + return $self->post_poll; + } +} + +sub watch_io +{ + my $self = shift; + my %params = @_; + + $self->__watch_io( %params ); + + my $poll = $self->{poll}; + + my $handle = $params{handle}; + my $fileno = $handle->fileno; + + my $curmask = $poll ? $poll->mask( $handle ) + : $self->{pollmask}{$fileno}; + $curmask ||= 0; + + my $mask = $curmask; + $params{on_read_ready} and $mask |= POLLIN; + $params{on_write_ready} and $mask |= POLLOUT | (POLL_CONNECT_POLLPRI ? POLLPRI : 0); + $params{on_hangup} and $mask |= POLLHUP; + + if( FAKE_ISREG_READY and S_ISREG +(stat $handle)[2] ) { + $self->{fake_isreg}{$fileno} = $mask; + } + + return if $mask == $curmask; + + if( $poll ) { + $poll->mask( $handle, $mask ); + } + else { + $self->{pollmask}{$fileno} = $mask; + } +} + +sub unwatch_io +{ + my $self = shift; + my %params = @_; + + $self->__unwatch_io( %params ); + + my $poll = $self->{poll}; + + my $handle = $params{handle}; + my $fileno = $handle->fileno; + + my $curmask = $poll ? $poll->mask( $handle ) + : $self->{pollmask}{$fileno}; + $curmask ||= 0; + + my $mask = $curmask; + $params{on_read_ready} and $mask &= ~POLLIN; + $params{on_write_ready} and $mask &= ~(POLLOUT | (POLL_CONNECT_POLLPRI ? POLLPRI : 0)); + $params{on_hangup} and $mask &= ~POLLHUP; + + if( FAKE_ISREG_READY and S_ISREG +(stat $handle)[2] ) { + if( $mask ) { + $self->{fake_isreg}{$handle->fileno} = $mask; + } + else { + delete $self->{fake_isreg}{$handle->fileno}; + } + } + + return if $mask == $curmask; + + if( $poll ) { + $poll->mask( $handle, $mask ); + } + else { + $mask ? ( $self->{pollmask}{$fileno} = $mask ) + : ( delete $self->{pollmask}{$fileno} ); + } +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Loop/Select.pm b/lib/IO/Async/Loop/Select.pm new file mode 100644 index 0000000..0c3bd9c --- /dev/null +++ b/lib/IO/Async/Loop/Select.pm @@ -0,0 +1,294 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2007-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Loop::Select; + +use strict; +use warnings; + +our $VERSION = '0.67'; +use constant API_VERSION => '0.49'; + +use base qw( IO::Async::Loop ); + +use IO::Async::OS; + +use Carp; + +# select() on most platforms claims that ISREG files are always read- and +# write-ready, but not on MSWin32. We need to fake this +use constant FAKE_ISREG_READY => IO::Async::OS->HAVE_FAKE_ISREG_READY; +# select() on most platforms indicates write-ready when connect() fails, but +# not on MSWin32. Have to pull from evec in that case +use constant SELECT_CONNECT_EVEC => IO::Async::OS->HAVE_SELECT_CONNECT_EVEC; + +use constant _CAN_WATCHDOG => 1; +use constant WATCHDOG_ENABLE => IO::Async::Loop->WATCHDOG_ENABLE; + +=head1 NAME + +C<IO::Async::Loop::Select> - use C<IO::Async> with C<select(2)> + +=head1 SYNOPSIS + +Normally an instance of this class would not be directly constructed by a +program. It may however, be useful for runinng L<IO::Async> with an existing +program already using a C<select> call. + + use IO::Async::Loop::Select; + + my $loop = IO::Async::Loop::Select->new; + + $loop->add( ... ); + + while(1) { + my ( $rvec, $wvec, $evec ) = ('') x 3; + my $timeout; + + $loop->pre_select( \$rvec, \$wvec, \$evec, \$timeout ); + ... + my $ret = select( $rvec, $wvec, $evec, $timeout ); + ... + $loop->post_select( $rvec, $evec, $wvec ); + } + +=head1 DESCRIPTION + +This subclass of C<IO::Async::Loop> uses the C<select(2)> syscall to perform +read-ready and write-ready tests. + +To integrate with an existing C<select>-based event loop, a pair of methods +C<pre_select> and C<post_select> can be called immediately before and +after a C<select> call. The relevant bits in the read-ready, write-ready and +exceptional-state bitvectors are set by the C<pre_select> method, and tested +by the C<post_select> method to pick which event callbacks to invoke. + +=cut + +=head1 CONSTRUCTOR + +=cut + +=head2 $loop = IO::Async::Loop::Select->new + +This function returns a new instance of a C<IO::Async::Loop::Select> object. +It takes no special arguments. + +=cut + +sub new +{ + my $class = shift; + + my $self = $class->__new( @_ ); + + $self->{rvec} = ''; + $self->{wvec} = ''; + $self->{evec} = ''; + + $self->{avec} = ''; # Bitvector of handles always to claim are ready + + return $self; +} + +=head1 METHODS + +=cut + +=head2 $loop->pre_select( \$readvec, \$writevec, \$exceptvec, \$timeout ) + +This method prepares the bitvectors for a C<select> call, setting the bits +that the Loop is interested in. It will also adjust the C<$timeout> value if +appropriate, reducing it if the next event timeout the Loop requires is sooner +than the current value. + +=over 8 + +=item \$readvec + +=item \$writevec + +=item \$exceptvec + +Scalar references to the reading, writing and exception bitvectors + +=item \$timeout + +Scalar reference to the timeout value + +=back + +=cut + +sub pre_select +{ + my $self = shift; + my ( $readref, $writeref, $exceptref, $timeref ) = @_; + + # BITWISE operations + $$readref |= $self->{rvec}; + $$writeref |= $self->{wvec}; + $$exceptref |= $self->{evec}; + + $self->_adjust_timeout( $timeref ); + + $$timeref = 0 if FAKE_ISREG_READY and length $self->{avec}; + + # Round up to nearest millisecond + if( $$timeref ) { + my $mils = $$timeref * 1000; + my $fraction = $mils - int $mils; + $$timeref += ( 1 - $fraction ) / 1000 if $fraction; + } + + return; +} + +=head2 $loop->post_select( $readvec, $writevec, $exceptvec ) + +This method checks the returned bitvectors from a C<select> call, and calls +any of the callbacks that are appropriate. + +=over 8 + +=item $readvec + +=item $writevec + +=item $exceptvec + +Scalars containing the read-ready, write-ready and exception bitvectors + +=back + +=cut + +sub post_select +{ + my $self = shift; + my ( $readvec, $writevec, $exceptvec ) = @_; + + my $iowatches = $self->{iowatches}; + + my $count = 0; + + alarm( IO::Async::Loop->WATCHDOG_INTERVAL ) if WATCHDOG_ENABLE; + + foreach my $fd ( keys %$iowatches ) { + my $watch = $iowatches->{$fd} or next; + + my $fileno = $watch->[0]->fileno; + + if( vec( $readvec, $fileno, 1 ) or + FAKE_ISREG_READY and vec( $self->{avec}, $fileno, 1 ) and vec( $self->{rvec}, $fileno, 1 ) ) { + $count++, $watch->[1]->() if defined $watch->[1]; + } + + if( vec( $writevec, $fileno, 1 ) or + SELECT_CONNECT_EVEC and vec( $exceptvec, $fileno, 1 ) or + FAKE_ISREG_READY and vec( $self->{avec}, $fileno, 1 ) and vec( $self->{wvec}, $fileno, 1 ) ) { + $count++, $watch->[2]->() if defined $watch->[2]; + } + } + + # Since we have no way to know if the timeout occured, we'll have to + # attempt to fire any waiting timeout events anyway + + $self->_manage_queues; + + alarm( 0 ) if WATCHDOG_ENABLE; +} + +=head2 $count = $loop->loop_once( $timeout ) + +This method calls the C<pre_select> method to prepare the bitvectors for a +C<select> syscall, performs it, then calls C<post_select> to process the +result. It returns the total number of callbacks invoked by the +C<post_select> method, or C<undef> if the underlying C<select(2)> syscall +returned an error. + +=cut + +sub loop_once +{ + my $self = shift; + my ( $timeout ) = @_; + + my ( $rvec, $wvec, $evec ) = ('') x 3; + + $self->pre_select( \$rvec, \$wvec, \$evec, \$timeout ); + + my $ret = select( $rvec, $wvec, $evec, $timeout ); + + if( $ret < 0 ) { + # r/w/e vec can't be trusted + $rvec = $wvec = $evec = ''; + } + + { + local $!; + $self->post_select( $rvec, $wvec, $evec ); + } + + return $ret; +} + +sub watch_io +{ + my $self = shift; + my %params = @_; + + $self->__watch_io( %params ); + + my $fileno = $params{handle}->fileno; + + vec( $self->{rvec}, $fileno, 1 ) = 1 if $params{on_read_ready}; + vec( $self->{wvec}, $fileno, 1 ) = 1 if $params{on_write_ready}; + + # MSWin32 does not indicate writeready for connect() errors, HUPs, etc + # but it does indicate exceptional + vec( $self->{evec}, $fileno, 1 ) = 1 if SELECT_CONNECT_EVEC and $params{on_write_ready}; + + vec( $self->{avec}, $fileno, 1 ) = 1 if FAKE_ISREG_READY and stat( $params{handle} ) and -f _; +} + +sub unwatch_io +{ + my $self = shift; + my %params = @_; + + $self->__unwatch_io( %params ); + + my $fileno = $params{handle}->fileno; + + vec( $self->{rvec}, $fileno, 1 ) = 0 if $params{on_read_ready}; + vec( $self->{wvec}, $fileno, 1 ) = 0 if $params{on_write_ready}; + + vec( $self->{evec}, $fileno, 1 ) = 0 if SELECT_CONNECT_EVEC and $params{on_write_ready}; + + vec( $self->{avec}, $fileno, 1 ) = 0 if FAKE_ISREG_READY and stat( $params{handle} ) and -f _; + + # vec will grow a bit vector as needed, but never shrink it. We'll trim + # trailing null bytes + $_ =~s/\0+\z// for $self->{rvec}, $self->{wvec}, $self->{evec}, $self->{avec}; +} + +=head1 SEE ALSO + +=over 4 + +=item * + +L<IO::Select> - OO interface to select system call + +=back + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/LoopTests.pm b/lib/IO/Async/LoopTests.pm new file mode 100644 index 0000000..63f1257 --- /dev/null +++ b/lib/IO/Async/LoopTests.pm @@ -0,0 +1,833 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2009-2015 -- leonerd@leonerd.org.uk + +package IO::Async::LoopTests; + +use strict; +use warnings; + +use Exporter 'import'; +our @EXPORT = qw( + run_tests +); + +use Test::More; +use Test::Fatal; +use Test::Refcount; + +use IO::Async::Test qw(); + +use IO::Async::OS; + +use IO::File; +use Fcntl qw( SEEK_SET ); +use POSIX qw( SIGTERM ); +use Socket qw( sockaddr_family AF_UNIX ); +use Time::HiRes qw( time ); + +our $VERSION = '0.67'; + +# Abstract Units of Time +use constant AUT => $ENV{TEST_QUICK_TIMERS} ? 0.1 : 1; + +# The loop under test. We keep it in a single lexical here, so we can use +# is_oneref tests in the individual test suite functions +my $loop; +END { undef $loop } + +=head1 NAME + +C<IO::Async::LoopTests> - acceptance testing for C<IO::Async::Loop> subclasses + +=head1 SYNOPSIS + + use IO::Async::LoopTests; + run_tests( 'IO::Async::Loop::Shiney', 'io' ); + +=head1 DESCRIPTION + +This module contains a collection of test functions for running acceptance +tests on L<IO::Async::Loop> subclasses. It is provided as a facility for +authors of such subclasses to ensure that the code conforms to the Loop API +required by C<IO::Async>. + +=head1 TIMING + +Certain tests require the use of timers or timed delays. Normally these are +counted in units of seconds. By setting the environment variable +C<TEST_QUICK_TIMERS> to some true value, these timers run 10 times quicker, +being measured in units of 0.1 seconds instead. This value may be useful when +running the tests interactively, to avoid them taking too long. The slower +timers are preferred on automated smoke-testing machines, to help guard +against false negatives reported simply because of scheduling delays or high +system load while testing. + + TEST_QUICK_TIMERS=1 ./Build test + +=cut + +=head1 FUNCTIONS + +=cut + +=head2 run_tests( $class, @tests ) + +Runs a test or collection of tests against the loop subclass given. The class +being tested is loaded by this function; the containing script does not need +to C<require> or C<use> it first. + +This function runs C<Test::More::plan> to output its expected test count; the +containing script should not do this. + +=cut + +sub run_tests +{ + my ( $testclass, @tests ) = @_; + + my $count = 0; + $count += __PACKAGE__->can( "count_tests_$_" )->() + 4 for @tests; + + plan tests => $count; + + ( my $file = "$testclass.pm" ) =~ s{::}{/}g; + + eval { require $file }; + if( $@ ) { + BAIL_OUT( "Unable to load $testclass - $@" ); + } + + foreach my $test ( @tests ) { + $loop = $testclass->new; + + isa_ok( $loop, $testclass, '$loop' ); + + is( IO::Async::Loop->new, $loop, 'magic constructor yields $loop' ); + + # Kill the reference in $ONE_TRUE_LOOP so as not to upset the refcounts + # and to ensure we get a new one each time + undef $IO::Async::Loop::ONE_TRUE_LOOP; + + is_oneref( $loop, '$loop has refcount 1' ); + + __PACKAGE__->can( "run_tests_$test" )->(); + + is_oneref( $loop, '$loop has refcount 1 finally' ); + } +} + +sub wait_for(&) +{ + # Bounce via here so we don't upset refcount tests by having loop + # permanently set in IO::Async::Test + IO::Async::Test::testing_loop( $loop ); + + # Override prototype - I know what I'm doing + &IO::Async::Test::wait_for( @_ ); + + IO::Async::Test::testing_loop( undef ); +} + +sub time_between(&$$$) +{ + my ( $code, $lower, $upper, $name ) = @_; + + my $start = time; + $code->(); + my $took = ( time - $start ) / AUT; + + cmp_ok( $took, '>=', $lower, "$name took at least $lower seconds" ) if defined $lower; + cmp_ok( $took, '<=', $upper * 3, "$name took no more than $upper seconds" ) if defined $upper; + if( $took > $upper and $took <= $upper * 3 ) { + diag( "$name took longer than $upper seconds - this may just be an indication of a busy testing machine rather than a bug" ); + } +} + +=head1 TEST SUITES + +The following test suite names exist, to be passed as a name in the C<@tests> +argument to C<run_tests>: + +=cut + +=head2 io + +Tests the Loop's ability to watch filehandles for IO readiness + +=cut + +use constant count_tests_io => 18; +sub run_tests_io +{ + { + my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot create socket pair - $!"; + $_->blocking( 0 ) for $S1, $S2; + + my $readready = 0; + my $writeready = 0; + $loop->watch_io( + handle => $S1, + on_read_ready => sub { $readready = 1 }, + ); + + is_oneref( $loop, '$loop has refcount 1 after watch_io on_read_ready' ); + is( $readready, 0, '$readready still 0 before ->loop_once' ); + + $loop->loop_once( 0.1 ); + + is( $readready, 0, '$readready when idle' ); + + $S2->syswrite( "data\n" ); + + # We should still wait a little while even thought we expect to be ready + # immediately, because talking to ourself with 0 poll timeout is a race + # condition - we can still race with the kernel. + + $loop->loop_once( 0.1 ); + + is( $readready, 1, '$readready after loop_once' ); + + # Ready $S1 to clear the data + $S1->getline; # ignore return + + $loop->unwatch_io( + handle => $S1, + on_read_ready => 1, + ); + + $loop->watch_io( + handle => $S1, + on_read_ready => sub { $readready = 1 }, + ); + + $readready = 0; + $S2->syswrite( "more data\n" ); + + $loop->loop_once( 0.1 ); + + is( $readready, 1, '$readready after ->unwatch_io/->watch_io' ); + + $S1->getline; # ignore return + + $loop->watch_io( + handle => $S1, + on_write_ready => sub { $writeready = 1 }, + ); + + is_oneref( $loop, '$loop has refcount 1 after watch_io on_write_ready' ); + + $loop->loop_once( 0.1 ); + + is( $writeready, 1, '$writeready after loop_once' ); + + $loop->unwatch_io( + handle => $S1, + on_write_ready => 1, + ); + + $readready = 0; + $loop->loop_once( 0.1 ); + + is( $readready, 0, '$readready before HUP' ); + + $S2->close; + + $readready = 0; + $loop->loop_once( 0.1 ); + + is( $readready, 1, '$readready after HUP' ); + + $loop->unwatch_io( + handle => $S1, + on_read_ready => 1, + ); + } + + # HUP of pipe - can be different to sockets on some architectures + { + my ( $Prd, $Pwr ) = IO::Async::OS->pipepair or die "Cannot pipepair - $!"; + $_->blocking( 0 ) for $Prd, $Pwr; + + my $readready = 0; + $loop->watch_io( + handle => $Prd, + on_read_ready => sub { $readready = 1 }, + ); + + $loop->loop_once( 0.1 ); + + is( $readready, 0, '$readready before pipe HUP' ); + + $Pwr->close; + + $readready = 0; + $loop->loop_once( 0.1 ); + + is( $readready, 1, '$readready after pipe HUP' ); + + $loop->unwatch_io( + handle => $Prd, + on_read_ready => 1, + ); + } + + SKIP: { + $loop->_CAN_ON_HANGUP or skip "Loop cannot watch_io for on_hangup", 2; + + SKIP: { + my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!"; + $_->blocking( 0 ) for $S1, $S2; + + sockaddr_family( $S1->sockname ) == AF_UNIX or skip "Cannot reliably detect hangup condition on non AF_UNIX sockets", 1; + + my $hangup = 0; + $loop->watch_io( + handle => $S1, + on_hangup => sub { $hangup = 1 }, + ); + + $S2->close; + + $loop->loop_once( 0.1 ); + + is( $hangup, 1, '$hangup after socket close' ); + } + + my ( $Prd, $Pwr ) = IO::Async::OS->pipepair or die "Cannot pipepair - $!"; + $_->blocking( 0 ) for $Prd, $Pwr; + + my $hangup = 0; + $loop->watch_io( + handle => $Pwr, + on_hangup => sub { $hangup = 1 }, + ); + + $Prd->close; + + $loop->loop_once( 0.1 ); + + is( $hangup, 1, '$hangup after pipe close for writing' ); + } + + # Check that combined read/write handlers can cancel each other + { + my ( $S1, $S2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!"; + $_->blocking( 0 ) for $S1, $S2; + + my $callcount = 0; + $loop->watch_io( + handle => $S1, + on_read_ready => sub { + $callcount++; + $loop->unwatch_io( handle => $S1, on_read_ready => 1, on_write_ready => 1 ); + }, + on_write_ready => sub { + $callcount++; + $loop->unwatch_io( handle => $S1, on_read_ready => 1, on_write_ready => 1 ); + }, + ); + + $S2->close; + + $loop->loop_once( 0.1 ); + + is( $callcount, 1, 'read/write_ready can cancel each other' ); + } + + # Check that cross-connected handlers can cancel each other + { + my ( $SA1, $SA2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!"; + my ( $SB1, $SB2 ) = IO::Async::OS->socketpair or die "Cannot socketpair - $!"; + $_->blocking( 0 ) for $SA1, $SA2, $SB1, $SB2; + + my @handles = ( $SA1, $SB1 ); + + my $callcount = 0; + $loop->watch_io( + handle => $_, + on_write_ready => sub { + $callcount++; + $loop->unwatch_io( handle => $_, on_write_ready => 1 ) for @handles; + }, + ) for @handles; + + $loop->loop_once( 0.1 ); + + is( $callcount, 1, 'write_ready on crosslinked handles can cancel each other' ); + } + + # Check that error conditions that aren't true read/write-ability are still + # invoked + { + my ( $S1, $S2 ) = IO::Async::OS->socketpair( 'inet', 'dgram' ) or die "Cannot create AF_INET/SOCK_DGRAM connected pair - $!"; + $_->blocking( 0 ) for $S1, $S2; + $S2->close; + + my $readready = 0; + $loop->watch_io( + handle => $S1, + on_read_ready => sub { $readready = 1 }, + ); + + $S1->syswrite( "Boo!" ); + + $loop->loop_once( 0.1 ); + + is( $readready, 1, 'exceptional socket invokes on_read_ready' ); + + $loop->unwatch_io( + handle => $S1, + on_read_ready => 1, + ); + } + + # Check that regular files still report read/writereadiness + { + my $F = IO::File->new_tmpfile or die "Cannot create temporary file - $!"; + + $F->print( "Here's some content\n" ); + $F->seek( 0, SEEK_SET ); + + my $readready = 0; + my $writeready = 0; + $loop->watch_io( + handle => $F, + on_read_ready => sub { $readready = 1 }, + on_write_ready => sub { $writeready = 1 }, + ); + + $loop->loop_once( 0.1 ); + + is( $readready, 1, 'regular file is readready' ); + is( $writeready, 1, 'regular file is writeready' ); + + $loop->unwatch_io( + handle => $F, + on_read_ready => 1, + on_write_ready => 1, + ); + } +} + +=head2 timer + +Tests the Loop's ability to handle timer events + +=cut + +use constant count_tests_timer => 21; +sub run_tests_timer +{ + my $done = 0; + # New watch/unwatch API + + cmp_ok( abs( $loop->time - time ), "<", 0.1, '$loop->time gives the current time' ); + + $loop->watch_time( after => 2 * AUT, code => sub { $done = 1; } ); + + is_oneref( $loop, '$loop has refcount 1 after watch_time' ); + + time_between { + my $now = time; + $loop->loop_once( 5 * AUT ); + + # poll might have returned just a little early, such that the TimerQueue + # doesn't think anything is ready yet. We need to handle that case. + while( !$done ) { + die "It should have been ready by now" if( time - $now > 5 * AUT ); + $loop->loop_once( 0.1 * AUT ); + } + } 1.5, 2.5, 'loop_once(5) while waiting for watch_time after'; + + $loop->watch_time( at => time + 2 * AUT, code => sub { $done = 2; } ); + + time_between { + my $now = time; + $loop->loop_once( 5 * AUT ); + + # poll might have returned just a little early, such that the TimerQueue + # doesn't think anything is ready yet. We need to handle that case. + while( !$done ) { + die "It should have been ready by now" if( time - $now > 5 * AUT ); + $loop->loop_once( 0.1 * AUT ); + } + } 1.5, 2.5, 'loop_once(5) while waiting for watch_time at'; + + my $cancelled_fired = 0; + my $id = $loop->watch_time( after => 1 * AUT, code => sub { $cancelled_fired = 1 } ); + $loop->unwatch_time( $id ); + undef $id; + + $loop->loop_once( 2 * AUT ); + + ok( !$cancelled_fired, 'unwatched watch_time does not fire' ); + + $loop->watch_time( after => -1, code => sub { $done = 1 } ); + + $done = 0; + + time_between { + $loop->loop_once while !$done; + } 0, 0.1, 'loop_once while waiting for negative interval timer'; + + { + my $done; + + my $id; + $id = $loop->watch_time( after => 1 * AUT, code => sub { + $loop->unwatch_time( $id ); undef $id; + }); + + $loop->watch_time( after => 1.1 * AUT, code => sub { + $done++; + }); + + wait_for { $done }; + + is( $done, 1, 'Other timers still fire after self-cancelling one' ); + } + + # Legacy enqueue/requeue/cancel API + $done = 0; + + $loop->enqueue_timer( delay => 2 * AUT, code => sub { $done = 1; } ); + + is_oneref( $loop, '$loop has refcount 1 after enqueue_timer' ); + + time_between { + my $now = time; + $loop->loop_once( 5 * AUT ); + + # poll might have returned just a little early, such that the TimerQueue + # doesn't think anything is ready yet. We need to handle that case. + while( !$done ) { + die "It should have been ready by now" if( time - $now > 5 * AUT ); + $loop->loop_once( 0.1 * AUT ); + } + } 1.5, 2.5, 'loop_once(5) while waiting for timer'; + + SKIP: { + skip "Unable to handle sub-second timers accurately", 3 unless $loop->_CAN_SUBSECOND_ACCURATELY; + + # Check that short delays are achievable in one ->loop_once call + foreach my $delay ( 0.001, 0.01, 0.1 ) { + my $done; + my $count = 0; + my $start = time; + + $loop->enqueue_timer( delay => $delay, code => sub { $done++ } ); + + while( !$done ) { + $loop->loop_once( 1 ); + $count++; + last if time - $start > 5; # bailout + } + + is( $count, 1, "One ->loop_once(1) sufficient for a single $delay second timer" ); + } + } + + $cancelled_fired = 0; + $id = $loop->enqueue_timer( delay => 1 * AUT, code => sub { $cancelled_fired = 1 } ); + $loop->cancel_timer( $id ); + undef $id; + + $loop->loop_once( 2 * AUT ); + + ok( !$cancelled_fired, 'cancelled timer does not fire' ); + + $id = $loop->enqueue_timer( delay => 1 * AUT, code => sub { $done = 2; } ); + $id = $loop->requeue_timer( $id, delay => 2 * AUT ); + + $done = 0; + + time_between { + $loop->loop_once( 1 * AUT ); + + is( $done, 0, '$done still 0 so far' ); + + my $now = time; + $loop->loop_once( 5 * AUT ); + + # poll might have returned just a little early, such that the TimerQueue + # doesn't think anything is ready yet. We need to handle that case. + while( !$done ) { + die "It should have been ready by now" if( time - $now > 5 * AUT ); + $loop->loop_once( 0.1 * AUT ); + } + } 1.5, 2.5, 'requeued timer of delay 2'; + + is( $done, 2, '$done is 2 after requeued timer' ); +} + +=head2 signal + +Tests the Loop's ability to watch POSIX signals + +=cut + +use constant count_tests_signal => 14; +sub run_tests_signal +{ + unless( IO::Async::OS->HAVE_SIGNALS ) { + SKIP: { skip "This OS does not have signals", 14; } + return; + } + + my $caught = 0; + + $loop->watch_signal( TERM => sub { $caught++ } ); + + is_oneref( $loop, '$loop has refcount 1 after watch_signal' ); + + $loop->loop_once( 0.1 ); + + is( $caught, 0, '$caught idling' ); + + kill SIGTERM, $$; + + is( $caught, 0, '$caught before ->loop_once' ); + + $loop->loop_once( 0.1 ); + + is( $caught, 1, '$caught after ->loop_once' ); + + kill SIGTERM, $$; + + is( $caught, 1, 'second raise is still deferred' ); + + $loop->loop_once( 0.1 ); + + is( $caught, 2, '$caught after second ->loop_once' ); + + is_oneref( $loop, '$loop has refcount 1 before unwatch_signal' ); + + $loop->unwatch_signal( 'TERM' ); + + is_oneref( $loop, '$loop has refcount 1 after unwatch_signal' ); + + my ( $cA, $cB ); + + my $idA = $loop->attach_signal( TERM => sub { $cA = 1 } ); + my $idB = $loop->attach_signal( TERM => sub { $cB = 1 } ); + + is_oneref( $loop, '$loop has refcount 1 after 2 * attach_signal' ); + + kill SIGTERM, $$; + + $loop->loop_once( 0.1 ); + + is( $cA, 1, '$cA after raise' ); + is( $cB, 1, '$cB after raise' ); + + $loop->detach_signal( 'TERM', $idA ); + + undef $cA; + undef $cB; + + kill SIGTERM, $$; + + $loop->loop_once( 0.1 ); + + is( $cA, undef, '$cA after raise' ); + is( $cB, 1, '$cB after raise' ); + + $loop->detach_signal( 'TERM', $idB ); + + ok( exception { $loop->attach_signal( 'this signal name does not exist', sub {} ) }, + 'Bad signal name fails' ); +} + +=head2 idle + +Tests the Loop's support for idle handlers + +=cut + +use constant count_tests_idle => 11; +sub run_tests_idle +{ + my $called = 0; + + my $id = $loop->watch_idle( when => 'later', code => sub { $called = 1 } ); + + ok( defined $id, 'idle watcher id is defined' ); + + is( $called, 0, 'deferred sub not yet invoked' ); + + time_between { $loop->loop_once( 3 * AUT ) } undef, 1.0, 'loop_once(3) with deferred sub'; + + is( $called, 1, 'deferred sub called after loop_once' ); + + $loop->watch_idle( when => 'later', code => sub { + $loop->watch_idle( when => 'later', code => sub { $called = 2 } ) + } ); + + $loop->loop_once( 1 ); + + is( $called, 1, 'inner deferral not yet invoked' ); + + $loop->loop_once( 1 ); + + is( $called, 2, 'inner deferral now invoked' ); + + $called = 2; # set it anyway in case previous test fails + + $id = $loop->watch_idle( when => 'later', code => sub { $called = 20 } ); + + $loop->unwatch_idle( $id ); + + time_between { $loop->loop_once( 1 * AUT ) } 0.5, 1.5, 'loop_once(1) with unwatched deferral'; + + is( $called, 2, 'unwatched deferral not called' ); + + $id = $loop->watch_idle( when => 'later', code => sub { $called = 3 } ); + my $timer_id = $loop->watch_time( after => 5, code => sub {} ); + + $loop->loop_once( 1 ); + + is( $called, 3, '$loop->later still invoked with enqueued timer' ); + + $loop->unwatch_time( $timer_id ); + + $loop->later( sub { $called = 4 } ); + + $loop->loop_once( 1 ); + + is( $called, 4, '$loop->later shortcut works' ); +} + +=head2 child + +Tests the Loop's support for watching child processes by PID + +=cut + +sub run_in_child(&) +{ + my $kid = fork; + defined $kid or die "Cannot fork() - $!"; + return $kid if $kid; + + shift->(); + die "Fell out of run_in_child!\n"; +} + +use constant count_tests_child => 7; +sub run_tests_child +{ + my $kid = run_in_child { + exit( 3 ); + }; + + my $exitcode; + + $loop->watch_child( $kid => sub { ( undef, $exitcode ) = @_; } ); + + is_oneref( $loop, '$loop has refcount 1 after watch_child' ); + ok( !defined $exitcode, '$exitcode not defined before ->loop_once' ); + + undef $exitcode; + wait_for { defined $exitcode }; + + ok( ($exitcode & 0x7f) == 0, 'WIFEXITED($exitcode) after child exit' ); + is( ($exitcode >> 8), 3, 'WEXITSTATUS($exitcode) after child exit' ); + + SKIP: { + skip "This OS does not have signals", 1 unless IO::Async::OS->HAVE_SIGNALS; + + # We require that SIGTERM perform its default action; i.e. terminate the + # process. Ensure this definitely happens, in case the test harness has it + # ignored or handled elsewhere. + local $SIG{TERM} = "DEFAULT"; + + $kid = run_in_child { + sleep( 10 ); + # Just in case the parent died already and didn't kill us + exit( 0 ); + }; + + $loop->watch_child( $kid => sub { ( undef, $exitcode ) = @_; } ); + + kill SIGTERM, $kid; + + undef $exitcode; + wait_for { defined $exitcode }; + + is( ($exitcode & 0x7f), SIGTERM, 'WTERMSIG($exitcode) after SIGTERM' ); + } + + my %kids; + + $loop->watch_child( 0 => sub { my ( $kid ) = @_; delete $kids{$kid} } ); + + %kids = map { run_in_child { exit 0 } => 1 } 1 .. 3; + + is( scalar keys %kids, 3, 'Waiting for 3 child processes' ); + + wait_for { !keys %kids }; + ok( !keys %kids, 'All child processes reclaimed' ); +} + +=head2 control + +Tests that the C<run>, C<stop>, C<loop_once> and C<loop_forever> methods +behave correctly + +=cut + +use constant count_tests_control => 8; +sub run_tests_control +{ + time_between { $loop->loop_once( 0 ) } 0, 0.1, 'loop_once(0) when idle'; + + time_between { $loop->loop_once( 2 * AUT ) } 1.5, 2.5, 'loop_once(2) when idle'; + + $loop->watch_time( after => 0.1, code => sub { $loop->stop( result => "here" ) } ); + + local $SIG{ALRM} = sub { die "Test timed out before ->stop" }; + alarm( 1 ); + + my @result = $loop->run; + + alarm( 0 ); + + is_deeply( \@result, [ result => "here" ], '->stop arguments returned by ->run' ); + + $loop->watch_time( after => 0.1, code => sub { $loop->stop( result => "here" ) } ); + + my $result = $loop->run; + + is( $result, "result", 'First ->stop argument returned by ->run in scalar context' ); + + $loop->watch_time( after => 0.1, code => sub { + $loop->watch_time( after => 0.1, code => sub { $loop->stop( "inner" ) } ); + my @result = $loop->run; + $loop->stop( @result, "outer" ); + } ); + + @result = $loop->run; + + is_deeply( \@result, [ "inner", "outer" ], '->run can be nested properly' ); + + $loop->watch_time( after => 0.1, code => sub { $loop->loop_stop } ); + + local $SIG{ALRM} = sub { die "Test timed out before ->loop_stop" }; + alarm( 1 ); + + $loop->loop_forever; + + alarm( 0 ); + + ok( 1, '$loop->loop_forever interruptable by ->loop_stop' ); +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Notifier.pm b/lib/IO/Async/Notifier.pm new file mode 100644 index 0000000..f21c346 --- /dev/null +++ b/lib/IO/Async/Notifier.pm @@ -0,0 +1,919 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2006-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Notifier; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use Carp; +use Scalar::Util qw( weaken ); + +use Future 0.26; # ->is_failed + +use IO::Async::Debug; + +# Perl 5.8.4 cannot do trampolines by modiying @_ then goto &$code +use constant HAS_BROKEN_TRAMPOLINES => ( $] == "5.008004" ); + +=head1 NAME + +C<IO::Async::Notifier> - base class for C<IO::Async> event objects + +=head1 SYNOPSIS + +Usually not directly used by a program, but one valid use case may be: + + use IO::Async::Notifier; + + use IO::Async::Stream; + use IO::Async::Signal; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my $notifier = IO::Async::Notifier->new; + + $notifier->add_child( + IO::Async::Stream->new_for_stdin( + on_read => sub { + my $self = shift; + my ( $buffref, $eof ) = @_; + + while( $$buffref =~ s/^(.*)\n// ) { + print "You said $1\n"; + } + + return 0; + }, + ) + ); + + $notifier->add_child( + IO::Async::Signal->new( + name => 'INT', + on_receipt => sub { + print "Goodbye!\n"; + $loop->stop; + }, + ) + ); + + $loop->add( $notifier ); + + $loop->run; + +=head1 DESCRIPTION + +This object class forms the basis for all the other event objects that an +C<IO::Async> program uses. It provides the lowest level of integration with a +C<IO::Async::Loop> container, and a facility to collect Notifiers together, in +a tree structure, where any Notifier can contain a collection of children. + +Normally, objects in this class would not be directly used by an end program, +as it performs no actual IO work, and generates no actual events. These are all +left to the various subclasses, such as: + +=over 4 + +=item * + +L<IO::Async::Handle> - event callbacks for a non-blocking file descriptor + +=item * + +L<IO::Async::Stream> - event callbacks and write bufering for a stream +filehandle + +=item * + +L<IO::Async::Socket> - event callbacks and send buffering for a socket +filehandle + +=item * + +L<IO::Async::Timer> - base class for Notifiers that use timed delays + +=item * + +L<IO::Async::Signal> - event callback on receipt of a POSIX signal + +=item * + +L<IO::Async::PID> - event callback on exit of a child process + +=item * + +L<IO::Async::Process> - start and manage a child process + +=back + +For more detail, see the SYNOPSIS section in one of the above. + +One case where this object class would be used, is when a library wishes to +provide a sub-component which consists of multiple other C<Notifier> +subclasses, such as C<Handle>s and C<Timers>, but no particular object is +suitable to be the root of a tree. In this case, a plain C<Notifier> object +can be used as the tree root, and all the other notifiers added as children of +it. + +=cut + +=head1 AS A MIXIN + +Rather than being used as a subclass this package also supports being used as +a non-principle superclass for an object, as a mix-in. It still provides +methods and satisfies an C<isa> test, even though the constructor is not +directly called. This simply requires that the object be based on a normal +blessed hash reference and include C<IO::Async::Notifier> somewhere in its +C<@ISA> list. + +The methods in this class all use only keys in the hash prefixed by +C<"IO_Async_Notifier__"> for namespace purposes. + +This is intended mainly for defining a subclass of some other object that is +also an C<IO::Async::Notifier>, suitable to be added to an C<IO::Async::Loop>. + + package SomeEventSource::Async; + use base qw( SomeEventSource IO::Async::Notifier ); + + sub _add_to_loop + { + my $self = shift; + my ( $loop ) = @_; + + # Code here to set up event handling on $loop that may be required + } + + sub _remove_from_loop + { + my $self = shift; + my ( $loop ) = @_; + + # Code here to undo the event handling set up above + } + +Since all the methods documented here will be available, the implementation +may wish to use the C<configure> and C<make_event_cb> or C<invoke_event> +methods to implement its own event callbacks. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters: + +=head2 on_error $message, $name, @details + +Invoked by C<invoke_error>. + +=cut + +=head1 PARAMETERS + +A specific subclass of C<IO::Async::Notifier> defines named parameters that +control its behaviour. These may be passed to the C<new> constructor, or to +the C<configure> method. The documentation on each specific subclass will give +details on the parameters that exist, and their uses. Some parameters may only +support being set once at construction time, or only support being changed if +the object is in a particular state. + +The following parameters are supported by all Notifiers: + +=over 8 + +=item on_error => CODE + +CODE reference for event handler. + +=item notifier_name => STRING + +Optional string used to identify this particular Notifier. This value will be +returned by the C<notifier_name> method. + +=back + +=cut + +=head1 CONSTRUCTOR + +=cut + +=head2 $notifier = IO::Async::Notifier->new( %params ) + +This function returns a new instance of a C<IO::Async::Notifier> object with +the given initial values of the named parameters. + +Up until C<IO::Async> version 0.19, this module used to implement the IO +handle features now found in the C<IO::Async::Handle> subclass. Code that +needs to use any of C<handle>, C<read_handle>, C<write_handle>, +C<on_read_ready> or C<on_write_ready> should use L<IO::Async::Handle> instead. + +=cut + +sub new +{ + my $class = shift; + my %params = @_; + + my $self = bless {}, $class; + + $self->_init( \%params ); + + $self->configure( %params ); + + return $self; +} + +=head1 METHODS + +=cut + +=head2 $notifier->configure( %params ) + +Adjust the named parameters of the C<Notifier> as given by the C<%params> +hash. + +=cut + +# for subclasses to override and call down to +sub configure +{ + my $self = shift; + my %params = @_; + + foreach (qw( notifier_name on_error )) { + $self->{"IO_Async_Notifier__$_"} = delete $params{$_} if exists $params{$_}; + } + + $self->configure_unknown( %params ) if keys %params; +} + +sub configure_unknown +{ + my $self = shift; + my %params = @_; + + my $class = ref $self; + croak "Unrecognised configuration keys for $class - " . join( " ", keys %params ); +} + +=head2 $loop = $notifier->loop + +Returns the C<IO::Async::Loop> that this Notifier is a member of. + +=cut + +sub loop +{ + my $self = shift; + return $self->{IO_Async_Notifier__loop} +} + +*get_loop = \&loop; + +# Only called by IO::Async::Loop, not external interface +sub __set_loop +{ + my $self = shift; + my ( $loop ) = @_; + + # early exit if no change + return if !$loop and !$self->loop or + $loop and $self->loop and $loop == $self->loop; + + $self->_remove_from_loop( $self->loop ) if $self->loop; + + $self->{IO_Async_Notifier__loop} = $loop; + weaken( $self->{IO_Async_Notifier__loop} ); # To avoid a cycle + + $self->_add_to_loop( $self->loop ) if $self->loop; +} + +=head2 $name = $notifier->notifier_name + +Returns the name to identify this Notifier. If a has not been set, it will +return the empty string. Subclasses may wish to override this behaviour to +return some more useful information, perhaps from configured parameters. + +=cut + +sub notifier_name +{ + my $self = shift; + return $self->{IO_Async_Notifier__notifier_name} || ""; +} + +=head2 $f = $notifier->adopt_future( $f ) + +Stores a reference to the L<Future> instance within the notifier itself, so +the reference doesn't get lost. This reference will be dropped when the future +becomes ready (either by success or failure). Additionally, if the future +failed the notifier's C<invoke_error> method will be informed. + +This means that if the notifier does not provide an C<on_error> handler, nor +is there one anywhere in the parent chain, this will be fatal to the caller of +C<< $f->fail >>. To avoid this being fatal if the failure is handled +elsewhere, use the C<else_done> method on the future to obtain a sequence one +that never fails. + + $notifier->adopt_future( $f->else_done() ) + +The future itself is returned. + +=cut + +sub adopt_future +{ + my $self = shift; + my ( $f ) = @_; + + my $fkey = "$f"; # stable stringification + + $self->{IO_Async_Notifier__futures}{$fkey} = $f; + + $f->on_ready( $self->_capture_weakself( sub { + my $self = shift; + my ( $f ) = @_; + + delete $self->{IO_Async_Notifier__futures}{$fkey}; + + $self->invoke_error( $f->failure ) if $f->is_failed; + })); + + return $f; +} + +=head1 CHILD NOTIFIERS + +During the execution of a program, it may be the case that certain IO handles +cause other handles to be created; for example, new sockets that have been +C<accept()>ed from a listening socket. To facilitate these, a notifier may +contain child notifier objects, that are automatically added to or removed +from the C<IO::Async::Loop> that manages their parent. + +=cut + +=head2 $parent = $notifier->parent + +Returns the parent of the notifier, or C<undef> if does not have one. + +=cut + +sub parent +{ + my $self = shift; + return $self->{IO_Async_Notifier__parent}; +} + +=head2 @children = $notifier->children + +Returns a list of the child notifiers contained within this one. + +=cut + +sub children +{ + my $self = shift; + return unless $self->{IO_Async_Notifier__children}; + return @{ $self->{IO_Async_Notifier__children} }; +} + +=head2 $notifier->add_child( $child ) + +Adds a child notifier. This notifier will be added to the containing loop, if +the parent has one. Only a notifier that does not currently have a parent and +is not currently a member of any loop may be added as a child. If the child +itself has grandchildren, these will be recursively added to the containing +loop. + +=cut + +sub add_child +{ + my $self = shift; + my ( $child ) = @_; + + croak "Cannot add a child that already has a parent" if defined $child->{IO_Async_Notifier__parent}; + + croak "Cannot add a child that is already a member of a loop" if defined $child->loop; + + if( defined( my $loop = $self->loop ) ) { + $loop->add( $child ); + } + + push @{ $self->{IO_Async_Notifier__children} }, $child; + $child->{IO_Async_Notifier__parent} = $self; + weaken( $child->{IO_Async_Notifier__parent} ); + + return; +} + +=head2 $notifier->remove_child( $child ) + +Removes a child notifier. The child will be removed from the containing loop, +if the parent has one. If the child itself has grandchildren, these will be +recurively removed from the loop. + +=cut + +sub remove_child +{ + my $self = shift; + my ( $child ) = @_; + + LOOP: { + my $childrenref = $self->{IO_Async_Notifier__children}; + for my $i ( 0 .. $#$childrenref ) { + next unless $childrenref->[$i] == $child; + splice @$childrenref, $i, 1, (); + last LOOP; + } + + croak "Cannot remove child from a parent that doesn't contain it"; + } + + undef $child->{IO_Async_Notifier__parent}; + + if( defined( my $loop = $self->loop ) ) { + $loop->remove( $child ); + } +} + +=head2 $notifier->remove_from_parent + +Removes this notifier object from its parent (either another notifier object +or the containing loop) if it has one. If the notifier is not a child of +another notifier nor a member of a loop, this method does nothing. + +=cut + +sub remove_from_parent +{ + my $self = shift; + + if( my $parent = $self->parent ) { + $parent->remove_child( $self ); + } + elsif( my $loop = $self->loop ) { + $loop->remove( $self ); + } +} + +=head1 SUBCLASS METHODS + +C<IO::Async::Notifier> is a base class provided so that specific subclasses of +it provide more specific behaviour. The base class provides a number of +methods that subclasses may wish to override. + +If a subclass implements any of these, be sure to invoke the superclass method +at some point within the code. + +=cut + +=head2 $notifier->_init( $paramsref ) + +This method is called by the constructor just before calling C<configure>. +It is passed a reference to the HASH storing the constructor arguments. + +This method may initialise internal details of the Notifier as required, +possibly by using parameters from the HASH. If any parameters are +construction-only they should be C<delete>d from the hash. + +=cut + +sub _init +{ + # empty default +} + +=head2 $notifier->configure( %params ) + +This method is called by the constructor to set the initial values of named +parameters, and by users of the object to adjust the values once constructed. + +This method should C<delete> from the C<%params> hash any keys it has dealt +with, then pass the remaining ones to the C<SUPER::configure>. The base +class implementation will throw an exception if there are any unrecognised +keys remaining. + +=cut + +=head2 $notifier->configure_unknown( %params ) + +This method is called by the base class C<configure> method, for any remaining +parameters that are not recognised. The default implementation throws an +exception using C<Carp> that lists the unrecognised keys. This method is +provided to allow subclasses to override the behaviour, perhaps to store +unrecognised keys, or to otherwise inspect the left-over arguments for some +other purpose. + +=cut + +=head2 $notifier->_add_to_loop( $loop ) + +This method is called when the Notifier has been added to a Loop; either +directly, or indirectly through being a child of a Notifer already in a loop. + +This method may be used to perform any initial startup activity required for +the Notifier to be fully functional but which requires a Loop to do so. + +=cut + +sub _add_to_loop +{ + # empty default +} + +=head2 $notifier->_remove_from_loop( $loop ) + +This method is called when the Notifier has been removed from a Loop; either +directly, or indirectly through being a child of a Notifier removed from the +loop. + +This method may be used to undo the effects of any setup that the +C<_add_to_loop> method had originally done. + +=cut + +sub _remove_from_loop +{ + # empty default +} + +=head1 UTILITY METHODS + +=cut + +=head2 $mref = $notifier->_capture_weakself( $code ) + +Returns a new CODE ref which, when invoked, will invoke the originally-passed +ref, with additionally a reference to the Notifier as its first argument. The +Notifier reference is stored weakly in C<$mref>, so this CODE ref may be +stored in the Notifier itself without creating a cycle. + +For example, + + my $mref = $notifier->_capture_weakself( sub { + my ( $notifier, $arg ) = @_; + print "Notifier $notifier got argument $arg\n"; + } ); + + $mref->( 123 ); + +This is provided as a utility for Notifier subclasses to use to build a +callback CODEref to pass to a Loop method, but which may also want to store +the CODE ref internally for efficiency. + +The C<$code> argument may also be a plain string, which will be used as a +method name; the returned CODE ref will then invoke that method on the object. +In this case the method name is stored symbolically in the returned CODE +reference, and dynamically dispatched each time the reference is invoked. This +allows it to follow code reloading, dynamic replacement of class methods, or +other similar techniques. + +If the C<$mref> CODE reference is being stored in some object other than the +one it refers to, remember that since the Notifier is only weakly captured, it +is possible that it has been destroyed by the time the code runs, and so the +reference will be passed as C<undef>. This should be protected against by the +code body. + + $other_object->{on_event} = $notifier->_capture_weakself( sub { + my $notifier = shift or return; + my ( @event_args ) = @_; + ... + } ); + +For stand-alone generic implementation of this behaviour, see also L<curry> +and C<curry::weak>. + +=cut + +sub _capture_weakself +{ + my $self = shift; + my ( $code ) = @_; # actually bare method names work too + + if( !ref $code ) { + my $class = ref $self; + # Don't save this coderef, or it will break dynamic method dispatch, + # which means code reloading, dynamic replacement, or other funky + # techniques stop working + $self->can( $code ) or + croak qq(Can't locate object method "$code" via package "$class"); + } + + weaken $self; + + return sub { + my $cv = ref( $code ) ? $code : $self->can( $code ); + + if( HAS_BROKEN_TRAMPOLINES ) { + return $cv->( $self, @_ ); + } + else { + unshift @_, $self; + goto &$cv; + } + }; +} + +=head2 $mref = $notifier->_replace_weakself( $code ) + +Returns a new CODE ref which, when invoked, will invoke the originally-passed +ref, with a reference to the Notifier replacing its first argument. The +Notifier reference is stored weakly in C<$mref>, so this CODE ref may be +stored in the Notifier itself without creating a cycle. + +For example, + + my $mref = $notifier->_replace_weakself( sub { + my ( $notifier, $arg ) = @_; + print "Notifier $notifier got argument $arg\n"; + } ); + + $mref->( $object, 123 ); + +This is provided as a utility for Notifier subclasses to use for event +callbacks on other objects, where the delegated object is passed in the +function's arguments. + +The C<$code> argument may also be a plain string, which will be used as a +method name; the returned CODE ref will then invoke that method on the object. +As with C<_capture_weakself> this is stored symbolically. + +As with C<_capture_weakself>, care should be taken against Notifier +destruction if the C<$mref> CODE reference is stored in some other object. + +=cut + +sub _replace_weakself +{ + my $self = shift; + my ( $code ) = @_; # actually bare method names work too + + if( !ref $code ) { + # Don't save this coderef, see _capture_weakself for why + my $class = ref $self; + $self->can( $code ) or + croak qq(Can't locate object method "$code" via package "$class"); + } + + weaken $self; + + return sub { + my $cv = ref( $code ) ? $code : $self->can( $code ); + + if( HAS_BROKEN_TRAMPOLINES ) { + return $cv->( $self, @_[1..$#_] ); + } + else { + # Don't assign to $_[0] directly or we will change caller's first argument + shift @_; + unshift @_, $self; + goto &$cv; + } + }; +} + +=head2 $code = $notifier->can_event( $event_name ) + +Returns a C<CODE> reference if the object can perform the given event name, +either by a configured C<CODE> reference parameter, or by implementing a +method. If the object is unable to handle this event, C<undef> is returned. + +=cut + +sub can_event +{ + my $self = shift; + my ( $event_name ) = @_; + + return $self->{$event_name} || $self->can( $event_name ); +} + +=head2 $callback = $notifier->make_event_cb( $event_name ) + +Returns a C<CODE> reference which, when invoked, will execute the given event +handler. Event handlers may either be subclass methods, or parameters given to +the C<new> or C<configure> method. + +The event handler can be passed extra arguments by giving them to the C<CODE> +reference; the first parameter received will be a reference to the notifier +itself. This is stored weakly in the closure, so it is safe to store the +resulting C<CODE> reference in the object itself without causing a reference +cycle. + +=cut + +sub make_event_cb +{ + my $self = shift; + my ( $event_name ) = @_; + + my $code = $self->can_event( $event_name ) + or croak "$self cannot handle $event_name event"; + + my $caller = caller; + + return $self->_capture_weakself( + !$IO::Async::Debug::DEBUG ? $code : sub { + my $self = $_[0]; + $self->_debug_printf_event( $caller, $event_name ); + goto &$code; + } + ); +} + +=head2 $callback = $notifier->maybe_make_event_cb( $event_name ) + +Similar to C<make_event_cb> but will return C<undef> if the object cannot +handle the named event, rather than throwing an exception. + +=cut + +sub maybe_make_event_cb +{ + my $self = shift; + my ( $event_name ) = @_; + + my $code = $self->can_event( $event_name ) + or return undef; + + my $caller = caller; + + return $self->_capture_weakself( + !$IO::Async::Debug::DEBUG ? $code : sub { + my $self = $_[0]; + $self->_debug_printf_event( $caller, $event_name ); + goto &$code; + } + ); +} + +=head2 @ret = $notifier->invoke_event( $event_name, @args ) + +Invokes the given event handler, passing in the given arguments. Event +handlers may either be subclass methods, or parameters given to the C<new> or +C<configure> method. Returns whatever the underlying method or CODE reference +returned. + +=cut + +sub invoke_event +{ + my $self = shift; + my ( $event_name, @args ) = @_; + + my $code = $self->can_event( $event_name ) + or croak "$self cannot handle $event_name event"; + + $self->_debug_printf_event( scalar caller, $event_name ) if $IO::Async::Debug::DEBUG; + return $code->( $self, @args ); +} + +=head2 $retref = $notifier->maybe_invoke_event( $event_name, @args ) + +Similar to C<invoke_event> but will return C<undef> if the object cannot +handle the name event, rather than throwing an exception. In order to +distinguish this from an event-handling function that simply returned +C<undef>, if the object does handle the event, the list that it returns will +be returned in an ARRAY reference. + +=cut + +sub maybe_invoke_event +{ + my $self = shift; + my ( $event_name, @args ) = @_; + + my $code = $self->can_event( $event_name ) + or return undef; + + $self->_debug_printf_event( scalar caller, $event_name ) if $IO::Async::Debug::DEBUG; + return [ $code->( $self, @args ) ]; +} + +=head1 DEBUGGING SUPPORT + +=cut + +=head2 $notifier->debug_printf( $format, @args ) + +Conditionally print a debugging message to C<STDERR> if debugging is enabled. +If such a message is printed, it will be printed using C<printf> using the +given format and arguments. The message will be prefixed with an string, in +square brackets, to help identify the C<$notifier> instance. This string will +be the class name of the notifier, and any parent notifiers it is contained +by, joined by an arrow C<< <- >>. To ensure this string does not grow too +long, certain prefixes are abbreviated: + + IO::Async::Protocol:: => IaP: + IO::Async:: => Ia: + Net::Async:: => Na: + +Finally, each notifier that has a name defined using the C<notifier_name> +parameter has that name appended in braces. + +For example, invoking + + $stream->debug_printf( "EVENT on_read" ) + +On an C<IO::Async::Stream> instance reading and writing a file descriptor +whose C<fileno> is 4, which is a child of an C<IO::Async::Protocol::Stream>, +will produce a line of output: + + [Ia:Stream{rw=4}<-IaP:Stream] EVENT on_read + +=cut + +sub debug_printf +{ + $IO::Async::Debug::DEBUG or return; + + my $self = shift; + my ( $format, @args ) = @_; + + my @id; + while( $self ) { + push @id, ref $self; + + my $name = $self->notifier_name; + $id[-1] .= "{$name}" if defined $name and length $name; + + $self = $self->parent; + } + + s/^IO::Async::Protocol::/IaP:/, + s/^IO::Async::/Ia:/, + s/^Net::Async::/Na:/ for @id; + + IO::Async::Debug::logf "[%s] $format\n", join("<-", @id), @args; +} + +sub _debug_printf_event +{ + my $self = shift; + my ( $caller, $event_name ) = @_; + + my $class = ref $self; + + if( $IO::Async::Debug::DEBUG > 1 or $class eq $caller ) { + s/^IO::Async::Protocol::/IaP:/, + s/^IO::Async::/Ia:/, + s/^Net::Async::/Na:/ for my $str_caller = $caller; + + $self->debug_printf( "EVENT %s", + ( $class eq $caller ? $event_name : "${str_caller}::$event_name" ) + ); + } +} + +=head2 $notifier->invoke_error( $message, $name, @details ) + +Invokes the stored C<on_error> event handler, passing in the given arguments. +If no handler is defined, it will be passed up to the containing parent +notifier, if one exists. If no parent exists, the error message will be thrown +as an exception by using C<die()> and this method will not return. + +If a handler is found to handle this error, the method will return as normal. +However, as the expected use-case is to handle "fatal" errors that now render +the notifier unsuitable to continue, code should be careful not to perform any +further work after invoking it. Specifically, sockets may become disconnected, +or the entire notifier may now be removed from its containing loop. + +The C<$name> and C<@details> list should follow similar semantics to L<Future> +failures. That is, the C<$name> should be a string giving a category of +failure, and the C<@details> list should contain additional arguments that +relate to that kind of failure. + +=cut + +sub invoke_error +{ + my $self = shift; + my ( $message, $name, @details ) = @_; + + if( my $code = $self->{IO_Async_Notifier__on_error} || $self->can( "on_error" ) ) { + return $code->( $self, $message, $name, @details ); + } + + if( my $parent = $self->parent ) { + return $parent->invoke_error( @_ ); + } + + die "$message\n"; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/OS.pm b/lib/IO/Async/OS.pm new file mode 100644 index 0000000..db16138 --- /dev/null +++ b/lib/IO/Async/OS.pm @@ -0,0 +1,599 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2012-2015 -- leonerd@leonerd.org.uk + +package IO::Async::OS; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +our @ISA = qw( IO::Async::OS::_Base ); + +if( eval { require "IO/Async/OS/$^O.pm" } ) { + @ISA = "IO::Async::OS::$^O"; +} + +package # hide from CPAN + IO::Async::OS::_Base; + +use Carp; + +use Socket 1.95 qw( + AF_INET AF_INET6 AF_UNIX INADDR_LOOPBACK SOCK_DGRAM SOCK_RAW SOCK_STREAM + pack_sockaddr_in inet_aton + pack_sockaddr_in6 inet_pton + pack_sockaddr_un +); + +use IO::Socket (); # empty import + +use POSIX qw( sysconf _SC_OPEN_MAX ); + +# Win32 [and maybe other places] don't have an _SC_OPEN_MAX. About the best we +# can do really is just make up some largeish number and hope for the best. +use constant OPEN_MAX_FD => eval { sysconf(_SC_OPEN_MAX) } || 1024; + +# Some constants that define features of the OS + +use constant HAVE_SOCKADDR_IN6 => defined eval { pack_sockaddr_in6 0, inet_pton( AF_INET6, "2001::1" ) }; +use constant HAVE_SOCKADDR_UN => defined eval { pack_sockaddr_un "/foo" }; + +# Do we have to fake S_ISREG() files read/write-ready in select()? +use constant HAVE_FAKE_ISREG_READY => 0; + +# Do we have to select() for for evec to get connect() failures +use constant HAVE_SELECT_CONNECT_EVEC => 0; +# Ditto; do we have to poll() for POLLPRI to get connect() failures +use constant HAVE_POLL_CONNECT_POLLPRI => 0; + +# Does connect() yield EWOULDBLOCK for nonblocking in progress? +use constant HAVE_CONNECT_EWOULDBLOCK => 0; + +# Can we rename() files that are open? +use constant HAVE_RENAME_OPEN_FILES => 1; + +# Do we have IO::Socket::IP available? +use constant HAVE_IO_SOCKET_IP => defined eval { require IO::Socket::IP }; + +# Can we reliably watch for POSIX signals, including SIGCHLD to reliably +# inform us that a fork()ed child has exit()ed? +use constant HAVE_SIGNALS => 1; + +# Do we support POSIX-style true fork()ed processes at all? +use constant HAVE_POSIX_FORK => !$ENV{IO_ASYNC_NO_FORK}; +# Can we potentially support threads? (would still need to 'require threads') +use constant HAVE_THREADS => !$ENV{IO_ASYNC_NO_THREADS} && + eval { require Config && $Config::Config{useithreads} }; + +# Preferred trial order for built-in Loop classes +use constant LOOP_BUILTIN_CLASSES => qw( Poll Select ); + +# Should there be any other Loop classes we try before the builtin ones? +use constant LOOP_PREFER_CLASSES => (); + +=head1 NAME + +C<IO::Async::OS> - operating system abstractions for C<IO::Async> + +=head1 DESCRIPTION + +This module acts as a class to provide a number of utility methods whose exact +behaviour may depend on the type of OS it is running on. It is provided as a +class so that specific kinds of operating system can override methods in it. + +As well as these support functions it also provides a number of constants, all +with names beginning C<HAVE_> which describe various features that may or may +not be available on the OS or perl build. Most of these are either hard-coded +per OS, or detected at runtime. + +The following constants may be overridden by environment variables. + +=over 4 + +=item * HAVE_POSIX_FORK + +True if the C<fork()> call has full POSIX semantics (full process separation). +This is true on most OSes but false on MSWin32. + +This may be overridden to be false by setting the environment variable +C<IO_ASYNC_NO_FORK>. + +=item * HAVE_THREADS + +True if C<ithreads> are available, meaning that the C<threads> module can be +used. This depends on whether perl was built with threading support. + +This may be overridable to be false by setting the environment variable +C<IO_ASYNC_NO_THREADS>. + +=back + +=cut + +=head2 $family = IO::Async::OS->getfamilybyname( $name ) + +Return a protocol family value based on the given name. If C<$name> looks like +a number it will be returned as-is. The string values C<inet>, C<inet6> and +C<unix> will be converted to the appropriate C<AF_*> constant. + +=cut + +sub getfamilybyname +{ + shift; + my ( $name ) = @_; + + return undef unless defined $name; + + return $name if $name =~ m/^\d+$/; + + return AF_INET if $name eq "inet"; + return AF_INET6() if $name eq "inet6" and defined &AF_INET6; + return AF_UNIX if $name eq "unix"; + + croak "Unrecognised socktype name '$name'"; +} + +=head2 $socktype = IO::Async::OS->getsocktypebyname( $name ) + +Return a socket type value based on the given name. If C<$name> looks like a +number it will be returned as-is. The string values C<stream>, C<dgram> and +C<raw> will be converted to the appropriate C<SOCK_*> constant. + +=cut + +sub getsocktypebyname +{ + shift; + my ( $name ) = @_; + + return undef unless defined $name; + + return $name if $name =~ m/^\d+$/; + + return SOCK_STREAM if $name eq "stream"; + return SOCK_DGRAM if $name eq "dgram"; + return SOCK_RAW if $name eq "raw"; + + croak "Unrecognised socktype name '$name'"; +} + +# This one isn't documented because it's not really overridable. It's largely +# here just for completeness +sub socket +{ + my $self = shift; + my ( $family, $socktype, $proto ) = @_; + + croak "Cannot create a new socket without a family" unless $family; + # PF_UNSPEC and undef are both false + $family = $self->getfamilybyname( $family ) || AF_UNIX; + + # SOCK_STREAM is the most likely + $socktype = $self->getsocktypebyname( $socktype ) || SOCK_STREAM; + + defined $proto or $proto = 0; + + if( HAVE_IO_SOCKET_IP and ( $family == AF_INET || $family == AF_INET6() ) ) { + return IO::Socket::IP->new->socket( $family, $socktype, $proto ); + } + + my $sock = eval { + IO::Socket->new( + Domain => $family, + Type => $socktype, + Proto => $proto, + ); + }; + return $sock if $sock; + + # That failed. Most likely because the Domain was unrecognised. This + # usually happens if getaddrinfo returns an AF_INET6 address but we don't + # have a suitable class loaded. In this case we'll return a generic one. + # It won't be in the specific subclass but that's the best we can do. And + # it will still work as a generic socket. + return IO::Socket->new->socket( $family, $socktype, $proto ); +} + +=head2 ( $S1, $S2 ) = IO::Async::OS->socketpair( $family, $socktype, $proto ) + +An abstraction of the C<socketpair(2)> syscall, where any argument may be +missing (or given as C<undef>). + +If C<$family> is not provided, a suitable value will be provided by the OS +(likely C<AF_UNIX> on POSIX-based platforms). If C<$socktype> is not provided, +then C<SOCK_STREAM> will be used. + +Additionally, this method supports building connected C<SOCK_STREAM> or +C<SOCK_DGRAM> pairs in the C<AF_INET> family even if the underlying platform's +C<socketpair(2)> does not, by connecting two normal sockets together. + +C<$family> and C<$socktype> may also be given symbolically as defined by +C<getfamilybyname> and C<getsocktypebyname>. + +=cut + +sub socketpair +{ + my $self = shift; + my ( $family, $socktype, $proto ) = @_; + + # PF_UNSPEC and undef are both false + $family = $self->getfamilybyname( $family ) || AF_UNIX; + + # SOCK_STREAM is the most likely + $socktype = $self->getsocktypebyname( $socktype ) || SOCK_STREAM; + + $proto ||= 0; + + my ( $S1, $S2 ) = IO::Socket->new->socketpair( $family, $socktype, $proto ); + return ( $S1, $S2 ) if defined $S1; + + return unless $family == AF_INET and ( $socktype == SOCK_STREAM or $socktype == SOCK_DGRAM ); + + # Now lets emulate an AF_INET socketpair call + + my $Stmp = IO::Async::OS->socket( $family, $socktype ) or return; + $Stmp->bind( pack_sockaddr_in( 0, INADDR_LOOPBACK ) ) or return; + + $S1 = IO::Async::OS->socket( $family, $socktype ) or return; + + if( $socktype == SOCK_STREAM ) { + $Stmp->listen( 1 ) or return; + $S1->connect( getsockname $Stmp ) or return; + $S2 = $Stmp->accept or return; + + # There's a bug in IO::Socket here, in that $S2 's ->socktype won't + # yet be set. We can apply a horribly hacky fix here + # defined $S2->socktype and $S2->socktype == $socktype or + # ${*$S2}{io_socket_type} = $socktype; + # But for now we'll skip the test for it instead + } + else { + $S2 = $Stmp; + $S1->connect( getsockname $S2 ) or return; + $S2->connect( getsockname $S1 ) or return; + } + + return ( $S1, $S2 ); +} + +=head2 ( $rd, $wr ) = IO::Async::OS->pipepair + +An abstraction of the C<pipe(2)> syscall, which returns the two new handles. + +=cut + +sub pipepair +{ + my $self = shift; + + pipe( my ( $rd, $wr ) ) or return; + return ( $rd, $wr ); +} + +=head2 ( $rdA, $wrA, $rdB, $wrB ) = IO::Async::OS->pipequad + +This method is intended for creating two pairs of filehandles that are linked +together, suitable for passing as the STDIN/STDOUT pair to a child process. +After this function returns, C<$rdA> and C<$wrA> will be a linked pair, as +will C<$rdB> and C<$wrB>. + +On platforms that support C<socketpair(2)>, this implementation will be +preferred, in which case C<$rdA> and C<$wrB> will actually be the same +filehandle, as will C<$rdB> and C<$wrA>. This saves a file descriptor in the +parent process. + +When creating a C<IO::Async::Stream> or subclass of it, the C<read_handle> +and C<write_handle> parameters should always be used. + + my ( $childRd, $myWr, $myRd, $childWr ) = IO::Async::OS->pipequad; + + IO::Async::OS->open_child( + stdin => $childRd, + stdout => $childWr, + ... + ); + + my $str = IO::Async::Stream->new( + read_handle => $myRd, + write_handle => $myWr, + ... + ); + IO::Async::OS->add( $str ); + +=cut + +sub pipequad +{ + my $self = shift; + + # Prefer socketpair + if( my ( $S1, $S2 ) = $self->socketpair ) { + return ( $S1, $S2, $S2, $S1 ); + } + + # Can't do that, fallback on pipes + my ( $rdA, $wrA ) = $self->pipepair or return; + my ( $rdB, $wrB ) = $self->pipepair or return; + + return ( $rdA, $wrA, $rdB, $wrB ); +} + +=head2 $signum = IO::Async::OS->signame2num( $signame ) + +This utility method converts a signal name (such as "TERM") into its system- +specific signal number. This may be useful to pass to C<POSIX::SigSet> or use +in other places which use numbers instead of symbolic names. + +=cut + +my %sig_num; +sub _init_signum +{ + my $self = shift; + # Copypasta from Config.pm's documentation + + our %Config; + require Config; + Config->import; + + unless($Config{sig_name} && $Config{sig_num}) { + die "No signals found"; + } + else { + my @names = split ' ', $Config{sig_name}; + @sig_num{@names} = split ' ', $Config{sig_num}; + } +} + +sub signame2num +{ + my $self = shift; + my ( $signame ) = @_; + + %sig_num or $self->_init_signum; + + return $sig_num{$signame}; +} + +=head2 ( $family, $socktype, $protocol, $addr ) = IO::Async::OS->extract_addrinfo( $ai ) + +Given an ARRAY or HASH reference value containing an addrinfo, returns a +family, socktype and protocol argument suitable for a C<socket> call and an +address suitable for C<connect> or C<bind>. + +If given an ARRAY it should be in the following form: + + [ $family, $socktype, $protocol, $addr ] + +If given a HASH it should contain the following keys: + + family socktype protocol addr + +Each field in the result will be initialised to 0 (or empty string for the +address) if not defined in the C<$ai> value. + +The family type may also be given as a symbolic string as defined by +C<getfamilybyname>. + +The socktype may also be given as a symbolic string; C<stream>, C<dgram> or +C<raw>; this will be converted to the appropriate C<SOCK_*> constant. + +Note that the C<addr> field, if provided, must be a packed socket address, +such as returned by C<pack_sockaddr_in> or C<pack_sockaddr_un>. + +If the HASH form is used, rather than passing a packed socket address in the +C<addr> field, certain other hash keys may be used instead for convenience on +certain named families. + +=over 4 + +=cut + +use constant ADDRINFO_FAMILY => 0; +use constant ADDRINFO_SOCKTYPE => 1; +use constant ADDRINFO_PROTOCOL => 2; +use constant ADDRINFO_ADDR => 3; + +sub extract_addrinfo +{ + my $self = shift; + my ( $ai, $argname ) = @_; + + $argname ||= "addr"; + + my @ai; + + if( ref $ai eq "ARRAY" ) { + @ai = @$ai; + } + elsif( ref $ai eq "HASH" ) { + $ai = { %$ai }; # copy so we can delete from it + @ai = delete @{$ai}{qw( family socktype protocol addr )}; + + if( defined $ai[ADDRINFO_FAMILY] and !defined $ai[ADDRINFO_ADDR] ) { + my $family = $ai[ADDRINFO_FAMILY]; + my $method = "_extract_addrinfo_$family"; + my $code = $self->can( $method ) or croak "Cannot determine addr for extract_addrinfo on family='$family'"; + + $ai[ADDRINFO_ADDR] = $code->( $self, $ai ); + + keys %$ai and croak "Unrecognised '$family' addrinfo keys: " . join( ", ", keys %$ai ); + } + } + else { + croak "Expected '$argname' to be an ARRAY or HASH reference"; + } + + $ai[ADDRINFO_FAMILY] = $self->getfamilybyname( $ai[ADDRINFO_FAMILY] ); + $ai[ADDRINFO_SOCKTYPE] = $self->getsocktypebyname( $ai[ADDRINFO_SOCKTYPE] ); + + # Make sure all fields are defined + $ai[$_] ||= 0 for ADDRINFO_FAMILY, ADDRINFO_SOCKTYPE, ADDRINFO_PROTOCOL; + $ai[ADDRINFO_ADDR] = "" if !defined $ai[ADDRINFO_ADDR]; + + return @ai; +} + +=item family => 'inet' + +Will pack an IP address and port number from keys called C<ip> and C<port>. +If C<ip> is missing it will be set to "0.0.0.0". If C<port> is missing it will +be set to 0. + +=cut + +sub _extract_addrinfo_inet +{ + my $self = shift; + my ( $ai ) = @_; + + my $port = delete $ai->{port} || 0; + my $ip = delete $ai->{ip} || "0.0.0.0"; + + return pack_sockaddr_in( $port, inet_aton( $ip ) ); +} + +=item family => 'inet6' + +Will pack an IP address and port number from keys called C<ip> and C<port>. +If C<ip> is missing it will be set to "::". If C<port> is missing it will be +set to 0. Optionally will also include values from C<scopeid> and C<flowinfo> +keys if provided. + +This will only work if a C<pack_sockaddr_in6> function can be found in +C<Socket> + +=cut + +sub _extract_addrinfo_inet6 +{ + my $self = shift; + my ( $ai ) = @_; + + my $port = delete $ai->{port} || 0; + my $ip = delete $ai->{ip} || "::"; + my $scopeid = delete $ai->{scopeid} || 0; + my $flowinfo = delete $ai->{flowinfo} || 0; + + if( HAVE_SOCKADDR_IN6 ) { + return pack_sockaddr_in6( $port, inet_pton( AF_INET6, $ip ), $scopeid, $flowinfo ); + } + else { + croak "Cannot pack_sockaddr_in6"; + } +} + +=item family => 'unix' + +Will pack a UNIX socket path from a key called C<path>. + +=cut + +sub _extract_addrinfo_unix +{ + my $self = shift; + my ( $ai ) = @_; + + defined( my $path = delete $ai->{path} ) or croak "Expected 'path' for extract_addrinfo on family='unix'"; + + return pack_sockaddr_un( $path ); +} + +=pod + +=back + +=cut + +=head1 LOOP IMPLEMENTATION METHODS + +The following methods are provided on C<IO::Async::OS> because they are likely +to require OS-specific implementations, but are used by L<IO::Async::Loop> to +implement its functionality. It can use the HASH reference C<< $loop->{os} >> +to store other data it requires. + +=cut + +=head2 IO::Async::OS->loop_watch_signal( $loop, $signal, $code ) + +=head2 IO::Async::OS->loop_unwatch_signal( $loop, $signal ) + +Used to implement the C<watch_signal> / C<unwatch_signal> Loop pair. + +=cut + +sub loop_watch_signal +{ + my $self = shift; + my ( $loop, $signal, $code ) = @_; + + exists $SIG{$signal} or croak "Unrecognised signal name $signal"; + ref $code or croak 'Expected $code as a reference'; + + my $signum = $self->signame2num( $signal ); + my $sigwatch = $loop->{os}{sigwatch} ||= {}; # {$num} = $code + + my $sigpipe; + unless( $sigpipe = $loop->{os}{sigpipe} ) { + require IO::Async::Handle; + + ( my $reader, $sigpipe ) = $self->pipepair or croak "Cannot pipe() - $!"; + $_->blocking( 0 ) for $reader, $sigpipe; + + $loop->{os}{sigpipe} = $sigpipe; + + $loop->add( $loop->{os}{sigpipe_reader} = IO::Async::Handle->new( + notifier_name => "sigpipe", + read_handle => $reader, + on_read_ready => sub { + sysread $reader, my $buffer, 8192 or return; + foreach my $signum ( unpack "I*", $buffer ) { + $sigwatch->{$signum}->() if $sigwatch->{$signum}; + } + }, + ) ); + } + + my $signum_str = pack "I", $signum; + $SIG{$signal} = sub { syswrite $sigpipe, $signum_str }; + + $sigwatch->{$signum} = $code; +} + +sub loop_unwatch_signal +{ + my $self = shift; + my ( $loop, $signal ) = @_; + + my $signum = $self->signame2num( $signal ); + my $sigwatch = $loop->{os}{sigwatch} or return; + + delete $sigwatch->{$signum}; + undef $SIG{$signal}; +} + +=head2 @fds = IO::Async::OS->potentially_open_fds + +Returns a list of filedescriptors which might need closing. By default this +will return C<0 .. _SC_OPEN_MAX>. OS-specific subclasses may have a better +guess. + +=cut + +sub potentially_open_fds +{ + return 0 .. OPEN_MAX_FD; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/OS/MSWin32.pm b/lib/IO/Async/OS/MSWin32.pm new file mode 100644 index 0000000..bfed7f7 --- /dev/null +++ b/lib/IO/Async/OS/MSWin32.pm @@ -0,0 +1,111 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2012-2013 -- leonerd@leonerd.org.uk + +package IO::Async::OS::MSWin32; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +our @ISA = qw( IO::Async::OS::_Base ); + +use Carp; + +use Socket qw( AF_INET SOCK_STREAM SOCK_DGRAM INADDR_LOOPBACK pack_sockaddr_in ); + +use IO::Socket (); # empty import + +use constant HAVE_FAKE_ISREG_READY => 1; + +# Also select() only reports connect() failures by evec, not wvec +use constant HAVE_SELECT_CONNECT_EVEC => 1; + +use constant HAVE_POLL_CONNECT_POLLPRI => 1; + +use constant HAVE_CONNECT_EWOULDBLOCK => 1; + +use constant HAVE_RENAME_OPEN_FILES => 0; + +# poll(2) on Windows is emulated by wrapping select(2) anyway, so we might as +# well try the Select loop first +use constant LOOP_BUILTIN_CLASSES => qw( Select Poll ); + +# CORE::fork() does not provide full POSIX semantics +use constant HAVE_POSIX_FORK => 0; + +# Windows does not have signals, and SIGCHLD is not available +use constant HAVE_SIGNALS => 0; + +=head1 NAME + +C<IO::Async::OS::MSWin32> - operating system abstractions on C<MSWin32> for C<IO::Async> + +=head1 DESCRIPTION + +This module contains OS support code for C<MSWin32>. + +See instead L<IO::Async::OS>. + +=cut + +# Win32's pipes don't actually work with select(). We'll have to create +# sockets instead +sub pipepair +{ + shift->socketpair( 'inet', 'stream' ); +} + +# Win32 doesn't have a socketpair(). We'll fake one up +sub socketpair +{ + my $self = shift; + my ( $family, $socktype, $proto ) = @_; + + $family = $self->getfamilybyname( $family ) || AF_INET; + + # SOCK_STREAM is the most likely + $socktype = $self->getsocktypebyname( $socktype ) || SOCK_STREAM; + + $proto ||= 0; + + $family == AF_INET or croak "Cannot emulate ->socketpair except on AF_INET"; + + my $Stmp = $self->socket( $family, $socktype ) or return; + $Stmp->bind( pack_sockaddr_in( 0, INADDR_LOOPBACK ) ) or return; + + my $S1 = $self->socket( $family, $socktype ) or return; + + my $S2; + if( $socktype == SOCK_STREAM ) { + $Stmp->listen( 1 ) or return; + $S1->connect( getsockname $Stmp ) or return; + $S2 = $Stmp->accept or return; + + # There's a bug in IO::Socket here, in that $S2 's ->socktype won't + # yet be set. We can apply a horribly hacky fix here + # defined $S2->socktype and $S2->socktype == $socktype or + # ${*$S2}{io_socket_type} = $socktype; + # But for now we'll skip the test for it instead + } + elsif( $socktype == SOCK_DGRAM ) { + $S2 = $Stmp; + $S1->connect( getsockname $S2 ) or return; + $S2->connect( getsockname $S1 ) or return; + } + else { + croak "Unrecognised socktype $socktype"; + } + + return ( $S1, $S2 ); +}; + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/OS/cygwin.pm b/lib/IO/Async/OS/cygwin.pm new file mode 100644 index 0000000..630bf9a --- /dev/null +++ b/lib/IO/Async/OS/cygwin.pm @@ -0,0 +1,40 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2013 -- leonerd@leonerd.org.uk + +package IO::Async::OS::cygwin; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +our @ISA = qw( IO::Async::OS::_Base ); + +# Cygwin almost needs no hinting above the POSIX-like base, except that its +# emulation of poll() isn't quite perfect. It needs POLLPRI +use constant HAVE_POLL_CONNECT_POLLPRI => 1; + +# Also select() only reports connect() failures by evec, not wvec +use constant HAVE_SELECT_CONNECT_EVEC => 1; + +=head1 NAME + +C<IO::Async::OS::cygwin> - operating system abstractions on C<cygwin> for C<IO::Async> + +=head1 DESCRIPTION + +This module contains OS support code for C<cygwin>. + +See instead L<IO::Async::OS>. + +=cut + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/OS/linux.pm b/lib/IO/Async/OS/linux.pm new file mode 100644 index 0000000..c12949b --- /dev/null +++ b/lib/IO/Async/OS/linux.pm @@ -0,0 +1,59 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2014-2015 -- leonerd@leonerd.org.uk + +package IO::Async::OS::linux; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +our @ISA = qw( IO::Async::OS::_Base ); + +=head1 NAME + +C<IO::Async::OS::linux> - operating system abstractions on C<Linux> for C<IO::Async> + +=head1 DESCRIPTION + +This module contains OS support code for C<Linux>. + +See instead L<IO::Async::OS>. + +=cut + +# Suggest either Epoll or Ppoll loops first if they are installed +use constant LOOP_PREFER_CLASSES => qw( Epoll Ppoll ); + +# Try to use /proc/pid/fd to get the list of actually-open file descriptors +# for our process. Saves a bit of time when running with high ulimit -n / +# fileno counts. +sub potentially_open_fds +{ + my $class = shift; + + opendir my $fd_path, "/proc/$$/fd" or do { + warn "Cannot open /proc/$$/fd, falling back to generic method - $!"; + return $class->SUPER::potentially_open_fds + }; + + # Skip ., .., our directory handle itself and any other cruft + # except fileno() isn't available for the handle so we'll + # end up with that in the output anyway. As long as we're + # called just before the relevant close() loop, this + # should be harmless enough. + my @fd = map { m/^([0-9]+)$/ ? $1 : () } readdir $fd_path; + closedir $fd_path; + + return @fd; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/PID.pm b/lib/IO/Async/PID.pm new file mode 100644 index 0000000..fc59f9c --- /dev/null +++ b/lib/IO/Async/PID.pm @@ -0,0 +1,196 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2010-2011 -- leonerd@leonerd.org.uk + +package IO::Async::PID; + +use strict; +use warnings; +use base qw( IO::Async::Notifier ); + +our $VERSION = '0.67'; + +use Carp; + +=head1 NAME + +C<IO::Async::PID> - event callback on exit of a child process + +=head1 SYNOPSIS + + use IO::Async::PID; + use POSIX qw( WEXITSTATUS ); + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my $kid = $loop->fork( + code => sub { + print "Child sleeping..\n"; + sleep 10; + print "Child exiting\n"; + return 20; + }, + ); + + print "Child process $kid started\n"; + + my $pid = IO::Async::PID->new( + pid => $kid, + + on_exit => sub { + my ( $self, $exitcode ) = @_; + printf "Child process %d exited with status %d\n", + $self->pid, WEXITSTATUS($exitcode); + }, + ); + + $loop->add( $pid ); + + $loop->run; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Notifier> invokes its callback when a process +exits. + +For most use cases, a L<IO::Async::Process> object provides more control of +setting up the process, connecting filehandles to it, sending data to and +receiving data from it. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters: + +=head2 on_exit $exitcode + +Invoked when the watched process exits. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 pid => INT + +The process ID to watch. Must be given before the object has been added to the +containing C<IO::Async::Loop> object. + +=head2 on_exit => CODE + +CODE reference for the C<on_exit> event. + +Once the C<on_exit> continuation has been invoked, the C<IO::Async::PID> +object is removed from the containing C<IO::Async::Loop> object. + +=cut + +sub configure +{ + my $self = shift; + my %params = @_; + + if( exists $params{pid} ) { + $self->loop and croak "Cannot configure 'pid' after adding to Loop"; + $self->{pid} = delete $params{pid}; + } + + if( exists $params{on_exit} ) { + $self->{on_exit} = delete $params{on_exit}; + + undef $self->{cb}; + + if( my $loop = $self->loop ) { + $self->_remove_from_loop( $loop ); + $self->_add_to_loop( $loop ); + } + } + + $self->SUPER::configure( %params ); +} + +sub _add_to_loop +{ + my $self = shift; + my ( $loop ) = @_; + + $self->pid or croak "Require a 'pid' in $self"; + + $self->SUPER::_add_to_loop( @_ ); + + # on_exit continuation gets passed PID value; need to replace that with + # $self + $self->{cb} ||= $self->_replace_weakself( sub { + my $self = shift or return; + my ( $exitcode ) = @_; + + $self->invoke_event( on_exit => $exitcode ); + + # Since this is a oneshot, we'll have to remove it from the loop or + # parent Notifier + $self->remove_from_parent; + } ); + + $loop->watch_child( $self->pid, $self->{cb} ); +} + +sub _remove_from_loop +{ + my $self = shift; + my ( $loop ) = @_; + + $loop->unwatch_child( $self->pid ); +} + +sub notifier_name +{ + my $self = shift; + if( length( my $name = $self->SUPER::notifier_name ) ) { + return $name; + } + + return $self->{pid}; +} + +=head1 METHODS + +=cut + +=head2 $process_id = $pid->pid + +Returns the underlying process ID + +=cut + +sub pid +{ + my $self = shift; + return $self->{pid}; +} + +=head2 $pid->kill( $signal ) + +Sends a signal to the process + +=cut + +sub kill +{ + my $self = shift; + my ( $signal ) = @_; + + kill $signal, $self->pid or croak "Cannot kill() - $!"; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Process.pm b/lib/IO/Async/Process.pm new file mode 100644 index 0000000..31c70d5 --- /dev/null +++ b/lib/IO/Async/Process.pm @@ -0,0 +1,849 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2011-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Process; + +use strict; +use warnings; +use base qw( IO::Async::Notifier ); + +our $VERSION = '0.67'; + +use Carp; + +use Socket qw( SOCK_STREAM ); + +use Future; + +use IO::Async::OS; + +=head1 NAME + +C<IO::Async::Process> - start and manage a child process + +=head1 SYNOPSIS + + use IO::Async::Process; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my $process = IO::Async::Process->new( + command => [ "tr", "a-z", "n-za-m" ], + stdin => { + from => "hello world\n", + }, + stdout => { + on_read => sub { + my ( $stream, $buffref ) = @_; + while( $$buffref =~ s/^(.*)\n// ) { + print "Rot13 of 'hello world' is '$1'\n"; + } + + return 0; + }, + }, + + on_finish => sub { + $loop->stop; + }, + ); + + $loop->add( $process ); + + $loop->run; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Notifier> starts a child process, and invokes a +callback when it exits. The child process can either execute a given block of +code (via C<fork(2)>), or a command. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters: + +=head2 on_finish $exitcode + +Invoked after the process has exited by normal means (i.e. an C<exit(2)> +syscall from a process, or C<return>ing from the code block), and has closed +all its file descriptors. + +=head2 on_exception $exception, $errno, $exitcode + +Invoked when the process exits by an exception from C<code>, or by failing to +C<exec(2)> the given command. C<$errno> will be a dualvar, containing both +number and string values. After a successful C<exec()> call, this condition +can no longer happen. + +Note that this has a different name and a different argument order from +C<< Loop->open_child >>'s C<on_error>. + +If this is not provided and the process exits with an exception, then +C<on_finish> is invoked instead, being passed just the exit code. + +Since this is just the results of the underlying C<< $loop->spawn_child >> +C<on_exit> handler in a different order it is possible that the C<$exception> +field will be an empty string. It will however always be defined. This can be +used to distinguish the two cases: + + on_exception => sub { + my ( $self, $exception, $errno, $exitcode ) = @_; + + if( length $exception ) { + print STDERR "The process died with the exception $exception " . + "(errno was $errno)\n"; + } + elsif( ( my $status = W_EXITSTATUS($exitcode) ) == 255 ) { + print STDERR "The process failed to exec() - $errno\n"; + } + else { + print STDERR "The process exited with exit status $status\n"; + } + } + +=cut + +=head1 CONSTRUCTOR + +=cut + +=head2 $process = IO::Async::Process->new( %args ) + +Constructs a new C<IO::Async::Process> object and returns it. + +Once constructed, the C<Process> will need to be added to the C<Loop> before +the child process is started. + +=cut + +sub _init +{ + my $self = shift; + $self->SUPER::_init( @_ ); + + $self->{to_close} = {}; + $self->{finish_futures} = []; +} + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 on_finish => CODE + +=head2 on_exception => CODE + +CODE reference for the event handlers. + +Once the C<on_finish> continuation has been invoked, the C<IO::Async::Process> +object is removed from the containing C<IO::Async::Loop> object. + +The following parameters may be passed to C<new>, or to C<configure> before +the process has been started (i.e. before it has been added to the C<Loop>). +Once the process is running these cannot be changed. + +=head2 command => ARRAY or STRING + +Either a reference to an array containing the command and its arguments, or a +plain string containing the command. This value is passed into perl's +C<exec(2)> function. + +=head2 code => CODE + +A block of code to execute in the child process. It will be called in scalar +context inside an C<eval> block. + +=head2 setup => ARRAY + +Optional reference to an array to pass to the underlying C<Loop> +C<spawn_child> method. + +=head2 fdI<n> => HASH + +A hash describing how to set up file descriptor I<n>. The hash may contain the +following keys: + +=over 4 + +=item via => STRING + +Configures how this file descriptor will be configured for the child process. +Must be given one of the following mode names: + +=over 4 + +=item pipe_read + +The child will be given the writing end of a C<pipe(2)>; the parent may read +from the other. + +=item pipe_write + +The child will be given the reading end of a C<pipe(2)>; the parent may write +to the other. Since an EOF condition of this kind of handle cannot reliably be +detected, C<on_finish> will not wait for this type of pipe to be closed. + +=item pipe_rdwr + +Only valid on the C<stdio> filehandle. The child will be given the reading end +of one C<pipe(2)> on STDIN and the writing end of another on STDOUT. A single +Stream object will be created in the parent configured for both filehandles. + +=item socketpair + +The child will be given one end of a C<socketpair(2)>; the parent will be +given the other. The family of this socket may be given by the extra key +called C<family>; defaulting to C<unix>. The socktype of this socket may be +given by the extra key called C<socktype>; defaulting to C<stream>. If the +type is not C<SOCK_STREAM> then a L<IO::Async::Socket> object will be +constructed for the parent side of the handle, rather than +C<IO::Async::Stream>. + +=back + +Once the filehandle is set up, the C<fd> method (or its shortcuts of C<stdin>, +C<stdout> or C<stderr>) may be used to access the +C<IO::Async::Handle>-subclassed object wrapped around it. + +The value of this argument is implied by any of the following alternatives. + +=item on_read => CODE + +The child will be given the writing end of a pipe. The reading end will be +wrapped by an C<IO::Async::Stream> using this C<on_read> callback function. + +=item into => SCALAR + +The child will be given the writing end of a pipe. The referenced scalar will +be filled by data read from the child process. This data may not be available +until the pipe has been closed by the child. + +=item from => STRING + +The child will be given the reading end of a pipe. The string given by the +C<from> parameter will be written to the child. When all of the data has been +written the pipe will be closed. + +=back + +=head2 stdin => ... + +=head2 stdout => ... + +=head2 stderr => ... + +Shortcuts for C<fd0>, C<fd1> and C<fd2> respectively. + +=head2 stdio => ... + +Special filehandle to affect STDIN and STDOUT at the same time. This +filehandle supports being configured for both reading and writing at the same +time. + +=cut + +sub configure +{ + my $self = shift; + my %params = @_; + + foreach (qw( on_finish on_exception )) { + $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + # All these parameters can only be configured while the process isn't + # running + my %setup_params; + foreach (qw( code command setup stdin stdout stderr stdio ), grep { m/^fd\d+$/ } keys %params ) { + $setup_params{$_} = delete $params{$_} if exists $params{$_}; + } + + if( $self->is_running ) { + keys %setup_params and croak "Cannot configure a running Process with " . join ", ", keys %setup_params; + } + + defined( exists $setup_params{code} ? $setup_params{code} : $self->{code} ) + + defined( exists $setup_params{command} ? $setup_params{command} : $self->{command} ) <= 1 or + croak "Cannot have both 'code' and 'command'"; + + foreach (qw( code command setup )) { + $self->{$_} = delete $setup_params{$_} if exists $setup_params{$_}; + } + + $self->configure_fd( 0, %{ delete $setup_params{stdin} } ) if $setup_params{stdin}; + $self->configure_fd( 1, %{ delete $setup_params{stdout} } ) if $setup_params{stdout}; + $self->configure_fd( 2, %{ delete $setup_params{stderr} } ) if $setup_params{stderr}; + + $self->configure_fd( 'io', %{ delete $setup_params{stdio} } ) if $setup_params{stdio}; + + # All the rest are fd\d+ + foreach ( keys %setup_params ) { + my ( $fd ) = m/^fd(\d+)$/ or croak "Expected 'fd\\d+'"; + $self->configure_fd( $fd, %{ $setup_params{$_} } ); + } + + $self->SUPER::configure( %params ); +} + +# These are from the perspective of the parent +use constant FD_VIA_PIPEREAD => 1; +use constant FD_VIA_PIPEWRITE => 2; +use constant FD_VIA_PIPERDWR => 3; # Only valid for stdio pseudo-fd +use constant FD_VIA_SOCKETPAIR => 4; + +my %via_names = ( + pipe_read => FD_VIA_PIPEREAD, + pipe_write => FD_VIA_PIPEWRITE, + pipe_rdwr => FD_VIA_PIPERDWR, + socketpair => FD_VIA_SOCKETPAIR, +); + +sub configure_fd +{ + my $self = shift; + my ( $fd, %args ) = @_; + + $self->is_running and croak "Cannot configure fd $fd in a running Process"; + + if( $fd eq "io" ) { + exists $self->{fd_opts}{$_} and croak "Cannot configure stdio since fd$_ is already defined" for 0 .. 1; + } + elsif( $fd == 0 or $fd == 1 ) { + exists $self->{fd_opts}{io} and croak "Cannot configure fd$fd since stdio is already defined"; + } + + my $opts = $self->{fd_opts}{$fd} ||= {}; + my $via = $opts->{via}; + + my ( $wants_read, $wants_write ); + + if( my $via_name = delete $args{via} ) { + defined $via and + croak "Cannot change the 'via' mode of fd$fd now that it is already configured"; + + $via = $via_names{$via_name} or + croak "Unrecognised 'via' name of '$via_name'"; + } + + if( my $on_read = delete $args{on_read} ) { + $opts->{handle}{on_read} = $on_read; + + $wants_read++; + } + elsif( my $into = delete $args{into} ) { + $opts->{handle}{on_read} = sub { + my ( undef, $buffref, $eof ) = @_; + $$into .= $$buffref if $eof; + return 0; + }; + + $wants_read++; + } + + if( defined( my $from = delete $args{from} ) ) { + $opts->{from} = $from; + + $wants_write++; + } + + if( defined $via and $via == FD_VIA_SOCKETPAIR ) { + $self->{fd_opts}{$fd}{$_} = delete $args{$_} for qw( family socktype ); + } + + keys %args and croak "Unexpected extra keys for fd $fd - " . join ", ", keys %args; + + if( !defined $via ) { + $via = FD_VIA_PIPEREAD if $wants_read and !$wants_write; + $via = FD_VIA_PIPEWRITE if !$wants_read and $wants_write; + $via = FD_VIA_PIPERDWR if $wants_read and $wants_write; + } + elsif( $via == FD_VIA_PIPEREAD ) { + $wants_write and $via = FD_VIA_PIPERDWR; + } + elsif( $via == FD_VIA_PIPEWRITE ) { + $wants_read and $via = FD_VIA_PIPERDWR; + } + elsif( $via == FD_VIA_PIPERDWR or $via == FD_VIA_SOCKETPAIR ) { + # Fine + } + else { + die "Need to check fd_via{$fd}\n"; + } + + $via == FD_VIA_PIPERDWR and $fd ne "io" and + croak "Cannot both read and write simultaneously on fd$fd"; + + defined $via and $opts->{via} = $via; +} + +sub _prepare_fds +{ + my $self = shift; + my ( $loop ) = @_; + + my $fd_handle = $self->{fd_handle}; + my $fd_opts = $self->{fd_opts}; + + my $finish_futures = $self->{finish_futures}; + + my @setup; + + foreach my $fd ( keys %$fd_opts ) { + my $opts = $fd_opts->{$fd}; + my $via = $opts->{via}; + + my $handle = $self->fd( $fd ); + + my $key = $fd eq "io" ? "stdio" : "fd$fd"; + my $write_only; + + if( $via == FD_VIA_PIPEREAD ) { + my ( $myfd, $childfd ) = IO::Async::OS->pipepair or croak "Unable to pipe() - $!"; + + $handle->configure( read_handle => $myfd ); + + push @setup, $key => [ dup => $childfd ]; + $self->{to_close}{$childfd->fileno} = $childfd; + } + elsif( $via == FD_VIA_PIPEWRITE ) { + my ( $childfd, $myfd ) = IO::Async::OS->pipepair or croak "Unable to pipe() - $!"; + $write_only++; + + $handle->configure( write_handle => $myfd ); + + push @setup, $key => [ dup => $childfd ]; + $self->{to_close}{$childfd->fileno} = $childfd; + } + elsif( $via == FD_VIA_PIPERDWR ) { + $key eq "stdio" or croak "Oops - should only be FD_VIA_PIPERDWR on stdio"; + # Can't use pipequad here for now because we need separate FDs so we + # can ->close them properly + my ( $myread, $childwrite ) = IO::Async::OS->pipepair or croak "Unable to pipe() - $!"; + my ( $childread, $mywrite ) = IO::Async::OS->pipepair or croak "Unable to pipe() - $!"; + + $handle->configure( read_handle => $myread, write_handle => $mywrite ); + + push @setup, stdin => [ dup => $childread ], stdout => [ dup => $childwrite ]; + $self->{to_close}{$childread->fileno} = $childread; + $self->{to_close}{$childwrite->fileno} = $childwrite; + } + elsif( $via == FD_VIA_SOCKETPAIR ) { + my ( $myfd, $childfd ) = IO::Async::OS->socketpair( $opts->{family}, $opts->{socktype} ) or croak "Unable to socketpair() - $!"; + + $handle->configure( handle => $myfd ); + + if( $key eq "stdio" ) { + push @setup, stdin => [ dup => $childfd ], stdout => [ dup => $childfd ]; + } + else { + push @setup, $key => [ dup => $childfd ]; + } + $self->{to_close}{$childfd->fileno} = $childfd; + } + else { + croak "Unsure what to do with fd_via==$via"; + } + + $self->add_child( $handle ); + + unless( $write_only ) { + push @$finish_futures, $handle->new_close_future; + } + } + + return @setup; +} + +sub _add_to_loop +{ + my $self = shift; + my ( $loop ) = @_; + + $self->{code} or $self->{command} or + croak "Require either 'code' or 'command' in $self"; + + $self->can_event( "on_finish" ) or + croak "Expected either an on_finish callback or to be able to ->on_finish"; + + my @setup; + push @setup, @{ $self->{setup} } if $self->{setup}; + + push @setup, $self->_prepare_fds( $loop ); + + my $finish_futures = delete $self->{finish_futures}; + + my ( $exitcode, $dollarbang, $dollarat ); + push @$finish_futures, my $exit_future = $loop->new_future; + + $self->{pid} = $loop->spawn_child( + code => $self->{code}, + command => $self->{command}, + + setup => \@setup, + + on_exit => $self->_capture_weakself( sub { + ( my $self, undef, $exitcode, $dollarbang, $dollarat ) = @_; + + $self->debug_printf( "EXIT status=0x%04x", $exitcode ) if $self; + $exit_future->done unless $exit_future->is_cancelled; + } ), + ); + $self->{running} = 1; + + $self->SUPER::_add_to_loop( @_ ); + + $_->close for values %{ delete $self->{to_close} }; + + my $is_code = defined $self->{code}; + + $self->{finish_future} = Future->needs_all( @$finish_futures ) + ->on_done( $self->_capture_weakself( sub { + my $self = shift or return; + + $self->{exitcode} = $exitcode; + $self->{dollarbang} = $dollarbang; + $self->{dollarat} = $dollarat; + + undef $self->{running}; + + if( $is_code ? $dollarat eq "" : $dollarbang == 0 ) { + $self->invoke_event( on_finish => $exitcode ); + } + else { + $self->maybe_invoke_event( on_exception => $dollarat, $dollarbang, $exitcode ) or + # Don't have a way to report dollarbang/dollarat + $self->invoke_event( on_finish => $exitcode ); + } + + $self->remove_from_parent; + } ), + ); +} + +sub DESTROY +{ + my $self = shift; + $self->{finish_future}->cancel if $self->{finish_future}; +} + +sub notifier_name +{ + my $self = shift; + if( length( my $name = $self->SUPER::notifier_name ) ) { + return $name; + } + + return "nopid" unless my $pid = $self->pid; + return "[$pid]" unless $self->is_running; + return "$pid"; +} + +=head1 METHODS + +=cut + +=head2 $pid = $process->pid + +Returns the process ID of the process, if it has been started, or C<undef> if +not. Its value is preserved after the process exits, so it may be inspected +during the C<on_finish> or C<on_exception> events. + +=cut + +sub pid +{ + my $self = shift; + return $self->{pid}; +} + +=head2 $process->kill( $signal ) + +Sends a signal to the process + +=cut + +sub kill +{ + my $self = shift; + my ( $signal ) = @_; + + kill $signal, $self->pid or croak "Cannot kill() - $!"; +} + +=head2 $running = $process->is_running + +Returns true if the Process has been started, and has not yet finished. + +=cut + +sub is_running +{ + my $self = shift; + return $self->{running}; +} + +=head2 $exited = $process->is_exited + +Returns true if the Process has finished running, and finished due to normal +C<exit(2)>. + +=cut + +sub is_exited +{ + my $self = shift; + return defined $self->{exitcode} ? ( $self->{exitcode} & 0x7f ) == 0 : undef; +} + +=head2 $status = $process->exitstatus + +If the process exited due to normal C<exit(2)>, returns the value that was +passed to C<exit(2)>. Otherwise, returns C<undef>. + +=cut + +sub exitstatus +{ + my $self = shift; + return defined $self->{exitcode} ? ( $self->{exitcode} >> 8 ) : undef; +} + +=head2 $exception = $process->exception + +If the process exited due to an exception, returns the exception that was +thrown. Otherwise, returns C<undef>. + +=cut + +sub exception +{ + my $self = shift; + return $self->{dollarat}; +} + +=head2 $errno = $process->errno + +If the process exited due to an exception, returns the numerical value of +C<$!> at the time the exception was thrown. Otherwise, returns C<undef>. + +=cut + +sub errno +{ + my $self = shift; + return $self->{dollarbang}+0; +} + +=head2 $errstr = $process->errstr + +If the process exited due to an exception, returns the string value of +C<$!> at the time the exception was thrown. Otherwise, returns C<undef>. + +=cut + +sub errstr +{ + my $self = shift; + return $self->{dollarbang}.""; +} + +=head2 $stream = $process->fd( $fd ) + +Returns the L<IO::Async::Stream> or L<IO::Async::Socket> associated with the +given FD number. This must have been set up by a C<configure> argument prior +to adding the C<Process> object to the C<Loop>. + +The returned object have its read or write handle set to the other end of a +pipe or socket connected to that FD number in the child process. Typically, +this will be used to call the C<write> method on, to write more data into the +child, or to set an C<on_read> handler to read data out of the child. + +The C<on_closed> event for these streams must not be changed, or it will break +the close detection used by the C<Process> object and the C<on_finish> event +will not be invoked. + +=cut + +sub fd +{ + my $self = shift; + my ( $fd ) = @_; + + return $self->{fd_handle}{$fd} ||= do { + my $opts = $self->{fd_opts}{$fd} or + croak "$self does not have an fd Stream for $fd"; + + my $handle_class; + if( defined $opts->{socktype} && IO::Async::OS->getsocktypebyname( $opts->{socktype} ) != SOCK_STREAM ) { + require IO::Async::Socket; + $handle_class = "IO::Async::Socket"; + } + else { + require IO::Async::Stream; + $handle_class = "IO::Async::Stream"; + } + + my $handle = $handle_class->new( + notifier_name => $fd eq "0" ? "stdin" : + $fd eq "1" ? "stdout" : + $fd eq "2" ? "stderr" : + $fd eq "io" ? "stdio" : "fd$fd", + %{ $opts->{handle} }, + ); + + if( defined $opts->{from} ) { + $handle->write( $opts->{from}, + on_flush => sub { + my ( $handle ) = @_; + $handle->close_write; + }, + ); + } + + $handle + }; +} + +=head2 $stream = $process->stdin + +=head2 $stream = $process->stdout + +=head2 $stream = $process->stderr + +=head2 $stream = $process->stdio + +Shortcuts for calling C<fd> with 0, 1, 2 or C<io> respectively, to obtain the +L<IO::Async::Stream> representing the standard input, output, error, or +combined input/output streams of the child process. + +=cut + +sub stdin { shift->fd( 0 ) } +sub stdout { shift->fd( 1 ) } +sub stderr { shift->fd( 2 ) } +sub stdio { shift->fd( 'io' ) } + +=head1 EXAMPLES + +=head2 Capturing the STDOUT stream of a process + +By configuring the C<stdout> filehandle of the process using the C<into> key, +data written by the process can be captured. + + my $stdout; + my $process = IO::Async::Process->new( + command => [ "writing-program", "arguments" ], + stdout => { into => \$stdout }, + on_finish => sub { + print "The process has finished, and wrote:\n"; + print $stdout; + } + ); + + $loop->add( $process ); + +Note that until C<on_finish> is invoked, no guarantees are made about how much +of the data actually written by the process is yet in the C<$stdout> scalar. + +See also the C<run_child> method of L<IO::Async::Loop>. + +To handle data more interactively as it arrives, the C<on_read> key can +instead be used, to provide a callback function to invoke whenever more data +is available from the process. + + my $process = IO::Async::Process->new( + command => [ "writing-program", "arguments" ], + stdout => { + on_read => sub { + my ( $stream, $buffref ) = @_; + while( $$buffref =~ s/^(.*)\n// ) { + print "The process wrote a line: $1\n"; + } + + return 0; + }, + }, + on_finish => sub { + print "The process has finished\n"; + } + ); + + $loop->add( $process ); + +If the code to handle data read from the process isn't available yet when +the object is constructed, it can be supplied later by using the C<configure> +method on the C<stdout> filestream at some point before it gets added to the +Loop. In this case, C<stdin> should be configured using C<pipe_read> in the +C<via> key. + + my $process = IO::Async::Process->new( + command => [ "writing-program", "arguments" ], + stdout => { via => "pipe_read" }, + on_finish => sub { + print "The process has finished\n"; + } + ); + + $process->stdout->configure( + on_read => sub { + my ( $stream, $buffref ) = @_; + while( $$buffref =~ s/^(.*)\n// ) { + print "The process wrote a line: $1\n"; + } + + return 0; + }, + ); + + $loop->add( $process ); + +=head2 Sending data to STDIN of a process + +By configuring the C<stdin> filehandle of the process using the C<from> key, +data can be written into the C<STDIN> stream of the process. + + my $process = IO::Async::Process->new( + command => [ "reading-program", "arguments" ], + stdin => { from => "Here is the data to send\n" }, + on_finish => sub { + print "The process has finished\n"; + } + ); + + $loop->add( $process ); + +The data in this scalar will be written until it is all consumed, then the +handle will be closed. This may be useful if the program waits for EOF on +C<STDIN> before it exits. + +To have the ability to write more data into the process once it has started. +the C<write> method on the C<stdin> stream can be used, when it is configured +using the C<pipe_write> value for C<via>: + + my $process = IO::Async::Process->new( + command => [ "reading-program", "arguments" ], + stdin => { via => "pipe_write" }, + on_finish => sub { + print "The process has finished\n"; + } + ); + + $loop->add( $process ); + + $process->stdin->write( "Here is some more data\n" ); + +=cut + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Protocol.pm b/lib/IO/Async/Protocol.pm new file mode 100644 index 0000000..c155963 --- /dev/null +++ b/lib/IO/Async/Protocol.pm @@ -0,0 +1,259 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2011 -- leonerd@leonerd.org.uk + +package IO::Async::Protocol; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Notifier ); + +use Carp; + +=head1 NAME + +C<IO::Async::Protocol> - base class for transport-based protocols + +=head1 DESCRIPTION + +This subclass of L<IO::Async:Notifier> provides storage for a +L<IO::Async::Handle> object, to act as a transport for some protocol. It +contains an instance of the transport object, which it adds as a child +notifier, allowing a level of independence from the actual transport being +used. For example, a stream may actually be an L<IO::Async::SSLStream> to +allow the protocol to be used over SSL. + +This class is not intended to be used directly, instead, see one of the +subclasses + +=over 4 + +=item L<IO::Async::Protocol::Stream> - base class for stream-based protocols + +=back + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters: + +=head2 on_closed + +Optional. Invoked when the transport handle becomes closed. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 transport => IO::Async::Handle + +The C<IO::Async::Handle> to delegate communications to. + +=head2 on_closed => CODE + +CODE reference for the C<on_closed> event. + +When a new C<transport> object is given, it will be configured by calling the +C<setup_transport> method, then added as a child notifier. If a different +transport object was already configured, this will first be removed and +deconfigured using the C<teardown_transport>. + +=cut + +sub configure +{ + my $self = shift; + my %params = @_; + + for (qw( on_closed )) { + $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + if( exists $params{transport} ) { + my $transport = delete $params{transport}; + + if( $self->{transport} ) { + $self->remove_child( $self->transport ); + + $self->teardown_transport( $self->transport ); + } + + $self->{transport} = $transport; + + if( $transport ) { + $self->setup_transport( $self->transport ); + + $self->add_child( $self->transport ); + } + } + + $self->SUPER::configure( %params ); +} + +=head1 METHODS + +=cut + +=head2 $transport = $protocol->transport + +Returns the stored transport object + +=cut + +sub transport +{ + my $self = shift; + return $self->{transport}; +} + +=head2 $protocol->connect( %args ) + +Sets up a connection to a peer, and configures the underlying C<transport> for +the Protocol. + +Takes the following named arguments: + +=over 8 + +=item socktype => STRING or INT + +Required. Identifies the socket type, and the type of continuation that will +be used. If this value is C<"stream"> or C<SOCK_STREAM> then C<on_stream> +continuation will be used; otherwise C<on_socket> will be used. + +=item on_connected => CODE + +Optional. If supplied, will be invoked once the connection has been +established. + + $on_connected->( $protocol ) + +=item transport => IO::Async::Handle + +Optional. If this is provided, it will immediately be configured as the +transport (by calling C<configure>), and the C<on_connected> callback will be +invoked. This is provided as a convenient shortcut. + +=back + +Other arguments will be passed to the underlying C<IO::Async::Loop> C<connect> +call. + +=cut + +sub connect +{ + my $self = shift; + my %args = @_; + + my $on_connected = delete $args{on_connected}; + + if( my $transport = $args{transport} ) { + $self->configure( transport => $transport ); + + $on_connected->( $self ) if $on_connected; + + return; + } + + my $socktype = $args{socktype} or croak "Expected socktype"; + + my $on_transport = do { + no warnings 'numeric'; + $socktype eq "stream" || $socktype == Socket::SOCK_STREAM() + } ? "on_stream" : "on_socket"; + + my $loop = $self->loop or croak "Cannot ->connect a ".ref($self)." that is not in a Loop"; + + $loop->connect( + %args, + socktype => "stream", + + $on_transport => sub { + my ( $transport ) = @_; + + $self->configure( transport => $transport ); + + $on_connected->( $self ) if $on_connected; + }, + ); +} + +=head1 TRANSPORT DELEGATION + +The following methods are delegated to the transport object + + close + +=cut + +sub close { shift->transport->close } + +=head1 SUBCLASS METHODS + +C<IO::Async::Protocol> is a base class provided so that specific subclasses of +it provide more specific behaviour. The base class provides a number of +methods that subclasses may wish to override. + +If a subclass implements any of these, be sure to invoke the superclass method +at some point within the code. + +=cut + +=head2 $protocol->setup_transport( $transport ) + +Called by C<configure> when a new C<transport> object is given, this method +should perform whatever setup is required to wire the new transport object +into the protocol object; typically by setting up event handlers. + +=cut + +sub setup_transport +{ + my $self = shift; + my ( $transport ) = @_; + + $transport->configure( + on_closed => $self->_capture_weakself( sub { + my $self = shift or return; + my ( $transport ) = @_; + + $self->maybe_invoke_event( on_closed => ); + + $self->configure( transport => undef ); + } ), + ); +} + +=head2 $protocol->teardown_transport( $transport ) + +The reverse of C<setup_transport>; called by C<configure> when a previously +set-up transport object is about to be replaced. + +=cut + +sub teardown_transport +{ + my $self = shift; + my ( $transport ) = @_; + + $transport->configure( + on_closed => undef, + ); +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Protocol/LineStream.pm b/lib/IO/Async/Protocol/LineStream.pm new file mode 100644 index 0000000..f6148e9 --- /dev/null +++ b/lib/IO/Async/Protocol/LineStream.pm @@ -0,0 +1,138 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2010 -- leonerd@leonerd.org.uk + +package IO::Async::Protocol::LineStream; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Protocol::Stream ); + +use Carp; + +=head1 NAME + +C<IO::Async::Protocol::LineStream> - stream-based protocols using lines of +text + +=head1 SYNOPSIS + +Most likely this class will be subclassed to implement a particular network +protocol. + + package Net::Async::HelloWorld; + + use strict; + use warnings; + use base qw( IO::Async::Protocol::LineStream ); + + sub on_read_line + { + my $self = shift; + my ( $line ) = @_; + + if( $line =~ m/^HELLO (.*)/ ) { + my $name = $1; + + $self->invoke_event( on_hello => $name ); + } + } + + sub send_hello + { + my $self = shift; + my ( $name ) = @_; + + $self->write_line( "HELLO $name" ); + } + +This small example elides such details as error handling, which a real +protocol implementation would be likely to contain. + +=head1 DESCRIPTION + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters: + +=head2 on_read_line $line + +Invoked when a new complete line of input is received. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 on_read_line => CODE + +CODE reference for the C<on_read_line> event. + +=cut + +sub _init +{ + my $self = shift; + $self->SUPER::_init; + + $self->{eol} = "\x0d\x0a"; + $self->{eol_pattern} = qr/\x0d?\x0a/; +} + +sub configure +{ + my $self = shift; + my %params = @_; + + foreach (qw( on_read_line )) { + $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + $self->SUPER::configure( %params ); +} + +sub on_read +{ + my $self = shift; + my ( $buffref, $eof ) = @_; + + # Easiest to run each event individually, in case it returns a CODE ref + $$buffref =~ s/^(.*?)$self->{eol_pattern}// or return 0; + + return $self->invoke_event( on_read_line => $1 ) || 1; +} + +=head1 METHODS + +=cut + +=head2 $lineprotocol->write_line( $text ) + +Writes a line of text to the transport stream. The text will have the +end-of-line marker appended to it; C<$text> should not end with it. + +=cut + +sub write_line +{ + my $self = shift; + my ( $line, @args ) = @_; + + $self->write( "$line$self->{eol}", @args ); +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Protocol/Stream.pm b/lib/IO/Async/Protocol/Stream.pm new file mode 100644 index 0000000..11d1144 --- /dev/null +++ b/lib/IO/Async/Protocol/Stream.pm @@ -0,0 +1,237 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2010-2013 -- leonerd@leonerd.org.uk + +package IO::Async::Protocol::Stream; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Protocol ); + +use Carp; + +=head1 NAME + +C<IO::Async::Protocol::Stream> - base class for stream-based protocols + +=head1 SYNOPSIS + +Most likely this class will be subclassed to implement a particular network +protocol. + + package Net::Async::HelloWorld; + + use strict; + use warnings; + use base qw( IO::Async::Protocol::Stream ); + + sub on_read + { + my $self = shift; + my ( $buffref, $eof ) = @_; + + return 0 unless $$buffref =~ s/^(.*)\n//; + my $line = $1; + + if( $line =~ m/^HELLO (.*)/ ) { + my $name = $1; + + $self->invoke_event( on_hello => $name ); + } + + return 1; + } + + sub send_hello + { + my $self = shift; + my ( $name ) = @_; + + $self->write( "HELLO $name\n" ); + } + +This small example elides such details as error handling, which a real +protocol implementation would be likely to contain. + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Protocol> is intended to stand as a base class +for implementing stream-based protocols. It provides an interface similar to +L<IO::Async::Stream>, primarily, a C<write> method and an C<on_read> event +handler. + +It contains an instance of an C<IO::Async::Stream> object which it uses for +actual communication, rather than being a subclass of it, allowing a level of +independence from the actual stream being used. For example, the stream may +actually be an L<IO::Async::SSLStream> to allow the protocol to be used over +SSL. + +As with C<IO::Async::Stream>, it is required that by the time the protocol +object is added to a Loop, that it either has an C<on_read> method, or has +been configured with an C<on_read> callback handler. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters: + +=head2 $ret = on_read \$buffer, $eof + +=head2 on_read_eof + +=head2 on_write_eof + +The event handlers are invoked identically to C<IO::Async::Stream>. + +=head2 on_closed + +The C<on_closed> handler is optional, but if provided, will be invoked after +the stream is closed by either side (either because the C<close()> method has +been invoked on it, or on an incoming EOF). + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 on_read => CODE + +=head2 on_read_eof => CODE + +=head2 on_write_eof => CODE + +CODE references for the events. + +=head2 handle => IO + +A shortcut for the common case where the transport only needs to be a plain +C<IO::Async::Stream> object. If this argument is provided without a +C<transport> object, a new C<IO::Async::Stream> object will be built around +the given IO handle, and used as the transport. + +=cut + +sub configure +{ + my $self = shift; + my %params = @_; + + for (qw( on_read on_read_eof on_write_eof )) { + $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + if( !exists $params{transport} and my $handle = delete $params{handle} ) { + require IO::Async::Stream; + $params{transport} = IO::Async::Stream->new( handle => $handle ); + } + + $self->SUPER::configure( %params ); + + if( $self->loop ) { + $self->can_event( "on_read" ) or + croak 'Expected either an on_read callback or to be able to ->on_read'; + } +} + +sub _add_to_loop +{ + my $self = shift; + + $self->can_event( "on_read" ) or + croak 'Expected either an on_read callback or to be able to ->on_read'; +} + +sub setup_transport +{ + my $self = shift; + my ( $transport ) = @_; + + $self->SUPER::setup_transport( $transport ); + + $transport->configure( + on_read => $self->_replace_weakself( sub { + my $self = shift or return; + $self->invoke_event( on_read => @_ ); + } ), + on_read_eof => $self->_replace_weakself( sub { + my $self = shift or return; + $self->maybe_invoke_event( on_read_eof => @_ ); + } ), + on_write_eof => $self->_replace_weakself( sub { + my $self = shift or return; + $self->maybe_invoke_event( on_write_eof => @_ ); + } ), + ); +} + +sub teardown_transport +{ + my $self = shift; + my ( $transport ) = @_; + + $transport->configure( + on_read => undef, + ); + + $self->SUPER::teardown_transport( $transport ); +} + +=head1 METHODS + +=cut + +=head2 $protocol->write( $data ) + +Writes the given data by calling the C<write> method on the contained +transport stream. + +=cut + +sub write +{ + my $self = shift; + my ( $data, %args ) = @_; + + if( ref $data eq "CODE" ) { + $data = $self->_replace_weakself( $data ); + } + + if( $args{on_flush} ) { + $args{on_flush} = $self->_replace_weakself( $args{on_flush} ); + } + + my $transport = $self->transport or croak "Attempted to ->write to a ".ref($self)." with no transport"; + $transport->write( $data, %args ); +} + +=head2 $protocol->connect( %args ) + +Sets up a connection to a peer, and configures the underlying C<transport> for +the Protocol. Calls C<IO::Async::Protocol> C<connect> with C<socktype> set to +C<"stream">. + +=cut + +sub connect +{ + my $self = shift; + $self->SUPER::connect( + @_, + socktype => "stream", + ); +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Resolver.pm b/lib/IO/Async/Resolver.pm new file mode 100644 index 0000000..10c0a15 --- /dev/null +++ b/lib/IO/Async/Resolver.pm @@ -0,0 +1,689 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2007-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Resolver; + +use strict; +use warnings; +use 5.010; +use base qw( IO::Async::Function ); + +our $VERSION = '0.67'; + +# Socket 2.006 fails to getaddrinfo() AI_NUMERICHOST properly on MSWin32 +use Socket 2.007 qw( + AI_NUMERICHOST AI_PASSIVE + NI_NUMERICHOST NI_NUMERICSERV NI_DGRAM + EAI_NONAME +); + +use IO::Async::OS; + +# Try to use HiRes alarm, but we don't strictly need it. +# MSWin32 doesn't implement it +BEGIN { + require Time::HiRes; + eval { Time::HiRes::alarm(0) } and Time::HiRes->import( qw( alarm ) ); +} + +use Carp; + +my $started = 0; +my %METHODS; + +=head1 NAME + +C<IO::Async::Resolver> - performing name resolutions asynchronously + +=head1 SYNOPSIS + +This object is used indirectly via an C<IO::Async::Loop>: + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + $loop->resolver->getaddrinfo( + host => "www.example.com", + service => "http", + )->on_done( sub { + foreach my $addr ( @_ ) { + printf "http://www.example.com can be reached at " . + "socket(%d,%d,%d) + connect('%v02x')\n", + @{$addr}{qw( family socktype protocol addr )}; + } + }); + + $loop->resolve( type => 'getpwuid', data => [ $< ] ) + ->on_done( sub { + print "My passwd ent: " . join( "|", @_ ) . "\n"; + }); + + $loop->run; + +=head1 DESCRIPTION + +This module extends an C<IO::Async::Loop> to use the system's name resolver +functions asynchronously. It provides a number of named resolvers, each one +providing an asynchronous wrapper around a single resolver function. + +Because the system may not provide asynchronous versions of its resolver +functions, this class is implemented using a C<IO::Async::Function> object +that wraps the normal (blocking) functions. In this case, name resolutions +will be performed asynchronously from the rest of the program, but will likely +be done by a single background worker process, so will be processed in the +order they were requested; a single slow lookup will hold up the queue of +other requests behind it. To mitigate this, multiple worker processes can be +used; see the C<workers> argument to the constructor. + +The C<idle_timeout> parameter for the underlying C<IO::Async::Function> object +is set to a default of 30 seconds, and C<min_workers> is set to 0. This +ensures that there are no spare processes sitting idle during the common case +of no outstanding requests. + +=cut + +sub _init +{ + my $self = shift; + my ( $params ) = @_; + $self->SUPER::_init( @_ ); + + $params->{code} = sub { + my ( $type, $timeout, @data ) = @_; + + if( my $code = $METHODS{$type} ) { + local $SIG{ALRM} = sub { die "Timed out\n" }; + + alarm( $timeout ); + my @ret = eval { $code->( @data ) }; + alarm( 0 ); + + die $@ if $@; + return @ret; + } + else { + die "Unrecognised resolver request '$type'"; + } + }; + + $params->{idle_timeout} = 30; + $params->{min_workers} = 0; + + $started = 1; +} + +=head1 METHODS + +The following methods documented with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +=head2 @result = $loop->resolve( %params )->get + +Performs a single name resolution operation, as given by the keys in the hash. + +The C<%params> hash keys the following keys: + +=over 8 + +=item type => STRING + +Name of the resolution operation to perform. See BUILT-IN RESOLVERS for the +list of available operations. + +=item data => ARRAY + +Arguments to pass to the resolver function. Exact meaning depends on the +specific function chosen by the C<type>; see BUILT-IN RESOLVERS. + +=item timeout => NUMBER + +Optional. Timeout in seconds, after which the resolver operation will abort +with a timeout exception. If not supplied, a default of 10 seconds will apply. + +=back + +=head2 $resolver->resolve( %params ) + +When not returning a future, additional parameters can be given containing the +continuations to invoke on success or failure: + +=over 8 + +=item on_resolved => CODE + +A continuation that is invoked when the resolver function returns a successful +result. It will be passed the array returned by the resolver function. + + $on_resolved->( @result ) + +=item on_error => CODE + +A continuation that is invoked when the resolver function fails. It will be +passed the exception thrown by the function. + +=back + +=cut + +sub resolve +{ + my $self = shift; + my %args = @_; + + my $type = $args{type}; + defined $type or croak "Expected 'type'"; + + if( $type eq "getaddrinfo" ) { + $type = "getaddrinfo_hash"; + } + + exists $METHODS{$type} or croak "Expected 'type' to be an existing resolver method, got '$type'"; + + my $on_resolved; + if( $on_resolved = $args{on_resolved} ) { + ref $on_resolved or croak "Expected 'on_resolved' to be a reference"; + } + elsif( !defined wantarray ) { + croak "Expected 'on_resolved' or to return a Future"; + } + + my $on_error; + if( $on_error = $args{on_error} ) { + ref $on_error or croak "Expected 'on_error' to be a reference"; + } + elsif( !defined wantarray ) { + croak "Expected 'on_error' or to return a Future"; + } + + my $timeout = $args{timeout} || 10; + + my $future = $self->call( + args => [ $type, $timeout, @{$args{data}} ], + ); + + $future->on_done( $on_resolved ) if $on_resolved; + $future->on_fail( $on_error ) if $on_error; + + return $future if defined wantarray; + + # Caller is not going to keep hold of the Future, so we have to ensure it + # stays alive somehow + $self->adopt_future( $future->else( sub { Future->done } ) ); +} + +=head2 @addrs = $resolver->getaddrinfo( %args )->get + +A shortcut wrapper around the C<getaddrinfo> resolver, taking its arguments in +a more convenient form. + +=over 8 + +=item host => STRING + +=item service => STRING + +The host and service names to look up. At least one must be provided. + +=item family => INT or STRING + +=item socktype => INT or STRING + +=item protocol => INT + +Hint values used to filter the results. + +=item flags => INT + +Flags to control the C<getaddrinfo(3)> function. See the C<AI_*> constants in +L<Socket>'s C<getaddrinfo> function for more detail. + +=item passive => BOOL + +If true, sets the C<AI_PASSIVE> flag. This is provided as a convenience to +avoid the caller from having to import the C<AI_PASSIVE> constant from +C<Socket>. + +=item timeout => NUMBER + +Time in seconds after which to abort the lookup with a C<Timed out> exception + +=back + +On success, the future will yield the result as a list of HASH references; +each containing one result. Each result will contain fields called C<family>, +C<socktype>, C<protocol> and C<addr>. If requested by C<AI_CANONNAME> then the +C<canonname> field will also be present. + +As a specific optimisation, this method will try to perform a lookup of +numeric values synchronously, rather than asynchronously, if it looks likely +to succeed. + +Specifically, if the service name is entirely numeric, and the hostname looks +like an IPv4 or IPv6 string, a synchronous lookup will first be performed +using the C<AI_NUMERICHOST> flag. If this gives an C<EAI_NONAME> error, then +the lookup is performed asynchronously instead. + +=head2 $resolver->getaddrinfo( %args ) + +When not returning a future, additional parameters can be given containing the +continuations to invoke on success or failure: + +=over 8 + +=item on_resolved => CODE + +Callback which is invoked after a successful lookup. + + $on_resolved->( @addrs ) + +=item on_error => CODE + +Callback which is invoked after a failed lookup, including for a timeout. + + $on_error->( $exception ) + +=back + +=cut + +sub getaddrinfo +{ + my $self = shift; + my %args = @_; + + $args{on_resolved} or defined wantarray or + croak "Expected 'on_resolved' or to return a Future"; + + $args{on_error} or defined wantarray or + croak "Expected 'on_error' or to return a Future"; + + my $host = $args{host} || ""; + my $service = $args{service} // ""; + my $flags = $args{flags} || 0; + + $flags |= AI_PASSIVE if $args{passive}; + + $args{family} = IO::Async::OS->getfamilybyname( $args{family} ) if defined $args{family}; + $args{socktype} = IO::Async::OS->getsocktypebyname( $args{socktype} ) if defined $args{socktype}; + + # Clear any other existing but undefined hints + defined $args{$_} or delete $args{$_} for keys %args; + + # It's likely this will succeed with AI_NUMERICHOST if host contains only + # [\d.] (IPv4) or [[:xdigit:]:] (IPv6) + # Technically we should pass AI_NUMERICSERV but not all platforms support + # it, but since we're checking service contains only \d we should be fine. + + # These address tests don't have to be perfect as if it fails we'll get + # EAI_NONAME and just try it asynchronously anyway + if( ( $host =~ m/^[\d.]+$/ or $host =~ m/^[[:xdigit:]:]$/ or $host eq "" ) and + $service =~ m/^\d+$/ ) { + + my ( $err, @results ) = Socket::getaddrinfo( $host, $service, + { %args, flags => $flags | AI_NUMERICHOST } + ); + + if( !$err ) { + my $future = $self->loop->new_future->done( @results ); + $future->on_done( $args{on_resolved} ) if $args{on_resolved}; + return $future; + } + elsif( $err == EAI_NONAME ) { + # fallthrough to async case + } + else { + my $future = $self->loop->new_future->fail( $err, resolve => getaddrinfo => $err+0 ); + $future->on_fail( $args{on_error} ) if $args{on_error}; + return $future; + } + } + + my $future = $self->resolve( + type => "getaddrinfo_hash", + data => [ + host => $host, + service => $service, + flags => $flags, + map { exists $args{$_} ? ( $_ => $args{$_} ) : () } qw( family socktype protocol ), + ], + timeout => $args{timeout}, + )->else( sub { + my $message = shift; + Future->fail( $message, resolve => getaddrinfo => @_ ); + }); + + $future->on_done( $args{on_resolved} ) if $args{on_resolved}; + $future->on_fail( $args{on_error} ) if $args{on_error}; + + return $future if defined wantarray; + + # Caller is not going to keep hold of the Future, so we have to ensure it + # stays alive somehow + $self->adopt_future( $future->else( sub { Future->done } ) ); +} + +=head2 ( $host, $service ) = $resolver->getnameinfo( %args )->get + +A shortcut wrapper around the C<getnameinfo> resolver, taking its arguments in +a more convenient form. + +=over 8 + +=item addr => STRING + +The packed socket address to look up. + +=item flags => INT + +Flags to control the C<getnameinfo(3)> function. See the C<NI_*> constants in +L<Socket>'s C<getnameinfo> for more detail. + +=item numerichost => BOOL + +=item numericserv => BOOL + +=item dgram => BOOL + +If true, set the C<NI_NUMERICHOST>, C<NI_NUMERICSERV> or C<NI_DGRAM> flags. + +=item numeric => BOOL + +If true, sets both C<NI_NUMERICHOST> and C<NI_NUMERICSERV> flags. + +=item timeout => NUMBER + +Time in seconds after which to abort the lookup with a C<Timed out> exception + +=back + +As a specific optimisation, this method will try to perform a lookup of +numeric values synchronously, rather than asynchronously, if both the +C<NI_NUMERICHOST> and C<NI_NUMERICSERV> flags are given. + +=head2 $resolver->getnameinfo( %args ) + +When not returning a future, additional parameters can be given containing the +continuations to invoke on success or failure: + +=over 8 + +=item on_resolved => CODE + +Callback which is invoked after a successful lookup. + + $on_resolved->( $host, $service ) + +=item on_error => CODE + +Callback which is invoked after a failed lookup, including for a timeout. + + $on_error->( $exception ) + +=back + +=cut + +sub getnameinfo +{ + my $self = shift; + my %args = @_; + + $args{on_resolved} or defined wantarray or + croak "Expected 'on_resolved' or to return a Future"; + + $args{on_error} or defined wantarray or + croak "Expected 'on_error' or to return a Future"; + + my $flags = $args{flags} || 0; + + $flags |= NI_NUMERICHOST if $args{numerichost}; + $flags |= NI_NUMERICSERV if $args{numericserv}; + $flags |= NI_DGRAM if $args{dgram}; + + $flags |= NI_NUMERICHOST|NI_NUMERICSERV if $args{numeric}; + + if( $flags & (NI_NUMERICHOST|NI_NUMERICSERV) ) { + # This is a numeric-only lookup that can be done synchronously + my ( $err, $host, $service ) = Socket::getnameinfo( $args{addr}, $flags ); + + if( $err ) { + my $future = $self->loop->new_future->fail( $err, resolve => getnameinfo => $err+0 ); + $future->on_fail( $args{on_error} ) if $args{on_error}; + return $future; + } + else { + my $future = $self->loop->new_future->done( $host, $service ); + $future->on_done( $args{on_resolved} ) if $args{on_resolved}; + return $future; + } + } + + my $future = $self->resolve( + type => "getnameinfo", + data => [ $args{addr}, $flags ], + timeout => $args{timeout}, + )->transform( + done => sub { @{ $_[0] } }, # unpack the ARRAY ref + )->else( sub { + my $message = shift; + Future->fail( $message, resolve => getnameinfo => @_ ); + }); + + $future->on_done( $args{on_resolved} ) if $args{on_resolved}; + $future->on_fail( $args{on_error} ) if $args{on_error}; + + return $future if defined wantarray; + + # Caller is not going to keep hold of the Future, so we have to ensure it + # stays alive somehow + $self->adopt_future( $future->else( sub { Future->done } ) ); +} + +=head1 FUNCTIONS + +=cut + +=head2 register_resolver( $name, $code ) + +Registers a new named resolver function that can be called by the C<resolve> +method. All named resolvers must be registered before the object is +constructed. + +=over 8 + +=item $name + +The name of the resolver function; must be a plain string. This name will be +used by the C<type> argument to the C<resolve> method, to identify it. + +=item $code + +A CODE reference to the resolver function body. It will be called in list +context, being passed the list of arguments given in the C<data> argument to +the C<resolve> method. The returned list will be passed to the +C<on_resolved> callback. If the code throws an exception at call time, it will +be passed to the C<on_error> continuation. If it returns normally, the list of +values it returns will be passed to C<on_resolved>. + +=back + +=cut + +# Plain function, not a method +sub register_resolver +{ + my ( $name, $code ) = @_; + + croak "Cannot register new resolver methods once the resolver has been started" if $started; + + croak "Already have a resolver method called '$name'" if exists $METHODS{$name}; + $METHODS{$name} = $code; +} + +=head1 BUILT-IN RESOLVERS + +The following resolver names are implemented by the same-named perl function, +taking and returning a list of values exactly as the perl function does: + + getpwnam getpwuid + getgrnam getgrgid + getservbyname getservbyport + gethostbyname gethostbyaddr + getnetbyname getnetbyaddr + getprotobyname getprotobynumber + +=cut + +# Now register the inbuilt methods + +register_resolver getpwnam => sub { my @r = getpwnam( $_[0] ) or die "$!\n"; @r }; +register_resolver getpwuid => sub { my @r = getpwuid( $_[0] ) or die "$!\n"; @r }; + +register_resolver getgrnam => sub { my @r = getgrnam( $_[0] ) or die "$!\n"; @r }; +register_resolver getgrgid => sub { my @r = getgrgid( $_[0] ) or die "$!\n"; @r }; + +register_resolver getservbyname => sub { my @r = getservbyname( $_[0], $_[1] ) or die "$!\n"; @r }; +register_resolver getservbyport => sub { my @r = getservbyport( $_[0], $_[1] ) or die "$!\n"; @r }; + +register_resolver gethostbyname => sub { my @r = gethostbyname( $_[0] ) or die "$!\n"; @r }; +register_resolver gethostbyaddr => sub { my @r = gethostbyaddr( $_[0], $_[1] ) or die "$!\n"; @r }; + +register_resolver getnetbyname => sub { my @r = getnetbyname( $_[0] ) or die "$!\n"; @r }; +register_resolver getnetbyaddr => sub { my @r = getnetbyaddr( $_[0], $_[1] ) or die "$!\n"; @r }; + +register_resolver getprotobyname => sub { my @r = getprotobyname( $_[0] ) or die "$!\n"; @r }; +register_resolver getprotobynumber => sub { my @r = getprotobynumber( $_[0] ) or die "$!\n"; @r }; + +=pod + +The following three resolver names are implemented using the L<Socket> module. + + getaddrinfo_hash + getaddrinfo_array + getnameinfo + +The C<getaddrinfo_hash> resolver takes arguments in a hash of name/value pairs +and returns a list of hash structures, as the C<Socket::getaddrinfo> function +does. For neatness it takes all its arguments as named values; taking the host +and service names from arguments called C<host> and C<service> respectively; +all the remaining arguments are passed into the hints hash. This name is also +aliased as simply C<getaddrinfo>. + +The C<getaddrinfo_array> resolver behaves more like the C<Socket6> version of +the function. It takes hints in a flat list, and mangles the result of the +function, so that the returned value is more useful to the caller. It splits +up the list of 5-tuples into a list of ARRAY refs, where each referenced array +contains one of the tuples of 5 values. + +As an extra convenience to the caller, both resolvers will also accept plain +string names for the C<family> argument, converting C<inet> and possibly +C<inet6> into the appropriate C<AF_*> value, and for the C<socktype> argument, +converting C<stream>, C<dgram> or C<raw> into the appropriate C<SOCK_*> value. + +The C<getnameinfo> resolver returns its result in the same form as C<Socket>. + +Because this module simply uses the system's C<getaddrinfo> resolver, it will +be fully IPv6-aware if the underlying platform's resolver is. This allows +programs to be fully IPv6-capable. + +=cut + +register_resolver getaddrinfo_hash => sub { + my %args = @_; + + my $host = delete $args{host}; + my $service = delete $args{service}; + + $args{family} = IO::Async::OS->getfamilybyname( $args{family} ) if defined $args{family}; + $args{socktype} = IO::Async::OS->getsocktypebyname( $args{socktype} ) if defined $args{socktype}; + + # Clear any other existing but undefined hints + defined $args{$_} or delete $args{$_} for keys %args; + + my ( $err, @addrs ) = Socket::getaddrinfo( $host, $service, \%args ); + + die "$err\n" if $err; + + return @addrs; +}; + +register_resolver getaddrinfo_array => sub { + my ( $host, $service, $family, $socktype, $protocol, $flags ) = @_; + + $family = IO::Async::OS->getfamilybyname( $family ); + $socktype = IO::Async::OS->getsocktypebyname( $socktype ); + + my %hints; + $hints{family} = $family if defined $family; + $hints{socktype} = $socktype if defined $socktype; + $hints{protocol} = $protocol if defined $protocol; + $hints{flags} = $flags if defined $flags; + + my ( $err, @addrs ) = Socket::getaddrinfo( $host, $service, \%hints ); + + die "$err\n" if $err; + + # Convert the @addrs list into a list of ARRAY refs of 5 values each + return map { + [ $_->{family}, $_->{socktype}, $_->{protocol}, $_->{addr}, $_->{canonname} ] + } @addrs; +}; + +register_resolver getnameinfo => sub { + my ( $addr, $flags ) = @_; + + my ( $err, $host, $service ) = Socket::getnameinfo( $addr, $flags || 0 ); + + die "$err\n" if $err; + + return [ $host, $service ]; +}; + +=head1 EXAMPLES + +The following somewhat contrieved example shows how to implement a new +resolver function. This example just uses in-memory data, but a real function +would likely make calls to OS functions to provide an answer. In traditional +Unix style, a pair of functions are provided that each look up the entity by +either type of key, where both functions return the same type of list. This is +purely a convention, and is in no way required or enforced by the +C<IO::Async::Resolver> itself. + + @numbers = qw( zero one two three four + five six seven eight nine ); + + register_resolver getnumberbyindex => sub { + my ( $index ) = @_; + die "Bad index $index" unless $index >= 0 and $index < @numbers; + return ( $index, $numbers[$index] ); + }; + + register_resolver getnumberbyname => sub { + my ( $name ) = @_; + foreach my $index ( 0 .. $#numbers ) { + return ( $index, $name ) if $numbers[$index] eq $name; + } + die "Bad name $name"; + }; + +=head1 TODO + +=over 4 + +=item * + +Look into (system-specific) ways of accessing asynchronous resolvers directly + +=back + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Routine.pm b/lib/IO/Async/Routine.pm new file mode 100644 index 0000000..f9a5a3b --- /dev/null +++ b/lib/IO/Async/Routine.pm @@ -0,0 +1,436 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2012-2013 -- leonerd@leonerd.org.uk + +package IO::Async::Routine; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Notifier ); + +use Carp; + +use IO::Async::OS; +use IO::Async::Process; + +=head1 NAME + +C<IO::Async::Routine> - execute code in an independent sub-process or thread + +=head1 SYNOPSIS + + use IO::Async::Routine; + use IO::Async::Channel; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my $nums_ch = IO::Async::Channel->new; + my $ret_ch = IO::Async::Channel->new; + + my $routine = IO::Async::Routine->new( + channels_in => [ $nums_ch ], + channels_out => [ $ret_ch ], + + code => sub { + my @nums = @{ $nums_ch->recv }; + my $ret = 0; $ret += $_ for @nums; + + # Can only send references + $ret_ch->send( \$ret ); + }, + + on_finish => sub { + say "The routine aborted early - $_[-1]"; + $loop->stop; + }, + ); + + $loop->add( $routine ); + + $nums_ch->send( [ 10, 20, 30 ] ); + $ret_ch->recv( + on_recv => sub { + my ( $ch, $totalref ) = @_; + say "The total of 10, 20, 30 is: $$totalref"; + $loop->stop; + } + ); + + $loop->run; + +=head1 DESCRIPTION + +This L<IO::Async::Notifier> contains a body of code and executes it in a +sub-process or thread, allowing it to act independently of the main program. +Once set up, all communication with the code happens by values passed into or +out of the Routine via L<IO::Async::Channel> objects. + +A choice of detachment model is available, with options being a C<fork()>ed +child process, or a thread. In both cases the code contained within the +Routine is free to make blocking calls without stalling the rest of the +program. This makes it useful for using existing code which has no option not +to block within an C<IO::Async>-based program. + +Code running inside a C<fork()>-based Routine runs within its own process; it +is isolated from the rest of the program in terms of memory, CPU time, and +other resources. Code running in a thread-based Routine however, shares memory +and other resources such as open filehandles with the main thread. + +To create asynchronous wrappers of functions that return a value based only on +their arguments, and do not generally maintain state within the process it may +be more convenient to use an L<IO::Async::Function> instead, which uses an +C<IO::Async::Routine> to contain the body of the function and manages the +Channels itself. + +=cut + +=head1 EVENTS + +=head2 on_finish $exitcode + +For C<fork()>-based Routines, this is invoked after the process has exited and +is passed the raw exitcode status. + +=head2 on_finish $type, @result + +For thread-based Routines, this is invoked after the thread has returned from +its code block and is passed the C<on_joined> result. + +As the behaviour of these events differs per model, it may be more convenient +to use C<on_return> and C<on_die> instead. + +=head2 on_return $result + +Invoked if the code block returns normally. Note that C<fork()>-based Routines +can only transport an integer result between 0 and 255, as this is the actual +C<exit()> value. + +=head2 on_die $exception + +Invoked if the code block fails with an exception. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 model => "fork" | "thread" + +Optional. Defines how the routine will detach itself from the main process. +C<fork> uses a child process detached using an L<IO::Async::Process>. +C<thread> uses a thread, and is only available on threaded Perls. + +If the model is not specified, the environment variable +C<IO_ASYNC_ROUTINE_MODEL> is used to pick a default. If that isn't defined, +C<fork> is preferred if it is available, otherwise C<thread>. + +=head2 channels_in => ARRAY of IO::Async::Channel + +ARRAY reference of C<IO::Async::Channel> objects to set up for passing values +in to the Routine. + +=head2 channels_out => ARRAY of IO::Async::Channel + +ARRAY reference of C<IO::Async::Channel> objects to set up for passing values +out of the Routine. + +=head2 code => CODE + +CODE reference to the body of the Routine, to execute once the channels are +set up. + +=head2 setup => ARRAY + +Optional. For C<fork()>-based Routines, gives a reference to an array to pass +to the underlying C<Loop> C<fork_child> method. Ignored for thread-based +Routines. + +=cut + +use constant PREFERRED_MODEL => + IO::Async::OS->HAVE_POSIX_FORK ? "fork" : + IO::Async::OS->HAVE_THREADS ? "thread" : + die "No viable Routine models"; + +sub _init +{ + my $self = shift; + my ( $params ) = @_; + + $params->{model} ||= $ENV{IO_ASYNC_ROUTINE_MODEL} || PREFERRED_MODEL; + + $self->SUPER::_init( @_ ); +} + +sub configure +{ + my $self = shift; + my %params = @_; + + # TODO: Can only reconfigure when not running + foreach (qw( channels_in channels_out code setup on_finish on_return on_die )) { + $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + if( defined( my $model = delete $params{model} ) ) { + $model eq "fork" or $model eq "thread" or + croak "Expected 'model' to be either 'fork' or 'thread'"; + + $model eq "fork" and !IO::Async::OS->HAVE_POSIX_FORK and + croak "Cannot use 'fork' model as fork() is not available"; + $model eq "thread" and !IO::Async::OS->HAVE_THREADS and + croak "Cannot use 'thread' model as threads are not available"; + + $self->{model} = $model; + } + + $self->SUPER::configure( %params ); +} + +sub _add_to_loop +{ + my $self = shift; + my ( $loop ) = @_; + $self->SUPER::_add_to_loop( $loop ); + + return $self->_setup_fork if $self->{model} eq "fork"; + return $self->_setup_thread if $self->{model} eq "thread"; + + die "TODO: unrecognised Routine model $self->{model}"; +} + +sub _setup_fork +{ + my $self = shift; + + my @setup; + my @channels_in; + my @channels_out; + + foreach my $ch ( @{ $self->{channels_in} || [] } ) { + my ( $rd, $wr ); + unless( $rd = $ch->_extract_read_handle ) { + ( $rd, $wr ) = IO::Async::OS->pipepair; + } + push @setup, $rd => "keep"; + push @channels_in, [ $ch, $wr, $rd ]; + } + + foreach my $ch ( @{ $self->{channels_out} || [] } ) { + my ( $rd, $wr ); + unless( $wr = $ch->_extract_write_handle ) { + ( $rd, $wr ) = IO::Async::OS->pipepair; + } + push @setup, $wr => "keep"; + push @channels_out, [ $ch, $rd, $wr ]; + } + + my $code = $self->{code}; + + my $setup = $self->{setup}; + push @setup, @$setup if $setup; + + my $process = IO::Async::Process->new( + setup => \@setup, + code => sub { + foreach ( @channels_in ) { + my ( $ch, undef, $rd ) = @$_; + $ch->setup_sync_mode( $rd ); + } + foreach ( @channels_out ) { + my ( $ch, undef, $wr ) = @$_; + $ch->setup_sync_mode( $wr ); + } + + my $ret = $code->(); + + foreach ( @channels_in, @channels_out ) { + my ( $ch ) = @$_; + $ch->close; + } + + return $ret; + }, + on_finish => $self->_replace_weakself( sub { + my $self = shift or return; + my ( $exitcode ) = @_; + $self->maybe_invoke_event( on_finish => $exitcode ); + + $self->maybe_invoke_event( on_return => ($exitcode >> 8) ) unless $exitcode & 0x7f; + }), + on_exception => $self->_replace_weakself( sub { + my $self = shift or return; + my ( $exception, $errno, $exitcode ) = @_; + + $self->maybe_invoke_event( on_die => $exception ); + }), + ); + + foreach ( @channels_in ) { + my ( $ch, $wr ) = @$_; + + $ch->setup_async_mode( write_handle => $wr ); + + $self->add_child( $ch ) unless $ch->parent; + } + + foreach ( @channels_out ) { + my ( $ch, $rd ) = @$_; + + $ch->setup_async_mode( read_handle => $rd ); + + $self->add_child( $ch ) unless $ch->parent; + } + + $self->add_child( $self->{process} = $process ); + $self->{id} = "P" . $process->pid; + + foreach ( @channels_in, @channels_out ) { + my ( undef, undef, $other ) = @$_; + $other->close; + } +} + +sub _setup_thread +{ + my $self = shift; + + my @channels_in; + my @channels_out; + + foreach my $ch ( @{ $self->{channels_in} || [] } ) { + my ( $rd, $wr ); + unless( $rd = $ch->_extract_read_handle ) { + ( $rd, $wr ) = IO::Async::OS->pipepair; + } + push @channels_in, [ $ch, $wr, $rd ]; + } + + foreach my $ch ( @{ $self->{channels_out} || [] } ) { + my ( $rd, $wr ); + unless( $wr = $ch->_extract_write_handle ) { + ( $rd, $wr ) = IO::Async::OS->pipepair; + } + push @channels_out, [ $ch, $rd, $wr ]; + } + + my $code = $self->{code}; + + my $tid = $self->loop->create_thread( + code => sub { + foreach ( @channels_in ) { + my ( $ch, $wr, $rd ) = @$_; + $ch->setup_sync_mode( $rd ); + $wr->close if $wr; + } + foreach ( @channels_out ) { + my ( $ch, $rd, $wr ) = @$_; + $ch->setup_sync_mode( $wr ); + $rd->close if $rd; + } + + my $ret = $code->(); + + foreach ( @channels_in, @channels_out ) { + my ( $ch ) = @$_; + $ch->close; + } + + return $ret; + }, + on_joined => $self->_capture_weakself( sub { + my $self = shift or return; + my ( $ev, @result ) = @_; + $self->maybe_invoke_event( on_finish => @_ ); + + $self->maybe_invoke_event( on_return => @result ) if $ev eq "return"; + $self->maybe_invoke_event( on_die => $result[0] ) if $ev eq "died"; + + delete $self->{tid}; + }), + ); + + $self->{tid} = $tid; + $self->{id} = "T" . $tid; + + foreach ( @channels_in ) { + my ( $ch, $wr, $rd ) = @$_; + + $ch->setup_async_mode( write_handle => $wr ); + $rd->close; + + $self->add_child( $ch ) unless $ch->parent; + } + + foreach ( @channels_out ) { + my ( $ch, $rd, $wr ) = @$_; + + $ch->setup_async_mode( read_handle => $rd ); + $wr->close; + + $self->add_child( $ch ) unless $ch->parent; + } +} + +=head1 METHODS + +=cut + +=head2 $id = $routine->id + +Returns an ID string that uniquely identifies the Routine out of all the +currently-running ones. (The ID of already-exited Routines may be reused, +however.) + +=cut + +sub id +{ + my $self = shift; + return $self->{id}; +} + +=head2 $model = $routine->model + +Returns the detachment model in use by the Routine. + +=cut + +sub model +{ + my $self = shift; + return $self->{model}; +} + +=head2 $routine->kill( $signal ) + +Sends the specified signal to the routine code. This is either implemented by +C<CORE::kill()> or C<threads::kill> as required. Note that in the thread case +this has the usual limits of signal delivery to threads; namely, that it works +at the Perl interpreter level, and cannot actually interrupt blocking system +calls. + +=cut + +sub kill +{ + my $self = shift; + my ( $signal ) = @_; + + $self->{process}->kill( $signal ) if $self->{model} eq "fork"; + threads->object( $self->{tid} )->kill( $signal ) if $self->{model} eq "thread"; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Signal.pm b/lib/IO/Async/Signal.pm new file mode 100644 index 0000000..4ef68f5 --- /dev/null +++ b/lib/IO/Async/Signal.pm @@ -0,0 +1,150 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2009-2011 -- leonerd@leonerd.org.uk + +package IO::Async::Signal; + +use strict; +use warnings; +use base qw( IO::Async::Notifier ); + +our $VERSION = '0.67'; + +use Carp; + +=head1 NAME + +C<IO::Async::Signal> - event callback on receipt of a POSIX signal + +=head1 SYNOPSIS + + use IO::Async::Signal; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my $signal = IO::Async::Signal->new( + name => "HUP", + + on_receipt => sub { + print "I caught SIGHUP\n"; + }, + ); + + $loop->add( $signal ); + + $loop->run; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Notifier> invokes its callback when a particular +POSIX signal is received. + +Multiple objects can be added to a C<Loop> that all watch for the same signal. +The callback functions will all be invoked, in no particular order. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters: + +=head2 on_receipt + +Invoked when the signal is received. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 name => STRING + +The name of the signal to watch. This should be a bare name like C<TERM>. Can +only be given at construction time. + +=head2 on_receipt => CODE + +CODE reference for the C<on_receipt> event. + +Once constructed, the C<Signal> will need to be added to the C<Loop> before it +will work. + +=cut + +sub _init +{ + my $self = shift; + my ( $params ) = @_; + + my $name = delete $params->{name} or croak "Expected 'name'"; + + $name =~ s/^SIG//; # Trim a leading "SIG" + + $self->{name} = $name; + + $self->SUPER::_init( $params ); +} + +sub configure +{ + my $self = shift; + my %params = @_; + + if( exists $params{on_receipt} ) { + $self->{on_receipt} = delete $params{on_receipt}; + + undef $self->{cb}; # Will be lazily constructed when needed + + if( my $loop = $self->loop ) { + $self->_remove_from_loop( $loop ); + $self->_add_to_loop( $loop ); + } + } + + unless( $self->can_event( 'on_receipt' ) ) { + croak 'Expected either a on_receipt callback or an ->on_receipt method'; + } + + $self->SUPER::configure( %params ); +} + +sub _add_to_loop +{ + my $self = shift; + my ( $loop ) = @_; + + $self->{cb} ||= $self->make_event_cb( 'on_receipt' ); + + $self->{id} = $loop->attach_signal( $self->{name}, $self->{cb} ); +} + +sub _remove_from_loop +{ + my $self = shift; + my ( $loop ) = @_; + + $loop->detach_signal( $self->{name}, $self->{id} ); + undef $self->{id}; +} + +sub notifier_name +{ + my $self = shift; + if( length( my $name = $self->SUPER::notifier_name ) ) { + return $name; + } + + return $self->{name}; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Socket.pm b/lib/IO/Async/Socket.pm new file mode 100644 index 0000000..23a4973 --- /dev/null +++ b/lib/IO/Async/Socket.pm @@ -0,0 +1,358 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2011-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Socket; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use base qw( IO::Async::Handle ); + +use Errno qw( EAGAIN EWOULDBLOCK EINTR ); + +use Carp; + +=head1 NAME + +C<IO::Async::Socket> - event callbacks and send buffering for a socket +filehandle + +=head1 SYNOPSIS + + use IO::Async::Socket; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my $socket = IO::Async::Socket->new( + on_recv => sub { + my ( $self, $dgram, $addr ) = @_; + + print "Received reply: $dgram\n", + $loop->stop; + }, + on_recv_error => sub { + my ( $self, $errno ) = @_; + die "Cannot recv - $errno\n"; + }, + ); + $loop->add( $socket ); + + $socket->connect( + host => "some.host.here", + service => "echo", + socktype => 'dgram', + )->get; + + $socket->send( "A TEST DATAGRAM" ); + + $loop->run; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Handle> contains a socket filehandle. It +provides a queue of outgoing data. It invokes the C<on_recv> handler when new +data is received from the filehandle. Data may be sent to the filehandle by +calling the C<send> method. + +It is primarily intended for C<SOCK_DGRAM> or C<SOCK_RAW> sockets (such as UDP +or packet-capture); for C<SOCK_STREAM> sockets (such as TCP) an instance of +L<IO::Async::Stream> is more appropriate. + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters: + +=head2 on_recv $data, $addr + +Invoke on receipt of a packet, datagram, or stream segment. + +The C<on_recv> handler is invoked once for each packet, datagram, or stream +segment that is received. It is passed the data itself, and the sender's +address. + +=head2 on_recv_error $errno + +Optional. Invoked when the C<recv> method on the receiving handle fails. + +=head2 on_send_error $errno + +Optional. Invoked when the C<send> method on the sending handle fails. + +The C<on_recv_error> and C<on_send_error> handlers are passed the value of +C<$!> at the time the error occured. (The C<$!> variable itself, by its +nature, may have changed from the original error by the time this handler +runs so it should always use the value passed in). + +If an error occurs when the corresponding error callback is not supplied, and +there is not a subclass method for it, then the C<close> method is +called instead. + +=head2 on_outgoing_empty + +Optional. Invoked when the sending data buffer becomes empty. + +=cut + +sub _init +{ + my $self = shift; + + $self->{recv_len} = 65536; + + $self->SUPER::_init( @_ ); +} + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 read_handle => IO + +The IO handle to receive from. Must implement C<fileno> and C<recv> methods. + +=head2 write_handle => IO + +The IO handle to send to. Must implement C<fileno> and C<send> methods. + +=head2 handle => IO + +Shortcut to specifying the same IO handle for both of the above. + +=head2 on_recv => CODE + +=head2 on_recv_error => CODE + +=head2 on_outgoing_empty => CODE + +=head2 on_send_error => CODE + +=head2 autoflush => BOOL + +Optional. If true, the C<send> method will atempt to send data to the +operating system immediately, without waiting for the loop to indicate the +filehandle is write-ready. + +=head2 recv_len => INT + +Optional. Sets the buffer size for C<recv> calls. Defaults to 64 KiB. + +=head2 recv_all => BOOL + +Optional. If true, repeatedly call C<recv> when the receiving handle first +becomes read-ready. By default this is turned off, meaning at most one +fixed-size buffer is received. If there is still more data in the kernel's +buffer, the handle will stil be readable, and will be received from again. + +This behaviour allows multiple streams and sockets to be multiplexed +simultaneously, meaning that a large bulk transfer on one cannot starve other +filehandles of processing time. Turning this option on may improve bulk data +transfer rate, at the risk of delaying or stalling processing on other +filehandles. + +=head2 send_all => INT + +Optional. Analogous to the C<recv_all> option, but for sending. When +C<autoflush> is enabled, this option only affects deferred sending if the +initial attempt failed. + +The condition requiring an C<on_recv> handler is checked at the time the +object is added to a Loop; it is allowed to create a C<IO::Async::Socket> +object with a read handle but without a C<on_recv> handler, provided that +one is later given using C<configure> before the stream is added to its +containing Loop, either directly or by being a child of another Notifier +already in a Loop, or added to one. + +=cut + +sub configure +{ + my $self = shift; + my %params = @_; + + for (qw( on_recv on_outgoing_empty on_recv_error on_send_error + recv_len recv_all send_all autoflush )) { + $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + $self->SUPER::configure( %params ); + + if( $self->loop and defined $self->read_handle ) { + $self->can_event( "on_recv" ) or + croak 'Expected either an on_recv callback or to be able to ->on_recv'; + } +} + +sub _add_to_loop +{ + my $self = shift; + + if( defined $self->read_handle ) { + $self->can_event( "on_recv" ) or + croak 'Expected either an on_recv callback or to be able to ->on_recv'; + } + + $self->SUPER::_add_to_loop( @_ ); +} + +=head1 METHODS + +=cut + +=head2 $socket->send( $data, $flags, $addr ) + +This method adds a segment of data to be sent, or sends it immediately, +according to the C<autoflush> parameter. C<$flags> and C<$addr> are optional. + +If the C<autoflush> option is set, this method will try immediately to send +the data to the underlying filehandle, optionally using the given flags and +destination address. If this completes successfully then it will have been +sent by the time this method returns. If it fails to send, then the data is +queued as if C<autoflush> were not set, and will be flushed as normal. + +=cut + +sub send +{ + my $self = shift; + my ( $data, $flags, $addr ) = @_; + + croak "Cannot send data to a Socket with no write_handle" unless my $handle = $self->write_handle; + + my $sendqueue = $self->{sendqueue} ||= []; + push @$sendqueue, [ $data, $flags, $addr ]; + + if( $self->{autoflush} ) { + while( @$sendqueue ) { + my ( $data, $flags, $addr ) = @{ $sendqueue->[0] }; + my $len = $handle->send( $data, $flags, $addr ); + + last if !$len; # stop on any errors and defer back to the non-autoflush path + + shift @$sendqueue; + } + + if( !@$sendqueue ) { + $self->want_writeready( 0 ); + return; + } + } + + $self->want_writeready( 1 ); +} + +sub on_read_ready +{ + my $self = shift; + + my $handle = $self->read_handle; + + while(1) { + my $addr = $handle->recv( my $data, $self->{recv_len} ); + + if( !defined $addr ) { + return if $! == EAGAIN || $! == EWOULDBLOCK || $! == EINTR; + + my $errno = $!; + + $self->maybe_invoke_event( on_recv_error => $errno ) + or $self->close; + + return; + } + + if( !length $data ) { + $self->close; + return; + } + + $self->invoke_event( on_recv => $data, $addr ); + + last unless $self->{recv_all}; + } +} + +sub on_write_ready +{ + my $self = shift; + + my $handle = $self->write_handle; + + my $sendqueue = $self->{sendqueue}; + + while( $sendqueue and @$sendqueue ) { + my ( $data, $flags, $addr ) = @{ shift @$sendqueue }; + my $len = $handle->send( $data, $flags, $addr ); + + if( !defined $len ) { + return if $! == EAGAIN || $! == EWOULDBLOCK || $! == EINTR; + + my $errno = $!; + + $self->maybe_invoke_event( on_send_error => $errno ) + or $self->close; + + return; + } + + if( $len == 0 ) { + $self->close; + return; + } + + last unless $self->{send_all}; + } + + if( !$sendqueue or !@$sendqueue ) { + $self->want_writeready( 0 ); + + $self->maybe_invoke_event( on_outgoing_empty => ); + } +} + +=head1 EXAMPLES + +=head2 Send-first on a UDP Socket + +C<UDP> is carried by the C<SOCK_DGRAM> socket type, for which the string +C<'dgram'> is a convenient shortcut: + + $socket->connect( + host => $hostname, + service => $service, + socktype => 'dgram', + ... + ) + +=head2 Receive-first on a UDP Socket + +A typical server pattern with C<UDP> involves binding a well-known port +number instead of connecting to one, and waiting on incoming packets. + + $socket->bind( + service => 12345, + socktype => 'dgram', + )->get; + +=head1 SEE ALSO + +=over 4 + +=item * + +L<IO::Handle> - Supply object methods for I/O handles + +=back + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Stream.pm b/lib/IO/Async/Stream.pm new file mode 100644 index 0000000..487eb38 --- /dev/null +++ b/lib/IO/Async/Stream.pm @@ -0,0 +1,1419 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2006-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Stream; + +use strict; +use warnings; +use 5.010; # // + +our $VERSION = '0.67'; + +use base qw( IO::Async::Handle ); + +use Errno qw( EAGAIN EWOULDBLOCK EINTR EPIPE ); + +use Carp; + +use Encode 2.11 qw( find_encoding STOP_AT_PARTIAL ); +use Scalar::Util qw( blessed ); + +use IO::Async::Debug; + +# Tuneable from outside +# Not yet documented +our $READLEN = 8192; +our $WRITELEN = 8192; + +use Struct::Dumb; + +# Element of the writequeue +struct Writer => [qw( data writelen on_write on_flush on_error watching )]; + +# Element of the readqueue +struct Reader => [qw( on_read future )]; + +# Bitfields in the want flags +use constant WANT_READ_FOR_READ => 0x01; +use constant WANT_READ_FOR_WRITE => 0x02; +use constant WANT_WRITE_FOR_READ => 0x04; +use constant WANT_WRITE_FOR_WRITE => 0x08; +use constant WANT_ANY_READ => WANT_READ_FOR_READ |WANT_READ_FOR_WRITE; +use constant WANT_ANY_WRITE => WANT_WRITE_FOR_READ|WANT_WRITE_FOR_WRITE; + +=head1 NAME + +C<IO::Async::Stream> - event callbacks and write bufering for a stream +filehandle + +=head1 SYNOPSIS + + use IO::Async::Stream; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my $stream = IO::Async::Stream->new( + read_handle => \*STDIN, + write_handle => \*STDOUT, + + on_read => sub { + my ( $self, $buffref, $eof ) = @_; + + while( $$buffref =~ s/^(.*\n)// ) { + print "Received a line $1"; + } + + if( $eof ) { + print "EOF; last partial line is $$buffref\n"; + } + + return 0; + } + ); + + $loop->add( $stream ); + + $stream->write( "An initial line here\n" ); + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Handle> contains a filehandle that represents +a byte-stream. It provides buffering for both incoming and outgoing data. It +invokes the C<on_read> handler when new data is read from the filehandle. Data +may be written to the filehandle by calling the C<write> method. + +This class is suitable for any kind of filehandle that provides a +possibly-bidirectional reliable byte stream, such as a pipe, TTY, or +C<SOCK_STREAM> socket (such as TCP or a byte-oriented UNIX local socket). For +datagram or raw message-based sockets (such as UDP) see instead +L<IO::Async::Socket>. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters: + +=head2 $ret = on_read \$buffer, $eof + +Invoked when more data is available in the internal receiving buffer. + +The first argument is a reference to a plain perl string. The code should +inspect and remove any data it likes, but is not required to remove all, or +indeed any of the data. Any data remaining in the buffer will be preserved for +the next call, the next time more data is received from the handle. + +In this way, it is easy to implement code that reads records of some form when +completed, but ignores partially-received records, until all the data is +present. If the handler is confident no more useful data remains, it should +return C<0>. If not, it should return C<1>, and the handler will be called +again. This makes it easy to implement code that handles multiple incoming +records at the same time. See the examples at the end of this documentation +for more detail. + +The second argument is a scalar indicating whether the stream has reported an +end-of-file (EOF) condition. A reference to the buffer is passed to the +handler in the usual way, so it may inspect data contained in it. Once the +handler returns a false value, it will not be called again, as the handle is +now at EOF and no more data can arrive. + +The C<on_read> code may also dynamically replace itself with a new callback +by returning a CODE reference instead of C<0> or C<1>. The original callback +or method that the object first started with may be restored by returning +C<undef>. Whenever the callback is changed in this way, the new code is called +again; even if the read buffer is currently empty. See the examples at the end +of this documentation for more detail. + +The C<push_on_read> method can be used to insert new, temporary handlers that +take precedence over the global C<on_read> handler. This event is only used if +there are no further pending handlers created by C<push_on_read>. + +=head2 on_read_eof + +Optional. Invoked when the read handle indicates an end-of-file (EOF) +condition. If there is any data in the buffer still to be processed, the +C<on_read> event will be invoked first, before this one. + +=head2 on_write_eof + +Optional. Invoked when the write handle indicates an end-of-file (EOF) +condition. Note that this condition can only be detected after a C<write> +syscall returns the C<EPIPE> error. If there is no data pending to be written +then it will not be detected yet. + +=head2 on_read_error $errno + +Optional. Invoked when the C<sysread> method on the read handle fails. + +=head2 on_write_error $errno + +Optional. Invoked when the C<syswrite> method on the write handle fails. + +The C<on_read_error> and C<on_write_error> handlers are passed the value of +C<$!> at the time the error occured. (The C<$!> variable itself, by its +nature, may have changed from the original error by the time this handler +runs so it should always use the value passed in). + +If an error occurs when the corresponding error callback is not supplied, and +there is not a handler for it, then the C<close> method is called instead. + +=head2 on_read_high_watermark $length + +=head2 on_read_low_watermark $length + +Optional. Invoked when the read buffer grows larger than the high watermark +or smaller than the low watermark respectively. These are edge-triggered +events; they will only be triggered once per crossing, not continuously while +the buffer remains above or below the given limit. + +If these event handlers are not defined, the default behaviour is to disable +read-ready notifications if the read buffer grows larger than the high +watermark (so as to avoid it growing arbitrarily if nothing is consuming it), +and re-enable notifications again once something has read enough to cause it to +drop. If these events are overridden, the overriding code will have to perform +this behaviour if required, by using + + $self->want_readready_for_read(...) + +=head2 on_outgoing_empty + +Optional. Invoked when the writing data buffer becomes empty. + +=head2 on_writeable_start + +=head2 on_writeable_stop + +Optional. These two events inform when the filehandle becomes writeable, and +when it stops being writeable. C<on_writeable_start> is invoked by the +C<on_write_ready> event if previously it was known to be not writeable. +C<on_writeable_stop> is invoked after a C<syswrite> operation fails with +C<EAGAIN> or C<EWOULDBLOCK>. These two events track the writeability state, +and ensure that only state change cause events to be invoked. A stream starts +off being presumed writeable, so the first of these events to be observed will +be C<on_writeable_stop>. + +=cut + +sub _init +{ + my $self = shift; + + $self->{writequeue} = []; # Queue of Writers + $self->{readqueue} = []; # Queue of Readers + $self->{writeable} = 1; # "innocent until proven guilty" (by means of EAGAIN) + $self->{readbuff} = ""; + + $self->{reader} = "_sysread"; + $self->{writer} = "_syswrite"; + + $self->{read_len} = $READLEN; + $self->{write_len} = $WRITELEN; + + $self->{want} = WANT_READ_FOR_READ; + + $self->{close_on_read_eof} = 1; +} + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 read_handle => IO + +The IO handle to read from. Must implement C<fileno> and C<sysread> methods. + +=head2 write_handle => IO + +The IO handle to write to. Must implement C<fileno> and C<syswrite> methods. + +=head2 handle => IO + +Shortcut to specifying the same IO handle for both of the above. + +=head2 on_read => CODE + +=head2 on_read_error => CODE + +=head2 on_outgoing_empty => CODE + +=head2 on_write_error => CODE + +=head2 on_writeable_start => CODE + +=head2 on_writeable_stop => CODE + +CODE references for event handlers. + +=head2 autoflush => BOOL + +Optional. If true, the C<write> method will attempt to write data to the +operating system immediately, without waiting for the loop to indicate the +filehandle is write-ready. This is useful, for example, on streams that should +contain up-to-date logging or console information. + +It currently defaults to false for any file handle, but future versions of +C<IO::Async> may enable this by default on STDOUT and STDERR. + +=head2 read_len => INT + +Optional. Sets the buffer size for C<read> calls. Defaults to 8 KiBytes. + +=head2 read_all => BOOL + +Optional. If true, attempt to read as much data from the kernel as possible +when the handle becomes readable. By default this is turned off, meaning at +most one fixed-size buffer is read. If there is still more data in the +kernel's buffer, the handle will still be readable, and will be read from +again. + +This behaviour allows multiple streams and sockets to be multiplexed +simultaneously, meaning that a large bulk transfer on one cannot starve other +filehandles of processing time. Turning this option on may improve bulk data +transfer rate, at the risk of delaying or stalling processing on other +filehandles. + +=head2 write_len => INT + +Optional. Sets the buffer size for C<write> calls. Defaults to 8 KiBytes. + +=head2 write_all => BOOL + +Optional. Analogous to the C<read_all> option, but for writing. When +C<autoflush> is enabled, this option only affects deferred writing if the +initial attempt failed due to buffer space. + +=head2 read_high_watermark => INT + +=head2 read_low_watermark => INT + +Optional. If defined, gives a way to implement flow control or other +behaviours that depend on the size of Stream's read buffer. + +If after more data is read from the underlying filehandle the read buffer is +now larger than the high watermark, the C<on_read_high_watermark> event is +triggered (which, by default, will disable read-ready notifications and pause +reading from the filehandle). + +If after data is consumed by an C<on_read> handler the read buffer is now +smaller than the low watermark, the C<on_read_low_watermark> event is +triggered (which, by default, will re-enable read-ready notifications and +resume reading from the filehandle). For to be possible, the read handler +would have to be one added by the C<push_on_read> method or one of the +Future-returning C<read_*> methods. + +By default these options are not defined, so this behaviour will not happen. +C<read_low_watermark> may not be set to a larger value than +C<read_high_watermark>, but it may be set to a smaller value, creating a +hysteresis region. If either option is defined then both must be. + +If these options are used with the default event handlers, be careful not to +cause deadlocks by having a high watermark sufficiently low that a single +C<on_read> invocation might not consider it finished yet. + +=head2 reader => STRING|CODE + +=head2 writer => STRING|CODE + +Optional. If defined, gives the name of a method or a CODE reference to use +to implement the actual reading from or writing to the filehandle. These will +be invoked as + + $stream->reader( $read_handle, $buffer, $len ) + $stream->writer( $write_handle, $buffer, $len ) + +Each is expected to modify the passed buffer; C<reader> by appending to it, +C<writer> by removing a prefix from it. Each is expected to return a true +value on success, zero on EOF, or C<undef> with C<$!> set for errors. If not +provided, they will be substituted by implenentations using C<sysread> and +C<syswrite> on the underlying handle, respectively. + +=head2 close_on_read_eof => BOOL + +Optional. Usually true, but if set to a false value then the stream will not +be C<close>d when an EOF condition occurs on read. This is normally not useful +as at that point the underlying stream filehandle is no longer useable, but it +may be useful for reading regular files, or interacting with TTY devices. + +=head2 encoding => STRING + +If supplied, sets the name of encoding of the underlying stream. If an +encoding is set, then the C<write> method will expect to receive Unicode +strings and encodes them into bytes, and incoming bytes will be decoded into +Unicode strings for the C<on_read> event. + +If an encoding is not supplied then C<write> and C<on_read> will work in byte +strings. + +I<IMPORTANT NOTE:> in order to handle reads of UTF-8 content or other +multibyte encodings, the code implementing the C<on_read> event uses a feature +of L<Encode>; the C<STOP_AT_PARTIAL> flag. While this flag has existed for a +while and is used by the C<:encoding> PerlIO layer itself for similar +purposes, the flag is not officially documented by the C<Encode> module. In +principle this undocumented feature could be subject to change, in practice I +believe it to be reasonably stable. + +This note applies only to the C<on_read> event; data written using the +C<write> method does not rely on any undocumented features of C<Encode>. + +If a read handle is given, it is required that either an C<on_read> callback +reference is configured, or that the object provides an C<on_read> method. It +is optional whether either is true for C<on_outgoing_empty>; if neither is +supplied then no action will be taken when the writing buffer becomes empty. + +An C<on_read> handler may be supplied even if no read handle is yet given, to +be used when a read handle is eventually provided by the C<set_handles> +method. + +This condition is checked at the time the object is added to a Loop; it is +allowed to create a C<IO::Async::Stream> object with a read handle but without +a C<on_read> handler, provided that one is later given using C<configure> +before the stream is added to its containing Loop, either directly or by being +a child of another Notifier already in a Loop, or added to one. + +=cut + +sub configure +{ + my $self = shift; + my %params = @_; + + for (qw( on_read on_outgoing_empty on_read_eof on_write_eof on_read_error + on_write_error on_writeable_start on_writeable_stop autoflush + read_len read_all write_len write_all on_read_high_watermark + on_read_low_watermark reader writer close_on_read_eof )) { + $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + if( exists $params{read_high_watermark} or exists $params{read_low_watermark} ) { + my $high = delete $params{read_high_watermark} // $self->{read_high_watermark}; + my $low = delete $params{read_low_watermark} // $self->{read_low_watermark}; + + croak "Cannot set read_low_watermark without read_high_watermark" if defined $low and !defined $high; + croak "Cannot set read_high_watermark without read_low_watermark" if defined $high and !defined $low; + + croak "Cannot set read_low_watermark higher than read_high_watermark" if defined $low and defined $high and $low > $high; + + $self->{read_high_watermark} = $high; + $self->{read_low_watermark} = $low; + + # TODO: reassert levels if we've moved them + } + + if( exists $params{encoding} ) { + my $encoding = delete $params{encoding}; + my $obj = find_encoding( $encoding ); + defined $obj or croak "Cannot handle an encoding of '$encoding'"; + $self->{encoding} = $obj; + } + + $self->SUPER::configure( %params ); + + if( $self->loop and $self->read_handle ) { + $self->can_event( "on_read" ) or + croak 'Expected either an on_read callback or to be able to ->on_read'; + } +} + +sub _add_to_loop +{ + my $self = shift; + + if( defined $self->read_handle ) { + $self->can_event( "on_read" ) or + croak 'Expected either an on_read callback or to be able to ->on_read'; + } + + $self->SUPER::_add_to_loop( @_ ); + + if( !$self->_is_empty ) { + $self->want_writeready_for_write( 1 ); + } +} + +=head1 METHODS + +The following methods documented with a trailing call to C<< ->get >> return +L<Future> instances. + +=cut + +=head2 $stream->want_readready_for_read( $set ) + +=head2 $stream->want_readready_for_write( $set ) + +Mutators for the C<want_readready> property on L<IO::Async::Handle>, which +control whether the C<read> or C<write> behaviour should be continued once the +filehandle becomes ready for read. + +Normally, C<want_readready_for_read> is always true (though the read watermark +behaviour can modify it), and C<want_readready_for_write> is not used. +However, if a custom C<writer> function is provided, it may find this useful +for being invoked again if it cannot proceed with a write operation until the +filehandle becomes readable (such as during transport negotiation or SSL key +management, for example). + +=cut + +sub want_readready_for_read +{ + my $self = shift; + my ( $set ) = @_; + $set ? ( $self->{want} |= WANT_READ_FOR_READ ) : ( $self->{want} &= ~WANT_READ_FOR_READ ); + + $self->want_readready( $self->{want} & WANT_ANY_READ ) if $self->read_handle; +} + +sub want_readready_for_write +{ + my $self = shift; + my ( $set ) = @_; + $set ? ( $self->{want} |= WANT_READ_FOR_WRITE ) : ( $self->{want} &= ~WANT_READ_FOR_WRITE ); + + $self->want_readready( $self->{want} & WANT_ANY_READ ) if $self->read_handle; +} + +=head2 $stream->want_writeready_for_write( $set ) + +=head2 $stream->want_writeready_for_read( $set ) + +Mutators for the C<want_writeready> property on L<IO::Async::Handle>, which +control whether the C<write> or C<read> behaviour should be continued once the +filehandle becomes ready for write. + +Normally, C<want_writeready_for_write> is managed by the C<write> method and +associated flushing, and C<want_writeready_for_read> is not used. However, if +a custom C<reader> function is provided, it may find this useful for being +invoked again if it cannot proceed with a read operation until the filehandle +becomes writable (such as during transport negotiation or SSL key management, +for example). + +=cut + +sub want_writeready_for_write +{ + my $self = shift; + my ( $set ) = @_; + $set ? ( $self->{want} |= WANT_WRITE_FOR_WRITE ) : ( $self->{want} &= ~WANT_WRITE_FOR_WRITE ); + + $self->want_writeready( $self->{want} & WANT_ANY_WRITE ) if $self->write_handle; +} + +sub want_writeready_for_read +{ + my $self = shift; + my ( $set ) = @_; + $set ? ( $self->{want} |= WANT_WRITE_FOR_READ ) : ( $self->{want} &= ~WANT_WRITE_FOR_READ ); + + $self->want_writeready( $self->{want} & WANT_ANY_WRITE ) if $self->write_handle; +} + +# FUNCTION not method +sub _nonfatal_error +{ + my ( $errno ) = @_; + + return $errno == EAGAIN || + $errno == EWOULDBLOCK || + $errno == EINTR; +} + +sub _is_empty +{ + my $self = shift; + return !@{ $self->{writequeue} }; +} + +=head2 $stream->close + +A synonym for C<close_when_empty>. This should not be used when the deferred +wait behaviour is required, as the behaviour of C<close> may change in a +future version of C<IO::Async>. Instead, call C<close_when_empty> directly. + +=cut + +sub close +{ + my $self = shift; + $self->close_when_empty; +} + +=head2 $stream->close_when_empty + +If the write buffer is empty, this method calls C<close> on the underlying IO +handles, and removes the stream from its containing loop. If the write buffer +still contains data, then this is deferred until the buffer is empty. This is +intended for "write-then-close" one-shot streams. + + $stream->write( "Here is my final data\n" ); + $stream->close_when_empty; + +Because of this deferred nature, it may not be suitable for error handling. +See instead the C<close_now> method. + +=cut + +sub close_when_empty +{ + my $self = shift; + + return $self->SUPER::close if $self->_is_empty; + + $self->{stream_closing} = 1; +} + +=head2 $stream->close_now + +This method immediately closes the underlying IO handles and removes the +stream from the containing loop. It will not wait to flush the remaining data +in the write buffer. + +=cut + +sub close_now +{ + my $self = shift; + + foreach ( @{ $self->{writequeue} } ) { + $_->on_error->( "stream closing" ) if $_->on_error; + } + + undef @{ $self->{writequeue} }; + undef $self->{stream_closing}; + + $self->SUPER::close; +} + +=head2 $eof = $stream->is_read_eof + +=head2 $eof = $stream->is_write_eof + +Returns true after an EOF condition is reported on either the read or the +write handle, respectively. + +=cut + +sub is_read_eof +{ + my $self = shift; + return $self->{read_eof}; +} + +sub is_write_eof +{ + my $self = shift; + return $self->{write_eof}; +} + +=head2 $stream->write( $data, %params ) + +This method adds data to the outgoing data queue, or writes it immediately, +according to the C<autoflush> parameter. + +If the C<autoflush> option is set, this method will try immediately to write +the data to the underlying filehandle. If this completes successfully then it +will have been written by the time this method returns. If it fails to write +completely, then the data is queued as if C<autoflush> were not set, and will +be flushed as normal. + +C<$data> can either be a plain string, a L<Future>, or a CODE reference. If it +is a plain string it is written immediately. If it is not, its value will be +used to generate more C<$data> values, eventually leading to strings to be +written. + +If C<$data> is a C<Future>, the Stream will wait until it is ready, and take +the single value it yields. + +If C<$data> is a CODE reference, it will be repeatedly invoked to generate new +values. Each time the filehandle is ready to write more data to it, the +function is invoked. Once the function has finished generating data it should +return undef. The function is passed the Stream object as its first argument. + +It is allowed that C<Future>s yield CODE references, or CODE references return +C<Future>s, as well as plain strings. + +For example, to stream the contents of an existing opened filehandle: + + open my $fileh, "<", $path or die "Cannot open $path - $!"; + + $stream->write( sub { + my ( $stream ) = @_; + + sysread $fileh, my $buffer, 8192 or return; + return $buffer; + } ); + +Takes the following optional named parameters in C<%params>: + +=over 8 + +=item write_len => INT + +Overrides the C<write_len> parameter for the data written by this call. + +=item on_write => CODE + +A CODE reference which will be invoked after every successful C<syswrite> +operation on the underlying filehandle. It will be passed the number of bytes +that were written by this call, which may not be the entire length of the +buffer - if it takes more than one C<syscall> operation to empty the buffer +then this callback will be invoked multiple times. + + $on_write->( $stream, $len ) + +=item on_flush => CODE + +A CODE reference which will be invoked once the data queued by this C<write> +call has been flushed. This will be invoked even if the buffer itself is not +yet empty; if more data has been queued since the call. + + $on_flush->( $stream ) + +=item on_error => CODE + +A CODE reference which will be invoked if a C<syswrite> error happens while +performing this write. Invoked as for the C<Stream>'s C<on_write_error> event. + + $on_error->( $stream, $errno ) + +=back + +If the object is not yet a member of a loop and doesn't yet have a +C<write_handle>, then calls to the C<write> method will simply queue the data +and return. It will be flushed when the object is added to the loop. + +If C<$data> is a defined but empty string, the write is still queued, and the +C<on_flush> continuation will be invoked, if supplied. This can be used to +obtain a marker, to invoke some code once the output queue has been flushed up +to this point. + +=head2 $stream->write( ... )->get + +If called in non-void context, this method returns a L<Future> which will +complete (with no value) when the write operation has been flushed. This may +be used as an alternative to, or combined with, the C<on_flush> callback. + +=cut + +sub _syswrite +{ + my $self = shift; + my ( $handle, undef, $len ) = @_; + + my $written = $handle->syswrite( $_[1], $len ); + return $written if !$written; # zero or undef + + substr( $_[1], 0, $written ) = ""; + return $written; +} + +sub _flush_one_write +{ + my $self = shift; + + my $writequeue = $self->{writequeue}; + + my $head; + while( $head = $writequeue->[0] and ref $head->data ) { + if( ref $head->data eq "CODE" ) { + my $data = $head->data->( $self ); + if( !defined $data ) { + $head->on_flush->( $self ) if $head->on_flush; + shift @$writequeue; + return 1; + } + if( !ref $data and my $encoding = $self->{encoding} ) { + $data = $encoding->encode( $data ); + } + unshift @$writequeue, my $new = Writer( + $data, $head->writelen, $head->on_write, undef, undef, 0 + ); + next; + } + elsif( blessed $head->data and $head->data->isa( "Future" ) ) { + my $f = $head->data; + if( !$f->is_ready ) { + return 0 if $head->watching; + $f->on_ready( sub { $self->_flush_one_write } ); + $head->watching++; + return 0; + } + my $data = $f->get; + if( !ref $data and my $encoding = $self->{encoding} ) { + $data = $encoding->encode( $data ); + } + $head->data = $data; + next; + } + else { + die "Unsure what to do with reference ".ref($head->data)." in write queue"; + } + } + + my $second; + while( $second = $writequeue->[1] and + !ref $second->data and + $head->writelen == $second->writelen and + !$head->on_write and !$second->on_write and + !$head->on_flush ) { + $head->data .= $second->data; + $head->on_write = $second->on_write; + $head->on_flush = $second->on_flush; + splice @$writequeue, 1, 1, (); + } + + die "TODO: head data does not contain a plain string" if ref $head->data; + + if( $IO::Async::Debug::DEBUG > 1 ) { + my $data = substr $head->data, 0, $head->writelen; + $self->debug_printf( "WRITE len=%d", length $data ); + IO::Async::Debug::log_hexdump( $data ) if $IO::Async::Debug::DEBUG_FLAGS{Sw}; + } + + my $writer = $self->{writer}; + my $len = $self->$writer( $self->write_handle, $head->data, $head->writelen ); + + if( !defined $len ) { + my $errno = $!; + + if( $errno == EAGAIN or $errno == EWOULDBLOCK ) { + $self->maybe_invoke_event( on_writeable_stop => ) if $self->{writeable}; + $self->{writeable} = 0; + } + + return 0 if _nonfatal_error( $errno ); + + if( $errno == EPIPE ) { + $self->{write_eof} = 1; + $self->maybe_invoke_event( on_write_eof => ); + } + + $head->on_error->( $self, $errno ) if $head->on_error; + $self->maybe_invoke_event( on_write_error => $errno ) + or $self->close_now; + + return 0; + } + + if( my $on_write = $head->on_write ) { + $on_write->( $self, $len ); + } + + if( !length $head->data ) { + $head->on_flush->( $self ) if $head->on_flush; + shift @{ $self->{writequeue} }; + } + + return 1; +} + +sub write +{ + my $self = shift; + my ( $data, %params ) = @_; + + carp "Cannot write data to a Stream that is closing" and return if $self->{stream_closing}; + + # Allow writes without a filehandle if we're not yet in a Loop, just don't + # try to flush them + my $handle = $self->write_handle; + + croak "Cannot write data to a Stream with no write_handle" if !$handle and $self->loop; + + if( !ref $data and my $encoding = $self->{encoding} ) { + $data = $encoding->encode( $data ); + } + + my $on_write = delete $params{on_write}; + my $on_flush = delete $params{on_flush}; + my $on_error = delete $params{on_error}; + + my $f; + if( defined wantarray ) { + my $orig_on_flush = $on_flush; + my $orig_on_error = $on_error; + + my $loop = $self->loop or + croak "Cannot ->write data returning a Future to a Stream not in a Loop"; + $f = $loop->new_future; + $on_flush = sub { + $f->done; + $orig_on_flush->( @_ ) if $orig_on_flush; + }; + $on_error = sub { + my $self = shift; + my ( $errno ) = @_; + + $f->fail( "write failed: $errno", syswrite => $errno ) unless $f->is_ready; + + $orig_on_error->( $self, @_ ) if $orig_on_error; + }; + } + + push @{ $self->{writequeue} }, Writer( + $data, $params{write_len} // $self->{write_len}, $on_write, $on_flush, $on_error, 0 + ); + + keys %params and croak "Unrecognised keys for ->write - " . join( ", ", keys %params ); + + return $f unless $handle; + + if( $self->{autoflush} ) { + 1 while !$self->_is_empty and $self->_flush_one_write; + + if( $self->_is_empty ) { + $self->want_writeready_for_write( 0 ); + return $f; + } + } + + $self->want_writeready_for_write( 1 ); + return $f; +} + +sub on_write_ready +{ + my $self = shift; + + if( !$self->{writeable} ) { + $self->maybe_invoke_event( on_writeable_start => ); + $self->{writeable} = 1; + } + + $self->_do_write if $self->{want} & WANT_WRITE_FOR_WRITE; + $self->_do_read if $self->{want} & WANT_WRITE_FOR_READ; +} + +sub _do_write +{ + my $self = shift; + + 1 while !$self->_is_empty and $self->_flush_one_write and $self->{write_all}; + + # All data successfully flushed + if( $self->_is_empty ) { + $self->want_writeready_for_write( 0 ); + + $self->maybe_invoke_event( on_outgoing_empty => ); + + $self->close_now if $self->{stream_closing}; + } +} + +sub _flush_one_read +{ + my $self = shift; + my ( $eof ) = @_; + + local $self->{flushing_read} = 1; + + my $readqueue = $self->{readqueue}; + + my $ret; + if( $readqueue->[0] and my $on_read = $readqueue->[0]->on_read ) { + $ret = $on_read->( $self, \$self->{readbuff}, $eof ); + } + else { + $ret = $self->invoke_event( on_read => \$self->{readbuff}, $eof ); + } + + if( defined $self->{read_low_watermark} and $self->{at_read_high_watermark} and + length $self->{readbuff} < $self->{read_low_watermark} ) { + undef $self->{at_read_high_watermark}; + $self->invoke_event( on_read_low_watermark => length $self->{readbuff} ); + } + + if( ref $ret eq "CODE" ) { + # Replace the top CODE, or add it if there was none + $readqueue->[0] = Reader( $ret, undef ); + return 1; + } + elsif( @$readqueue and !defined $ret ) { + shift @$readqueue; + return 1; + } + else { + return $ret && ( length( $self->{readbuff} ) > 0 || $eof ); + } +} + +sub _sysread +{ + my $self = shift; + my ( $handle, undef, $len ) = @_; + return $handle->sysread( $_[1], $len ); +} + +sub on_read_ready +{ + my $self = shift; + + $self->_do_read if $self->{want} & WANT_READ_FOR_READ; + $self->_do_write if $self->{want} & WANT_READ_FOR_WRITE; +} + +sub _do_read +{ + my $self = shift; + + my $handle = $self->read_handle; + my $reader = $self->{reader}; + + while(1) { + my $data; + my $len = $self->$reader( $handle, $data, $self->{read_len} ); + + if( !defined $len ) { + my $errno = $!; + + return if _nonfatal_error( $errno ); + + $self->maybe_invoke_event( on_read_error => $errno ) + or $self->close_now; + + foreach ( @{ $self->{readqueue} } ) { + $_->future->fail( "read failed: $errno", sysread => $errno ) if $_->future; + } + undef @{ $self->{readqueue} }; + + return; + } + + if( $IO::Async::Debug::DEBUG > 1 ) { + $self->debug_printf( "READ len=%d", $len ); + IO::Async::Debug::log_hexdump( $data ) if $IO::Async::Debug::DEBUG_FLAGS{Sr}; + } + + my $eof = $self->{read_eof} = ( $len == 0 ); + + if( my $encoding = $self->{encoding} ) { + my $bytes = defined $self->{bytes_remaining} ? $self->{bytes_remaining} . $data : $data; + $data = $encoding->decode( $bytes, STOP_AT_PARTIAL ); + $self->{bytes_remaining} = $bytes; + } + + $self->{readbuff} .= $data if !$eof; + + 1 while $self->_flush_one_read( $eof ); + + if( $eof ) { + $self->maybe_invoke_event( on_read_eof => ); + $self->close_now if $self->{close_on_read_eof}; + foreach ( @{ $self->{readqueue} } ) { + $_->future->done( undef ) if $_->future; + } + undef @{ $self->{readqueue} }; + return; + } + + last unless $self->{read_all}; + } + + if( defined $self->{read_high_watermark} and length $self->{readbuff} >= $self->{read_high_watermark} ) { + $self->{at_read_high_watermark} or + $self->invoke_event( on_read_high_watermark => length $self->{readbuff} ); + + $self->{at_read_high_watermark} = 1; + } +} + +sub on_read_high_watermark +{ + my $self = shift; + $self->want_readready_for_read( 0 ); +} + +sub on_read_low_watermark +{ + my $self = shift; + $self->want_readready_for_read( 1 ); +} + +=head2 $stream->push_on_read( $on_read ) + +Pushes a new temporary C<on_read> handler to the end of the queue. This queue, +if non-empty, is used to provide C<on_read> event handling code in preference +to using the object's main event handler or method. New handlers can be +supplied at any time, and they will be used in first-in first-out (FIFO) +order. + +As with the main C<on_read> event handler, each can return a (defined) boolean +to indicate if they wish to be invoked again or not, another C<CODE> reference +to replace themself with, or C<undef> to indicate it is now complete and +should be removed. When a temporary handler returns C<undef> it is shifted +from the queue and the next one, if present, is invoked instead. If there are +no more then the object's main handler is invoked instead. + +=cut + +sub push_on_read +{ + my $self = shift; + my ( $on_read, %args ) = @_; + # %args undocumented for internal use + + push @{ $self->{readqueue} }, Reader( $on_read, $args{future} ); + + # TODO: Should this always defer? + return if $self->{flushing_read}; + 1 while length $self->{readbuff} and $self->_flush_one_read( 0 ); +} + +=head1 FUTURE-RETURNING READ METHODS + +The following methods all return a L<Future> which will become ready when +enough data has been read by the Stream into its buffer. At this point, the +data is removed from the buffer and given to the C<Future> object to complete +it. + + my $f = $stream->read_... + + my ( $string ) = $f->get; + +Unlike the C<on_read> event handlers, these methods don't allow for access to +"partial" results; they only provide the final result once it is ready. + +If a C<Future> is cancelled before it completes it is removed from the read +queue without consuming any data; i.e. each C<Future> atomically either +completes or is cancelled. + +Since it is possible to use a readable C<Stream> entirely using these +C<Future>-returning methods instead of the C<on_read> event, it may be useful +to configure a trivial return-false event handler to keep it from consuming +any input, and to allow it to be added to a C<Loop> in the first place. + + my $stream = IO::Async::Stream->new( on_read => sub { 0 }, ... ); + $loop->add( $stream ); + + my $f = $stream->read_... + +If a read EOF or error condition happens while there are read C<Future>s +pending, they are all completed. In the case of a read EOF, they are done with +C<undef>; in the case of a read error they are failed using the C<$!> error +value as the failure. + + $f->fail( $message, sysread => $! ) + +If a read EOF condition happens to the currently-processing read C<Future>, it +will return a partial result. The calling code can detect this by the fact +that the returned data is not complete according to the specification (too +short in C<read_exactly>'s case, or lacking the ending pattern in +C<read_until>'s case). Additionally, each C<Future> will yield the C<$eof> +value in its results. + + my ( $string, $eof ) = $f->get; + +=cut + +sub _read_future +{ + my $self = shift; + my $f = $self->loop->new_future; + $f->on_cancel( $self->_capture_weakself( sub { + my $self = shift or return; + 1 while $self->_flush_one_read; + })); + return $f; +} + +=head2 ( $string, $eof ) = $stream->read_atmost( $len )->get + +=head2 ( $string, $eof ) = $stream->read_exactly( $len )->get + +Completes the C<Future> when the read buffer contains C<$len> or more +characters of input. C<read_atmost> will also complete after the first +invocation of C<on_read>, even if fewer characters are available, whereas +C<read_exactly> will wait until at least C<$len> are available. + +=cut + +sub read_atmost +{ + my $self = shift; + my ( $len ) = @_; + + my $f = $self->_read_future; + $self->push_on_read( sub { + my ( undef, $buffref, $eof ) = @_; + return undef if $f->is_cancelled; + $f->done( substr( $$buffref, 0, $len, "" ), $eof ); + return undef; + }, future => $f ); + return $f; +} + +sub read_exactly +{ + my $self = shift; + my ( $len ) = @_; + + my $f = $self->_read_future; + $self->push_on_read( sub { + my ( undef, $buffref, $eof ) = @_; + return undef if $f->is_cancelled; + return 0 unless $eof or length $$buffref >= $len; + $f->done( substr( $$buffref, 0, $len, "" ), $eof ); + return undef; + }, future => $f ); + return $f; +} + +=head2 ( $string, $eof ) = $stream->read_until( $end )->get + +Completes the C<Future> when the read buffer contains a match for C<$end>, +which may either be a plain string or a compiled C<Regexp> reference. Yields +the prefix of the buffer up to and including this match. + +=cut + +sub read_until +{ + my $self = shift; + my ( $until ) = @_; + + ref $until or $until = qr/\Q$until\E/; + + my $f = $self->_read_future; + $self->push_on_read( sub { + my ( undef, $buffref, $eof ) = @_; + return undef if $f->is_cancelled; + if( $$buffref =~ $until ) { + $f->done( substr( $$buffref, 0, $+[0], "" ), $eof ); + return undef; + } + elsif( $eof ) { + $f->done( $$buffref, $eof ); $$buffref = ""; + return undef; + } + else { + return 0; + } + }, future => $f ); + return $f; +} + +=head2 ( $string, $eof ) = $stream->read_until_eof->get + +Completes the C<Future> when the stream is eventually closed at EOF, and +yields all of the data that was available. + +=cut + +sub read_until_eof +{ + my $self = shift; + + my $f = $self->_read_future; + $self->push_on_read( sub { + my ( undef, $buffref, $eof ) = @_; + return undef if $f->is_cancelled; + return 0 unless $eof; + $f->done( $$buffref, $eof ); $$buffref = ""; + return undef; + }, future => $f ); + return $f; +} + +=head1 UTILITY CONSTRUCTORS + +=cut + +=head2 $stream = IO::Async::Stream->new_for_stdin + +=head2 $stream = IO::Async::Stream->new_for_stdout + +=head2 $stream = IO::Async::Stream->new_for_stdio + +Return a C<IO::Async::Stream> object preconfigured with the correct +C<read_handle>, C<write_handle> or both. + +=cut + +sub new_for_stdin { shift->new( read_handle => \*STDIN, @_ ) } +sub new_for_stdout { shift->new( write_handle => \*STDOUT, @_ ) } + +sub new_for_stdio { shift->new( read_handle => \*STDIN, write_handle => \*STDOUT, @_ ) } + +=head2 $future = $stream->connect( %args ) + +A convenient wrapper for calling the C<connect> method on the underlying +L<IO::Async::Loop> object, passing the C<socktype> hint as C<stream> if not +otherwise supplied. + +=cut + +sub connect +{ + my $self = shift; + return $self->SUPER::connect( socktype => "stream", @_ ); +} + +=head1 DEBUGGING FLAGS + +The following flags in C<IO_ASYNC_DEBUG_FLAGS> enable extra logging: + +=over 4 + +=item C<Sr> + +Log byte buffers as data is read from a Stream + +=item C<Sw> + +Log byte buffers as data is written to a Stream + +=back + +=cut + +=head1 EXAMPLES + +=head2 A line-based C<on_read> method + +The following C<on_read> method accepts incoming C<\n>-terminated lines and +prints them to the program's C<STDOUT> stream. + + sub on_read + { + my $self = shift; + my ( $buffref, $eof ) = @_; + + while( $$buffref =~ s/^(.*\n)// ) { + print "Received a line: $1"; + } + + return 0; + } + +Because a reference to the buffer itself is passed, it is simple to use a +C<s///> regular expression on the scalar it points at, to both check if data +is ready (i.e. a whole line), and to remove it from the buffer. If no data is +available then C<0> is returned, to indicate it should not be tried again. If +a line was successfully extracted, then C<1> is returned, to indicate it +should try again in case more lines exist in the buffer. + +=head2 Reading binary data + +This C<on_read> method accepts incoming records in 16-byte chunks, printing +each one. + + sub on_read + { + my ( $self, $buffref, $eof ) = @_; + + if( length $$buffref >= 16 ) { + my $record = substr( $$buffref, 0, 16, "" ); + print "Received a 16-byte record: $record\n"; + + return 1; + } + + if( $eof and length $$buffref ) { + print "EOF: a partial record still exists\n"; + } + + return 0; + } + +The 4-argument form of C<substr()> extracts the 16-byte record from the buffer +and assigns it to the C<$record> variable, if there was enough data in the +buffer to extract it. + +A lot of protocols use a fixed-size header, followed by a variable-sized body +of data, whose size is given by one of the fields of the header. The following +C<on_read> method extracts messages in such a protocol. + + sub on_read + { + my ( $self, $buffref, $eof ) = @_; + + return 0 unless length $$buffref >= 8; # "N n n" consumes 8 bytes + + my ( $len, $x, $y ) = unpack "N n n", $$buffref; + + return 0 unless length $$buffref >= 8 + $len; + + substr( $$buffref, 0, 8, "" ); + my $data = substr( $$buffref, 0, $len, "" ); + + print "A record with values x=$x y=$y\n"; + + return 1; + } + +In this example, the header is C<unpack()>ed first, to extract the body +length, and then the body is extracted. If the buffer does not have enough +data yet for a complete message then C<0> is returned, and the buffer is left +unmodified for next time. Only when there are enough bytes in total does it +use C<substr()> to remove them. + +=head2 Dynamic replacement of C<on_read> + +Consider the following protocol (inspired by IMAP), which consists of +C<\n>-terminated lines that may have an optional data block attached. The +presence of such a data block, as well as its size, is indicated by the line +prefix. + + sub on_read + { + my $self = shift; + my ( $buffref, $eof ) = @_; + + if( $$buffref =~ s/^DATA (\d+):(.*)\n// ) { + my $length = $1; + my $line = $2; + + return sub { + my $self = shift; + my ( $buffref, $eof ) = @_; + + return 0 unless length $$buffref >= $length; + + # Take and remove the data from the buffer + my $data = substr( $$buffref, 0, $length, "" ); + + print "Received a line $line with some data ($data)\n"; + + return undef; # Restore the original method + } + } + elsif( $$buffref =~ s/^LINE:(.*)\n// ) { + my $line = $1; + + print "Received a line $line with no data\n"; + + return 1; + } + else { + print STDERR "Unrecognised input\n"; + # Handle it somehow + } + } + +In the case where trailing data is supplied, a new temporary C<on_read> +callback is provided in a closure. This closure captures the C<$length> +variable so it knows how much data to expect. It also captures the C<$line> +variable so it can use it in the event report. When this method has finished +reading the data, it reports the event, then restores the original method by +returning C<undef>. + +=head1 SEE ALSO + +=over 4 + +=item * + +L<IO::Handle> - Supply object methods for I/O handles + +=back + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Test.pm b/lib/IO/Async/Test.pm new file mode 100644 index 0000000..933330f --- /dev/null +++ b/lib/IO/Async/Test.pm @@ -0,0 +1,185 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2007-2012 -- leonerd@leonerd.org.uk + +package IO::Async::Test; + +use strict; +use warnings; + +our $VERSION = '0.67'; + +use Exporter 'import'; +our @EXPORT = qw( + testing_loop + wait_for + wait_for_stream +); + +=head1 NAME + +C<IO::Async::Test> - utility functions for use in test scripts + +=head1 SYNOPSIS + + use Test::More tests => 1; + use IO::Async::Test; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + testing_loop( $loop ); + + my $result; + + $loop->do_something( + some => args, + + on_done => sub { + $result = the_outcome; + } + ); + + wait_for { defined $result }; + + is( $result, what_we_expected, 'The event happened' ); + + ... + + my $buffer = ""; + my $handle = IO::Handle-> ... + + wait_for_stream { length $buffer >= 10 } $handle => $buffer; + + is( substr( $buffer, 0, 10, "" ), "0123456789", 'Buffer was correct' ); + +=head1 DESCRIPTION + +This module provides utility functions that may be useful when writing test +scripts for code which uses C<IO::Async> (as well as being used in the +C<IO::Async> test scripts themselves). + +Test scripts are often synchronous by nature; they are a linear sequence of +actions to perform, interspersed with assertions which check for given +conditions. This goes against the very nature of C<IO::Async> which, being an +asynchronisation framework, does not provide a linear stepped way of working. + +In order to write a test, the C<wait_for> function provides a way of +synchronising the code, so that a given condition is known to hold, which +would typically signify that some event has occured, the outcome of which can +now be tested using the usual testing primitives. + +Because the primary purpose of C<IO::Async> is to provide IO operations on +filehandles, a great many tests will likely be based around connected pipes or +socket handles. The C<wait_for_stream> function provides a convenient way +to wait for some content to be written through such a connected stream. + +=cut + +my $loop; +END { undef $loop } + +=head1 FUNCTIONS + +=cut + +=head2 testing_loop( $loop ) + +Set the C<IO::Async::Loop> object which the C<wait_for> function will loop +on. + +=cut + +sub testing_loop +{ + $loop = shift; +} + +=head2 wait_for( $condfunc ) + +Repeatedly call the C<loop_once> method on the underlying loop (given to the +C<testing_loop> function), until the given condition function callback +returns true. + +To guard against stalled scripts, if the loop indicates a timeout for 10 +consequentive seconds, then an error is thrown. + +=cut + +sub wait_for(&) +{ + my ( $cond ) = @_; + + my ( undef, $callerfile, $callerline ) = caller; + + my $timedout = 0; + my $timerid = $loop->watch_time( + after => 10, + code => sub { $timedout = 1 }, + ); + + $loop->loop_once( 1 ) while !$cond->() and !$timedout; + + if( $timedout ) { + die "Nothing was ready after 10 second wait; called at $callerfile line $callerline\n"; + } + else { + $loop->unwatch_time( $timerid ); + } +} + +=head2 wait_for_stream( $condfunc, $handle, $buffer ) + +As C<wait_for>, but will also watch the given IO handle for readability, and +whenever it is readable will read bytes in from it into the given buffer. The +buffer is NOT initialised when the function is entered, in case data remains +from a previous call. + +C<$buffer> can also be a CODE reference, in which case it will be invoked +being passed data read from the handle, whenever it is readable. + +=cut + +sub wait_for_stream(&$$) +{ + my ( $cond, $handle, undef ) = @_; + + my $on_read; + if( ref $_[2] eq "CODE" ) { + $on_read = $_[2]; + } + else { + my $varref = \$_[2]; + $on_read = sub { $$varref .= $_[0] }; + } + + $loop->watch_io( + handle => $handle, + on_read_ready => sub { + my $ret = $handle->sysread( my $buffer, 8192 ); + if( !defined $ret ) { + die "Read failed on $handle - $!\n"; + } + elsif( $ret == 0 ) { + die "Read returned EOF on $handle\n"; + } + $on_read->( $buffer ); + } + ); + + # Have to defeat the prototype... grr I hate these + &wait_for( $cond ); + + $loop->unwatch_io( + handle => $handle, + on_read_ready => 1, + ); +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Timer.pm b/lib/IO/Async/Timer.pm new file mode 100644 index 0000000..8e5961b --- /dev/null +++ b/lib/IO/Async/Timer.pm @@ -0,0 +1,187 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2009-2012 -- leonerd@leonerd.org.uk + +package IO::Async::Timer; + +use strict; +use warnings; +use base qw( IO::Async::Notifier ); + +our $VERSION = '0.67'; + +use Carp; + +=head1 NAME + +C<IO::Async::Timer> - base class for Notifiers that use timed delays + +=head1 DESCRIPTION + +This module provides a subclass of L<IO::Async::Notifier> for implementing +notifiers that use timed delays. For specific implementations, see one of the +subclasses: + +=over 8 + +=item * + +L<IO::Async::Timer::Absolute> - event callback at a fixed future time + +=item * + +L<IO::Async::Timer::Countdown> - event callback after a fixed delay + +=item * + +L<IO::Async::Timer::Periodic> - event callback at regular intervals + +=back + +=cut + +=head1 CONSTRUCTOR + +=cut + +=head2 $timer = IO::Async::Timer->new( %args ) + +Constructs a particular subclass of C<IO::Async::Timer> object, and returns +it. This constructor is provided for backward compatibility to older code +which doesn't use the subclasses. New code should directly construct a +subclass instead. + +=over 8 + +=item mode => STRING + +The type of timer to create. Currently the only allowed mode is C<countdown> +but more types may be added in the future. + +=back + +Once constructed, the C<Timer> will need to be added to the C<Loop> before it +will work. It will also need to be started by the C<start> method. + +=cut + +sub new +{ + my $class = shift; + my %args = @_; + + if( my $mode = delete $args{mode} ) { + # Might define some other modes later + $mode eq "countdown" or croak "Expected 'mode' to be 'countdown'"; + + require IO::Async::Timer::Countdown; + return IO::Async::Timer::Countdown->new( %args ); + } + + return $class->SUPER::new( %args ); +} + +sub _add_to_loop +{ + my $self = shift; + $self->start if delete $self->{pending}; +} + +sub _remove_from_loop +{ + my $self = shift; + $self->stop; +} + +=head1 METHODS + +=cut + +=head2 $running = $timer->is_running + +Returns true if the Timer has been started, and has not yet expired, or been +stopped. + +=cut + +sub is_running +{ + my $self = shift; + + defined $self->{id}; +} + +=head2 $timer->start + +Starts the Timer. Throws an error if it was already running. + +If the Timer is not yet in a Loop, the actual start will be deferred until it +is added. Once added, it will be running, and will expire at the given +duration after the time it was added. + +As a convenience, C<$timer> is returned. This may be useful for starting +timers at construction time: + + $loop->add( IO::Async::Timer->new( ... )->start ); + +=cut + +sub start +{ + my $self = shift; + + my $loop = $self->loop; + if( !defined $loop ) { + $self->{pending} = 1; + return $self; + } + + defined $self->{id} and croak "Cannot start a Timer that is already running"; + + if( !$self->{cb} ) { + $self->{cb} = $self->_make_cb; + } + + $self->{id} = $loop->watch_time( + $self->_make_enqueueargs, + code => $self->{cb}, + ); + + return $self; +} + +=head2 $timer->stop + +Stops the Timer if it is running. If it has not yet been added to the C<Loop> +but there is a start pending, this will cancel it. + +=cut + +sub stop +{ + my $self = shift; + + if( $self->{pending} ) { + delete $self->{pending}; + return; + } + + return if !$self->is_running; + + my $loop = $self->loop or croak "Cannot stop a Timer that is not in a Loop"; + + defined $self->{id} or return; # nothing to do but no error + + $loop->unwatch_time( $self->{id} ); + + undef $self->{id}; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Timer/Absolute.pm b/lib/IO/Async/Timer/Absolute.pm new file mode 100644 index 0000000..a925415 --- /dev/null +++ b/lib/IO/Async/Timer/Absolute.pm @@ -0,0 +1,142 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2010-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Timer::Absolute; + +use strict; +use warnings; +use base qw( IO::Async::Timer ); + +our $VERSION = '0.67'; + +use Carp; + +=head1 NAME + +C<IO::Async::Timer::Absolute> - event callback at a fixed future time + +=head1 SYNOPSIS + + use IO::Async::Timer::Absolute; + + use POSIX qw( mktime ); + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my @time = gmtime; + + my $timer = IO::Async::Timer::Absolute->new( + time => mktime( 0, 0, 0, $time[3]+1, $time[4], $time[5] ), + + on_expire => sub { + print "It's midnight\n"; + $loop->stop; + }, + ); + + $loop->add( $timer ); + + $loop->run; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Timer> implements one-shot events at a fixed +time in the future. The object waits for a given timestamp, and invokes its +callback at that point in the future. + +For a C<Timer> object that waits for a delay relative to the time it is +started, see instead L<IO::Async::Timer::Countdown>. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters: + +=head2 on_expire + +Invoked when the timer expires. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 on_expire => CODE + +CODE reference for the C<on_expire> event. + +=head2 time => NUM + +The epoch time at which the timer will expire. + +Once constructed, the timer object will need to be added to the C<Loop> before +it will work. + +Unlike other timers, it does not make sense to C<start> this object, because +its expiry time is absolute, and not relative to the time it is started. + +=cut + +sub configure +{ + my $self = shift; + my %params = @_; + + if( exists $params{on_expire} ) { + my $on_expire = delete $params{on_expire}; + ref $on_expire or croak "Expected 'on_expire' as a reference"; + + $self->{on_expire} = $on_expire; + undef $self->{cb}; # Will be lazily constructed when needed + } + + if( exists $params{time} ) { + my $time = delete $params{time}; + + $self->stop if $self->is_running; + + $self->{time} = $time; + + $self->start if !$self->is_running; + } + + unless( $self->can_event( 'on_expire' ) ) { + croak 'Expected either a on_expire callback or an ->on_expire method'; + } + + $self->SUPER::configure( %params ); +} + +sub _make_cb +{ + my $self = shift; + + return $self->_capture_weakself( sub { + my $self = shift or return; + + undef $self->{id}; + + $self->invoke_event( "on_expire" ); + } ); +} + +sub _make_enqueueargs +{ + my $self = shift; + + return at => $self->{time}; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Timer/Countdown.pm b/lib/IO/Async/Timer/Countdown.pm new file mode 100644 index 0000000..201ba42 --- /dev/null +++ b/lib/IO/Async/Timer/Countdown.pm @@ -0,0 +1,274 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2009-2012 -- leonerd@leonerd.org.uk + +package IO::Async::Timer::Countdown; + +use strict; +use warnings; +use base qw( IO::Async::Timer ); + +our $VERSION = '0.67'; + +use Carp; + +=head1 NAME + +C<IO::Async::Timer::Countdown> - event callback after a fixed delay + +=head1 SYNOPSIS + + use IO::Async::Timer::Countdown; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my $timer = IO::Async::Timer::Countdown->new( + delay => 10, + + on_expire => sub { + print "Sorry, your time's up\n"; + $loop->stop; + }, + ); + + $timer->start; + + $loop->add( $timer ); + + $loop->run; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Timer> implements one-shot fixed delays. +The object implements a countdown timer, which invokes its callback after the +given period from when it was started. After it has expired the Timer may be +started again, when it will wait the same period then invoke the callback +again. A timer that is currently running may be stopped or reset. + +For a C<Timer> object that repeatedly runs a callback at regular intervals, +see instead L<IO::Async::Timer::Periodic>. For a C<Timer> that invokes its +callback at a fixed time in the future, see L<IO::Async::Timer::Absolute>. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters: + +=head2 on_expire + +Invoked when the timer expires. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 on_expire => CODE + +CODE reference for the C<on_expire> event. + +=head2 delay => NUM + +The delay in seconds after starting the timer until it expires. Cannot be +changed if the timer is running. A timer with a zero delay expires +"immediately". + +=head2 remove_on_expire => BOOL + +Optional. If true, remove this timer object from its parent notifier or +containing loop when it expires. Defaults to false. + +Once constructed, the timer object will need to be added to the C<Loop> before +it will work. It will also need to be started by the C<start> method. + +=cut + +sub configure +{ + my $self = shift; + my %params = @_; + + foreach (qw( remove_on_expire )) { + $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + if( exists $params{on_expire} ) { + my $on_expire = delete $params{on_expire}; + ref $on_expire or croak "Expected 'on_expire' as a reference"; + + $self->{on_expire} = $on_expire; + undef $self->{cb}; # Will be lazily constructed when needed + } + + if( exists $params{delay} ) { + $self->is_running and croak "Cannot configure 'delay' of a running timer\n"; + + my $delay = delete $params{delay}; + $delay >= 0 or croak "Expected a 'delay' as a non-negative number"; + + $self->{delay} = $delay; + } + + unless( $self->can_event( 'on_expire' ) ) { + croak 'Expected either a on_expire callback or an ->on_expire method'; + } + + $self->SUPER::configure( %params ); +} + +=head1 METHODS + +=cut + +=head2 $expired = $timer->is_expired + +Returns true if the Timer has already expired. + +=cut + +sub is_expired +{ + my $self = shift; + return $self->{expired}; +} + +sub _make_cb +{ + my $self = shift; + + return $self->_capture_weakself( sub { + my $self = shift or return; + + undef $self->{id}; + $self->{expired} = 1; + + $self->remove_from_parent if $self->{remove_on_expire}; + + $self->invoke_event( "on_expire" ); + } ); +} + +sub _make_enqueueargs +{ + my $self = shift; + + undef $self->{expired}; + return after => $self->{delay}; +} + +=head2 $timer->reset + +If the timer is running, restart the countdown period from now. If the timer +is not running, this method has no effect. + +=cut + +sub reset +{ + my $self = shift; + + my $loop = $self->loop or croak "Cannot reset a Timer that is not in a Loop"; + + return if !$self->is_running; + + $self->stop; + $self->start; +} + +=head1 EXAMPLES + +=head2 Watchdog Timer + +Because the C<reset> method restarts a running countdown timer back to its +full period, it can be used to implement a watchdog timer. This is a timer +which will not expire provided the method is called at least as often as it +is configured. If the method fails to be called, the timer will eventually +expire and run its callback. + +For example, to expire an accepted connection after 30 seconds of inactivity: + + ... + + on_accept => sub { + my ( $newclient ) = @_; + + my $watchdog = IO::Async::Timer::Countdown->new( + delay => 30, + + on_expire => sub { + my $self = shift; + + my $stream = $self->parent; + $stream->close; + }, + ); + + my $stream = IO::Async::Stream->new( + handle => $newclient, + + on_read => sub { + my ( $self, $buffref, $eof ) = @_; + $watchdog->reset; + + ... + }, + + on_closed => sub { + $watchdog->stop; + }, + ) ); + + $stream->add_child( $watchdog ); + $watchdog->start; + + $loop->add( $watchdog ); + } + +Rather than setting up a lexical variable to store the Stream so that the +Timer's C<on_expire> closure can call C<close> on it, the parent/child +relationship between the two Notifier objects is used. At the time the Timer +C<on_expire> closure is invoked, it will have been added as a child notifier +of the Stream; this means the Timer's C<parent> method will return the Stream +Notifier. This enables it to call C<close> without needing to capture a +lexical variable, which would create a cyclic reference. + +=head2 Fixed-Delay Repeating Timer + +The C<on_expire> event fires a fixed delay after the C<start> method has begun +the countdown. The C<start> method can be invoked again at some point during +the C<on_expire> handling code, to create a timer that invokes its code +regularly a fixed delay after the previous invocation has finished. This +creates an arrangement similar to an L<IO::Async::Timer::Periodic>, except +that it will wait until the previous invocation has indicated it is finished, +before starting the countdown for the next call. + + my $timer = IO::Async::Timer::Countdown->new( + delay => 60, + + on_expire => sub { + my $self = shift; + + start_some_operation( + on_complete => sub { $self->start }, + ); + }, + ); + + $timer->start; + $loop->add( $timer ); + +This example invokes the C<start_some_operation> function 60 seconds after the +previous iteration has indicated it has finished. + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/IO/Async/Timer/Periodic.pm b/lib/IO/Async/Timer/Periodic.pm new file mode 100644 index 0000000..f99a43c --- /dev/null +++ b/lib/IO/Async/Timer/Periodic.pm @@ -0,0 +1,249 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2009-2015 -- leonerd@leonerd.org.uk + +package IO::Async::Timer::Periodic; + +use strict; +use warnings; +use base qw( IO::Async::Timer ); + +our $VERSION = '0.67'; + +use Carp; + +=head1 NAME + +C<IO::Async::Timer::Periodic> - event callback at regular intervals + +=head1 SYNOPSIS + + use IO::Async::Timer::Periodic; + + use IO::Async::Loop; + my $loop = IO::Async::Loop->new; + + my $timer = IO::Async::Timer::Periodic->new( + interval => 60, + + on_tick => sub { + print "You've had a minute\n"; + }, + ); + + $timer->start; + + $loop->add( $timer ); + + $loop->run; + +=head1 DESCRIPTION + +This subclass of L<IO::Async::Timer> implements repeating events at regular +clock intervals. The timing may or may not be subject to how long it takes the +callback to execute. Iterations may be rescheduled runs at fixed regular +intervals beginning at the time the timer was started, or by a fixed delay +after the previous code has finished executing. + +For a C<Timer> object that only runs a callback once, after a given delay, see +instead L<IO::Async::Timer::Countdown>. A Countdown timer can also be used to +create repeating events that fire at a fixed delay after the previous event +has finished processing. See als the examples in +C<IO::Async::Timer::Countdown>. + +=cut + +=head1 EVENTS + +The following events are invoked, either using subclass methods or CODE +references in parameters: + +=head2 on_tick + +Invoked on each interval of the timer. + +=cut + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 on_tick => CODE + +CODE reference for the C<on_tick> event. + +=head2 interval => NUM + +The interval in seconds between invocations of the callback or method. Cannot +be changed if the timer is running. + +=head2 first_interval => NUM + +Optional. If defined, the interval in seconds after calling the C<start> +method before the first invocation of the callback or method. Thereafter, the +regular C<interval> will be used. If not supplied, the first interval will be +the same as the others. + +Even if this value is zero, the first invocation will be made asynchronously, +by the containing C<Loop> object, and not synchronously by the C<start> method +itself. + +=head2 reschedule => STRING + +Optional. Must be one of C<hard>, C<skip> or C<drift>. Defines the algorithm +used to reschedule the next invocation. + +C<hard> schedules each iteration at the fixed interval from the previous +iteration's schedule time, ensuring a regular repeating event. + +C<skip> schedules similarly to C<hard>, but skips over times that have already +passed. This matters if the duration is particularly short and there's a +possibility that times may be missed, or if the entire process is stopped and +resumed by C<SIGSTOP> or similar. + +C<drift> schedules each iteration at the fixed interval from the time that the +previous iteration's event handler returns. This allows it to slowly drift over +time and become desynchronised with other events of the same interval or +multiples/fractions of it. + +Once constructed, the timer object will need to be added to the C<Loop> before +it will work. It will also need to be started by the C<start> method. + +=cut + +sub _init +{ + my $self = shift; + $self->SUPER::_init( @_ ); + + $self->{reschedule} = "hard"; +} + +sub configure +{ + my $self = shift; + my %params = @_; + + if( exists $params{on_tick} ) { + my $on_tick = delete $params{on_tick}; + ref $on_tick or croak "Expected 'on_tick' as a reference"; + + $self->{on_tick} = $on_tick; + undef $self->{cb}; # Will be lazily constructed when needed + } + + if( exists $params{interval} ) { + $self->is_running and croak "Cannot configure 'interval' of a running timer\n"; + + my $interval = delete $params{interval}; + $interval > 0 or croak "Expected a 'interval' as a positive number"; + + $self->{interval} = $interval; + } + + if( exists $params{first_interval} ) { + $self->is_running and croak "Cannot configure 'first_interval' of a running timer\n"; + + my $first_interval = delete $params{first_interval}; + $first_interval >= 0 or croak "Expected a 'first_interval' as a non-negative number"; + + $self->{first_interval} = $first_interval; + } + + if( exists $params{reschedule} ) { + my $resched = delete $params{reschedule} || "hard"; + grep { $_ eq $resched } qw( hard skip drift ) or + croak "Expected 'reschedule' to be one of hard, skip, drift"; + + $self->{reschedule} = $resched; + } + + unless( $self->can_event( 'on_tick' ) ) { + croak 'Expected either a on_tick callback or an ->on_tick method'; + } + + $self->SUPER::configure( %params ); +} + +sub _next_interval +{ + my $self = shift; + return $self->{first_interval} if defined $self->{first_interval}; + return $self->{interval}; +} + +sub start +{ + my $self = shift; + + # Only actually define a time if we've got a loop; otherwise it'll just + # become start-pending. We'll calculate it properly when it gets added to + # the Loop + if( my $loop = $self->loop ) { + my $now = $loop->time; + my $resched = $self->{reschedule}; + + if( !defined $self->{next_time} ) { + $self->{next_time} = $now + $self->_next_interval; + } + elsif( $resched eq "hard" ) { + $self->{next_time} += $self->_next_interval; + } + elsif( $resched eq "skip" ) { + # How many ticks are needed? + my $ticks = POSIX::ceil( $now - $self->{next_time} ); + # $self->{last_ticks} = $ticks; + $self->{next_time} += $self->_next_interval * $ticks; + } + elsif( $resched eq "drift" ) { + $self->{next_time} = $now + $self->_next_interval; + } + } + + $self->SUPER::start; +} + +sub stop +{ + my $self = shift; + $self->SUPER::stop; + + undef $self->{next_time}; +} + +sub _make_cb +{ + my $self = shift; + + return $self->_capture_weakself( sub { + my $self = shift or return; + + undef $self->{first_interval}; + + undef $self->{id}; + + my $ok = eval { $self->invoke_event( on_tick => ); 1 } or + my $e = $@; + + # detect ->stop + $self->start if defined $self->{next_time}; + + die $e if !$ok; + } ); +} + +sub _make_enqueueargs +{ + my $self = shift; + + return at => $self->{next_time}; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; |