File Coverage

inc/My/Module/Test/App.pm

Criterion	Covered	Total	%
statement	159	261	60.9
branch	31	82	37.8
condition	11	25	44.0
subroutine	37	51	72.5
pod	14	19	73.6
total	252	438	57.5

package My::Module::Test::App;

use 5.008;

use strict;
use warnings;

use Exporter ();
our @ISA = qw{ Exporter };

use Carp;

use Cwd qw{ abs_path };
use Getopt::Long 2.39 ();
use POSIX qw{ strftime };
use Scalar::Util 1.26 qw{ blessed };
use Test2::V0;
use Test2::Util::Table qw{ table };

use constant CODE_REF	=> ref sub {};
use constant REGEXP_REF	=> ref qr{};

our @EXPORT = qw{
    any_greg_time_gm
    any_greg_time_local
    call_m
    call_m_result
    check_access
    check_datetime_timezone_local
    dependencies_table
    dt_greg_time_gm
    dt_greg_time_local
    dump_date_manip
    dump_date_manip_init
    dump_zones
    dump_zones_init
    execute
    invocant
    klass
    load_or_skip
    mock_usgs
    normalize_path
    same_path
    setup_app_mocker
    FALSE
    INSTANTIATE
    TRUE
};

{
    local $@ = undef;

    use constant HAVE_DATETIME => eval {
	require DateTime;
	require DateTime::TimeZone;
	1;
    } || 0;
}

BEGIN {
    # If I should need to write a test that uses a dirty environment (or
    # at least wants something in $ENV{TZ}) the plan is to handle it via
    # the import mechanism. See @EXPORT_FAIL, which is good back to at
    # least 5.12. Except this may be causing problems with CPAN Testers
    # machines set up correctly for zones other than their default.
    # delete $ENV{TZ};

    # Note that we have to load Astro::App::Satpass2 this way because we
    # need to clean up the environment before we do the load.
    require Astro::App::Satpass2;
    Astro::App::Satpass2->import();
}

my $app = 'Astro::App::Satpass2';

use constant FALSE => sub {
    shift;
    $_[0] = !$_[0];
    goto &ok;
};

use constant INSTANTIATE => sub {
    shift;
    $app = $_[0];
    goto &ok;
};

use constant TRUE => sub {
    shift;
    goto &ok;
};

if ( HAVE_DATETIME ) {
    *any_greg_time_gm = \&dt_greg_time_gm;
    *any_greg_time_local = \&dt_greg_time_local;
} else {
    require Astro::Coord::ECI::Utils;
    Astro::Coord::ECI::Utils->VERSION( 0.112 );
    *any_greg_time_gm = \&Astro::Coord::ECI::Utils::greg_time_gm;
    *any_greg_time_local = \&Astro::Coord::ECI::Utils::greg_time_local;
}

sub invocant {
    return $app;
}

sub check_access {
    my ( $url ) = @_;

    local $@ = undef;

    eval {
	require LWP::UserAgent;
	1;
    } or return 'Can not load LWP::UserAgent';

    my $ua = LWP::UserAgent->new()
	or return 'Can not instantiate LWP::UserAgent';

    my $rslt = $ua->get( $url )
	or return "Can not get $url";

    $rslt->is_success or return $rslt->status_line;

    return;
}

sub check_datetime_timezone_local {
    local $@ = undef;
    eval {
	require DateTime;
	require DateTime::TimeZone;
	1;
    } or return 1;
    return eval {
	DateTime::TimeZone->new( name => 'local' );
	1;
    };
}

sub klass {
    ( $app ) = @_;
    return;
}

sub _dtz_to_epoch {
    my ( $sec, $min, $hr, $day, $mon, $yr, $zone ) = @_;
    $mon += 1;
    ( my $nano, $sec ) = POSIX::modf( $sec );
    $nano *= 1_000_000_000;
    return DateTime->new(
	year	=> $yr,
	month	=> $mon,
	day	=> $day,
	hour	=> $hr,
	minute	=> $min,
	second	=> $sec,
	nanosecond	=> $nano,
	time_zone	=> $zone,
    )->epoch();
}

