File Coverage

blib/lib/Test/Ping.pm

Criterion	Covered	Total	%
statement	75	77	97.4
branch	2	4	50.0
condition	4	9	44.4
subroutine	19	19	100.0
pod	4	4	100.0
total	104	113	92.0

package Test::Ping;
$Test::Ping::VERSION = '0.204';
use strict;
use warnings;
# ABSTRACT: Testing pings using Net::Ping

use Test::Ping::Ties::BIND;
use Test::Ping::Ties::PORT;
use Test::Ping::Ties::PROTO;
use Test::Ping::Ties::HIRES;
use Test::Ping::Ties::TIMEOUT;
use Test::Ping::Ties::SOURCE_VERIFY;
use Test::Ping::Ties::SERVICE_CHECK;

my  $CLASS         = __PACKAGE__;
my  $OBJPATH       = __PACKAGE__->builder->{'_net-ping_object'};
my  $method_ignore = '__NONE';
our @EXPORT        = qw(
    ping_ok
    ping_not_ok
    create_ping_object_ok
    create_ping_object_not_ok
);

# Net::Ping variables
our $PORT;
our $BIND;
our $PROTO;
our $HIRES;
our $TIMEOUT;
our $SOURCE_VERIFY;
our $SERVICE_CHECK;

BEGIN {
    use parent 'Test::Builder::Module';
    use Net::Ping;

    __PACKAGE__->builder->{'_net-ping_object'} = Net::Ping->new($PROTO);

    ## no critic qw(Miscellanea::ProhibitTies)
    tie $PORT,          'Test::Ping::Ties::PORT';
    tie $BIND,          'Test::Ping::Ties::BIND';
    tie $PROTO,         'Test::Ping::Ties::PROTO';
    tie $HIRES,         'Test::Ping::Ties::HIRES';
    tie $TIMEOUT,       'Test::Ping::Ties::TIMEOUT';
    tie $SOURCE_VERIFY, 'Test::Ping::Ties::SOURCE_VERIFY';
    tie $SERVICE_CHECK, 'Test::Ping::Ties::SERVICE_CHECK';
}

sub ping_ok {
    my ( $host, $name ) = @_;
    my $tb     = $CLASS->builder;
    my $pinger = $OBJPATH;

    my ( $ret, $duration ) = $pinger->ping( $host, $TIMEOUT );
    $tb->ok( $ret, $name );

    return ( $ret, $duration );
}

sub ping_not_ok {
    my ( $host, $name ) = @_;
    my $tb     = $CLASS->builder;
    my $pinger = $OBJPATH;

    my $alive = $pinger->ping( $host, $TIMEOUT );
    $tb->ok( !$alive, $name );

    return 1;
}

sub create_ping_object_ok {
    my @args = @_;
    my $name = pop @args || q{};
    my $tb   = $CLASS->builder;

    my $success = eval { $OBJPATH = Net::Ping->new(@args); 1; };

    $tb->ok( $success && ref $OBJPATH eq 'Net::Ping', $name );
}

sub create_ping_object_not_ok {
    my @args = @_;
    my $name = pop @args || q{};
    my $tb   = $CLASS->builder;
    my $error;
    eval { Net::Ping->new(@args); 1; }
    or $error = $@;

    $tb->ok( $error, $name );
}

sub _has_var_ok { ## no critic qw( Subroutines::ProhibitUnusedPrivateSubroutines )
    my ( $var_name, $var_value, $name ) = @_;
    my $tb = $CLASS->builder;
    $tb->is_eq( $OBJPATH->{$var_name}, $var_value, $name );
    return 1;
}

sub _ping_object { ## no critic qw( Subroutines::ProhibitUnusedPrivateSubroutines Subroutines::RequireArgUnpacking )
    my $obj = $_[1] || $_[0] || q{};

    if ( ref $obj eq 'Net::Ping' ) {
        $OBJPATH = $obj;
    }

    return $OBJPATH;
}

END { $OBJPATH->close(); }

1;

__END__