Astro-SpaceTrack
13 results

 view release on metacpan or  search on metacpan

inc/My/Module/Test.pm  view on Meta::CPAN 

package My::Module::Test;

use 5.006002;

use strict;
use warnings;

use Exporter;

our @ISA = qw{ Exporter };

use HTTP::Date;
use HTTP::Status qw{ :constants };
use Test::More 0.96;	# For subtest

our $VERSION = '0.181';

# Set the following to zero if Space Track (or any other SSL host)
# starts using a certificate that can not be verified.
use constant VERIFY_HOSTNAME => defined $ENV{SPACETRACK_VERIFY_HOSTNAME}
    ? $ENV{SPACETRACK_VERIFY_HOSTNAME}
    : 0;

our @EXPORT =		## no critic (ProhibitAutomaticExportation)
qw{
    is_error
    is_error_or_skip
    is_not_success
    is_success
    is_success_or_skip
    last_modified
    most_recent_http_response
    not_defined
    site_check
    spacetrack_user
    spacetrack_skip_no_prompt
    skip_site
    throws_exception
    VERIFY_HOSTNAME
};

use constant HASH_REF	=> ref {};
use constant REGEXP_REF	=> ref qr{};

use constant NO_SPACE_TRACK_ACCOUNT => 'No Space-Track account provided';

# Deliberately not localized, to prevent unwanted settings from sneaking
# in from the user's identity file.
$Astro::SpaceTrack::SPACETRACK_IDENTITY_KEY = {
    map { $_ => 1 } qw{ username password } };

my $rslt;

sub is_error {		## no critic (RequireArgUnpacking)
    my ( $obj, $method, @args ) = @_;
    my ( $code, $name ) = splice @args, -2, 2;
    $rslt = eval { $obj->$method( @args ) };
    $rslt or do {
	@_ = ( "$name threw exception: $@" );
	goto \&fail;
    };
    @_ = ( $rslt->code() == $code, $name );
    goto &ok;
}

sub is_error_or_skip {		## no critic (RequireArgUnpacking)
    my ( $obj, $method, @args ) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my ( $code, $name ) = splice @args, -2, 2;
    $rslt = eval { $obj->$method( @args ) };
    $rslt
	or return fail "$name threw exception: $@";
    my $got = $rslt->code();
    __skip_if_server_error( $method, $got );
    return cmp_ok $got, '==', $code, $name;
}

sub is_not_success {	## no critic (RequireArgUnpacking)
    my ( $obj, $method, @args ) = @_;
    my $name = pop @args;
    $rslt = eval { $obj->$method( @args ) };
    $rslt or do {
	@_ = ( "$name threw exception: $@" );
	goto \&fail;
    };
    @_ = ( ! $rslt->is_success(), $name );
    goto &ok;
}

sub is_success {	## no critic (RequireArgUnpacking)
    my ( $obj, $method, @args ) = @_;
    my $name = pop @args;
    $rslt = eval { $obj->$method( @args ) }
	or do {
	@_ = ( "$name threw exception: $@" );
	chomp $_[0];
	goto \&fail;
    };
    $rslt->is_success() or $name .= ": " . $rslt->status_line();
    @_ = ( $rslt->is_success(), $name );
    goto &ok;
}

sub is_success_or_skip {	## no critic (RequireArgUnpacking)
    my ( $obj, $method, @args ) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my $skip = pop @args;
    $skip =~ m/ [^0-9] /smx
	and fail "Skip number '$skip' not numeric";

inc/My/Module/Test.pm  view on Meta::CPAN 

	    1;
	} or $set_read_mode = sub {};

	local $@ = undef;
	eval {		## no critic (RequireCheckingReturnValueOfEval)
	    require IO::Handle;
	    STDERR->autoflush( 1 );
	};
    }

    sub prompt {
	my @args = @_;
	my $opt = HASH_REF eq ref $args[0] ? shift @args : {};
	$readkey_loaded
	    or not $opt->{password}
	    or push @args, '(ECHOED)';
	print STDERR "@args: ";
	# We're a test, and we're trying to be lightweight.
	$opt->{password}
	    and $set_read_mode->( 2 );
	my $input = <STDIN>;	## no critic (ProhibitExplicitStdin)
	if ( $opt->{password} ) {
	    $set_read_mode->( 0 );
	    $readkey_loaded
		and print STDERR "\n\n";
	}
	defined $input
	    and chomp $input;
	return $input;
    }

}


