File Coverage

inc/My/Module/Test.pm

Criterion	Covered	Total	%
statement	105	121	86.7
branch	23	32	71.8
condition	11	26	42.3
subroutine	17	19	89.4
pod	5	6	83.3
total	161	204	78.9

package My::Module::Test;

use 5.006002;

use strict;
use warnings;

our $VERSION = '0.129_01';

use Exporter qw{ import };

use Astro::Coord::ECI::TLE qw{ :constants };
use Astro::Coord::ECI::Utils qw{ rad2deg };
use Test::More 0.88;

use constant CODE_REF	=> ref sub {};

our @EXPORT_OK = qw{
    format_pass format_time
    magnitude
    tolerance tolerance_frac
    velocity_sanity
};
our %EXPORT_TAGS = (
    all => \@EXPORT_OK,
    format => [ qw{ format_pass format_time } ],
    tolerance => [ qw{ tolerance tolerance_frac } ],
);

# Perl::Critic can't find interpolated sub calls
sub _dor {	## no critic (ProhibitUnusedPrivateSubroutines)
    foreach ( @_ ) {
	defined $_ and return $_;
    }
    return;
}

{

    my @decoder;

    # We jump through this hoop in case the constants turn out not to be
    # dualvars.
    BEGIN {
	$decoder[ PASS_EVENT_NONE ]	= '';
	$decoder[ PASS_EVENT_SHADOWED ]	= 'shdw';
	$decoder[ PASS_EVENT_LIT ]	= 'lit';
	$decoder[ PASS_EVENT_DAY ]	= 'day';
	$decoder[ PASS_EVENT_RISE ]	= 'rise';
	$decoder[ PASS_EVENT_MAX ]	= 'max';
	$decoder[ PASS_EVENT_SET ]	= 'set';
	$decoder[ PASS_EVENT_APPULSE ]	= 'apls';
	$decoder[ PASS_EVENT_START ]	= 'start';
	$decoder[ PASS_EVENT_END ]	= 'end';
    }

    sub _format_event {
	my ( $event ) = @_;
	defined $event or return '';
	return $decoder[ $event + 0 ];
    }

}

sub format_pass {
    my @passes = @_;
    my $rslt = '';
    foreach my $pass ( @passes ) {
	$pass
	    or next;
	$rslt .= "\n";
	foreach my $event ( @{ $pass->{events} } ) {
	    $rslt .= sprintf '%19s %5s %5s %7s %-5s %-5s',
		format_time( $event->{time} ),
		_format_optional( '%5.1f', $event, 'elevation', \&rad2deg ),
		_format_optional( '%5.1f', $event, 'azimuth', \&rad2deg ),
		_format_optional( '%7.1f', $event, 'range' ),
		_format_event( $event->{illumination} ),
		_format_event( $event->{event} ),
		;
	    $rslt =~ s/ \s+ \z //smx;
	    $rslt .= "\n";
	    if ( $event->{appulse} ) {
		my $sta = $event->{station};
		my ( $az, $el ) = $sta->azel(
		    $event->{appulse}{body}->universal( $event->{time} ) );
		$rslt .= sprintf '%19s %5.1f %5.1f %7.1f %s', '',
		    rad2deg( $el ),
		    rad2deg( $az ),
		    rad2deg( $event->{appulse}{angle} ),
		    $event->{appulse}{body}->get( 'name' ),
		    ;
		$rslt =~ s/ \s+ \z //smx;
		$rslt .= "\n";
	    }
	}
    }
    $rslt =~ s/ \A \n //smx;
    $rslt =~ s/ (?<= \s ) - (?= 0 [.] 0+ \s ) / /smxg;
    return $rslt;
}

sub _format_optional {
    my ( $tplt, $hash, $key, $xfrm ) = @_;
    defined( my $val = $hash->{$key} )
	or return '';
    CODE_REF eq ref $xfrm
	and $val = $xfrm->( $val );
    return sprintf $tplt, $val;
}

sub format_time {
    my ( $time ) = @_;
    my @parts = gmtime int( $time + 0.5 );
    return sprintf '%04d/%02d/%02d %02d:%02d:%02d', $parts[5] + 1900,
	$parts[4] + 1, @parts[ 3, 2, 1, 0 ];
}

