File Coverage

inc/My/Module/Test.pm

Criterion	Covered	Total	%
statement	125	179	69.8
branch	38	82	46.3
condition	8	23	34.7
subroutine	27	34	79.4
pod	19	22	86.3
total	217	340	63.8

package My::Module::Test;

use strict;
use warnings;

use Astro::SIMBAD::Client;
use Test::More 0.96;	# Because of subtest()

use Exporter ();
our @ISA = qw{ Exporter };

our @CARP_NOT = ( qw{ Astro::SIMBAD::Client } );

use constant ARRAY_REF	=> ref [];
use constant HASH_REF	=> ref {};
use constant REGEXP_REF	=> ref qr{};

our @EXPORT_OK = qw{
    access
    call
    call_a
    canned
    clear
    count
    deref
    deref_curr
    diag
    dumper
    echo
    end
    find
    have_scheme
    hidden
    load_data
    load_module
    load_module_or_skip_all
    module_loaded
    note
    plan
    returned_value
    silent
    subtest
    test
    test_false
    $TODO
};
our @EXPORT = @EXPORT_OK;	## no critic (ProhibitAutomaticExportation)

my $canned;	# Canned data to test against.
my $got;	# Result of method call.
my %loaded;	# Record of the results of attempting to load modules.
my $obj;	# The object to be tested.
my $ref;	# Reference to result of method call, if it is a reference.
my $skip;	# True to skip tests.
my $silent;	# True to silence exceptions if $skip is true.

sub access {
    eval {
	require LWP::UserAgent;
	1;
    } or plan skip_all => 'Can not load LWP::UserAgent';
    my $resp = LWP::UserAgent->new(
    )->get( Astro::SIMBAD::Client->__build_url( 'simbad/' ) );
    $resp->is_success
	or plan skip_all => "@{[$resp->status_line]}";
    return;
}

sub call {
    my ( $method, @args ) = @_;
    $obj ||= Astro::SIMBAD::Client->new();
    eval {
	$got = $obj->$method( @args );
	1;
    } or do {
	_method_failure( $method, @args );
	$got = $@;
    };
    $ref = ref $got ? $got : undef;
    return;
}

sub call_a {
    my ( $method, @args ) = @_;
    $obj ||= Astro::SIMBAD::Client->new();
    eval {
	$got = [ $obj->$method( @args ) ];
	1;
    } or do {
	_method_failure( $method. @args );
	$got = $@;
    };
    $ref = ref $got ? $got : undef;
    return;
}

sub canned {
    my ( @args ) = @_;
    my $want = $canned;
    foreach my $key (@args) {
	my $ref = ref $want;
	if ( ARRAY_REF eq $ref ) {
	    $want = $want->[$key];
	} elsif ( HASH_REF eq $ref ) {
	    $want = $want->{$key};
	} elsif ($ref) {
	    die "Loaded data contains unexpected $ref reference for key $key\n";
	} else {
	    die "Loaded data does not contain key @args\n";
	}
    }
    return $want;
}

sub clear {
    $got = $ref = undef;	# clear
    $skip = undef;		# noskip
    $silent = undef;		# Not silent.
    return;
}

sub count {
    if ( ARRAY_REF eq ref $got ) {
	$got = @{ $got };
    } else {
	$got = undef;
    };
    return;
}

sub deref {
    $got = $ref;
    goto &deref_curr;
}

sub deref_curr {
    my ( @args ) = @_;
    foreach my $key (@args) {
	my $type = ref $got;
	if ( ARRAY_REF eq $type ) {
	    $got = $got->[$key];
	} elsif ($type eq HASH_REF) {
	    $got = $got->{$key};
	} else {
	    $got = undef;
	}
    }
    return;
}

sub dumper {
	require Data::Dumper;
	diag Data::Dumper::Dumper( $got );
    return;
}

sub echo {
    my @args = @_;
    foreach ( @args ) {
	note $_;
    }
    return;
}

sub end {
    done_testing;
    return;
}

