File Coverage

blib/lib/IO/Async/Loop/IO/Async.pm

Criterion	Covered	Total	%
statement	119	124	95.9
branch	21	32	65.6
condition	6	9	66.6
subroutine	25	26	96.1
pod	14	14	100.0
total	185	205	90.2

#  You may distribute under the terms of either the GNU General Public License
#  or the Artistic License (the same terms as Perl itself)
#
#  (C) Paul Evans, 2010 -- [e-mail]

package IO::Async::Loop::IO::Async;

use strict;
use warnings;

our $VERSION = '0.02';
use constant API_VERSION => '0.33';

use base qw( IO::Async::Loop );

use Carp;

use Scalar::Util qw( weaken );

use IO::Async::Notifier;
use IO::Async::Handle;
use IO::Async::Timer::Absolute;
use IO::Async::Signal;
use IO::Async::PID;

=head1 NAME

L - use C with C

=head1 SYNOPSIS

 use IO::Async::Loop::IO::Async;

 my $loop = IO::Async::Loop::IO::Async->new();

 $loop->add( ... );

 $loop->add( IO::Async::Signal->new(
       name => 'HUP',
       on_receipt => sub { ... },
 ) );

 $loop->loop_forever();

=head1 DESCRIPTION

This subclass of L uses another instance of an
C object as its underlying implementation. While this at
first appears to be pointless, this module distribution is not primarily
intended to serve a useful purpose for end-users. Rather, it stands as a real
code example, for authors of other modules to use for reference.

=head2 For C Authors

Authors of other subclasses to implement C subclasses may
find this distribution useful as a template. By copying the code and replacing
the contents of the various C and C methods, a Loop
implementation can be built making use of some other event system or
underlying kernel blocking primative.

=head2 For Authors of Other Event Systems

Authors of implementations in other event systems wishing to support running
their event system on top of L may find this distribution useful to
read a way to implement the various underlying behaviours, such as watching
filehandles and timers. Examples in each of the C and C
methods may be useful to demonstrate the sort of code that might be required
to attach some other event system on top of C.

=head1 CONSTRUCTOR

=cut

=head2 $loop = IO::Async::Loop::IO::Async->new()

This function returns a new instance of a C object.

=cut

sub new
{
   my $class = shift;
   my ( %args ) = @_;

   my $self = $class->SUPER::__new( %args );

   $self->{root_notifier} = IO::Async::Notifier->new;

   return $self;
}

=head1 METHODS

=cut

=head2 $loop->parent_loop( $parent )

=head2 $parent = $loop->parent_loop

Accessor for the underlying C that this loop will use. If one
is not provided by the time that C is first invoked, one will be
constructed using the normal C<< IO::Async::Loop->new >> constructor. This
method may be used to access it after that.

=cut

sub parent_loop
{
   my $self = shift;
   my ( $loop ) = @_;

   $self->{parent_loop} = $loop if $loop;

   $self->{parent_loop} ||= do {
      my $loop = IO::Async::Loop->new;
      $loop->add( $self->{root_notifier} );
      $loop;
   };

   return $self->{parent_loop};
}

sub loop_once
{
   my $self = shift;
   my ( $timeout ) = @_;

   $self->parent_loop->loop_once( $timeout );
}

sub watch_io
{
   my $self = shift;
   my %params = @_;

   my $handle = $params{handle} or die "Need a handle";

   my $ioa_handle = $self->{handles}{$handle} ||= do {
      my $h = IO::Async::Handle->new;
      $self->{root_notifier}->add_child( $h );
      $h;
   };

   if( my $on_read_ready = $params{on_read_ready} ) {
      $ioa_handle->configure(
         read_handle => $handle,
         on_read_ready => $on_read_ready,
      );
      $ioa_handle->want_readready( 1 );
   }

   if( my $on_write_ready = $params{on_write_ready} ) {
      $ioa_handle->configure(
         write_handle => $handle,
         on_write_ready => $on_write_ready,
      );
      $ioa_handle->want_writeready( 1 );
   }
}

sub unwatch_io
{
   my $self = shift;
   my %params = @_;

   my $handle = $params{handle} or die "Need a handle";

   my $ioa_handle = $self->{handles}{$handle} or return;

   if( $params{on_read_ready} ) {
      $ioa_handle->want_readready( 0 );
      $ioa_handle->configure(
         read_handle => undef,
         on_read_ready => undef,
      );
   }

   if( $params{on_write_ready} ) {
      $ioa_handle->want_writeready( 0 );
      $ioa_handle->configure(
         write_handle => undef,
         on_write_ready => undef,
      );
   }

   if( !$ioa_handle->want_readready and !$ioa_handle->want_writeready ) {
      $self->{root_notifier}->remove_child( $ioa_handle );
   }
}

sub enqueue_timer
{
   my $self = shift;
   my %params = @_;

   my $time = $self->_build_time( %params );

   my $code = $params{code} or croak "Expected 'code' as CODE ref";

   my $timer = IO::Async::Timer::Absolute->new(
      time => $time,
      on_expire => $code,
   );

   $self->{root_notifier}->add_child( $timer );

   return $timer;
}

sub cancel_timer
{
   my $self = shift;
   my ( $timer ) = @_;

   $timer->stop if $timer->get_loop;
   $self->{root_notifier}->remove_child( $timer );
}

sub requeue_timer
{
   my $self = shift;
   my ( $timer, %params ) = @_;

   my $time = $self->_build_time( %params );

   $timer->configure( time => $time );

   return $timer;
}

sub watch_signal
{
   my $self = shift;
   my ( $signal, $code ) = @_;

   my $ioa_signal = IO::Async::Signal->new(
      name => $signal,
      on_receipt => $code,
   );

   $self->{signals}{$signal} = $ioa_signal;

   $self->{root_notifier}->add_child( $ioa_signal );
}

sub unwatch_signal
{
   my $self = shift;
   my ( $signal ) = @_;

   $self->{root_notifier}->remove_child( delete $self->{signals}{$signal} );
}

sub watch_idle
{
   my $self = shift;
   my %params = @_;

   my $code = $params{code} or croak "Expected 'code' as CODE ref";

   my $when = $params{when} or croak "Expected 'when'";

   $when eq "later" or croak "Expected 'when' to be 'later'";

   # TODO: Find a nice way to do this that isn't cheating
   return $self->parent_loop->watch_idle(
      when => "later",
      code => $code,
   );
}

sub unwatch_idle
{
   my $self = shift;
   my ( $id ) = @_;

   $self->parent_loop->unwatch_idle( $id );
}

sub watch_child
{
   my $self = shift;
   my ( $pid, $code ) = @_;

   # Some more cheating
   if( $pid == 0 ) {
      $self->parent_loop->watch_child( 0, $code );
      return;
   }

   weaken( my $weakself = $self );

   my $ioa_pid = IO::Async::PID->new(
      pid => $pid,
      on_exit => sub {
         my ( undef, $exitstatus ) = @_;

         $code->( $pid, $exitstatus );

         delete $weakself->{pids}{$pid};
      }
   );

   $self->{pids}{$pid} = $ioa_pid;

   $self->{root_notifier}->add_child( $ioa_pid );
}

sub unwatch_child
{
   my $self = shift;
   my ( $pid ) = @_;

   if( $pid == 0 ) {
      $self->parent_loop->unwatch_child( 0 );
   }

   $self->{root_notifier}->remove_child( delete $self->{pids}{$pid} );
}

# Keep perl happy; keep Britain tidy
1;

__END__