sub magnitude {
    my ( $tle, @arg ) = @_;
    my ( $time, $want, $name ) = splice @arg, -3;
    my $got;
    eval {
	$got = $tle->universal( $time )->magnitude( @arg );
	defined $got
	    and $got = sprintf '%.1f', $got;
	1;
    } or do {
	@_ = "$name failed: $@";
	goto &fail;
    };
    if ( defined $want ) {
	$want = sprintf '%.1f', $want;
	@_ = ( $got, 'eq', $want, $name );
	goto &cmp_ok;
    } else {
	@_ = ( ! defined $got, $name );
	goto &ok;
    }
}

sub tolerance {
    my ( $got, $want, $tolerance, $title, $fmtr ) = @_;
    $fmtr ||= sub { return $_[0] };
    $title =~ s{ (?
    my $delta = $got - $want;
    my $rslt = abs( $delta ) < $tolerance;
    $rslt or $title .= <<"EOD";

         Got: @{[ $fmtr->( $got ) ]}
    Expected: @{[ $fmtr->( $want ) ]}
  Difference: $delta
   Tolerance: $tolerance
EOD
    chomp $title;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    return ok( $rslt, $title );
}

sub tolerance_frac {
    my ( $got, $want, $tolerance, $title, $fmtr ) = @_;
    @_ = ( $got, $want, $tolerance * abs $want, $title, $fmtr );
    goto &tolerance;
}

{
    my @dim_name = qw{ X Y Z };
    my %method_dim_name = (
	azel	=> [ qw{ azimuth elevation range } ],
	equatorial => [ 'right ascension', 'declination', 'range' ],
    );
    my %tweak = (
	azel => sub {
	    my ( $delta, $current, $previous ) = @_;
	    $delta->[0] *= cos( ( $current->[1] + $previous->[1] ) / 2 );
	    return;
	},
	equatorial => sub {
	    my ( $delta, $current, $previous ) = @_;
	    $delta->[1] *= cos( ( $current->[0] + $previous->[0] ) / 2 );
	    return;
	},
    );

    sub velocity_sanity {
	my ( $method, $body, $sta ) = @_;
	my $time = $body->universal();
	my @rslt;
	foreach my $delta_t ( 0, 1 ) {
	    $delta_t
		and $body->universal( $time + $delta_t );
	    my @coord = $sta ? $sta->$method( $body ) :
		$body->$method();
	    # Accommodate internal methods that return a reference to an
	    # array of intermediate results.
	    ref @coord and shift @coord;
	    push @rslt, \@coord;
	}
	my @delta_p = map { $rslt[1][$_] - $rslt[0][$_] } ( 0 .. 2 );
	$tweak{$method}
	    and $tweak{$method}->( \@delta_p, @rslt );
	my @time_a = gmtime $time;
	my $title = sprintf
	    '%s converted to %s at %i/%i/%i %i:%02i:%02i GMT',
	    $body->get( 'name' ) || $body->get( 'id' ), $method,
	    $time_a[5] + 1900, $time_a[4] + 1, @time_a[ 3, 2, 1, 0 ];
	my $grade = \&pass;
	foreach my $inx ( 0 .. 2 ) {
	    my $v_inx = $inx + 3;
	    defined $rslt[0][$v_inx]
		and defined $rslt[1][$v_inx]
		and $rslt[0][$v_inx] <= $delta_p[$inx]
		and $delta_p[$inx] <= $rslt[1][$v_inx]
		and next;
	    defined $rslt[0][$v_inx]
		and defined $rslt[1][$v_inx]
		and $rslt[0][$v_inx] >= $delta_p[$inx]
		and $delta_p[$inx] >= $rslt[1][$v_inx]
		and next;
	    my $dim = $method_dim_name{$method}[$inx] || $dim_name[$inx];
	    $grade = \&fail;
	    $title .= <<"EOD";

           $dim( t + 1 ): $rslt[1][$inx]
               $dim( t ): $rslt[0][$inx]
          $dim dot ( t ): @{[ _dor( $rslt[0][$v_inx], '' ) ]}
  $dim( t + 1 ) - $dim( t ): $delta_p[$inx]
      $dim dot ( t + 1 ): @{[ _dor( $rslt[1][$v_inx], '' ) ]}
EOD
	    chomp $title;
	}
	@_ = ( $title );
	goto &$grade;
    }
}

1;

__END__