Acme-Sort-Sleep
view release on metacpan or search on metacpan
local/lib/perl5/Future.pm view on Meta::CPAN
my $GLOBAL_END;
END { $GLOBAL_END = 1; }
sub DESTROY_debug {
my $self = shift;
return if $GLOBAL_END;
return if $self->{ready} and ( $self->{reported} or !$self->{failure} );
my $lost_at = join " line ", (caller)[1,2];
# We can't actually know the real line where the last reference was lost;
# a variable set to 'undef' or close of scope, because caller can't see it;
# the current op has already been updated. The best we can do is indicate
# 'near'.
if( $self->{ready} and $self->{failure} ) {
warn "${\$self->__selfstr} was $self->{constructed_at} and was lost near $lost_at with an unreported failure of: " .
$self->{failure}[0] . "\n";
}
elsif( !$self->{ready} ) {
warn "${\$self->__selfstr} was $self->{constructed_at} and was lost near $lost_at before it was ready.\n";
}
local/lib/perl5/Future.pm view on Meta::CPAN
next if $cancelled and not( $flags & CB_CANCEL );
$self->{reported} = 1 if $fail;
if( $is_future ) {
$done ? $code->done( @result ) :
$fail ? $code->fail( @result ) :
$code->cancel;
}
elsif( $flags & (CB_SEQ_ONDONE|CB_SEQ_ONFAIL) ) {
my ( undef, undef, $fseq ) = @$cb;
if( !$fseq ) { # weaken()ed; it might be gone now
# This warning should always be printed, even not in DEBUG mode.
# It's always an indication of a bug
Carp::carp +(DEBUG ? "${\$self->__selfstr} ($self->{constructed_at})"
: "${\$self->__selfstr} $self" ) .
" lost a sequence Future";
next;
}
my $f2;
local/lib/perl5/Future.pm view on Meta::CPAN
my $self = shift;
return $self->{ready} && !!$self->{failure}; # boolify
}
=head2 failure
$exception = $future->failure
$exception, @details = $future->failure
Returns the exception passed to the C<fail> method, C<undef> if the future
completed successfully via the C<done> method, or raises an exception if
called on a future that is not yet ready.
If called in list context, will additionally yield a list of the details
provided to the C<fail> method.
Because the exception value must be true, this can be used in a simple C<if>
statement:
if( my $exception = $future->failure ) {
local/lib/perl5/Future.pm view on Meta::CPAN
return $self unless $fail_code;
return $fail_code->( @maybe_self, $self->failure );
}
};
};
sub then
{
my $self = shift;
my $done_code = shift;
my $fail_code = ( @_ % 2 ) ? pop : undef;
my @catch_list = @_;
if( $done_code and !@catch_list and !$fail_code ) {
return $self->_sequence( $done_code, CB_SEQ_ONDONE|CB_RESULT );
}
# Complex
return $self->_sequence( $make_donecatchfail_sub->(
0, $done_code, $fail_code, @catch_list,
), CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF );
local/lib/perl5/Future.pm view on Meta::CPAN
The C<then> method can be passed an even-sized list inbetween the
C<$done_code> and the C<$fail_code>, with the same meaning as the C<catch>
method.
=cut
sub catch
{
my $self = shift;
my $fail_code = ( @_ % 2 ) ? pop : undef;
my @catch_list = @_;
return $self->_sequence( $make_donecatchfail_sub->(
0, undef, $fail_code, @catch_list,
), CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF );
}
=head2 transform
$future = $f1->transform( %args )
Returns a new sequencing C<Future> that wraps the one given as C<$f1>. With no
arguments this will be a trivial wrapper; C<$future> will complete or fail
when C<$f1> does, and C<$f1> will be cancelled when C<$future> is.
local/lib/perl5/Future.pm view on Meta::CPAN
This is useful for conditional execution cases where the code block may just
return the same result of the original future. In this case it is more
efficient to return the original future itself.
=cut
sub then_with_f
{
my $self = shift;
my $done_code = shift;
my $fail_code = ( @_ % 2 ) ? pop : undef;
my @catch_list = @_;
if( $done_code and !@catch_list and !$fail_code ) {
return $self->_sequence( $done_code, CB_SEQ_ONDONE|CB_SELF|CB_RESULT );
}
return $self->_sequence( $make_donecatchfail_sub->(
1, $done_code, $fail_code, @catch_list,
), CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF );
}
local/lib/perl5/Future.pm view on Meta::CPAN
I<Since version 0.33.>
Returns a new sequencing C<Future> that behaves like C<catch>, but also passes
the original future, C<$f1>, to any functions it invokes.
=cut
sub catch_with_f
{
my $self = shift;
my $fail_code = ( @_ % 2 ) ? pop : undef;
my @catch_list = @_;
return $self->_sequence( $make_donecatchfail_sub->(
1, undef, $fail_code, @catch_list,
), CB_SEQ_ONDONE|CB_SEQ_ONFAIL|CB_SELF );
}
=head2 followed_by
$future = $f1->followed_by( \&code )
Returns a new sequencing C<Future> that runs the code regardless of success or
failure. Once C<$f1> is ready the code reference will be invoked and is passed
one argument, C<$f1>. It should return a future, C<$f2>. Once C<$f2> completes
local/lib/perl5/Future.pm view on Meta::CPAN
}
=head2 elapsed
$sec = $future->elapsed
I<Since version 0.28.>
If both tracing timestamps are defined, returns the number of seconds of
elapsed time between them as a floating-point number. If not, returns
C<undef>.
=cut
sub elapsed
{
my $self = shift;
return undef unless defined $self->{btime} and defined $self->{rtime};
return $self->{elapsed} ||= tv_interval( $self->{btime}, $self->{rtime} );
}
=head2 wrap_cb
$cb = $future->wrap_cb( $operation_name, $cb )
I<Since version 0.31.>
I<Note: This method is experimental and may be changed or removed in a later
local/lib/perl5/Future/Phrasebook.pod view on Meta::CPAN
C<then>, but is only invoked if the initial C<Future> fails; not if it
succeeds.
my $f = F_FIRST()
->else( sub { F_ERROR( @_ ); } );
Alternatively, the second argument to the C<then> method can be applied, which
is invoked only on case of failure.
my $f = F_FIRST()
->then( undef, sub { F_ERROR( @_ ); } );
Often it may be the case that the failure-handling code is in fact immediate,
and doesn't return a C<Future>. In that case, the C<else> code block can
return an immediate C<Future> instance.
my $f = F_FIRST()
->else( sub {
ERROR( @_ );
return Future->done;
});
local/lib/perl5/Future/Utils.pm view on Meta::CPAN
=head2 repeat+foreach
$future = repeat { CODE } foreach => ARRAY, otherwise => CODE
I<Since version 0.13.>
Calls the C<CODE> block once for each value obtained from the array, passing
in the value as the first argument (before the previous trial future). When
there are no more items left in the array, the C<otherwise> code is invoked
once and passed the last trial future, if there was one, or C<undef> if the
list was originally empty. The result of the eventual future will be the
result of the future returned from C<otherwise>.
The referenced array may be modified by this operation.
$trial_f = $code->( $item, $previous_trial_f )
$final_f = $otherwise->( $last_trial_f )
The C<otherwise> code is optional; if not supplied then the result of the
eventual future will simply be that of the last trial. If there was no trial,
local/lib/perl5/Future/Utils.pm view on Meta::CPAN
=head2 repeat+generate
$future = repeat { CODE } generate => CODE, otherwise => CODE
I<Since version 0.13.>
Calls the C<CODE> block once for each value obtained from the generator code,
passing in the value as the first argument (before the previous trial future).
When the generator returns an empty list, the C<otherwise> code is invoked and
passed the last trial future, if there was one, otherwise C<undef> if the
generator never returned a value. The result of the eventual future will be
the result of the future returned from C<otherwise>.
$trial_f = $code->( $item, $previous_trial_f )
$final_f = $otherwise->( $last_trial_f )
( $item ) = $generate->()
The generator is called in list context but should return only one item per
call. Subsequent values will be ignored. When it has no more items to return
local/lib/perl5/Future/Utils.pm view on Meta::CPAN
$trial->on_done( $return );
$trial->on_fail( $return );
return $return;
}
if( !$is_try and $trial->failure ) {
carp "Using Future::Utils::repeat to retry a failure is deprecated; use try_repeat instead";
}
# redo
undef $$trialp;
}
}
sub repeat(&@)
{
my $code = shift;
my %args = @_;
# This makes it easier to account for other conditions
defined($args{while}) + defined($args{until}) == 1
local/lib/perl5/Future/Utils.pm view on Meta::CPAN
aliased as C<$_>.
=cut
# This function is invoked in two circumstances:
# a) to create an item Future in a slot,
# b) once a non-immediate item Future is complete, to check its results
# It can tell which circumstance by whether the slot itself is defined or not
sub _fmap_slot
{
my ( $slots, undef, $code, $generator, $collect, $results, $return ) = @_;
SLOT: while(1) {
# Capture args each call because we mutate them
my ( undef, $idx ) = my @args = @_;
unless( $slots->[$idx] ) {
# No item Future yet (case a), so create one
my $item;
unless( ( $item ) = $generator->() ) {
# All out of items, so now just wait for the slots to be finished
undef $slots->[$idx];
defined and return $return for @$slots;
# All the slots are done
$return ||= Future->new;
$return->done( @$results );
return $return;
}
my $f = $slots->[$idx] = Future->call( $code, local $_ = $item );
if( $collect eq "array" ) {
push @$results, my $r = [];
$f->on_done( sub { @$r = @_ });
}
elsif( $collect eq "scalar" ) {
push @$results, undef;
my $r = \$results->[-1];
$f->on_done( sub { $$r = $_[0] });
}
}
my $f = $slots->[$idx];
# Slot is non-immediate; arrange for us to be invoked again later when it's ready
if( !$f->is_ready ) {
$args[-1] = ( $return ||= $f->new );
local/lib/perl5/Future/Utils.pm view on Meta::CPAN
}
# Either we've been invoked again (case b), or the immediate Future was
# already ready.
if( $f->failure ) {
$return ||= $f->new;
$return->fail( $f->failure );
return $return;
}
undef $slots->[$idx];
# next
}
}
sub _fmap
{
my $code = shift;
my %args = @_;
my $concurrent = $args{concurrent} || 1;
local/lib/perl5/Future/Utils.pm view on Meta::CPAN
=head2 fmap_scalar
$future = fmap_scalar { CODE } ...
I<Since version 0.14.>
This version of C<fmap> acts more like the C<map> functions found in Scheme or
Haskell; it expects that each item future returns only one value, and the
overall result will be a list containing these, in order of the original input
items. If an item future returns more than one value the others will be
discarded. If it returns no value, then C<undef> will be substituted in its
place so that the result list remains in correspondence with the input list.
This function is also available under the shorter name of C<fmap1>.
=cut
sub fmap_scalar(&@)
{
my $code = shift;
my %args = @_;
local/lib/perl5/IO/Async/Channel.pm view on Meta::CPAN
sub _make_codec_Sereal
{
require Sereal::Encoder;
require Sereal::Decoder;
my $encoder;
my $decoder;
# "thread safety" to Sereal::{Encoder,Decoder} means that the variables get
# reset to undef in new threads. We should defend against that.
return
sub { ( $encoder ||= Sereal::Encoder->new )->encode( $_[0] ) },
sub { ( $decoder ||= Sereal::Decoder->new )->decode( $_[0] ) };
}
=head2 send
$channel->send( $data )
local/lib/perl5/IO/Async/Channel.pm view on Meta::CPAN
=cut
*send_frozen = \&send_encoded;
=head2 recv
$data = $channel->recv
When called on a synchronous mode Channel this method will block until a Perl
reference value is available from the other end and then return it. If the
Channel is closed this method will return C<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.
$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.
local/lib/perl5/IO/Async/Channel.pm view on Meta::CPAN
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 close
$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";
local/lib/perl5/IO/Async/Channel.pm view on Meta::CPAN
$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 );
}
local/lib/perl5/IO/Async/Channel.pm view on Meta::CPAN
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 => );
local/lib/perl5/IO/Async/Channel.pm view on Meta::CPAN
$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>
local/lib/perl5/IO/Async/ChildManager.pm view on Meta::CPAN
# 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.
local/lib/perl5/IO/Async/ChildManager.pm view on Meta::CPAN
# 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 ) = @_;
local/lib/perl5/IO/Async/ChildManager.pm view on Meta::CPAN
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
local/lib/perl5/IO/Async/ChildManager.pm view on Meta::CPAN
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;
local/lib/perl5/IO/Async/Debug.pm view on Meta::CPAN
=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
local/lib/perl5/IO/Async/FileStream.pm view on Meta::CPAN
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
local/lib/perl5/IO/Async/FileStream.pm view on Meta::CPAN
$self->{last_size} = 0;
if( $self->{last_pos} ) {
$self->maybe_invoke_event( on_truncated => );
$self->{last_pos} = 0;
$self->loop->later( sub { $self->read_more } );
}
$self->configure( read_handle => $self->{file}->handle );
undef $self->{renamed};
}
}
sub write
{
carp "Cannot ->write from a ".ref($_[0]);
}
=head2 seek
local/lib/perl5/IO/Async/Function.pm view on Meta::CPAN
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 ) {
local/lib/perl5/IO/Async/Handle.pm view on Meta::CPAN
=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} ) {
local/lib/perl5/IO/Async/Handle.pm view on Meta::CPAN
carp "Constructing a ".ref($self)." with an encoding-enabled handle may not read correctly";
}
$self->{read_handle} = $read_handle;
$self->want_readready( defined $read_handle );
}
else {
$self->want_readready( 0 );
undef $self->{read_handle};
}
# In case someone has reopened the filehandles during an on_closed handler
undef $self->{handle_closing};
}
if( exists $params{write_handle} ) {
my $write_handle = delete $params{write_handle};
if( defined $write_handle ) {
if( !defined eval { $write_handle->fileno } ) {
croak 'Expected that write_handle can ->fileno';
}
unless( $self->can_event( 'on_write_ready' ) ) {
# This used not to be fatal. Make it just a warning for now.
carp 'A write handle was provided but neither a on_write_ready callback nor an ->on_write_ready method were. Perhaps you mean \'read_handle\' instead?';
}
$self->{write_handle} = $write_handle;
}
else {
$self->want_writeready( 0 );
undef $self->{write_handle};
}
# In case someone has reopened the filehandles during an on_closed handler
undef $self->{handle_closing};
}
if( exists $params{want_readready} ) {
$self->want_readready( delete $params{want_readready} );
}
if( exists $params{want_writeready} ) {
$self->want_writeready( delete $params{want_writeready} );
}
local/lib/perl5/IO/Async/Handle.pm view on Meta::CPAN
$fileno = $handle->write_fileno
These accessors return the file descriptor numbers of the underlying IO
handles.
=cut
sub read_fileno
{
my $self = shift;
my $handle = $self->read_handle or return undef;
return $handle->fileno;
}
sub write_fileno
{
my $self = shift;
my $handle = $self->write_handle or return undef;
return $handle->fileno;
}
=head2 want_readready
=head2 want_writeready
$value = $handle->want_readready
$oldvalue = $handle->want_readready( $newvalue )
local/lib/perl5/IO/Async/Internals/Connector.pm view on Meta::CPAN
## 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";
local/lib/perl5/IO/Async/Internals/TimeQueue.pm view on Meta::CPAN
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;
local/lib/perl5/IO/Async/Internals/TimeQueue.pm view on Meta::CPAN
}
# 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 );
local/lib/perl5/IO/Async/Listener.pm view on Meta::CPAN
=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;
},
);
local/lib/perl5/IO/Async/Listener.pm view on Meta::CPAN
!defined $acceptconn or unpack( "I", $acceptconn ) or croak "Socket is not accepting connections";
# This is a bit naughty but hopefully nobody will mind...
bless $handle, "IO::Socket" if ref( $handle ) eq "GLOB";
$self->SUPER::configure( read_handle => $handle );
}
elsif( exists $params{handle} ) {
delete $params{handle};
$self->SUPER::configure( read_handle => undef );
}
unless( grep $self->can_event( $_ ), @acceptor_events ) {
croak "Expected to be able to 'on_accept', 'on_stream' or 'on_socket'";
}
foreach (qw( acceptor handle_constructor handle_class )) {
$self->{$_} = delete $params{$_} if exists $params{$_};
}
local/lib/perl5/IO/Async/Listener.pm view on Meta::CPAN
$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
$family = $listener->family
Returns the socket address family of the underlying listening socket
=cut
sub family
{
my $self = shift;
my $sockname = $self->sockname or return undef;
return sockaddr_family( $sockname );
}
=head2 socktype
$socktype = $listener->socktype
Returns the socket type of the underlying listening socket
=cut
sub socktype
{
my $self = shift;
my $handle = $self->read_handle or return undef;
return $handle->sockopt(SO_TYPE);
}
=head2 listen
$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.
local/lib/perl5/IO/Async/Listener.pm view on Meta::CPAN
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;
},
);
local/lib/perl5/IO/Async/Loop.pm view on Meta::CPAN
$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
local/lib/perl5/IO/Async/Loop.pm view on Meta::CPAN
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};
local/lib/perl5/IO/Async/Loop.pm view on Meta::CPAN
{
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
@notifiers = $loop->notifiers
local/lib/perl5/IO/Async/Loop.pm view on Meta::CPAN
The following methods control the actual run cycle of the loop, and hence the
program.
=cut
=head2 loop_once
$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;
local/lib/perl5/IO/Async/Loop.pm view on Meta::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 stop
$loop->stop( @result )
Stops the inner-most C<run> method currently in progress, causing it to return
local/lib/perl5/IO/Async/Loop.pm view on Meta::CPAN
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_forever
$loop->loop_forever
A synonym for C<run>, though this method does not return a result.
=cut
local/lib/perl5/IO/Async/Loop.pm view on Meta::CPAN
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 = @_;
local/lib/perl5/IO/Async/Loop.pm view on Meta::CPAN
$future->on_done( $on_done ) if $on_done;
$future->on_fail( sub {
$on_connect_error->( @_[2,3] ) if $on_connect_error and $_[1] eq "connect";
$on_resolve_error->( $_[2] ) if $on_resolve_error and $_[1] eq "resolve";
} );
return $future if defined wantarray;
# Caller is not going to keep hold of the Future, so we have to ensure it
# stays alive somehow
$future->on_ready( sub { undef $future } ); # intentional cycle
}
=head2 listen
$listener = $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.
local/lib/perl5/IO/Async/Loop.pm view on Meta::CPAN
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 );
}
local/lib/perl5/IO/Async/Loop.pm view on Meta::CPAN
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.
local/lib/perl5/IO/Async/Loop.pm view on Meta::CPAN
sub __unwatch_io
{
my $self = shift;
my %params = @_;
my $handle = delete $params{handle} or croak "Expected 'handle'";
my $watch = $self->{iowatches}->{$handle->fileno} or return;
if( delete $params{on_read_ready} ) {
undef $watch->[1];
}
if( delete $params{on_write_ready} ) {
undef $watch->[2];
}
if( delete $params{on_hangup} ) {
$self->_CAN_ON_HANGUP or croak "Cannot watch_io for 'on_hangup' in ".ref($self);
undef $watch->[3];
}
if( not $watch->[1] and not $watch->[2] and not $watch->[3] ) {
delete $self->{iowatches}->{$handle->fileno};
}
keys %params and croak "Unrecognised keys for ->unwatch_io - " . join( ", ", keys %params );
}
=head2 watch_signal
local/lib/perl5/IO/Async/Loop/Poll.pm view on Meta::CPAN
return $count;
}
=head2 loop_once
$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 );
local/lib/perl5/IO/Async/Loop/Poll.pm view on Meta::CPAN
# 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 @pollmasks = %{ $self->{pollmask} };
# Perl 5.8.x's IO::Poll::_poll gets confused with no masks
my $pollret;
if( @pollmasks ) {
my $msec = defined $timeout ? $timeout * 1000 : -1;
$pollret = IO::Poll::_poll( $msec, @pollmasks );
local/lib/perl5/IO/Async/Loop/Poll.pm view on Meta::CPAN
local $!;
@pollmasks = %{ $self->{pollmask} };
my $secondattempt = IO::Poll::_poll( $msec, @pollmasks );
$pollret = $secondattempt if $secondattempt > 0;
}
}
else {
# Workaround - we'll use select to fake a millisecond-accurate sleep
$pollret = select( undef, undef, undef, $timeout );
}
return undef unless defined $pollret;
$self->{pollevents} = { @pollmasks };
return $self->post_poll;
}
}
sub watch_io
{
my $self = shift;
my %params = @_;
local/lib/perl5/IO/Async/Loop/Select.pm view on Meta::CPAN
alarm( 0 ) if WATCHDOG_ENABLE;
}
=head2 loop_once
$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;
local/lib/perl5/IO/Async/LoopTests.pm view on Meta::CPAN
use Time::HiRes qw( time );
our $VERSION = '0.70';
# 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 L<IO::Async::Loop> subclasses
=head1 SYNOPSIS
use IO::Async::LoopTests;
run_tests( 'IO::Async::Loop::Shiney', 'io' );
local/lib/perl5/IO/Async/LoopTests.pm view on Meta::CPAN
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;
local/lib/perl5/IO/Async/LoopTests.pm view on Meta::CPAN
# 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' );
}
local/lib/perl5/IO/Async/LoopTests.pm view on Meta::CPAN
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;
local/lib/perl5/IO/Async/LoopTests.pm view on Meta::CPAN
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
local/lib/perl5/IO/Async/LoopTests.pm view on Meta::CPAN
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' );
local/lib/perl5/IO/Async/LoopTests.pm view on Meta::CPAN
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;
local/lib/perl5/IO/Async/Notifier.pm view on Meta::CPAN
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 L<IO::Async::Loop> that manages their parent.
=cut
=head2 parent
$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
local/lib/perl5/IO/Async/Notifier.pm view on Meta::CPAN
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 remove_from_parent
$notifier->remove_from_parent
local/lib/perl5/IO/Async/Notifier.pm view on Meta::CPAN
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>.
local/lib/perl5/IO/Async/Notifier.pm view on Meta::CPAN
}
};
}
=head2 can_event
$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 );
}
local/lib/perl5/IO/Async/Notifier.pm view on Meta::CPAN
$self->_debug_printf_event( $caller, $event_name );
goto &$code;
}
);
}
=head2 maybe_make_event_cb
$callback = $notifier->maybe_make_event_cb( $event_name )
Similar to C<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;
}
);
local/lib/perl5/IO/Async/Notifier.pm view on Meta::CPAN
or croak "$self cannot handle $event_name event";
$self->_debug_printf_event( scalar caller, $event_name ) if $IO::Async::Debug::DEBUG;
return $code->( $self, @args );
}
=head2 maybe_invoke_event
$retref = $notifier->maybe_invoke_event( $event_name, @args )
Similar to C<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 debug_printf
local/lib/perl5/IO/Async/OS.pm view on Meta::CPAN
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 socket family name '$name'";
}
local/lib/perl5/IO/Async/OS.pm view on Meta::CPAN
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 );
}
local/lib/perl5/IO/Async/OS.pm view on Meta::CPAN
# It won't be in the specific subclass but that's the best we can do. And
# it will still work as a generic socket.
return IO::Socket->new->socket( $family, $socktype, $proto );
}
=head2 socketpair
( $S1, $S2 ) = IO::Async::OS->socketpair( $family, $socktype, $proto )
An abstraction of the C<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;
local/lib/perl5/IO/Async/OS.pm view on Meta::CPAN
sub loop_unwatch_signal
{
my $self = shift;
my ( $loop, $signal ) = @_;
my $signum = $self->signame2num( $signal );
my $sigwatch = $loop->{os}{sigwatch} or return;
delete $sigwatch->{$signum};
undef $SIG{$signal};
}
=head2 potentially_open_fds
@fds = IO::Async::OS->potentially_open_fds
Returns a list of filedescriptors which might need closing. By default this
will return C<0 .. _SC_OPEN_MAX>. OS-specific subclasses may have a better
guess.
local/lib/perl5/IO/Async/PID.pm view on Meta::CPAN
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 );
}
local/lib/perl5/IO/Async/Process.pm view on Meta::CPAN
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;
local/lib/perl5/IO/Async/Process.pm view on Meta::CPAN
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} };
local/lib/perl5/IO/Async/Process.pm view on Meta::CPAN
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 );
}
local/lib/perl5/IO/Async/Process.pm view on Meta::CPAN
}
=head1 METHODS
=cut
=head2 pid
$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};
}
local/lib/perl5/IO/Async/Process.pm view on Meta::CPAN
$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 exitstatus
$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
$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
$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
$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 fd
local/lib/perl5/IO/Async/Protocol.pm view on Meta::CPAN
my $self = shift;
my ( $transport ) = @_;
$transport->configure(
on_closed => $self->_capture_weakself( sub {
my $self = shift or return;
my ( $transport ) = @_;
$self->maybe_invoke_event( on_closed => );
$self->configure( transport => undef );
} ),
);
}
=head2 teardown_transport
$protocol->teardown_transport( $transport )
The reverse of C<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;
local/lib/perl5/IO/Async/Protocol/Stream.pm view on Meta::CPAN
} ),
);
}
sub teardown_transport
{
my $self = shift;
my ( $transport ) = @_;
$transport->configure(
on_read => undef,
);
$self->SUPER::teardown_transport( $transport );
}
=head1 METHODS
=cut
=head2 write
local/lib/perl5/IO/Async/Resolver.pm view on Meta::CPAN
my $host = $args{host} || "";
my $service = $args{service}; defined $service or $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
local/lib/perl5/IO/Async/Resolver.pm view on Meta::CPAN
register_resolver getaddrinfo => sub {
my %args = @_;
my $host = delete $args{host};
my $service = delete $args{service};
$args{family} = IO::Async::OS->getfamilybyname( $args{family} ) if defined $args{family};
$args{socktype} = IO::Async::OS->getsocktypebyname( $args{socktype} ) if defined $args{socktype};
# Clear any other existing but undefined hints
defined $args{$_} or delete $args{$_} for keys %args;
my ( $err, @addrs ) = Socket::getaddrinfo( $host, $service, \%args );
die [ "$err", $err+0 ] if $err;
return @addrs;
};
register_resolver getaddrinfo_array => sub {
local/lib/perl5/IO/Async/Routine.pm view on Meta::CPAN
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;
}
local/lib/perl5/IO/Async/Routine.pm view on Meta::CPAN
$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;
local/lib/perl5/IO/Async/Signal.pm view on Meta::CPAN
}
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';
}
local/lib/perl5/IO/Async/Signal.pm view on Meta::CPAN
$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};
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
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)
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
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.
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
=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 is_read_eof
=head2 is_write_eof
$eof = $stream->is_read_eof
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
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 ) = @_;
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
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};
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
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;
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
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;
}
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
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 );
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
}
$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} );
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
$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
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
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.
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
=cut
sub read_atmost
{
my $self = shift;
my ( $len ) = @_;
my $f = $self->_read_future;
$self->push_on_read( sub {
my ( undef, $buffref, $eof ) = @_;
return undef if $f->is_cancelled;
$f->done( substr( $$buffref, 0, $len, "" ), $eof );
return undef;
}, future => $f );
return $f;
}
sub read_exactly
{
my $self = shift;
my ( $len ) = @_;
my $f = $self->_read_future;
$self->push_on_read( sub {
my ( undef, $buffref, $eof ) = @_;
return undef if $f->is_cancelled;
return 0 unless $eof or length $$buffref >= $len;
$f->done( substr( $$buffref, 0, $len, "" ), $eof );
return undef;
}, future => $f );
return $f;
}
=head2 read_until
( $string, $eof ) = $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
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
sub read_until
{
my $self = shift;
my ( $until ) = @_;
ref $until or $until = qr/\Q$until\E/;
my $f = $self->_read_future;
$self->push_on_read( sub {
my ( undef, $buffref, $eof ) = @_;
return undef if $f->is_cancelled;
if( $$buffref =~ $until ) {
$f->done( substr( $$buffref, 0, $+[0], "" ), $eof );
return undef;
}
elsif( $eof ) {
$f->done( $$buffref, $eof ); $$buffref = "";
return undef;
}
else {
return 0;
}
}, future => $f );
return $f;
}
=head2 read_until_eof
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
yields all of the data that was available.
=cut
sub read_until_eof
{
my $self = shift;
my $f = $self->_read_future;
$self->push_on_read( sub {
my ( undef, $buffref, $eof ) = @_;
return undef if $f->is_cancelled;
return 0 unless $eof;
$f->done( $$buffref, $eof ); $$buffref = "";
return undef;
}, future => $f );
return $f;
}
=head1 UTILITY CONSTRUCTORS
=cut
=head2 new_for_stdin
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
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
local/lib/perl5/IO/Async/Test.pm view on Meta::CPAN
now be tested using the usual testing primitives.
Because the primary purpose of L<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
testing_loop( $loop )
Set the L<IO::Async::Loop> object which the C<wait_for> function will loop
local/lib/perl5/IO/Async/Test.pm view on Meta::CPAN
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 ) {
local/lib/perl5/IO/Async/Test.pm view on Meta::CPAN
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] };
}
local/lib/perl5/IO/Async/Timer.pm view on Meta::CPAN
}
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;
local/lib/perl5/IO/Async/Timer/Absolute.pm view on Meta::CPAN
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;
local/lib/perl5/IO/Async/Timer/Absolute.pm view on Meta::CPAN
$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};
local/lib/perl5/IO/Async/Timer/Countdown.pm view on Meta::CPAN
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;
}
local/lib/perl5/IO/Async/Timer/Countdown.pm view on Meta::CPAN
return $self->{expired};
}
sub _make_cb
{
my $self = shift;
return $self->_capture_weakself( sub {
my $self = shift or return;
undef $self->{id};
$self->{expired} = 1;
$self->remove_from_parent if $self->{remove_on_expire};
$self->invoke_event( "on_expire" );
} );
}
sub _make_enqueueargs
{
my $self = shift;
undef $self->{expired};
return after => $self->{delay};
}
=head2 reset
$timer->reset
If the timer is running, restart the countdown period from now. If the timer
is not running, this method has no effect.
( run in 2.140 seconds using v1.01-cache-2.11-cpan-d80b1682f3f )