sub find {
    my ( @args ) = @_;
    my $target = pop @args;
    if ( ARRAY_REF eq ref $got ) {
	foreach my $item ( @{ $got } ) {
	    my $test = $item;
	    foreach my $key ( @args ) {
		my $type = ref $test;
		if ( ARRAY_REF eq $type ) {
		    $test = $test->[$key];
		} elsif ( HASH_REF eq $type ) {
		    $test = $test->{$key};
		} else {
		    $test = undef;
		}
	    }
	    (defined $test && $test eq $target)
	       and do {$got = $item; last;};
	}
    }
    return;
}

sub have_scheme {
    my ( $protocol ) = @_;
    local $@ = undef;
    return eval {
	require "LWP/Protocol/$protocol.pm";
	1;
    };
}

sub hidden {
    my ( $module ) = @_;
    my $code = Test::Without::Module->can( 'get_forbidden_list' )
	or return 0;
    return exists $code->()->{$module} || 0;
}

sub load_data {
    my ( $arg ) = @_;
    if ( defined $arg ) {
	local @INC = ( @INC, '.' );
	$canned = do $arg;
    } else {
	$canned = undef;
    }
    return;
}

sub load_module {
    my @args = @_;
    my $prob = @args > 1 ?
	("Can not load any of " . join (', ', @args)) :
	@args ? "Can not load @args" : '';
    foreach ( @args ) {
	if ( exists $loaded{$_} ) {
	    $loaded{$_} and do {
		$prob = undef;
		last;
	    };
	} else {
	    $loaded{$_} = undef;
	    eval "require $_; 1" and do {
		$prob = undef;
		$loaded{$_} = 1;
		last;
	    };
	}
    }
    defined $prob
	and not $skip
	and $skip = $prob;
    return;
}

sub load_module_or_skip_all {
    my @args = @_;
    load_module( @args );
    $skip
	and plan skip_all => $skip;
    return;
}

sub module_loaded {		## no critic (RequireArgUnpacking)
    my ( @args ) = @_;
    $loaded{shift @args} or return;
    my $verb = shift @args;
    my $code = __PACKAGE__->can( $verb )
	or die "Unknown command $verb";
    @_ = @args;
    goto &$code;
}

sub returned_value {
    return $got;
}

sub silent {
    my ( $arg ) = @_;
    defined $arg
	or $arg = ! $silent;
    $silent = $arg;
    return;
}

sub test {		## no critic (RequireArgUnpacking)
    $_[2] = 1;
    goto &_test;
}

sub test_false {	## no critic (RequireArgUnpacking)
    $_[2] = 0;
    goto &_test;
}

sub _test {		## no critic (RequireArgUnpacking)
    my ( $want, $title, $type ) = @_;
    $got = 'undef' unless defined $got;
    foreach ($want, $got) {
	ref $_ and next;
	chomp $_;
	m/(.+?)\s+$/ and _numberp ($1 . '') and $_ = $1;
    }
    if ( $skip ) {
	SKIP: {
	    skip $skip, 1;
	}
    } elsif ( REGEXP_REF eq ref $want ) {
	@_ = ( $got, $want, $title );
	goto $type ? \&like : \&unlike;
    } elsif (_numberp ($want) && _numberp ($got)) {
	@_ = ( $got, ( $type ? '==' : '!=' ), $want, $title );
	goto &cmp_ok;
    } else {
	@_ = ( $got, $want, $title );
	goto $type ? \&is : \&isnt;
    }
    return;
}

##################################################################

sub _method_failure {
    my ( $method, @args ) = @_;
    $skip
	and $silent
	and return;
    my $msg = $skip ? ' ($skip set)' : '';
    @args = map { _quote() } @args;
    local $" = ', ';
    diag "$method( @args ) failed$msg: $@";
    return;
}

sub _numberp {
    return ($_[0] =~ m/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/);
}

sub _quote {
    defined $_
	or return 'undef';
    _numberp( $_ )
	and return $_;
    s/ ( ['\\] ) /\\$1/smx;
    return "'$_'";
}

1;

__END__