Acme-Sort-Sleep
view release on metacpan or search on metacpan
local/lib/perl5/Future.pm view on Meta::CPAN
may be useful to provide C<Future> subclasses with event systems, or similar.
Each method that returns a new future object will use the invocant to
construct its return value. If the constructor needs to perform per-instance
setup it can override the C<new> method, and take context from the given
instance.
sub new
{
my $proto = shift;
my $self = $proto->SUPER::new;
if( ref $proto ) {
# Prototype was an instance
}
else {
# Prototype was a class
}
return $self;
}
local/lib/perl5/IO/Async/Channel.pm view on Meta::CPAN
=cut
sub _init
{
my $self = shift;
my ( $params ) = @_;
defined $params->{codec} or $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
local/lib/perl5/IO/Async/Channel.pm view on Meta::CPAN
$self->{$_} = delete $params{$_};
$self->_build_stream;
}
if( my $codec = delete $params{codec} ) {
@{ $self }{qw( encode decode )} = (
$self->can( "_make_codec_$codec" ) or croak "Unrecognised codec name '$codec'"
)->();
}
$self->SUPER::configure( %params );
}
sub _make_codec_Storable
{
require Storable;
return
\&Storable::freeze,
\&Storable::thaw;
}
local/lib/perl5/IO/Async/File.pm view on Meta::CPAN
=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} ) {
local/lib/perl5/IO/Async/File.pm view on Meta::CPAN
}
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 - $!";
local/lib/perl5/IO/Async/FileStream.pm view on Meta::CPAN
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' ),
) );
}
local/lib/perl5/IO/Async/FileStream.pm view on Meta::CPAN
elsif( exists $params{handle} or exists $params{read_handle} ) {
my $handle = delete $params{handle};
defined $handle or $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 );
}
}
local/lib/perl5/IO/Async/Function.pm view on Meta::CPAN
=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
local/lib/perl5/IO/Async/Function.pm view on Meta::CPAN
$self->{$_} = delete $params{$_} if exists $params{$_};
# TODO: something about retuning
}
my $need_restart;
foreach (qw( init_code 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 start
local/lib/perl5/IO/Async/Function.pm view on Meta::CPAN
# Presume that $@ is an ARRAYref of error results
$ret_channel->send( [ e => @{ $@ } ] );
}
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};
local/lib/perl5/IO/Async/Future.pm view on Meta::CPAN
$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;
}
local/lib/perl5/IO/Async/Handle.pm view on Meta::CPAN
}
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;
local/lib/perl5/IO/Async/Handle.pm view on Meta::CPAN
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";
local/lib/perl5/IO/Async/Internals/TimeQueue.pm view on Meta::CPAN
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;
local/lib/perl5/IO/Async/Listener.pm view on Meta::CPAN
It is invoked with the listening socket as its its argument, and optionally
an L<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 = @_;
local/lib/perl5/IO/Async/Listener.pm view on Meta::CPAN
# So now we know it's at least some kind of socket. Is it listening?
# SO_ACCEPTCONN would tell us, but not all OSes implement it. Since it's
# only a best-effort sanity check, we won't mind if the OS doesn't.
my $acceptconn = getsockopt( $handle, SOL_SOCKET, SO_ACCEPTCONN );
!defined $acceptconn or unpack( "I", $acceptconn ) or croak "Socket is not accepting connections";
# This is a bit naughty but hopefully nobody will mind...
bless $handle, "IO::Socket" if ref( $handle ) eq "GLOB";
$self->SUPER::configure( read_handle => $handle );
}
elsif( exists $params{handle} ) {
delete $params{handle};
$self->SUPER::configure( read_handle => undef );
}
unless( grep $self->can_event( $_ ), @acceptor_events ) {
croak "Expected to be able to 'on_accept', 'on_stream' or 'on_socket'";
}
foreach (qw( acceptor handle_constructor handle_class )) {
$self->{$_} = delete $params{$_} if exists $params{$_};
}
local/lib/perl5/IO/Async/Notifier.pm view on Meta::CPAN
}
=head2 configure
$notifier->configure( %params )
This method is called by the constructor to set the initial values of named
parameters, and by users of the object to adjust the values once constructed.
This method should C<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 configure_unknown
$notifier->configure_unknown( %params )
This method is called by the base class C<configure> method, for any remaining
local/lib/perl5/IO/Async/OS/linux.pm view on Meta::CPAN
# 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;
local/lib/perl5/IO/Async/PID.pm view on Meta::CPAN
$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
local/lib/perl5/IO/Async/PID.pm view on Meta::CPAN
{
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
local/lib/perl5/IO/Async/Process.pm view on Meta::CPAN
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
local/lib/perl5/IO/Async/Process.pm view on Meta::CPAN
$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,
local/lib/perl5/IO/Async/Process.pm view on Meta::CPAN
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;
local/lib/perl5/IO/Async/Process.pm view on Meta::CPAN
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
local/lib/perl5/IO/Async/Protocol.pm view on Meta::CPAN
$self->{transport} = $transport;
if( $transport ) {
$self->setup_transport( $self->transport );
$self->add_child( $self->transport );
}
}
$self->SUPER::configure( %params );
}
=head1 METHODS
=cut
=head2 transport
$transport = $protocol->transport
local/lib/perl5/IO/Async/Protocol/LineStream.pm view on Meta::CPAN
=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;
local/lib/perl5/IO/Async/Protocol/Stream.pm view on Meta::CPAN
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 => @_ );
} ),
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
$protocol->write( $data )
local/lib/perl5/IO/Async/Protocol/Stream.pm view on Meta::CPAN
Sets up a connection to a peer, and configures the underlying C<transport> for
the Protocol. Calls L<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
local/lib/perl5/IO/Async/Resolver.pm view on Meta::CPAN
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 );
local/lib/perl5/IO/Async/Routine.pm view on Meta::CPAN
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{$_};
local/lib/perl5/IO/Async/Routine.pm view on Meta::CPAN
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;
local/lib/perl5/IO/Async/Signal.pm view on Meta::CPAN
{
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};
local/lib/perl5/IO/Async/Signal.pm view on Meta::CPAN
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} );
local/lib/perl5/IO/Async/Signal.pm view on Meta::CPAN
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>
local/lib/perl5/IO/Async/Socket.pm view on Meta::CPAN
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.
local/lib/perl5/IO/Async/Socket.pm view on Meta::CPAN
sub configure
{
my $self = shift;
my %params = @_;
for (qw( on_recv on_outgoing_empty on_recv_error on_send_error
recv_len recv_all send_all autoflush )) {
$self->{$_} = delete $params{$_} if exists $params{$_};
}
$self->SUPER::configure( %params );
if( $self->loop and defined $self->read_handle ) {
$self->can_event( "on_recv" ) or
croak 'Expected either an on_recv callback or to be able to ->on_recv';
}
}
sub _add_to_loop
{
my $self = shift;
if( defined $self->read_handle ) {
$self->can_event( "on_recv" ) or
croak 'Expected either an on_recv callback or to be able to ->on_recv';
}
$self->SUPER::_add_to_loop( @_ );
}
=head1 METHODS
=cut
=head2 send
$socket->send( $data, $flags, $addr )
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
# 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.
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
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 close_now
$stream->close_now
This method immediately closes the underlying IO handles and removes the
stream from the containing loop. It will not wait to flush the remaining data
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
{
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
$eof = $stream->is_write_eof
local/lib/perl5/IO/Async/Stream.pm view on Meta::CPAN
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>
local/lib/perl5/IO/Async/Timer.pm view on Meta::CPAN
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
{
local/lib/perl5/IO/Async/Timer/Absolute.pm view on Meta::CPAN
$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};
local/lib/perl5/IO/Async/Timer/Countdown.pm view on Meta::CPAN
my $delay = delete $params{delay};
$delay >= 0 or croak "Expected a 'delay' as a non-negative number";
$self->{delay} = $delay;
}
unless( $self->can_event( 'on_expire' ) ) {
croak 'Expected either a on_expire callback or an ->on_expire method';
}
$self->SUPER::configure( %params );
}
=head1 METHODS
=cut
=head2 is_expired
$expired = $timer->is_expired
local/lib/perl5/IO/Async/Timer/Periodic.pm view on Meta::CPAN
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} ) {
local/lib/perl5/IO/Async/Timer/Periodic.pm view on Meta::CPAN
grep { $_ eq $resched } qw( hard skip drift ) or
croak "Expected 'reschedule' to be one of hard, skip, drift";
$self->{reschedule} = $resched;
}
unless( $self->can_event( 'on_tick' ) ) {
croak 'Expected either a on_tick callback or an ->on_tick method';
}
$self->SUPER::configure( %params );
}
sub _reschedule
{
my $self = shift;
my $now = $self->loop->time;
my $resched = $self->{reschedule};
my $next_interval = $self->{is_first} && defined $self->{first_interval}
local/lib/perl5/IO/Async/Timer/Periodic.pm view on Meta::CPAN
elsif( $resched eq "skip" ) {
# How many ticks are needed?
my $ticks = POSIX::ceil( $now - $self->{next_time} );
# $self->{last_ticks} = $ticks;
$self->{next_time} += $next_interval * $ticks;
}
elsif( $resched eq "drift" ) {
$self->{next_time} = $now + $next_interval;
}
$self->SUPER::start;
}
sub start
{
my $self = shift;
$self->{is_first} = 1;
# Only actually define a time if we've got a loop; otherwise it'll just
# become start-pending. We'll calculate it properly when it gets added to
# the Loop
if( $self->loop ) {
$self->_reschedule;
}
else {
$self->SUPER::start;
}
}
sub stop
{
my $self = shift;
$self->SUPER::stop;
undef $self->{next_time};
}
sub _make_cb
{
my $self = shift;
return $self->_capture_weakself( sub {
my $self = shift or return;
local/lib/perl5/Module/Build/API.pod view on Meta::CPAN
This method returns a hash reference of metadata that can be used to create a
YAML datastream. It is provided for authors to override or customize the fields
of F<META.yml>. E.g.
package My::Builder;
use base 'Module::Build';
sub get_metadata {
my $self, @args = @_;
my $data = $self->SUPER::get_metadata(@args);
$data->{custom_field} = 'foo';
return $data;
}
Valid arguments include:
=over
=item *
local/lib/perl5/Module/Build/Cookbook.pm view on Meta::CPAN
# Build.PL
use Module::Build;
my $class = Module::Build->subclass(
class => "Module::Build::Custom",
code => <<'SUBCLASS' );
sub ACTION_install {
my $self = shift;
# YOUR CODE HERE
$self->SUPER::ACTION_install;
}
SUBCLASS
$class->new(
module_name => 'Your::Module',
# rest of the usual Module::Build parameters
)->create_build_script;
=head2 Adding an action
local/lib/perl5/Module/Build/Platform/MacOS.pm view on Meta::CPAN
$VERSION = eval $VERSION;
use Module::Build::Base;
our @ISA = qw(Module::Build::Base);
use ExtUtils::Install;
sub have_forkpipe { 0 }
sub new {
my $class = shift;
my $self = $class->SUPER::new(@_);
# $Config{sitelib} and $Config{sitearch} are, unfortunately, missing.
foreach ('sitelib', 'sitearch') {
$self->config($_ => $self->config("install$_"))
unless $self->config($_);
}
# For some reason $Config{startperl} is filled with a bunch of crap.
(my $sp = $self->config('startperl')) =~ s/.*Exit \{Status\}\s//;
$self->config(startperl => $sp);
local/lib/perl5/Module/Build/Platform/MacOS.pm view on Meta::CPAN
my $cmd = MacPerl::Pick("What build command? ('*' requires ToolServer)", @action_list);
return unless defined $cmd;
$cmd =~ s/ \*$//;
$ARGV[0] = ($cmd);
my $args = MacPerl::Ask('Any extra arguments? (ie. verbose=1)', '');
return unless defined $args;
push @ARGV, $self->split_like_shell($args);
}
$self->SUPER::dispatch(@_);
}
sub ACTION_realclean {
my $self = shift;
chmod 0666, $self->{properties}{build_script};
$self->SUPER::ACTION_realclean;
}
# ExtUtils::Install has a hard-coded '.' directory in versions less
# than 1.30. We use a sneaky trick to turn that into ':'.
#
# Note that we do it here in a cross-platform way, so this code could
# actually go in Module::Build::Base. But we put it here to be less
# intrusive for other platforms.
sub ACTION_install {
my $self = shift;
return $self->SUPER::ACTION_install(@_)
if eval {ExtUtils::Install->VERSION('1.30'); 1};
local $^W = 0; # Avoid a 'redefine' warning
local *ExtUtils::Install::find = sub {
my ($code, @dirs) = @_;
@dirs = map { $_ eq '.' ? File::Spec->curdir : $_ } @dirs;
return File::Find::find($code, @dirs);
};
return $self->SUPER::ACTION_install(@_);
}
1;
__END__
=head1 NAME
Module::Build::Platform::MacOS - Builder class for MacOS platforms
=head1 DESCRIPTION
local/lib/perl5/Module/Build/Platform/Unix.pm view on Meta::CPAN
# question "can I execute this file", but I think we want "is this
# file executable".
my ($self, $file) = @_;
return +(stat $file)[2] & 0100;
}
sub _startperl { "#! " . shift()->perl }
sub _construct {
my $self = shift()->SUPER::_construct(@_);
# perl 5.8.1-RC[1-3] had some broken %Config entries, and
# unfortunately Red Hat 9 shipped it like that. Fix 'em up here.
my $c = $self->{config};
for (qw(siteman1 siteman3 vendorman1 vendorman3)) {
$c->{"install${_}dir"} ||= $c->{"install${_}"};
}
return $self;
}
local/lib/perl5/Module/Build/Platform/VMS.pm view on Meta::CPAN
=over 4
=item _set_defaults
Change $self->{build_script} to 'Build.com' so @Build works.
=cut
sub _set_defaults {
my $self = shift;
$self->SUPER::_set_defaults(@_);
$self->{properties}{build_script} = 'Build.com';
}
=item cull_args
'@Build foo' on VMS will not preserve the case of 'foo'. Rather than forcing
people to write '@Build "foo"' we'll dispatch case-insensitively.
=cut
sub cull_args {
my $self = shift;
my($action, $args) = $self->SUPER::cull_args(@_);
my @possible_actions = grep { lc $_ eq lc $action } $self->known_actions;
die "Ambiguous action '$action'. Could be one of @possible_actions"
if @possible_actions > 1;
return ($possible_actions[0], $args);
}
=item manpage_separator
local/lib/perl5/Module/Build/Platform/VMS.pm view on Meta::CPAN
my ($self, $command) = @_;
# a lot of VMS executables have a symbol defined
# check those first
if ( $^O eq 'VMS' ) {
require VMS::DCLsym;
my $syms = VMS::DCLsym->new;
return $command if scalar $syms->getsym( uc $command );
}
$self->SUPER::find_command($command);
}
# _maybe_command copied from ExtUtils::MM_VMS::maybe_command
=item _maybe_command (override)
Follows VMS naming conventions for executable files.
If the name passed in doesn't exactly match an executable file,
appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
to check for DCL procedure. If this fails, checks directories in DCL$PATH
local/lib/perl5/Module/Build/Platform/VMS.pm view on Meta::CPAN
}
=item oneliner
Override to ensure that we do not quote the command.
=cut
sub oneliner {
my $self = shift;
my $oneliner = $self->SUPER::oneliner(@_);
$oneliner =~ s/^\"\S+\"//;
return "MCR $^X $oneliner";
}
=item rscan_dir
Inherit the standard version but remove dots at end of name.
If the extended character set is in effect, do not remove dots from filenames
with Unix path delimiters.
=cut
sub rscan_dir {
my ($self, $dir, $pattern) = @_;
my $result = $self->SUPER::rscan_dir( $dir, $pattern );
for my $file (@$result) {
if (!_efs() && ($file =~ m#/#)) {
$file =~ s/\.$//;
}
}
return $result;
}
=item dist_dir
Inherit the standard version but replace embedded dots with underscores because
a dot is the directory delimiter on VMS.
=cut
sub dist_dir {
my $self = shift;
my $dist_dir = $self->SUPER::dist_dir;
$dist_dir =~ s/\./_/g unless _efs();
return $dist_dir;
}
=item man3page_name
Inherit the standard version but chop the extra manpage delimiter off the front if
there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
=cut
sub man3page_name {
my $self = shift;
my $mpname = $self->SUPER::man3page_name( shift );
my $sep = $self->manpage_separator;
$mpname =~ s/^$sep//;
return $mpname;
}
=item expand_test_dir
Inherit the standard version but relativize the paths as the native glob() doesn't
do that for us.
=cut
sub expand_test_dir {
my ($self, $dir) = @_;
my @reldirs = $self->SUPER::expand_test_dir( $dir );
for my $eachdir (@reldirs) {
my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
$eachdir = File::Spec->catfile( $reldir, $f );
}
return @reldirs;
}
=item _detildefy
( run in 1.071 second using v1.01-cache-2.11-cpan-49f99fa48dc )