File Coverage

inc/My/Module/Test/App.pm

Criterion	Covered	Total	%
statement	112	211	53.0
branch	27	72	37.5
condition	9	24	37.5
subroutine	29	40	72.5
pod	12	16	75.0
total	189	363	52.0

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 Test::More 0.52;

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

our @EXPORT = qw{
    application
    call_m
    call_m_result
    check_access
    check_datetime_timezone_local
    dt_greg_time_gm
    dt_greg_time_local
    dump_date_manip
    dump_date_manip_init
    dump_zones
    dump_zones_init
    execute
    klass
    load_or_skip
    normalize_path
    same_path
    FALSE
    INSTANTIATE
    TRUE
};

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;
};

sub application {
    return $app;
}

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

    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 ) = @_;

    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 plan skip_all => $display;
	skip $display, $skip;
    }
}

{
    my $got;

    sub call_m {	## no critic (RequireArgUnpacking)
	my ( $method, @args ) = @_;
	my ( $want, $title ) = splice @args, -2;
	if ( eval { $got = $app->$method( @args ); 1 } ) {

	    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 :
		ref $want ? goto &is_deeply : goto &is;
	} else {
	    $got = $@;
	    chomp $got;
	    defined $want or $want = 'Unexpected error';
	    REGEXP_REF eq ref $want
		or $want = qr<\Q$want>smx;
	    @_ = ( $got, $want, $title );
	    goto &like;
	}
    }

    sub call_m_result {
	return $got;
    }
}

{
    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 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__