File Coverage

blib/lib/perl5i/1/DateTime.pm
Criterion Covered Total %
statement 28 93 30.1
branch 0 34 0.0
condition 1 3 33.3
subroutine 10 24 41.6
pod 0 3 0.0
total 39 157 24.8


line stmt bran cond sub pod time code
1             package perl5i::1::DateTime;
2              
3             # A file to contain the Datetime work for perl5i to get it out of perl5i.pm
4              
5 2     2   56 use 5.010;
  2         9  
  2         92  
6 2     2   13 use strict;
  2         4  
  2         67  
7 2     2   23 use warnings;
  2         6  
  2         311  
8              
9             # Determine if we need Time::y2038 and only load if necessary.
10             # XXX This is a bit of a hack and should go into a config file.
11 2   33     391 use constant NEEDS_y2038 => (
12             ((((CORE::gmtime(2**47-1))[5] || 0) + 1900) != 4461763) ||
13             ((((CORE::gmtime(-62135510400))[5] || 0) + 1900) != 1)
14 2     2   14 );
  2         14  
15              
16             BEGIN {
17 2     2   1181 if( NEEDS_y2038 ) {
18             require Time::y2038;
19             Time::y2038->import;
20             }
21             }
22              
23              
24             ## no critic (Subroutines::ProhibitSubroutinePrototypes)
25             sub dt_gmtime (;$) {
26 0 0   0 0   my $time = @_ ? shift : time;
27 0 0         return gmtime($time) if wantarray;
28              
29 0           my($sec, $min, $hour, $mday, $mon, $year) = gmtime($time);
30 0           $mon++;
31 0           $year += 1900;
32              
33 0           require DateTime;
34 0           return perl5i::1::DateTime::y2038->new(
35             year => $year,
36             month => $mon,
37             day => $mday,
38             hour => $hour,
39             minute => $min,
40             second => $sec,
41             formatter => "perl5i::1::DateTime::Format::CTime"
42             );
43             }
44              
45              
46             sub _get_datetime_timezone {
47 0     0     state $local_tzfile = "/etc/localtime";
48              
49             # Always be sure to honor the TZ environment var
50 0 0         return "local" if $ENV{TZ};
51              
52             # Work around a bug in DateTime::TimeZone on FreeBSD where it
53             # can't determine the time zone if /etc/localtime is not a link.
54             # Tzfile is also faster to do localtime calculations.
55 0 0         if( -e $local_tzfile ) {
56             # Could go through more effort to figure it out. Meh.
57 0           my $tzname = "Local";
58 0 0         if( -l $local_tzfile ) {
59 0 0         if( my $real_tzfile = eval { readlink $local_tzfile } ) {
  0            
60 0           $tzname = $real_tzfile;
61             }
62             }
63 0           require DateTime::TimeZone::Tzfile;
64 0           my $tz = DateTime::TimeZone::Tzfile->new(
65             name => $tzname,
66             filename => $local_tzfile
67             );
68 0 0         return $tz if $tz;
69             }
70              
71 0           return "local";
72             }
73              
74             ## no critic (Subroutines::ProhibitSubroutinePrototypes)
75             sub dt_localtime (;$) {
76 0 0   0 0   my $time = @_ ? shift : time;
77 0 0         return localtime($time) if wantarray;
78              
79 0           my($sec, $min, $hour, $mday, $mon, $year) = localtime($time);
80 0           $mon++;
81 0           $year += 1900;
82              
83 0           state $tz = _get_datetime_timezone();
84              
85 0           require DateTime;
86 0           return perl5i::1::DateTime::y2038->new(
87             year => $year,
88             month => $mon,
89             day => $mday,
90             hour => $hour,
91             minute => $min,
92             second => $sec,
93             time_zone => $tz,
94             formatter => "perl5i::1::DateTime::Format::CTime"
95             );
96             }
97              
98              
99             ## no critic (Subroutines::ProhibitSubroutinePrototypes)
100             sub dt_time () {
101 0     0 0   require DateTime::Format::Epoch;
102 0           state $formatter = DateTime::Format::Epoch->new( epoch => DateTime->from_epoch( epoch => 0 ) );
103              
104 0           require DateTime;
105 0           return perl5i::1::DateTime::time->from_epoch(
106             epoch => time,
107             formatter => $formatter
108             );
109             }
110              
111              
112             {
113             package perl5i::1::DateTime::y2038;
114              
115             # Don't load DateTime until we need it.
116             our @ISA = qw(DateTime);
117              
118             use overload
119             "eq" => sub {
120 0     0   0 my($dt1, $dt2) = @_;
121 0 0       0 return "$dt1" eq "$dt2" if !eval { $dt2->isa("DateTime") };
  0         0  
122 0         0 return $dt1 eq $dt2;
123 2     2   1683 };
  2         1031  
  2         24  
124              
125             sub say {
126 0     0     CORE::say("$_[0]");
127             }
128              
129             sub print {
130 0     0     CORE::print("$_[0]");
131             }
132              
133             sub from_epoch {
134 0     0     my $class = shift;
135              
136 0           if( perl5i::1::DateTime::NEEDS_y2038 ) {
137 2     2   291 no warnings 'redefine';
  2         3  
  2         538  
138             local *CORE::GLOBAL::gmtime = \&Time::y2038::gmtime;
139             local *CORE::GLOBAL::localtime = \&Time::y2038::localtime;
140              
141             return $class->SUPER::from_epoch(@_);
142             }
143             else {
144 0           return $class->SUPER::from_epoch(@_);
145             }
146             }
147              
148              
149             # Copy of DateTime's own epoch() function.
150             if( perl5i::1::DateTime::NEEDS_y2038 ) {
151             *epoch = sub {
152             my $self = shift;
153              
154             my $zone = $self->time_zone;
155             $self->set_time_zone("UTC");
156              
157             require Time::y2038;
158             my $time = Time::y2038::timegm(
159             $self->sec, $self->min, $self->hour, $self->mday,
160             $self->mon - 1,
161             $self->year - 1900,
162             );
163              
164             $self->set_time_zone($zone);
165              
166             return $time;
167             }
168             }
169             }
170              
171             {
172              
173             package perl5i::1::DateTime::time;
174              
175 2     2   1846 use parent -norequire, qw(perl5i::1::DateTime::y2038);
  2         761  
  2         14  
176              
177             use overload
178 0     0   0 "0+" => sub { $_[0]->epoch },
179             "-" => sub {
180 0     0   0 my( $a, $b, $reverse ) = @_;
181              
182 0 0       0 if($reverse) {
183 0         0 ( $b, $a ) = ( $a, $b );
184             }
185              
186 0 0       0 my $time_a = eval { $a->isa("DateTime") } ? $a->epoch : $a;
  0         0  
187 0 0       0 my $time_b = eval { $b->isa("DateTime") } ? $b->epoch : $b;
  0         0  
188              
189 0         0 return $time_a - $time_b;
190             },
191              
192             "+" => sub {
193 0     0   0 my( $a, $b, $reverse ) = @_;
194              
195 0 0       0 if($reverse) {
196 0         0 ( $b, $a ) = ( $a, $b );
197             }
198              
199 0 0       0 my $time_a = eval { $a->isa("DateTime") } ? $a->epoch : $a;
  0         0  
200 0 0       0 my $time_b = eval { $b->isa("DateTime") } ? $b->epoch : $b;
  0         0  
201              
202 0         0 return $time_a + $time_b;
203             },
204              
205             "==" => sub {
206 0     0   0 my($a, $b) = @_;
207 0 0       0 return $a+0 == $b+0 if !eval { $b->isa("DateTime") };
  0         0  
208 0         0 return $a == $b;
209             },
210              
211 2     2   604 fallback => 1;
  2         3  
  2         33  
212             }
213              
214              
215             {
216              
217             package perl5i::1::DateTime::Format::CTime;
218              
219 2     2   11238 use CLASS;
  2         695  
  2         11  
220              
221             sub new {
222 0     0     return bless {}, $CLASS;
223             }
224              
225             sub format_datetime {
226 0     0     my $self = shift;
227 0           my $dt = shift;
228              
229             # Straight from the Open Group asctime() docs.
230 0           return sprintf "%.3s %.3s%3d %.2d:%.2d:%.2d %d",
231             $dt->day_abbr,
232             $dt->month_abbr,
233             $dt->mday,
234             $dt->hour,
235             $dt->min,
236             $dt->sec,
237             $dt->year,
238             ;
239             }
240             }
241              
242              
243             1;