File Coverage

blib/lib/Astro/App/Satpass2/ParseTime/Date/Manip/v6.pm

Criterion	Covered	Total	%
statement	18	64	28.1
branch	3	26	11.5
condition	1	13	7.6
subroutine	6	18	33.3
pod	6	6	100.0
total	34	127	26.7

package Astro::App::Satpass2::ParseTime::Date::Manip::v6;

use strict;
use warnings;

use Astro::Coord::ECI::Utils 0.112 qw{ looks_like_number };

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

use Astro::App::Satpass2::Utils qw{ load_package @CARP_NOT };

our $VERSION = '0.051_01';

my $invalid;

BEGIN {
    eval {
	load_package( 'Date::Manip' )
	    or return;
	load_package( 'Date::Manip::Date' )
	    or return;
	my $ver = Date::Manip->VERSION();
	$ver =~ s/ _ //smxg;
	$ver >= 6
	    and do {
		Date::Manip->import();
		1;
	    }
	    or $invalid = sprintf
		'%s assumes a Date::Manip version >= 6. You have %s',
		__PACKAGE__, Date::Manip->VERSION();
	$ver >= 6.49
	    and *_normalize_zone = sub {
		$_[0] =~ s/ \A (?: gmt | ut ) \z /UT/smxi;
	    };
	1;
    } or $invalid = ( $@ || 'Unable to load Date::Manip' );
    __PACKAGE__->can( '_normalize_zone' )
	or *_normalize_zone = sub{};
}

sub delegate {
    return __PACKAGE__;
}

sub dmd_err {
    my ( $self ) = @_;
    return $self->_get_dm_field( 'object' )->err();
}

sub dmd_zone {
    my ( $self ) = @_;
    return scalar $self->_get_dm_field( 'object' )->tz->zone();
}

sub parse_time_absolute {
    my ( $self, $string ) = @_;
    $invalid and $self->wail( $invalid );
    my $dm = $self->_get_dm_field( 'object' );
    $dm->parse( $string ) and return;
    return $dm->secs_since_1970_GMT() - $self->__epoch_offset();
}

sub use_perltime {
    return 0;
}

sub tz {
    my ( $self, @args ) = @_;
    $invalid and $self->wail( $invalid );
    if ( @args ) {
	my $zone = $args[0];
	my $dm = $self->_get_dm_field( 'object' );
	defined $zone and '' ne $zone
	    or $zone = $self->_get_dm_field( 'default_zone' );
	_normalize_zone( $zone );
	$dm->config( setdate => "zone,$zone" );
    }
    return $self->SUPER::tz( @args );
}

sub __back_end_validate {
    my ( $self, $cls ) = @_;
    $cls->can( 'parse' )
	or $self->wail( "$cls does not have a parse() method" );
    return;
}

sub __set_back_end_location {
    my ( $self, $location ) = @_;
    if ( my $dm = $self->_get_dm_field( 'object' ) ) {
	# NOTE that we have no way to introspect Date::Manip::Date (or
	# any other back end) to see if it has the 'location' config, so
	# since Date::Manip uses warn() to report errors, we just
	# blindly set it and swallow the possible warning.
	local $SIG{__WARN__} = sub {};
	$dm->config( location => $location );
    }
    return;
}

sub _get_dm_field {
    my ( $self, $field ) = @_;
    my $info = $self->{+__PACKAGE__} ||= $self->_make_dm_hash();
    return $info->{$field};
}

sub _make_dm_hash {
    my ( $self ) = @_;

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

    my $back_end = $self->back_end() || 'Date::Manip::Date';
    my $dm = $back_end->new();
    return {
	default_zone	=> scalar $dm->tz->zone(),
	object		=> $dm,
    };
}

1;

=head1 NAME

Astro::App::Satpass2::ParseTime::Date::Manip::v6 - Astro::App::Satpass2 wrapper for Date::Manip v6 or greater

=head1 SYNOPSIS

No user-serviceable parts inside.

=head1 DETAILS

This class wraps the L object from
L version 6.0 or higher, and uses it to parse
dates. It ignores the C mechanism.

B the L configuration mechanism (used
to set the time zone) reports errors using the C built-in, rather
than by returning a bad status or throwing an exception. Yes, I could
use the C<$SIG{__WARN__}> hook to trap this, but I would rather hope
that Mr.  Beck will provide a more friendly mechanism.

=head1 METHODS

This class supports the following public methods over and above those
documented in its superclass
L.

=head2 dmd_err

 my $error_string = $pt->dmd_err();

This method wraps the L object's
C method, and returns whatever that method
returns.

=head2 dmd_zone

 my $zone_name = $pt->dmd_zone();

This method wraps the L object's
C method, calling it in scalar context to
get the default zone name, and returning the result.

Note that unlike the inherited C method, this is an accessor
only, and, it is possible that C<< $pt->dmd_zone() >> will not return
the same thing that C<< $pt->tz() >> does. For example,

 $pt->tz( 'EST5EDT' );
 print '$pt->tz(): ', $pt->tz(), "\n";
 print '$pt->dmd_zone(): ', $pt->dmd_zone(), "\n";

prints

 $pt->tz(): EST5EDT
 $pt->dmd_zone(): America/New_York

This is because C<< $pt->tz() >> returns the last setting, whereas C<<
$pt->dmd_zone() >> returns the name of the time zone in the Olson
zoneinfo database, which is typically something like C,
even though the time zone was set using an alias, abbreviation or
offset. See L for the gory details.

Another difference is the if the time zone has never been set,
C<< $pt->tz() >> will return C, whereas
C<< $pt->dmd_zone() >> will actually return the name of the default
zone.

=head1 SUPPORT

Support is by the author. Please file bug reports at
L,
L, or in
electronic mail to the author.

=head1 AUTHOR

Thomas R. Wyant, III F

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2009-2023 by Thomas R. Wyant, III

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl 5.10.0. For more details, see the full text
of the licenses in the directory LICENSES.

This program is distributed in the hope that it will be useful, but
without any warranty; without even the implied warranty of
merchantability or fitness for a particular purpose.

=cut

__END__