{
    my $tz_utc;

    sub dt_greg_time_gm {
	my ( $sec, $min, $hr, $day, $mon, $yr ) = @_;
	$tz_utc ||= DateTime::TimeZone->new( name => 'UTC' );
	return _dtz_to_epoch( $sec, $min, $hr, $day, $mon, $yr, $tz_utc );
    }
}

{
    my $tz_local;

    sub dt_greg_time_local {
	my ( $sec, $min, $hr, $day, $mon, $yr ) = @_;
	$tz_local ||= DateTime::TimeZone->new( name => 'local' );
	return _dtz_to_epoch( $sec, $min, $hr, $day, $mon, $yr, $tz_local );
    }
}

{
    my $dumped;

    sub dump_date_manip {
	my ( $time_tested ) = @_;

	diag '  difference: ', $time_tested - call_m_result();

	$dumped++
	    and return;

	my $vers = Date::Manip->VERSION();

	diag '';

	diag "Date::Manip version: $vers";

	$vers =~ s/ _ //smxg;

	if ( $vers >= 6 ) {

	    diag 'Date::Manip superclasses: ', join ', ', @Date::Manip::ISA;

	    if ( Date::Manip->isa( 'Date::Manip::DM5' ) ) {
		no warnings qw{ once };
		diag '$Cnf{Language}: ', $Date::Manip::DM5::Cnf{Language};
	    }

	}

	if ( my $code = Date::Manip->can( 'Date_TimeZone' ) ) {
	    diag 'Date_TimeZone = ', $code->();
	} else {
	    diag 'Date_TimeZone unavailable';
	}

	if ( $app->isa( 'Astro::App::Satpass2::ParseTime' ) ) {
	    # Only displays for Date::Manip v6 interface
	    $app->can( 'dmd_zone' )
		and diag 'dmd_zone = ', $app->dmd_zone();
	    $app->can( '__epoch_offset' )
		and diag 'epoch_offset = ', $app->__epoch_offset();
	}

	{
	    local $ENV{DATE_MANIP_DEBUG} = 1;
	    local $@ = undef;
	    eval {
		require Date::Manip::TZ;
		my $text;
		open my $fh, '>', \$text;
		local *STDOUT = $fh;
		Date::Manip::TZ->new();
		close $fh;
		diag $text;
	    };
	}

	goto &__dump_zones;
    }

    sub dump_date_manip_init {
	$dumped = undef;
	return;
    }
}

{
    my $dumped;

    sub dump_zones {
	my ( $time_tested ) = @_;

	diag '  difference: ', $time_tested - call_m_result();

	$dumped++
	    and return;

	goto &__dump_zones;
    }

    sub dump_zones_init {
	$dumped = undef;
	return;
    }
}

sub __dump_zones {
    my ( $time_tested ) = @_;

    local $@ = undef;
    if ( eval { require DateTime; 1; } ) {
	diag 'Have DateTime ', DateTime->VERSION();
    } else {
	diag 'DateTime not available';
    }

    if ( eval { require DateTime::TimeZone; 1; } ) {
	diag 'Have DateTime::TimeZone ', DateTime::TimeZone->VERSION();
	my $dt_zone = DateTime::TimeZone->new( name => 'local')->name();
	diag "DateTime::TimeZone is '$dt_zone'";
    } else {
	diag 'DateTime::TimeZone not available';
    }

    diag strftime(
	q, localtime( $time_tested || 0 ) );

    eval {
	no strict qw{ refs };
	my $class = defined $Time::y2038::VERSION ? 'Time::y2038' :
	    'Time::Local';
	diag sprintf 'Time to epoch uses %s %s', $class,
	    $class->VERSION();
    };

    diag '$main::TZ is ', defined $main::TZ ? "'$main::TZ'" : 'undef';

    diag q<$ENV{TZ} = >, defined $ENV{TZ} ? "'$ENV{TZ}'" : 'undef';

    return;
}

