view release on metacpan or  search on metacpan

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

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

use strict;
use warnings;

use Astro::App::Satpass2::Utils qw{
    back_end __back_end_class_name_of_record __parse_class_and_args
    HAVE_DATETIME
    @CARP_NOT
};
use Astro::Coord::ECI::Utils 0.112 qw{
    looks_like_number SECSPERDAY greg_time_gm greg_time_local };

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

our $VERSION = '0.057';

my $package = __PACKAGE__;

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

sub class_name_of_record {
    my ( $self ) = @_;
    return $self->__back_end_class_name_of_record(
	$self->SUPER::class_name_of_record() );
}

my $zone_re = qr{ (?i: ( Z | UT | GMT ) |
    ( [+-] ) ( [0-9]{1,2} ) :? ( [0-9]{1,2} )? ) }smx;

sub delegate {
    return __PACKAGE__;
}

{

    my %special_day_offset = (
	yesterday => -SECSPERDAY(),
	today => 0,
	tomorrow => SECSPERDAY(),
    );

    my $era_ad = sub { return $_[0] };
    my $era_bc = sub { return 1 - $_[0] };
    my %era_cvt = (
	AD	=> $era_ad,
	BC	=> $era_bc,
	BCE	=> $era_bc,
	CE	=> $era_ad,
    );

    # Note that we have to reverse sort the keys because otherwise 'BC'
    # gets matched before we have a chance to try 'BCE'.
    my $era_re = qr< (?: @{[
	join ' | ', reverse sort keys %era_cvt
    ]} ) >smxi;

    my $make_epoch = HAVE_DATETIME ? sub {
	my ( $self, $zone, $offset, @date ) = @_;
	$zone ||= 'local';
	if ( defined( my $special = $special_day_offset{$date[0]} ) ) {
	    my $dt = DateTime->today(
		time_zone	=> $zone,
	    );
	    splice @date, 0, 3, $dt->year(), $dt->month(), $dt->day();
	    $offset += $special;
	}
	my %dt_arg;
	@dt_arg{ qw<
	    year month day hour minute second nanosecond
	> } = @date;
	$dt_arg{nanosecond} *= 1_000_000_000;
	$dt_arg{time_zone} = $zone;
	$self->{_back_end}
	    and return $self->{_back_end}{class}->new(
		%dt_arg,
		@{ $self->{_back_end}{arg} },
	    )->epoch() + $offset;
	return DateTime->new( %dt_arg )->epoch() + $offset;
    } : sub {
	my ( undef, $zone, $offset, @date ) = @_;
	if ( defined( my $special = $special_day_offset{$date[0]} )
	    ) {
	    my @today = $zone ? gmtime : localtime;
	    splice @date, 0, 3, @today[ 5, 4, 3 ];

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

		)?
	    >smxgc ) {
	    push @date, $1, $2 || 0, $3 || 0, $4 ? ".$4" : 0;
	    $special_only = 0;
	} else {
	    push @date, ( 0 ) x 4;
	}

	# We might have gobbled part of the zone.
	not $special_only
	    and $string =~ m/ \G (?<= [^0-9] ) /smxgc
	    and pos $string -= 1;
	my ( $zone ) = $string =~ m/ \G ( .* ) /smxgc;

	my ( $z, $offset ) = $self->_interpret_zone( $zone );
	defined $offset
	    or return;

	return $make_epoch->( $self, $z, $offset, @date );
    }

}

sub _interpret_zone {
    my ( $self, $zone, $fatal ) = @_;
    defined $zone
	and $zone =~ s/ \A \s+ //smx;
    $zone
	or return ( @{ $self->{$package}{tz} || [ undef, 0 ] } );
    if ( $zone =~ m/ \A $zone_re \z /smxo ) {
	$1
	    and return ( UTC => 0 );
	my $offset = ( ( $3 || 0 ) * 60 + ( $4 || 0 ) ) * 60;
	$2
	    and '-' eq $2
	    or $offset = - $offset;
	return ( UTC => $offset );
    } else {
	HAVE_DATETIME
	    or return ( $zone => 0 );	# On the user's head be it.

	DateTime::TimeZone->is_valid_name( $zone )
	    and return ( $zone => 0 );

	$fatal
	    and $self->wail( "Invalid time zone '$zone'" );
	return;
    }
}

sub tz {
    my ( $self, @args ) = @_;
    if ( @args ) {
	if ( defined $args[0] && $args[0] ne '' ) {
	    $self->{$package}{tz} = [
		$self->_interpret_zone( $args[0], 1 ) ];
	} else {
	    delete $self->{$package}{tz};
	}
    }
    return $self->SUPER::tz( @args );
}

sub __back_end_default {
    my ( undef, $cls ) = @_;		# Invocant ($self) unused
    defined $cls
	and return $cls;
    return 'DateTime';
}

sub __back_end_validate {
    my ( undef, $cls, @arg ) = @_;	# Invocant ($self) unused
    $cls->now( @arg );
    return;
}

1;

=head1 NAME

Astro::App::Satpass2::ParseTime::ISO8601 - Astro::App::Satpass2 minimal ISO-8601 parser

=head1 SYNOPSIS

No user-serviceable parts inside.

=head1 DETAILS

This class parses ISO-8601 dates. It does not do ordinal days or weeks,
but it is rather permissive on punctuation, and permits the convenience
dates C<'yesterday'>, C<'today'>, and C<'tomorrow'>.

This class understands ISO-8601 time zone specifications of the form
'Z', 'UT', 'GMT' and C<[+-]\d{1,2}:?\d{,2}>, but it knows nothing about
shifts for summer time. So C<2009/7/1 12:00:00 -5> is 5:00 PM GMT, not
4:00 PM. Other zones will be accepted, but may not do what you want. See
below.

As an extension to the ISO-8601 standard, years can be followed by an
era specification, which is one of C<'AD'>, C<'BC'>, C<'BCE'>, or
C<'CE'> without regard to case. The era indicator may be separated from
the year by white space, and be followed by a non-digit separator
character.

Unless the era is specified, years less than C<70> will have C<2000>
added, and years at least equal to C<70> but less than C<100> will have
C<1900> added.

If L<DateTime|DateTime> can be loaded, it will be used to get an epoch
from the parsed date, including zone.

If L<DateTime|DateTime> can B<not> be loaded, L<Time::Local|Time::Local>
will be used to get an epoch from the parsed date.
L<Time::Local|Time::Local> has its own quirks when it sees a year in the
distant past. Zones other than C<UTC>, C<GMT>, C<Z>, and numeric offsets
will be handled by setting C<$ENV{TZ}> to the specified zone before
converting from local time to epoch.  If this works for you, fine. If
not, tough.  B<You have been warned!>

=head1 METHODS