# Determine whether a given web site is to be skipped.

{
    my %info;
    my %skip_site;
    BEGIN {
	%info = (
	    'celestrak.org'	=> {
		url	=> 'https://celestrak.org/',
	    },
	    'mike.mccants'	=> {
		# url	=> 'http://www.prismnet.com/~mmccants/',
		url	=> 'https://www.mmccants.org/',
	    },
	    'rod.sladen'	=> {
		url	=> 'http://www.rod.sladen.org.uk/iridium.htm',
	    },
	    'www.amsat.org'	=> {
		url	=> 'https://www.amsat.org/',
	    },
	    'www.space-track.org'	=> {
		url	=> 'https://www.space-track.org/',
		check	=> \&__spacetrack_skip,
	    }
	);

	if ( defined $ENV{ASTRO_SPACETRACK_SKIP_SITE} ) {
	    foreach my $site ( split qr{ \s* , \s* }smx,
		$ENV{ASTRO_SPACETRACK_SKIP_SITE} ) {
		exists $info{$site}{url}
		    and $skip_site{$site} = "$site skipped by user request";
	    }
	}
    }

    sub __site_to_check_uri {
	my ( $site ) = @_;
	return $info{$site}{url};
    }

    sub __site_codes {
	return sort keys %info;
    }

    my $ua;

    sub set_skip {
	my ( $site, $skip ) = @_;
	exists $info{$site}{url}
	    or die "Programming error. '$site' unknown";
	$skip_site{$site} = $skip;
	return;
    }

    sub site_check {
	my @sites = @_;
	my @rslt = grep { defined $_ } map { _site_check( $_ ) } @sites
	    or return;
	return join '; ', @rslt;
    }

    sub _site_check {
	my ( $site ) = @_;
	exists $skip_site{$site} and return $skip_site{$site};
	my $url = __site_to_check_uri( $site ) or do {
	    my $skip = "Programming error - No known url for '$site'";
	    diag( $skip );
	    return ( $skip_site{$site} = $skip );
	};

	{
	    no warnings qw{ once };
	    $Astro::SpaceTrack::Test::SKIP_SITES
		and return ( $skip_site{$site} =
		"$site skipped: $Astro::SpaceTrack::Test::SKIP_SITES"
	    );
	}

	$ua ||= LWP::UserAgent->new(
	    agent	=> 'curl/7.77.0',
	    ssl_opts	=> { verify_hostname => VERIFY_HOSTNAME },
	);
	my $rslt = $ua->get( $url );
	$rslt->is_success()
	    or return ( $skip_site{$site} =
		"$site not available: " . $rslt->status_line() );
	if ( $info{$site}{check} and my $check = $info{$site}{check}->() ) {
	    return ( $skip_site{$site} = $check );
	}
	return ( $skip_site{$site} = undef );
    }
}

{
    my @is_server_error;

    BEGIN {
	foreach my $inx (
	    HTTP_INTERNAL_SERVER_ERROR,
	) {
	    $is_server_error[$inx] = 1;
	}
    }

    sub __skip_if_server_error {
	my ( $method, $code, $skip ) = @_;
	$is_server_error[$code]
	    or return;
	skip "$method() encountered server error $code", ( $skip || 0 ) + 1;
    }
}

