1package Astro::App::Satpass2::ParseTime::Date::Manip::v6;
2
3use strict;
4use warnings;
5
6use Astro::Coord::ECI::Utils 0.112 qw{ looks_like_number greg_time_gm };
7
8use parent qw{ Astro::App::Satpass2::ParseTime::Date::Manip };
9
10use Astro::App::Satpass2::Utils qw{ load_package @CARP_NOT };
11
12our $VERSION = '0.049';
13
14my $invalid;
15
16BEGIN {
17    eval {
18	load_package( 'Date::Manip' )
19	    or return;
20	load_package( 'Date::Manip::Date' )
21	    or return;
22	my $ver = Date::Manip->VERSION();
23	$ver =~ s/ _ //smxg;
24	$ver >= 6
25	    and do {
26		Date::Manip->import();
27		1;
28	    }
29	    or $invalid = sprintf
30		'%s assumes a Date::Manip version >= 6. You have %s',
31		__PACKAGE__, Date::Manip->VERSION();
32	$ver >= 6.49
33	    and *_normalize_zone = sub {
34		$_[0] =~ s/ \A (?: gmt | ut ) \z /UT/smxi;
35	    };
36	1;
37    } or $invalid = ( $@ || 'Unable to load Date::Manip' );
38    __PACKAGE__->can( '_normalize_zone' )
39	or *_normalize_zone = sub{};
40}
41
42my $epoch_offset = greg_time_gm( 0, 0, 0, 1, 0, 1970 );
43
44sub delegate {
45    return __PACKAGE__;
46}
47
48sub dmd_err {
49    my ( $self ) = @_;
50    return $self->_get_dm_field( 'object' )->err();
51}
52
53sub dmd_zone {
54    my ( $self ) = @_;
55    return scalar $self->_get_dm_field( 'object' )->tz->zone();
56}
57
58sub parse_time_absolute {
59    my ( $self, $string ) = @_;
60    $invalid and $self->wail( $invalid );
61    my $dm = $self->_get_dm_field( 'object' );
62    $dm->parse( $string ) and return;
63    return $dm->secs_since_1970_GMT() - $epoch_offset;
64}
65
66sub use_perltime {
67    return 0;
68}
69
70sub tz {
71    my ( $self, @args ) = @_;
72    $invalid and $self->wail( $invalid );
73    if ( @args ) {
74	my $zone = $args[0];
75	my $dm = $self->_get_dm_field( 'object' );
76	defined $zone and '' ne $zone
77	    or $zone = $self->_get_dm_field( 'default_zone' );
78	_normalize_zone( $zone );
79	$dm->config( setdate => "zone,$zone" );
80    }
81    return $self->SUPER::tz( @args );
82}
83
84sub __back_end_validate {
85    my ( $self, $cls ) = @_;
86    $cls->can( 'parse' )
87	or $self->wail( "$cls does not have a parse() method" );
88    return;
89}
90
91sub __set_back_end_location {
92    my ( $self, $location ) = @_;
93    if ( my $dm = $self->_get_dm_field( 'object' ) ) {
94	# NOTE that we have no way to introspect Date::Manip::Date (or
95	# any other back end) to see if it has the 'location' config, so
96	# since Date::Manip uses warn() to report errors, we just
97	# blindly set it and swallow the possible warning.
98	local $SIG{__WARN__} = sub {};
99	$dm->config( location => $location );
100    }
101    return;
102}
103
104sub _get_dm_field {
105    my ( $self, $field ) = @_;
106    my $info = $self->{+__PACKAGE__} ||= $self->_make_dm_hash();
107    return $info->{$field};
108}
109
110sub _make_dm_hash {
111    my ( $self ) = @_;
112
113    # Workaround for bug (well, _I_ think it's a bug) introduced into
114    # Date::Manip with 6.34, while fixing RT #78566. My bug report is RT
115    # #80435.
116    my $path = $ENV{PATH};
117    local $ENV{PATH} = $path;
118
119    my $back_end = $self->back_end() || 'Date::Manip::Date';
120    my $dm = $back_end->new();
121    return {
122	default_zone	=> scalar $dm->tz->zone(),
123	object		=> $dm,
124    };
125}
126
1271;
128
129=head1 NAME
130
131Astro::App::Satpass2::ParseTime::Date::Manip::v6 - Astro::App::Satpass2 wrapper for Date::Manip v6 or greater
132
133=head1 SYNOPSIS
134
135No user-serviceable parts inside.
136
137=head1 DETAILS
138
139This class wraps the L<Date::Manip::Date|Date::Manip::Date> object from
140L<Date::Manip|Date::Manip> version 6.0 or higher, and uses it to parse
141dates. It ignores the C<perltime> mechanism.
142
143B<Caveat:> the L<Date::Manip|Date::Manip> configuration mechanism (used
144to set the time zone) reports errors using the C<warn> built-in, rather
145than by returning a bad status or throwing an exception. Yes, I could
146use the C<$SIG{__WARN__}> hook to trap this, but I would rather hope
147that Mr.  Beck will provide a more friendly mechanism.
148
149=head1 METHODS
150
151This class supports the following public methods over and above those
152documented in its superclass
153L<Astro::App::Satpass2::ParseTime|Astro::App::Satpass2::ParseTime>.
154
155=head2 dmd_err
156
157 my $error_string = $pt->dmd_err();
158
159This method wraps the L<Date::Manip::Date|Date::Manip::Date> object's
160C<err()> method, and returns whatever that method
161returns.
162
163=head2 dmd_zone
164
165 my $zone_name = $pt->dmd_zone();
166
167This method wraps the L<Date::Manip::TZ|Date::Manip::TZ> object's
168C<zone()> method, calling it in scalar context to
169get the default zone name, and returning the result.
170
171Note that unlike the inherited C<tz()> method, this is an accessor
172only, and, it is possible that C<< $pt->dmd_zone() >> will not return
173the same thing that C<< $pt->tz() >> does. For example,
174
175 $pt->tz( 'EST5EDT' );
176 print '$pt->tz(): ', $pt->tz(), "\n";
177 print '$pt->dmd_zone(): ', $pt->dmd_zone(), "\n";
178
179prints
180
181 $pt->tz(): EST5EDT
182 $pt->dmd_zone(): America/New_York
183
184This is because C<< $pt->tz() >> returns the last setting, whereas C<<
185$pt->dmd_zone() >> returns the name of the time zone in the Olson
186zoneinfo database, which is typically something like C<Continent/City>,
187even though the time zone was set using an alias, abbreviation or
188offset. See L<Date::Manip::TZ|Date::Manip::TZ> for the gory details.
189
190Another difference is the if the time zone has never been set,
191C<< $pt->tz() >> will return C<undef>, whereas
192C<< $pt->dmd_zone() >> will actually return the name of the default
193zone.
194
195=head1 SUPPORT
196
197Support is by the author. Please file bug reports at
198L<https://rt.cpan.org/Public/Dist/Display.html?Name=Astro-App-Satpass2>,
199L<https://github.com/trwyant/perl-Astro-App-Satpass2/issues>, or in
200electronic mail to the author.
201
202=head1 AUTHOR
203
204Thomas R. Wyant, III F<wyant at cpan dot org>
205
206=head1 COPYRIGHT AND LICENSE
207
208Copyright (C) 2009-2021 by Thomas R. Wyant, III
209
210This program is free software; you can redistribute it and/or modify it
211under the same terms as Perl 5.10.0. For more details, see the full text
212of the licenses in the directory LICENSES.
213
214This program is distributed in the hope that it will be useful, but
215without any warranty; without even the implied warranty of
216merchantability or fitness for a particular purpose.
217
218=cut
219
220__END__
221
222# ex: set textwidth=72 :
223