sub execute {	## no critic (RequireArgUnpacking)
    splice @_, 0, 0, 'execute';
    goto &call_m;
}

{
    my $go;

    # CAVEAT:
    #
    # Unfortunately as things currently stand, the version needs to be
    # maintained three places:
    # - lib/Astro/App/Satpass2/Utils.pm
    # - inc/My/Module/Recommend.pm
    # - inc/My/Module/Test/App.pm
    # These all need to stay the same. Sigh.
    # Any such should be in xt/author/consistent_module_versions.t

    my %version = (
	'DateTime::Calendar::Christian'	=> 0.06,
    );

    # Expose the module version so we can test for consistent definition.
    sub __module_version {
	my $module = $_[-1];
	exists $version{$module}
	    or confess "Bug - Module $module has no defined version";
	return $version{$module};
    }

    # skip() actually jumps out via 'goto SKIP', but Perl::Critic does
    # not know this.
    sub load_or_skip {	## no critic (RequireFinalReturn)
	my @arg = @_;
	$go ||= Getopt::Long::Parser->new();
	my %opt;
	$go->getoptionsfromarray( \@arg, \%opt,
	    qw{ import=s@ noimport! } );
	my ( $module, $skip ) = @arg;
	my $v = $version{$module};
	local $@ = undef;
	my $caller = caller;
	eval "require $module; 1"
	    and eval {
	    $v and $module->VERSION( $v );
	    my @import = map { split qr{ \s* , \s* }smx }
		@{ $opt{import} || [] };
	    # We rely on the following statement always being true
	    # unless the import is requested and fails.
	    $opt{noimport}
		or eval "package $caller; $module->import( qw{ @import } ); 1";
	} and return;
	my $display = $v ? "$module $v" : $module;
	$display .= ' not available';
	$skip
	    and $skip =~ m/ \A all \z /smxi
	    and skip_all $display;
	skip $display, $skip;
    }
}

{
    my $got;

    sub call_m {	## no critic (RequireArgUnpacking)
	my ( $method, @args ) = @_;
	my ( $want, $title ) = splice @args, -2;

	if ( defined( my $err = dies { $got = $app->$method( @args ) } ) ) {
	    chomp $err;
	    defined $want or $want = 'Unexpected error';
	    REGEXP_REF eq ref $want
		or $want = qr<\A\Q$want>smx;
	    @_ = ( $err, $want, $title );
	    goto &like;
	} else {

	    if ( CODE_REF eq ref $want ) {
		@_ = ( $want, $got, $title );
		goto &$want;
	    }

	    foreach ( $want, $got ) {
		defined and not ref and chomp;
	    }
	    @_ = ( $got, $want, $title );
	    REGEXP_REF eq ref $want ? goto &like : goto &is;
	}
    }

    sub call_m_result {
	return $got;
    }
}

{
    my $kind_hdr = {
	configure_requires	=> 'CONFIGURE REQUIRES',
	build_requires		=> 'BUILD REQUIRES',
	test_requires		=> 'TEST REQUIRES',
	requires		=> 'RUNTIME REQUIRES',
	optional_modules	=> 'OPTIONAL MODULES',
    };

    sub dependencies_table {
	require My::Module::Meta;
	my @tables = ( '' );

	{
	    my @perls = ( My::Module::Meta->requires_perl(), $] );
	    foreach ( @perls ) {
		$_ = sprintf '%.6f', $_;
		$_ =~ s/ (?= ... \z ) /./smx;
		$_ =~ s/ (?<= \. ) 00? //smxg;
	    }
	    push @tables, table(
		header	=> [ qw{ PERL REQUIRED INSTALLED } ],
		rows	=> [ [ perl => @perls ] ],
	    );
	}

	foreach my $kind ( qw{ configure_requires build_requires test_requires requires optional_modules }
	) {
	    my $code = My::Module::Meta->can( $kind )
		or next;
	    my $req = $code->();
	    my @rows;
	    foreach my $module ( sort keys %{ $req } ) {
		( my $file = "$module.pm" ) =~ s| :: |/|smxg;
		# NOTE that an alternative implementation here is to use
		# Module::Load::Conditional (core since 5.10.0) to find the
		# installed modules, and then MM->parse_version() (from
		# ExtUtils::MakeMaker) to find the version without actually
		# loading the module.
		my $installed;
		local $@ = undef;
		eval {
		    require $file;
		    $installed = $module->VERSION();
		    defined $installed
			or $installed = 'undef';
		    1;
		} or $installed = 'not installed';
		push @rows, [ $module, $req->{$module}, $installed ];
	    }

	    my $hdr = $kind_hdr->{$kind};
	    defined $hdr
		or $hdr = uc $kind;
	    push @tables, table(
		header	=> [ $hdr, 'REQUIRED', 'INSTALLED' ],
		rows	=> \@rows,
	    );
	}

	return @tables;
    }
}

