File Coverage

inc/My/Module/Test.pm

Criterion	Covered	Total	%
statement	108	193	55.9
branch	19	86	22.0
condition	2	23	8.7
subroutine	26	35	74.2
pod	11	14	78.5
total	166	351	47.2

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.180';

# 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";
    my $name = pop @args;
    $rslt = eval { $obj->$method( @args ) } or do {
	fail "$name threw exception: $!" ;
	skip "$method() threw exception", $skip;
    };
    __skip_if_server_error( $method, $rslt->code(), $skip );
    ok $rslt->is_success(), $name
	or do {
	diag $rslt->status_line();
	skip "$method() failed", $skip;
    };
    return 1;
}


sub last_modified {
    $rslt
	or return;
    foreach my $hdr ( $rslt->header( 'Last-Modified' ) ) {
	return str2time( $hdr );
    }
    return;
}

sub most_recent_http_response {
    return $rslt;
}

sub not_defined {
    @_ = ( ! defined $_[0], @_[1 .. $#_] );
    goto &ok;
}

# Prompt the user. DO NOT call this if $ENV{AUTOMATED_TESTING} is set.

{
    my ( $set_read_mode, $readkey_loaded );

    BEGIN {
	eval {
	    require Term::ReadKey;
	    $set_read_mode = Term::ReadKey->can( 'ReadMode' );
	    $readkey_loaded = 1;
	    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 = ;	## 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__