1package My::Module::Test;
2
3use 5.006002;
4
5use strict;
6use warnings;
7
8our $VERSION = '0.122';
9
10use Exporter qw{ import };
11
12use Astro::Coord::ECI::TLE qw{ :constants };
13use Astro::Coord::ECI::Utils qw{ rad2deg };
14use Test::More 0.88;
15
16use constant CODE_REF	=> ref sub {};
17
18our @EXPORT_OK = qw{
19    format_pass format_time
20    magnitude
21    tolerance tolerance_frac
22    velocity_sanity
23};
24our %EXPORT_TAGS = (
25    all => \@EXPORT_OK,
26    format => [ qw{ format_pass format_time } ],
27    tolerance => [ qw{ tolerance tolerance_frac } ],
28);
29
30# Perl::Critic can't find interpolated sub calls
31sub _dor {	## no critic (ProhibitUnusedPrivateSubroutines)
32    foreach ( @_ ) {
33	defined $_ and return $_;
34    }
35    return;
36}
37
38{
39
40    my @decoder;
41
42    # We jump through this hoop in case the constants turn out not to be
43    # dualvars.
44    BEGIN {
45	$decoder[ PASS_EVENT_NONE ]	= '';
46	$decoder[ PASS_EVENT_SHADOWED ]	= 'shdw';
47	$decoder[ PASS_EVENT_LIT ]	= 'lit';
48	$decoder[ PASS_EVENT_DAY ]	= 'day';
49	$decoder[ PASS_EVENT_RISE ]	= 'rise';
50	$decoder[ PASS_EVENT_MAX ]	= 'max';
51	$decoder[ PASS_EVENT_SET ]	= 'set';
52	$decoder[ PASS_EVENT_APPULSE ]	= 'apls';
53	$decoder[ PASS_EVENT_START ]	= 'start';
54	$decoder[ PASS_EVENT_END ]	= 'end';
55    }
56
57    sub _format_event {
58	my ( $event ) = @_;
59	defined $event or return '';
60	return $decoder[ $event + 0 ];
61    }
62
63}
64
65sub format_pass {
66    my @passes = @_;
67    my $rslt = '';
68    foreach my $pass ( @passes ) {
69	$pass
70	    or next;
71	$rslt .= "\n";
72	foreach my $event ( @{ $pass->{events} } ) {
73	    $rslt .= sprintf '%19s %5s %5s %7s %-5s %-5s',
74		format_time( $event->{time} ),
75		_format_optional( '%5.1f', $event, 'elevation', \&rad2deg ),
76		_format_optional( '%5.1f', $event, 'azimuth', \&rad2deg ),
77		_format_optional( '%7.1f', $event, 'range' ),
78		_format_event( $event->{illumination} ),
79		_format_event( $event->{event} ),
80		;
81	    $rslt =~ s/ \s+ \z //smx;
82	    $rslt .= "\n";
83	    if ( $event->{appulse} ) {
84		my $sta = $event->{station};
85		my ( $az, $el ) = $sta->azel(
86		    $event->{appulse}{body}->universal( $event->{time} ) );
87		$rslt .= sprintf '%19s %5.1f %5.1f %7.1f %s', '',
88		    rad2deg( $el ),
89		    rad2deg( $az ),
90		    rad2deg( $event->{appulse}{angle} ),
91		    $event->{appulse}{body}->get( 'name' ),
92		    ;
93		$rslt =~ s/ \s+ \z //smx;
94		$rslt .= "\n";
95	    }
96	}
97    }
98    $rslt =~ s/ \A \n //smx;
99    $rslt =~ s/ (?<= \s ) - (?= 0 [.] 0+ \s ) / /smxg;
100    return $rslt;
101}
102
103sub _format_optional {
104    my ( $tplt, $hash, $key, $xfrm ) = @_;
105    defined( my $val = $hash->{$key} )
106	or return '';
107    CODE_REF eq ref $xfrm
108	and $val = $xfrm->( $val );
109    return sprintf $tplt, $val;
110}
111
112sub format_time {
113    my ( $time ) = @_;
114    my @parts = gmtime int( $time + 0.5 );
115    return sprintf '%04d/%02d/%02d %02d:%02d:%02d', $parts[5] + 1900,
116	$parts[4] + 1, @parts[ 3, 2, 1, 0 ];
117}
118
119sub magnitude {
120    my ( $tle, @arg ) = @_;
121    my ( $time, $want, $name ) = splice @arg, -3;
122    my $got;
123    eval {
124	$got = $tle->universal( $time )->magnitude( @arg );
125	defined $got
126	    and $got = sprintf '%.1f', $got;
127	1;
128    } or do {
129	@_ = "$name failed: $@";
130	goto &fail;
131    };
132    if ( defined $want ) {
133	$want = sprintf '%.1f', $want;
134	@_ = ( $got, 'eq', $want, $name );
135	goto &cmp_ok;
136    } else {
137	@_ = ( ! defined $got, $name );
138	goto &ok;
139    }
140}
141
142sub tolerance {
143    my ( $got, $want, $tolerance, $title, $fmtr ) = @_;
144    $fmtr ||= sub { return $_[0] };
145    $title =~ s{ (?<! [.] ) \z }{.}smx;
146    my $delta = $got - $want;
147    my $rslt = abs( $delta ) < $tolerance;
148    $rslt or $title .= <<"EOD";
149
150         Got: @{[ $fmtr->( $got ) ]}
151    Expected: @{[ $fmtr->( $want ) ]}
152  Difference: $delta
153   Tolerance: $tolerance
154EOD
155    chomp $title;
156    local $Test::Builder::Level = $Test::Builder::Level + 1;
157    return ok( $rslt, $title );
158}
159
160sub tolerance_frac {
161    my ( $got, $want, $tolerance, $title, $fmtr ) = @_;
162    @_ = ( $got, $want, $tolerance * abs $want, $title, $fmtr );
163    goto &tolerance;
164}
165
166{
167    my @dim_name = qw{ X Y Z };
168    my %method_dim_name = (
169	azel	=> [ qw{ azimuth elevation range } ],
170	equatorial => [ 'right ascension', 'declination', 'range' ],
171    );
172    my %tweak = (
173	azel => sub {
174	    my ( $delta, $current, $previous ) = @_;
175	    $delta->[0] *= cos( ( $current->[1] + $previous->[1] ) / 2 );
176	    return;
177	},
178	equatorial => sub {
179	    my ( $delta, $current, $previous ) = @_;
180	    $delta->[1] *= cos( ( $current->[0] + $previous->[0] ) / 2 );
181	    return;
182	},
183    );
184
185    sub velocity_sanity {
186	my ( $method, $body, $sta ) = @_;
187	my $time = $body->universal();
188	my @rslt;
189	foreach my $delta_t ( 0, 1 ) {
190	    $delta_t
191		and $body->universal( $time + $delta_t );
192	    my @coord = $sta ? $sta->$method( $body ) :
193		$body->$method();
194	    # Accommodate internal methods that return a reference to an
195	    # array of intermediate results.
196	    ref @coord and shift @coord;
197	    push @rslt, \@coord;
198	}
199	my @delta_p = map { $rslt[1][$_] - $rslt[0][$_] } ( 0 .. 2 );
200	$tweak{$method}
201	    and $tweak{$method}->( \@delta_p, @rslt );
202	my @time_a = gmtime $time;
203	my $title = sprintf
204	    '%s converted to %s at %i/%i/%i %i:%02i:%02i GMT',
205	    $body->get( 'name' ) || $body->get( 'id' ), $method,
206	    $time_a[5] + 1900, $time_a[4] + 1, @time_a[ 3, 2, 1, 0 ];
207	my $grade = \&pass;
208	foreach my $inx ( 0 .. 2 ) {
209	    my $v_inx = $inx + 3;
210	    defined $rslt[0][$v_inx]
211		and defined $rslt[1][$v_inx]
212		and $rslt[0][$v_inx] <= $delta_p[$inx]
213		and $delta_p[$inx] <= $rslt[1][$v_inx]
214		and next;
215	    defined $rslt[0][$v_inx]
216		and defined $rslt[1][$v_inx]
217		and $rslt[0][$v_inx] >= $delta_p[$inx]
218		and $delta_p[$inx] >= $rslt[1][$v_inx]
219		and next;
220	    my $dim = $method_dim_name{$method}[$inx] || $dim_name[$inx];
221	    $grade = \&fail;
222	    $title .= <<"EOD";
223
224           $dim( t + 1 ): $rslt[1][$inx]
225               $dim( t ): $rslt[0][$inx]
226          $dim dot ( t ): @{[ _dor( $rslt[0][$v_inx], '<undef>' ) ]}
227  $dim( t + 1 ) - $dim( t ): $delta_p[$inx]
228      $dim dot ( t + 1 ): @{[ _dor( $rslt[1][$v_inx], '<undef>' ) ]}
229EOD
230	    chomp $title;
231	}
232	@_ = ( $title );
233	goto &$grade;
234    }
235}
236
2371;
238
239__END__
240
241=head1 NAME
242
243My::Module::Test - Useful subroutines for testing
244
245=head1 SYNOPSIS
246
247 use lib qw{ inc };
248 use My::Module::Test qw{ :all };
249
250 say 'Time: ', format_time( time );
251
252=head1 DESCRIPTION
253
254This module is private to the My::Module package. The author
255reserves the right to change or revoke it without notice.
256
257This module is a repository for subroutines used in testing
258L<My::Module|My::Module>.
259
260=head1 SUBROUTINES
261
262The following public subroutines are exported by this module. None of
263them are exported by default, but export tag C<:all> exports all of
264them.
265
266=head2 format_pass
267
268 print format_pass( $pass, ... );
269
270This subroutine converts the given C<$pass>es (which are references to
271the hashes returned by the C<My::Module::TLE> C<pass()>
272method) to a string. The output contains the events of the passes one
273per line, with date and time (ISO-8601-ish, GMT), azimuth, elevation and
274range (or blanks if not present), illumination, and event name for each
275pass.  For appulses the time, position, and name of the appulsed body
276are also provided, on a line after the event.
277
278=head2 format_time
279
280 print format_time( $pass->{time} );
281
282This subroutine converts a given Perl time into an ISO-8601-ish GMT
283time. It is used by C<format_pass()>.
284
285=head2 magnitude
286
287 magnitude( $tle, $station, $time, $want, $name );
288 magnitude( $tle, $time, $want, $name );
289
290This subroutine tests whether the magnitude of the satellite specified
291by C<$tle>, seen from the given C<$station> at the given C<$time>, has
292the value C<$want> to one decimal place. Argument C<$name> is the name
293of the test.
294
295If argument C<$station> is omitted, the C<station> attribute of the TLE
296is used.
297
298=head2 tolerance
299
300 tolerance $got, $want, $tolerance, $title, $formatter
301
302This subroutine runs a test, to see if the absolute value of
303C<$got - $want> is less than C<$tolerance>. If so, the test passes. If
304not, it fails. This subroutine computes the passage or failure, but does
305a C<< goto &Test::More::ok >> to generate the appropriate TAP output.
306However, if the test is going to fail, the title is modified to include
307the C<$got> and C<$want> values, their difference, and the tolerance.
308
309The C<$formatter> argument is optional. If specified, it is a reference
310to code used to format the C<$got> and C<$want> values for display if
311the test fails. The formatter will be called with a single argument,
312which is the value to display.
313
314=head2 tolerance_frac
315
316 tolerance_frac $got, $want, $tolerance, $title
317
318This subroutine is a variant on C<tolerance()> in which the tolerance is
319expressed as a fraction of the C<$want> value. It is actually just a
320stub that replaces the C<$tolerance> argument by
321C<< abs( $want * $tolerance ) >> and then does a C<goto &tolerance>.
322
323=head1 SUPPORT
324
325Support is by the author. Please file bug reports at
326L<https://rt.cpan.org/Public/Dist/Display.html?Name=Astro-satpass>,
327L<https://github.com/trwyant/perl-Astro-Coord-ECI/issues>, or in
328electronic mail to the author.
329
330=head1 AUTHOR
331
332Thomas R. Wyant, III F<wyant at cpan dot org>
333
334=head1 COPYRIGHT AND LICENSE
335
336Copyright (C) 2011-2021 by Thomas R. Wyant, III
337
338This program is free software; you can redistribute it and/or modify it
339under the same terms as Perl 5.10.0. For more details, see the full text
340of the licenses in the directory LICENSES.
341
342This program is distributed in the hope that it will be useful, but
343without any warranty; without even the implied warranty of
344merchantability or fitness for a particular purpose.
345
346=cut
347
348# ex: set textwidth=72 :
349