sub mock_usgs {
    my ( $ele ) = @_;
    my $attr = {
	error	=> ( defined( $ele ) ?
	    'Unexpected error' :
	    'Forced error for testing' ),
    };
    return mock 'Geo::WebService::Elevation::USGS' => (
	override	=> [
	    elevation	=> sub { return {
		    Elevation	=> $ele,
		    Units	=> 'Meters',
		} },
	    get		=> sub {
		my ( undef, $name ) = @_;
		exists $attr->{$name}
		    or confess "Bug - Attribute '$name' not mocked";
		return $attr->{$name};
	    },
	],
    );
}

{
    my $win32 = sub {
	my ( $path ) = @_;
	$path =~ tr{\\}{/};
	return $path;
    };

    my %normalizer = (
	dos		=> $win32,
	dragonfly	=> sub {
	    my ( $path ) = @_;
	    $path =~ s{ / \z }{}smx;
	    return $path;
	},
	MSWin32		=> $win32,
	os2		=> $win32,
    );

    sub normalize_path {
	my ( $path ) = @_;
	$path = abs_path( $path );
	my $code = $normalizer{$^O}
	    or return $path;
	return $code->( $path );
    }
}

{

    my %no_stat = map { $_ => 1 } qw{ dos MSWin32 os2 riscos VMS };

    sub same_path {
	my ( $got, $want, $name ) = @_;
	$got = normalize_path( $got );
	$want = normalize_path( $want );
	if ( $want eq $got || $no_stat{$^O} ) {
	    @_ = ( $got, $want, $name );
	    goto &is;
	}
	my $got_inode = ( stat $got )[1];
	my $want_inode = ( stat $want )[1];
	@_ = ( $got_inode, '==', $want_inode, $name );
	goto &cmp_ok;
    }
}

sub setup_app_mocker {
    return mock 'Astro::App::Satpass2' => (
    override	=> [
	new	=> sub {
	    my ( $class, %self ) = @_;
	    return bless \%self, $class;
	},
	get	=> sub { return $_[0]{$_[1]}; },
	set	=> sub {
	    my ( $self, @args ) = @_;
	    while ( @args ) {
		my ( $name, $value ) = splice @args, 0, 2;
		$self->{$name} = $value;
	    }
	    return $self;
	},
    ],
);
}

sub Astro::App::Satpass2::__TEST__frame_stack_depth {
    my ( $self ) = @_;
    return scalar @{ $self->{frame} };
}

sub Astro::App::Satpass2::__TEST__is_exported {
    my ( $self, $name ) = @_;
    return exists $self->{exported}{$name} ? 1 : 0;
}

#	$string = $self->__raw_attr( $name, $format )

#	Fetches the raw value of the named attribute, running it through
#	the given sprintf format if that is not undef. THIS IS AN
#	UNSUPPORTED INTERFACE USED FOR TESTING ONLY.

sub Astro::App::Satpass2::__TEST__raw_attr {
    my ( $self, $name, $format ) = @_;
    defined $format or return $self->{$name};
    return sprintf $format, $self->{$name};
}

1;

__END__