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";
    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 = <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/',

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

=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.

Everything in this module is B<private> to the C<Astro::SpaceTrack>
package. The author reserves the right to change or revoke anything here
without notice.

=head1 SUBROUTINES

This package exports the following subroutines, all by default.

=head2 is_error

 is_error $st, fubar => 42,
     404,
     'Make sure $st->fubar( 42 ) returns a 404';

This subroutine executes the given method and tests its result code for
numeric equality to the given code.  The method is assumed to return an
HTTP::Response object. The arguments are:

  - The method's invocant
  - The method's name
  - Zero or more arguments
  - The expected HTTP status code
  - The test name

=head2 is_error_or_skip

 is_error $st, fubar => 42,
     404,
     'Make sure $st->fubar( 42 ) returns a 404';

This subroutine is like C<is_error(), but if the returned status is 500,
the test is skipped.

=head2 is_not_success

 is_not_success $st, fubar => 42,
     'Make sure $st->fubar( 42 ) fails';

This subroutine executes the given method and tests its result for
failure. The method is assumed to return an HTTP::Response object. The
arguments are:

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

=head2 is_success

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

This subroutine executes the given method and tests its result for
success. The method is assumed to return an HTTP::Response object. The
arguments are:

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

=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