sub __spacetrack_identity {
    # The following needs to be armor-plated so that a compilation
    # failure does not shut down the testing system (though maybe it
    # should!)
    local $@ = undef;
    return eval {	## no critic (RequireCheckingReturnValueOfEval)
	local @INC = @INC;
	require blib;
	blib->import();
	require Astro::SpaceTrack;
	-f Astro::SpaceTrack->__identity_file_name()
	    or return;
	# Ad-hocery. Under Mac OS X the GPG machinery seems not to work in
	# an SSH session; a dialog pops up which the originator of the
	# session has no way to respond to. If the dialog is actually
	# executed, the primary user's information gets clobbered. If
	# the identity file is not binary, we assume we don't need GPG,
	# because that is what Config::Identity assumes.
	Astro::SpaceTrack->__identity_file_is_encrypted()
	    and $ENV{SSH_CONNECTION}
	    and return;
	my $id = Astro::SpaceTrack->__spacetrack_identity();
	defined $id->{username} && defined $id->{password} &&
	    "$id->{username}/$id->{password}";
    };
    return;
}

{
    my $spacetrack_auth;

    sub __spacetrack_skip {
	my ( %arg ) = @_;
	defined $spacetrack_auth
	    or $spacetrack_auth = $ENV{SPACETRACK_USER};
	defined $spacetrack_auth
	    and $spacetrack_auth =~ m< \A [:/] \z >smx
	    and return NO_SPACE_TRACK_ACCOUNT;
	$spacetrack_auth
	    and return;
	$ENV{AUTOMATED_TESTING}
	    and return 'Automated testing and SPACETRACK_USER not set.';
	$spacetrack_auth = __spacetrack_identity()
	    and do {
	    $arg{envir}
		and $ENV{SPACETRACK_USER} = $spacetrack_auth; ## no critic (RequireLocalizedPunctuationVars)
	    return;
	};
	$arg{no_prompt}
	    and return $arg{no_prompt};
	$^O eq 'VMS' and do {
	    warn <<'EOD';

Several tests will be skipped because you have not provided logical
name SPACETRACK_USER. This should be set to your Space Track username
and password, separated by a slash ("/") character.

EOD
	    return 'No Space-Track account provided.';
	};
	warn <<'EOD';

Several tests require the username and password of a registered Space
Track user. Because you have not provided environment variable
SPACETRACK_USER, you will be prompted for this information. The password
will be echoed unless Term::ReadKey is installed and supports ReadMode.
If you leave either username or password blank, the tests will be
skipped.

If you set environment variable SPACETRACK_USER to your Space Track
username and password, separated by a slash ("/") character, that
username and password will be used, and you will not be prompted.

You may also supress prompts by setting the AUTOMATED_TESTING
environment variable to any value Perl takes as true. This is
equivalent to not specifying a username, and tests that require a
username will be skipped.

EOD

	my $user = prompt( 'Space-Track username' )
	    and my $pass = prompt( { password => 1 }, 'Space-Track password' )
	    or do {
	    $ENV{SPACETRACK_USER} = '/'; ## no critic (RequireLocalizedPunctuationVars)
	    return NO_SPACE_TRACK_ACCOUNT;
	};
	$ENV{SPACETRACK_USER} = $spacetrack_auth = "$user/$pass"; ## no critic (RequireLocalizedPunctuationVars)
	return;
    }
}

sub spacetrack_skip_no_prompt {
    my $skip;
    $ENV{SPACETRACK_TEST_LIVE}
	or plan skip_all => 'SPACETRACK_TEST_LIVE not set';
    defined( $skip = __spacetrack_skip(
	    envir	=> 1,
	    no_prompt	=> NO_SPACE_TRACK_ACCOUNT,
	)
    ) and plan skip_all => $skip;
    return;
}

sub spacetrack_user {
    __spacetrack_skip( envir => 1 );
    return;
}

sub throws_exception {	## no critic (RequireArgUnpacking)
    my ( $obj, $method, @args ) = @_;
    my $name = pop @args;
    my $exception = pop @args;
    REGEXP_REF eq ref $exception
	or $exception = qr{\A$exception};
    $rslt = eval { $obj->$method( @args ) }
	and do {
	@_ = ( "$name throw no exception. Status: " .
	    $rslt->status_line() );
	goto &fail;
    };
    @_ = ( $@, $exception, $name );
    goto &like;
}


