File Coverage

blib/lib/Astro/App/Satpass2/ParseTime.pm

Criterion	Covered	Total	%
statement	97	128	75.7
branch	32	64	50.0
condition	3	8	37.5
subroutine	15	21	71.4
pod	11	11	100.0
total	158	232	68.1

package Astro::App::Satpass2::ParseTime;

use 5.008;

use strict;
use warnings;

use parent qw{ Astro::App::Satpass2::Copier };

use Astro::App::Satpass2::FormatTime;
use Astro::App::Satpass2::Utils qw{
    load_package
    ARRAY_REF CODE_REF SCALAR_REF
    @CARP_NOT
};
use Astro::Coord::ECI::Utils 0.059 qw{ looks_like_number };

our $VERSION = '0.051_01';

my %static = (
    perltime	=> 0,
);

sub new {
    my ( $class, %args ) = @_;
    ref $class and $class = ref $class;

    # Workaround for bug (well, _I_ think it's a bug) introduced into
    # Date::Manip with 6.34, while fixing RT #78566. My bug report is RT
    # #80435.
    my $path = $ENV{PATH};
    local $ENV{PATH} = $path;

    if ( __PACKAGE__ eq $class ) {

	$args{class} ||= [ qw{ Date::Manip ISO8601 } ];

	my @classes = ARRAY_REF eq ref $args{class} ? @{ $args{class} } :
	    split qr{ \s* , \s* }smx, $args{class};

	$class = _try ( @classes )
	    or return;

    } else {
	$class = _try( $class )
	    or return;
    }
    delete $args{class};

    defined $args{base}
	or $args{base} = time;

    my $self = { %static };
    bless $self, $class;
    $self->warner( delete $args{warner} );
    $self->base( delete $args{base} );
    $self->init( %args );
    return $self;
}

sub attribute_names {
    my ( $self ) = @_;
    return ( $self->SUPER::attribute_names(), qw{
	base perltime tz } );
}

sub base {
    my ( $self, @args ) = @_;
    if ( @args > 0 ) {
	$self->{base} = $self->{absolute} = $args[0];
	return $self;
    }
    return $self->{base};
}

sub class_name_of_record {
    my ( $self ) = @_;
    my $rslt = substr $self->__class_name(), 2 + length __PACKAGE__;
    foreach my $attr ( qw{ tz } ) {
	my $value = $self->$attr()
	    or next;
	$rslt .= ",$attr=$value";
    }
    return $rslt;
}

# For the use of class_name_of_record(). It exists so that
# Astro::App::Satpass2::ParseTime::Date::Manip can override it, so that
# we do not get the trailing '::v5' or '::v6';
sub __class_name {
    my ( $self ) = @_;
    return ref $self;
}

{

    my %skip = map { $_ => 1 } qw{ base warner };

    sub config {
	my ( $self, %args ) = @_;
	my @data;

	foreach my $name ( $self->attribute_names() ) {
	    $skip{$name} and next;
	    my $val = $self->$name();
	    no warnings qw{ uninitialized };
	    next if $args{changes} && $val eq $static{$name};
	    push @data, [ $name, $args{decode} ? $self->decode( $name )
		: $val ];
	}

	return wantarray ? @data : \@data;
    }

}

sub delegate {	## no critic (RequireFinalReturn)
    my ( $self ) = @_;
    $self->weep( 'The delegate() method must be overridden' );
    # Weep throws an exception, but there is no way to tell perlcritic
    # this.
}

{

    my %decoder = (
	base	=> sub {
	    my ( $self, $method, @args ) = @_;
	    my $rslt = $self->$method( @args );
	    @args
		and return $rslt;
	    $rslt
		or return $rslt;
	    $self->{_time_formatter} ||=
		Astro::App::Satpass2::FormatTime->new();
	    return $self->{_time_formatter}->format_datetime(
		$self->{_time_formatter}->ISO_8601_FORMAT(),
		$rslt, 1 );
	},
    );

    sub decode {
	my ( $self, $method, @args ) = @_;
	my $dcdr = $decoder{$method}
	    or return $self->$method( @args );
	my $type = ref $dcdr
	    or $self->weep( "Decoder for $method is scalar" );
	CODE_REF eq $type
	    or $self->weep(
	    "Decoder for $method is $type reference" );
	return $dcdr->( $self, $method, @args );
    }
}

{

    my @scale = ( 24, 60, 60, 1 );

    sub parse {
	my ( $self, $string, $default ) = @_;

	if ( SCALAR_REF eq ref $string ) {
	    my $time = ${ $string };
	    $self->base( $self->{absolute} = $time );
	    return $time;
	}

	if ( ! defined $string || '' eq $string ) {
	    defined $default
		and $self->base( $self->{absolute} = $default );
	    return $default;
	}

	if ( $string =~ m/ \A \s* [+-] /smx ) {
	    defined $self->{base} or return;
	    defined $self->{absolute}
		or $self->{absolute} = $self->base();
	    $string =~ s/ \A \s+ //smx;
	    $string =~ s/ \s+ \z //smx;
	    my $sign = substr $string, 0, 1;
	    substr( $string, 0, 1, '' );
	    my @delta = split qr{ \s* : \s* | \s+ }smx, $string;
	    @delta > 4 and return;
	    push @delta, ( 0 ) x ( 4 - @delta );
	    my $dt = 0;
	    foreach my $inx ( 0 .. 3 ) {
		looks_like_number( $delta[$inx] ) or return;
		$dt += $delta[$inx];
		$dt *= $scale[$inx];
	    }
	    '-' eq $sign and $dt = - $dt;
	    return ( $self->{absolute} = $dt + $self->{absolute} );

	} elsif ( $string =~
	    m/ \A epoch \s* ( [0-9]+ (?: [.] [0-9]* )? ) \z /smx ) {

	    my $time = $1 + 0;
	    $self->base( $self->{absolute} = $time );
	    return $time;

	} else {

	    defined( my $time = $self->parse_time_absolute( $string ) )
		or return;
	    $self->base( $self->{absolute} = $time );
	    return $time;

	}

    }

}

sub parse_time_absolute {	## no critic (RequireFinalReturn)
##  my ( $self, $string ) = @_;
    my ( $self ) = @_;		# $string unused
    $self->weep(
	'parse_time_absolute() must be overridden' );
    # Weep throws an exception, but there is no way to tell perlcritic
    # this.
}

sub reset : method {	## no critic (ProhibitBuiltinHomonyms)
    my ( $self ) = @_;
    $self->{absolute} = $self->base();
    return $self;
}

sub use_perltime {
    return 0;
}

{

    # %trial is indexed by class name. The value is the class to
    # delegate to (which can be the same as the class itself), or undef
    # if the class can not be loaded, or has no delegate.

    my %trial;

    sub _try {
	my ( @args ) = @_;

	my @flatten;

	while ( @args ) {

	    my $try = shift @args;

	    $trial{$try} and return $trial{$try};

	    exists $trial{$try} and next;

	    $try =~ m/ \A \w+ (?: :: \w+ )* \z /smx or do {
		$trial{$try} = undef;
		next;
	    };

	    my $pkg = $trial{$try} = load_package(
		$try, 'Astro::App::Satpass2::ParseTime' )
		or next;

	    my $delegate = $trial{$try} = eval { $pkg->delegate() }
		or next;

	    if ( $trial{$delegate} ) {
		foreach ( @flatten ) {
		    $trial{$_} = $delegate;
		}
		return $delegate;
	    }

	    push @flatten, $try;
	    unshift @args, $delegate;
	}

	return;
    }
}

__PACKAGE__->create_attribute_methods();

1;

__END__