view release on metacpan or  search on metacpan

lib/Astro/App/Satpass2/ParseTime.pm  view on Meta::CPAN

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

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 {

lib/Astro/App/Satpass2/ParseTime.pm  view on Meta::CPAN

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