1package My::Module::Test;
2
3use 5.006002;
4
5use strict;
6use warnings;
7
8use Exporter;
9
10our @ISA = qw{ Exporter };
11
12use HTTP::Date;
13use HTTP::Status qw{ :constants };
14use Test::More 0.96;	# For subtest
15
16our $VERSION = '0.148';
17
18# Set the following to zero if Space Track (or any other SSL host)
19# starts using a certificate that can not be verified.
20use constant VERIFY_HOSTNAME => defined $ENV{SPACETRACK_VERIFY_HOSTNAME}
21    ? $ENV{SPACETRACK_VERIFY_HOSTNAME}
22    : 0;
23
24our @EXPORT =		## no critic (ProhibitAutomaticExportation)
25qw{
26    is_error
27    is_error_or_skip
28    is_not_success
29    is_success
30    is_success_or_skip
31    last_modified
32    most_recent_http_response
33    not_defined
34    site_check
35    spacetrack_user
36    spacetrack_skip_no_prompt
37    skip_site
38    throws_exception
39    VERIFY_HOSTNAME
40};
41
42use constant HASH_REF	=> ref {};
43use constant REGEXP_REF	=> ref qr{};
44
45use constant NO_SPACE_TRACK_ACCOUNT => 'No Space-Track account provided';
46
47# Deliberately not localized, to prevent unwanted settings from sneaking
48# in from the user's identity file.
49$Astro::SpaceTrack::SPACETRACK_IDENTITY_KEY = {
50    map { $_ => 1 } qw{ username password } };
51
52my $rslt;
53
54sub is_error {		## no critic (RequireArgUnpacking)
55    my ( $obj, $method, @args ) = @_;
56    my ( $code, $name ) = splice @args, -2, 2;
57    $rslt = eval { $obj->$method( @args ) };
58    $rslt or do {
59	@_ = ( "$name threw exception: $@" );
60	goto \&fail;
61    };
62    @_ = ( $rslt->code() == $code, $name );
63    goto &ok;
64}
65
66sub is_error_or_skip {		## no critic (RequireArgUnpacking)
67    my ( $obj, $method, @args ) = @_;
68    local $Test::Builder::Level = $Test::Builder::Level + 1;
69    my ( $code, $name ) = splice @args, -2, 2;
70    $rslt = eval { $obj->$method( @args ) };
71    $rslt
72	or return fail "$name threw exception: $@";
73    my $got = $rslt->code();
74    __skip_if_server_error( $method, $got );
75    return cmp_ok $got, '==', $code, $name;
76}
77
78sub is_not_success {	## no critic (RequireArgUnpacking)
79    my ( $obj, $method, @args ) = @_;
80    my $name = pop @args;
81    $rslt = eval { $obj->$method( @args ) };
82    $rslt or do {
83	@_ = ( "$name threw exception: $@" );
84	goto \&fail;
85    };
86    @_ = ( ! $rslt->is_success(), $name );
87    goto &ok;
88}
89
90sub is_success {	## no critic (RequireArgUnpacking)
91    my ( $obj, $method, @args ) = @_;
92    my $name = pop @args;
93    $rslt = eval { $obj->$method( @args ) }
94	or do {
95	@_ = ( "$name threw exception: $@" );
96	chomp $_[0];
97	goto \&fail;
98    };
99    $rslt->is_success() or $name .= ": " . $rslt->status_line();
100    @_ = ( $rslt->is_success(), $name );
101    goto &ok;
102}
103
104sub is_success_or_skip {	## no critic (RequireArgUnpacking)
105    my ( $obj, $method, @args ) = @_;
106    local $Test::Builder::Level = $Test::Builder::Level + 1;
107    my $skip = pop @args;
108    $skip =~ m/ [^0-9] /smx
109	and fail "Skip number '$skip' not numeric";
110    my $name = pop @args;
111    $rslt = eval { $obj->$method( @args ) } or do {
112	fail "$name threw exception: $!" ;
113	skip "$method() threw exception", $skip;
114    };
115    __skip_if_server_error( $method, $rslt->code(), $skip );
116    ok $rslt->is_success(), $name
117	or do {
118	diag $rslt->status_line();
119	skip "$method() failed", $skip;
120    };
121    return 1;
122}
123
124
125sub last_modified {
126    $rslt
127	or return;
128    foreach my $hdr ( $rslt->header( 'Last-Modified' ) ) {
129	return str2time( $hdr );
130    }
131    return;
132}
133
134sub most_recent_http_response {
135    return $rslt;
136}
137
138sub not_defined {
139    @_ = ( ! defined $_[0], @_[1 .. $#_] );
140    goto &ok;
141}
142
143# Prompt the user. DO NOT call this if $ENV{AUTOMATED_TESTING} is set.
144
145{
146    my ( $set_read_mode, $readkey_loaded );
147
148    BEGIN {
149	eval {
150	    require Term::ReadKey;
151	    $set_read_mode = Term::ReadKey->can( 'ReadMode' );
152	    $readkey_loaded = 1;
153	    1;
154	} or $set_read_mode = sub {};
155
156	local $@ = undef;
157	eval {		## no critic (RequireCheckingReturnValueOfEval)
158	    require IO::Handle;
159	    STDERR->autoflush( 1 );
160	};
161    }
162
163    sub prompt {
164	my @args = @_;
165	my $opt = HASH_REF eq ref $args[0] ? shift @args : {};
166	$readkey_loaded
167	    or not $opt->{password}
168	    or push @args, '(ECHOED)';
169	print STDERR "@args: ";
170	# We're a test, and we're trying to be lightweight.
171	$opt->{password}
172	    and $set_read_mode->( 2 );
173	my $input = <STDIN>;	## no critic (ProhibitExplicitStdin)
174	if ( $opt->{password} ) {
175	    $set_read_mode->( 0 );
176	    $readkey_loaded
177		and print STDERR "\n\n";
178	}
179	defined $input
180	    and chomp $input;
181	return $input;
182    }
183
184}
185
186
187# Determine whether a given web site is to be skipped.
188
189{
190    my %info;
191    my %skip_site;
192    BEGIN {
193	%info = (
194	    'celestrak.com'	=> {
195		url	=> 'https://celestrak.com/',
196	    },
197	    'mike.mccants'	=> {
198		url	=> 'http://www.prismnet.com/~mmccants/',
199	    },
200	    'rod.sladen'	=> {
201		url	=> 'http://www.rod.sladen.org.uk/iridium.htm',
202	    },
203	    'spaceflight.nasa.gov'	=> {
204		# url	=> 'http://spaceflight.nasa.gov',
205		url	=> 'https://spaceflight.nasa.gov/realdata/elements/index.html'
206	    },
207	    'www.amsat.org'	=> {
208		url	=> 'https://www.amsat.org/',
209	    },
210	    'www.space-track.org'	=> {
211		url	=> 'https://www.space-track.org/',
212		check	=> \&__spacetrack_skip,
213	    }
214	);
215
216	%skip_site = (
217	    'spaceflight.nasa.gov'	=> 'Site retired',
218	);
219
220	if ( defined $ENV{ASTRO_SPACETRACK_SKIP_SITE} ) {
221	    foreach my $site ( split qr{ \s* , \s* }smx,
222		$ENV{ASTRO_SPACETRACK_SKIP_SITE} ) {
223		exists $info{$site}{url}
224		    and $skip_site{$site} = "$site skipped by user request";
225	    }
226	}
227    }
228
229    sub __site_to_check_uri {
230	my ( $site ) = @_;
231	return $info{$site}{url};
232    }
233
234    my $ua;
235
236    sub set_skip {
237	my ( $site, $skip ) = @_;
238	exists $info{$site}{url}
239	    or die "Programming error. '$site' unknown";
240	$skip_site{$site} = $skip;
241	return;
242    }
243
244    sub site_check {
245	my @sites = @_;
246	my @rslt = grep { defined $_ } map { _site_check( $_ ) } @sites
247	    or return;
248	return join '; ', @rslt;
249    }
250
251    sub _site_check {
252	my ( $site ) = @_;
253	exists $skip_site{$site} and return $skip_site{$site};
254	my $url = __site_to_check_uri( $site ) or do {
255	    my $skip = "Programming error - No known url for '$site'";
256	    diag( $skip );
257	    return ( $skip_site{$site} = $skip );
258	};
259
260	{
261	    no warnings qw{ once };
262	    $Astro::SpaceTrack::Test::SKIP_SITES
263		and return ( $skip_site{$site} =
264		"$site skipped: $Astro::SpaceTrack::Test::SKIP_SITES"
265	    );
266	}
267
268	$ua ||= LWP::UserAgent->new(
269	    agent	=> 'curl/7.77.0',
270	    ssl_opts	=> { verify_hostname => VERIFY_HOSTNAME },
271	);
272	my $rslt = $ua->get( $url );
273	Astro::SpaceTrack::__tweak_response( $rslt );
274	$rslt->is_success()
275	    or return ( $skip_site{$site} =
276		"$site not available: " . $rslt->status_line() );
277	if ( $info{$site}{check} and my $check = $info{$site}{check}->() ) {
278	    return ( $skip_site{$site} = $check );
279	}
280	return ( $skip_site{$site} = undef );
281    }
282}
283
284{
285    my @is_server_error;
286
287    BEGIN {
288	foreach my $inx (
289	    HTTP_INTERNAL_SERVER_ERROR,
290	) {
291	    $is_server_error[$inx] = 1;
292	}
293    }
294
295    sub __skip_if_server_error {
296	my ( $method, $code, $skip ) = @_;
297	$is_server_error[$code]
298	    or return;
299	skip "$method() encountered server error $code", ( $skip || 0 ) + 1;
300    }
301}
302
303sub __spacetrack_identity {
304    # The following needs to be armor-plated so that a compilation
305    # failure does not shut down the testing system (though maybe it
306    # should!)
307    local $@ = undef;
308    return eval {	## no critic (RequireCheckingReturnValueOfEval)
309	local @INC = @INC;
310	require blib;
311	blib->import();
312	require Astro::SpaceTrack;
313	-f Astro::SpaceTrack->__identity_file_name()
314	    or return;
315	# Ad-hocery. Under Mac OS X the GPG machinery seems not to work in
316	# an SSH session; a dialog pops up which the originator of the
317	# session has no way to respond to. If the dialog is actually
318	# executed, the primary user's information gets clobbered. If
319	# the identity file is not binary, we assume we don't need GPG,
320	# because that is what Config::Identity assumes.
321	Astro::SpaceTrack->__identity_file_is_encrypted()
322	    and $ENV{SSH_CONNECTION}
323	    and return;
324	my $id = Astro::SpaceTrack->__spacetrack_identity();
325	defined $id->{username} && defined $id->{password} &&
326	    "$id->{username}/$id->{password}";
327    };
328    return;
329}
330
331{
332    my $spacetrack_auth;
333
334    sub __spacetrack_skip {
335	my ( %arg ) = @_;
336	defined $spacetrack_auth
337	    or $spacetrack_auth = $ENV{SPACETRACK_USER};
338	defined $spacetrack_auth
339	    and $spacetrack_auth =~ m< \A [:/] \z >smx
340	    and return NO_SPACE_TRACK_ACCOUNT;
341	$spacetrack_auth
342	    and return;
343	$ENV{AUTOMATED_TESTING}
344	    and return 'Automated testing and SPACETRACK_USER not set.';
345	$spacetrack_auth = __spacetrack_identity()
346	    and do {
347	    $arg{envir}
348		and $ENV{SPACETRACK_USER} = $spacetrack_auth; ## no critic (RequireLocalizedPunctuationVars)
349	    return;
350	};
351	$arg{no_prompt}
352	    and return $arg{no_prompt};
353	$^O eq 'VMS' and do {
354	    warn <<'EOD';
355
356Several tests will be skipped because you have not provided logical
357name SPACETRACK_USER. This should be set to your Space Track username
358and password, separated by a slash ("/") character.
359
360EOD
361	    return 'No Space-Track account provided.';
362	};
363	warn <<'EOD';
364
365Several tests require the username and password of a registered Space
366Track user. Because you have not provided environment variable
367SPACETRACK_USER, you will be prompted for this information. The password
368will be echoed unless Term::ReadKey is installed and supports ReadMode.
369If you leave either username or password blank, the tests will be
370skipped.
371
372If you set environment variable SPACETRACK_USER to your Space Track
373username and password, separated by a slash ("/") character, that
374username and password will be used, and you will not be prompted.
375
376You may also supress prompts by setting the AUTOMATED_TESTING
377environment variable to any value Perl takes as true. This is
378equivalent to not specifying a username, and tests that require a
379username will be skipped.
380
381EOD
382
383	my $user = prompt( 'Space-Track username' )
384	    and my $pass = prompt( { password => 1 }, 'Space-Track password' )
385	    or do {
386	    $ENV{SPACETRACK_USER} = '/'; ## no critic (RequireLocalizedPunctuationVars)
387	    return NO_SPACE_TRACK_ACCOUNT;
388	};
389	$ENV{SPACETRACK_USER} = $spacetrack_auth = "$user/$pass"; ## no critic (RequireLocalizedPunctuationVars)
390	return;
391    }
392}
393
394sub spacetrack_skip_no_prompt {
395    my $skip;
396    $ENV{SPACETRACK_TEST_LIVE}
397	or plan skip_all => 'SPACETRACK_TEST_LIVE not set';
398    defined( $skip = __spacetrack_skip(
399	    envir	=> 1,
400	    no_prompt	=> NO_SPACE_TRACK_ACCOUNT,
401	)
402    ) and plan skip_all => $skip;
403    return;
404}
405
406sub spacetrack_user {
407    __spacetrack_skip( envir => 1 );
408    return;
409}
410
411sub throws_exception {	## no critic (RequireArgUnpacking)
412    my ( $obj, $method, @args ) = @_;
413    my $name = pop @args;
414    my $exception = pop @args;
415    REGEXP_REF eq ref $exception
416	or $exception = qr{\A$exception};
417    $rslt = eval { $obj->$method( @args ) }
418	and do {
419	@_ = ( "$name throw no exception. Status: " .
420	    $rslt->status_line() );
421	goto &fail;
422    };
423    @_ = ( $@, $exception, $name );
424    goto &like;
425}
426
427
4281;
429
430__END__
431
432=head1 NAME
433
434My::Module::Test - Test routines for Astro::SpaceTrack
435
436=head1 SYNOPSIS
437
438 use Astro::SpaceTrack;
439
440 use lib qw{ inc };
441 use My::Module::Test;
442
443 my $st = Astro::SpaceTrack->new();
444
445 is_success $st, fubar => 42,
446     'fubar( 42 ) succeeds';
447
448 my $resp = most_recent_http_response;
449 is $resp->content(), 'XLII',
450     q<fubar( 42 ) returned 'XLII'>;
451
452=head1 DESCRIPTION
453
454This Perl module contains testing routines for Astro::SpaceTrack. Some
455of them actually perform tests, others perform whatever miscellany of
456functions seemed appropriate.
457
458Everything in this module is B<private> to the C<Astro::SpaceTrack>
459package. The author reserves the right to change or revoke anything here
460without notice.
461
462=head1 SUBROUTINES
463
464This package exports the following subroutines, all by default.
465
466=head2 is_error
467
468 is_error $st, fubar => 42,
469     404,
470     'Make sure $st->fubar( 42 ) returns a 404';
471
472This subroutine executes the given method and tests its result code for
473numeric equality to the given code.  The method is assumed to return an
474HTTP::Response object. The arguments are:
475
476  - The method's invocant
477  - The method's name
478  - Zero or more arguments
479  - The expected HTTP status code
480  - The test name
481
482=head2 is_error_or_skip
483
484 is_error $st, fubar => 42,
485     404,
486     'Make sure $st->fubar( 42 ) returns a 404';
487
488This subroutine is like C<is_error(), but if the returned status is 500,
489the test is skipped.
490
491=head2 is_not_success
492
493 is_not_success $st, fubar => 42,
494     'Make sure $st->fubar( 42 ) fails';
495
496This subroutine executes the given method and tests its result for
497failure. The method is assumed to return an HTTP::Response object. The
498arguments are:
499
500  - The method's invocant
501  - The method's name
502  - Zero or more arguments
503  - The test name
504
505=head2 is_success
506
507 is_success $st, fubar => 42,
508     'Make sure $st->fubar( 42 ) succeeds';
509
510This subroutine executes the given method and tests its result for
511success. The method is assumed to return an HTTP::Response object. The
512arguments are:
513
514  - The method's invocant
515  - The method's name
516  - Zero or more arguments
517  - The test name
518
519=head2 is_success_or_skop
520
521 is_success_or_skip $st, fubar => 42,
522     'Make sure $st->fubar( 42 ) succeeds', 3;
523
524This subroutine is like C<is_success>, but if a problem occurs the
525number of tests given by the last argument is skipped. The skip argument
526assumes that the current test is B<not> skipped. If a 500 error is
527encountered, the current test B<is> skipped, and the number of tests
528skipped is the skip argument plus 1.
529
530=head2 last_modified
531
532This subroutine returns the value of the C<Last-Modified> header from
533the most recent HTTP::Respose object, as a Perl time. If there is no
534HTTP::Response, or if it did not contain that header, C<undef> is
535returned.
536
537=head2 most_recent_http_response
538
539 my $resp = most_recent_http_response;
540 $resp->is_success()
541     or diag $resp->status_line();
542
543This subroutine returns the HTTP::Response object from the most-recent
544test that actually generated one.
545
546=head2 not_defined
547
548 not_defined $resp, 'Make sure we have a response';
549
550This subroutine performs a test which succeeds its first argument is not
551defined. The second argument is the test name.
552
553=head2 set_skip
554
555 set_skip 'spaceflight.nasa.gov';
556 set_skip 'spaceflight.nasa.gov', 'Manually skipping';
557
558This subroutine sets or clears the skip indicator for the given site.
559The first argument is the site name, which must appear on the list
560supported by L<site_check|/site_check>. The second argument is optional
561and represents the skip message, if any.
562
563=head2 site_check
564
565 site_check 'spaceflight.nasa.gov', 'celestrak.com';
566
567This subroutine tests a preselected URL on the given sites, and sets the
568skip indicator appropriately. Allowed site names are:
569
570 celestrak.com
571 mike.mccants
572 rod.sladen
573 spaceflight.nasa.gov
574 www.amsat.org
575 www.space-track.org
576
577=head2 spacetrack_user
578
579If C<$ENV{SPACETRACK_USER}> is not set, this subroutine sets it to
580whatever value is obtained from the identity file if available, or by
581prompting the user. The environment variable is B<not> localized.
582
583=head2 throws_exception
584
585 is_error $st, fubar => 666,
586     'The exception of the beast',
587     'Make sure $st->fubar( 666 ) throws the correct exception';
588
589This subroutine executes the given method and succeeds if the method
590throws the expected exception. The arguments are:
591
592  - The method's invocant
593  - The method's name
594  - Zero or more arguments
595  - The expected exception
596  - The test name
597
598The exception can be specified either as a Regexp object or as a scalar.
599In the latter case the scalar is expected to match at the beginning of
600the exception text.
601
602=head1 SUPPORT
603
604Support is by the author. Please file bug reports at
605L<https://rt.cpan.org/Public/Dist/Display.html?Name=Astro-SpaceTrack>,
606L<https://github.com/trwyant/perl-Astro-SpaceTrack/issues/>, or in
607electronic mail to the author.
608
609=head1 AUTHOR
610
611Thomas R. Wyant, III F<wyant at cpan dot org>
612
613=head1 COPYRIGHT AND LICENSE
614
615Copyright (C) 2014-2021 by Thomas R. Wyant, III
616
617This program is free software; you can redistribute it and/or modify it
618under the same terms as Perl 5.10.0. For more details, see the full text
619of the licenses in the directory LICENSES.
620
621This program is distributed in the hope that it will be useful, but
622without any warranty; without even the implied warranty of
623merchantability or fitness for a particular purpose.
624
625=cut
626
627# ex: set textwidth=72 :
628