1;

__END__

=head1 NAME

My::Module::Test - Test routines for Astro::SpaceTrack

=head1 SYNOPSIS

 use Astro::SpaceTrack;

 use lib qw{ inc };
 use My::Module::Test;

 my $st = Astro::SpaceTrack->new();

 is_success $st, fubar => 42,
     'fubar( 42 ) succeeds';

 my $resp = most_recent_http_response;
 is $resp->content(), 'XLII',
     q<fubar( 42 ) returned 'XLII'>;

=head1 DESCRIPTION

This Perl module contains testing routines for Astro::SpaceTrack. Some
of them actually perform tests, others perform whatever miscellany of
functions seemed appropriate.

inc/My/Module/Test.pm  view on Meta::CPAN 


=head2 is_success_or_skop

 is_success_or_skip $st, fubar => 42,
     'Make sure $st->fubar( 42 ) succeeds', 3;

This subroutine is like C<is_success>, but if a problem occurs the
number of tests given by the last argument is skipped. The skip argument
assumes that the current test is B<not> skipped. If a 500 error is
encountered, the current test B<is> skipped, and the number of tests
skipped is the skip argument plus 1.

=head2 last_modified

This subroutine returns the value of the C<Last-Modified> header from
the most recent HTTP::Respose object, as a Perl time. If there is no
HTTP::Response, or if it did not contain that header, C<undef> is
returned.

=head2 most_recent_http_response

 my $resp = most_recent_http_response;
 $resp->is_success()
     or diag $resp->status_line();

This subroutine returns the HTTP::Response object from the most-recent
test that actually generated one.

=head2 not_defined

 not_defined $resp, 'Make sure we have a response';

This subroutine performs a test which succeeds its first argument is not
defined. The second argument is the test name.

=head2 set_skip

 set_skip 'celestrak.org';
 set_skip 'celestrak.org', 'Manually skipping';

This subroutine sets or clears the skip indicator for the given site.
The first argument is the site name, which must appear on the list
supported by L<site_check|/site_check>. The second argument is optional
and represents the skip message, if any.

=head2 site_check

 site_check 'www.amsat.org', 'celestrak.org';

This subroutine tests a preselected URL on the given sites, and sets the
skip indicator appropriately. Allowed site names are:

 celestrak.org
 mike.mccants
 rod.sladen
 www.amsat.org
 www.space-track.org

=head2 spacetrack_user

If C<$ENV{SPACETRACK_USER}> is not set, this subroutine sets it to
whatever value is obtained from the identity file if available, or by
prompting the user. The environment variable is B<not> localized.

=head2 throws_exception

 is_error $st, fubar => 666,
     'The exception of the beast',
     'Make sure $st->fubar( 666 ) throws the correct exception';

This subroutine executes the given method and succeeds if the method
throws the expected exception. The arguments are:

  - The method's invocant
  - The method's name
  - Zero or more arguments
  - The expected exception
  - The test name

The exception can be specified either as a Regexp object or as a scalar.
In the latter case the scalar is expected to match at the beginning of
the exception text.

=head1 SUPPORT

Support is by the author. Please file bug reports at
L<https://rt.cpan.org/Public/Dist/Display.html?Name=Astro-SpaceTrack>,
L<https://github.com/trwyant/perl-Astro-SpaceTrack/issues/>, or in
electronic mail to the author.

=head1 AUTHOR

Thomas R. Wyant, III F<wyant at cpan dot org>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2014-2026 by Thomas R. Wyant, III

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl 5.10.0. For more details, see the full text
of the licenses in the files F<LICENSE-Artistic> and F<LICENSE-GPL>.

This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.

=cut

# ex: set textwidth=72 :



( run in 1.736 second using v1.01-cache-2.11-cpan-75ffa21a3d4 )