File Coverage

blib/lib/UV/Loop.pm

Criterion	Covered	Total	%
statement	50	55	90.9
branch	5	12	41.6
condition	2	5	40.0
subroutine	13	14	92.8
pod	6	6	100.0
total	76	92	82.6

package UV::Loop;

our $VERSION = '1.900';

use strict;
use warnings;

use Carp ();
use Exporter qw(import);
use Scalar::Util ();
use UV ();

use constant DEBUG => $ENV{PERL_UV_DEBUG};

our @EXPORT_OK = (@UV::Loop::EXPORT_XS,);
my $default_loop;

# simple function to ensure we've been given a UV::Loop
# this is useful in new Handle construction
sub _is_a_loop {
    my $loop = shift;
    return undef unless $loop;
    return undef unless ref($loop) && Scalar::Util::blessed($loop);
    return undef unless $loop->isa('UV::Loop');
    return 1;
}

sub new {
    my $class = shift;
    print STDERR "UV::Loop->new() called\n" if DEBUG;
    my $args = UV::_parse_args(@_);

    my $self = $class->_new($args->{_default} // 0);

    $self->on('walk', $args->{on_walk});
    print STDERR "UV::Loop->new() walk callback added\n" if DEBUG;

    print STDERR "UV::Loop->new() done\n" if DEBUG;
    return $self;
}

# Return the singleton uv_default_loop
sub default {
    print STDERR "loop default() singleton called\n" if DEBUG;
    my $class = shift;
    if (defined($default_loop)) {
        print STDERR "loop default() returning already stored default loop\n" if DEBUG;
        return $default_loop;
    }
    print STDERR "loop default() We don't have a default. Let's create one!\n" if DEBUG;
    $default_loop = $class->new(@_, _default => 1);
    print STDERR "loop default() returning newly created and stored default loop\n" if DEBUG;
    return $default_loop;
}

sub default_loop { return shift->default(); }

sub on {
    my $self = shift;
    my $method = "_on_" . shift;
    return $self->$method( @_ );
}

sub walk {
    my $self = shift;
    return unless $self->alive();
    $self->on('walk', @_) if @_; # set the callback ahead of time if exists
    $self->_walk();
}

sub getaddrinfo {
    my $self = shift;
    my ($args, $cb) = @_;

    $self->_getaddrinfo(@{$args}{qw( node service flags family socktype protocol )}, $cb);
}

1;

__END__