File Coverage

inc/My/Module/Test.pm

Criterion	Covered	Total	%
statement	52	59	88.1
branch	11	16	68.7
condition	3	5	60.0
subroutine	10	10	100.0
pod	5	5	100.0
total	81	95	85.2

package My::Module::Test;

use strict;
use warnings;

use Carp;
use Exporter qw{ import };
use Test::More 0.88;

my @export = qw{
    decode
    fails
    hexify
    returns
    round_trip
};

our @EXPORT = ( @export, @Test::More::EXPORT );	## no critic (ProhibitAutomaticExportation)
our @EXPORT_OK = ( @export, @Test::More::EXPORT_OK );

sub decode {
    splice @_, 1, 0, 'decode';
    goto &returns;
}

sub fails {	## no critic (RequireArgUnpacking)
    my ( $obj, @args ) = @_;
##  my $opt = ref $args[0] eq 'HASH' ? shift @args : {};
    ref $args[0] eq 'HASH' and shift @args;	# $opt is unused
    my $method = shift @args;
    my $name = pop @args;
    my $want = pop @args;
    ref $want or $want = qr<@{[ quotemeta $want ]}>;
    local $@;
    eval { $obj->$method( @args ); 1 }
	and do {
	@_ = ( "$name did not throw an exception" );
	goto &fail;
    };
    @_ = ( $@, $want, $name );
    goto &like;
}

sub hexify {
    splice @_, 1, 0, { unpack => 'H*' };
    goto &returns;
}

sub returns {	## no critic (RequireArgUnpacking)
    my ( $obj, @args ) = @_;
    my $opt = ref $args[0] eq 'HASH' ? shift @args : {};
    my $method = shift @args;
    my $name = pop @args;
    my $want = pop @args;
    my $got;
    eval { $got = $obj->$method( @args ); 1 }
	or do {
	@_ = ( "$name threw $@" );
	goto &fail;
    };
    $opt->{unpack}
	and $got = unpack $opt->{unpack}, $got;
    $opt->{sprintf}
	and $got = sprintf $opt->{sprintf}, $got;
    @_ = ( $got, $want, $name );
    goto &is;
}

sub round_trip {	## no critic (RequireArgUnpacking)
    my ( $attr, $value, $opt ) = @_;
    $opt ||= {};
    my $name = $opt->{name} || "Round-trip $attr( $value )";
    my $utdf = eval {
	my $obj = Astro::UTDF->new( $attr => $value );
	return Astro::UTDF->new( raw_record => $obj->raw_record() );
    } or do {
	@_ = ( "$name threw $@" );
	goto &fail;
    };
    @_ = ( $utdf, $opt, $attr, $value, $name );
    goto &returns;
}

1;

__END__