File Coverage

lib/Class/Usul/Time.pm
Criterion Covered Total %
statement 118 148 79.7
branch 61 108 56.4
condition 27 68 39.7
subroutine 15 17 88.2
pod 5 5 100.0
total 226 346 65.3


line stmt bran cond sub pod time code
1             package Class::Usul::Time;
2              
3 20     20   118447 use strict;
  20         50  
  20         567  
4 20     20   115 use warnings;
  20         47  
  20         688  
5              
6 20     20   450 use Class::Usul::Constants qw( EXCEPTION_CLASS FALSE TRUE );
  20         48  
  20         195  
7 20     20   15187 use Class::Usul::Functions qw( ensure_class_loaded throw );
  20         50  
  20         171  
8 20     20   39827 use Date::Format ( );
  20         120688  
  20         674  
9 20     20   199 use Exporter 5.57 qw( import );
  20         543  
  20         856  
10 20     20   9434 use Time::HiRes qw( usleep );
  20         20391  
  20         176  
11 20     20   3582 use Time::Local;
  20         46  
  20         966  
12 20     20   118 use Time::Zone;
  20         49  
  20         1107  
13 20     20   149 use Unexpected::Functions qw( DateTimeCoercion );
  20         46  
  20         196  
14              
15             our @EXPORT = qw( str2time time2str );
16             our @EXPORT_OK = qw( nap str2date_time str2time str2time_piece time2str );
17              
18             # Private package variables
19             my $_datetime_loaded = FALSE;
20             my $_time_piece_loaded = FALSE;
21              
22             # Public functions
23             sub nap ($) {
24 37     37 1 301 my $period = shift;
25              
26 37 50 33     1732 $period = $period && $period =~ m{ \A [\d._]+ \z }msx && $period > 0
27             ? $period : 1;
28              
29 37         11105712 return usleep( 1_000_000 * $period );
30             }
31              
32             sub str2date_time ($;$) {
33 5     5 1 2177 my ($dstr, $zone) = @_; my $time = str2time( $dstr, $zone );
  5         23  
34              
35 5 100       25 defined $time or throw DateTimeCoercion, [ $dstr ];
36              
37 3 100 50     22 $_datetime_loaded or (ensure_class_loaded 'DateTime::Format::Epoch'
38             and $_datetime_loaded = TRUE);
39              
40 3         33 my $dt = DateTime->new( year => 1970, month => 1, day => 1, );
41 3         1639 my $formatter = DateTime::Format::Epoch->new
42             ( epoch => $dt,
43             unit => 'seconds',
44             type => 'int',
45             skip_leap_seconds => TRUE,
46             start_at => 0,
47             local_epoch => undef, );
48              
49 3         492 return $formatter->parse_datetime( $time );
50             }
51              
52             sub str2time ($;$) {
53             # This subroutine: Copyright (c) 1995 Graham Barr. All rights reserved.
54             # British version dd/mm/yyyy
55 11     11 1 4021 my ($dtstr, $zone) = @_;
56              
57 11 50 33     88 (defined $dtstr and length $dtstr) or return;
58              
59 11         35 my ($year, $month, $day, $hh, $mm, $ss, $dst, $frac, $m, $h, $result);
60 11         107 my %day =
61             ( sunday => 0, monday => 1, tuesday => 2, tues => 2,
62             wednesday => 3, wednes => 3, thursday => 4, thur => 4,
63             thurs => 4, friday => 5, saturday => 6, );
64 11         112 my %month =
65             ( january => 0, february => 1, march => 2, april => 3,
66             may => 4, june => 5, july => 6, august => 7,
67             september => 8, sept => 8, october => 9, november =>10,
68             december => 11, );
69 11         71 my @suf = (qw( th st nd rd th th th th th th )) x 3;
70 11         41 @suf[11, 12, 13] = qw( th th th );
71              
72 11         152 $day{ substr $_, 0, 3 } = $day{ $_ } for (keys %day);
73 11         156 $month{ substr $_, 0, 3 } = $month{ $_ } for (keys %month);
74              
75 11         144 my $daypat = join '|', reverse sort keys %day;
76 11         136 my $monpat = join '|', reverse sort keys %month;
77 11         95 my $sufpat = join '|', reverse sort @suf;
78 11         31 my $dstpat = 'bst|dst';
79              
80 11         45 my %ampm = ( a => 0, p => 12 ); my ($AM, $PM) = ( 0, 12 );
  11         34  
81              
82 11         25 my $merid = 24; my @lt = localtime time;
  11         499  
83              
84 11         49 $dtstr = lc $dtstr;
85 11 100       67 $zone = tz_offset( $zone ) if ($zone);
86              
87 11         412 1 while ($dtstr =~ s{\([^\(\)]*\)}{ }mox);
88              
89 11         115 $dtstr =~ s{ (\A|\n|\z) }{ }gmox;
90 11         59 $dtstr =~ s{ ([\d\w\s]) [\.\,] \s }{$1 }gmox;
91 11         34 $dtstr =~ s{ , }{ }gmx;
92 11         254 $dtstr =~ s{ ($daypat) \s* (den\s)? }{ }mox;
93              
94 11 50       64 return unless ($dtstr =~ m{ \S }mx);
95              
96 11 100       74 if ($dtstr =~ s{ \s (\d{4}) ([-:]?) # ccyy + optional separator - or : (1)
97             (\d\d?) \2 # mm(1 - 12) + same separator (1)
98             (\d\d?) # dd(1 - 31)
99             (?:[Tt ]
100             (\d\d?) # H or HH
101             (?:([-:]?) # Optionally separator - or : (2)
102             (\d\d?) # and M or MM
103             (?:\6 # Optionally same separator (2)
104             (\d\d?) # and S or SS
105             (?:[.,] # Optionally separator . or ,
106             (\d+) )? # and fractions of a second
107             )? )? )?
108             (?=\D)
109             }{ }mx) {
110 3         33 ($year, $month, $day, $hh, $mm, $ss, $frac)
111             = ($1, $3-1, $4, $5, $7, $8, $9);
112             }
113              
114 11 100       37 unless (defined $hh) {
115 8 100       70 if ($dtstr =~ s{ [:\s] (\d\d?) : (\d\d?) ( : (\d\d?) (?:\.\d+)? )? \s*
    50          
116             (?:([ap]) \.?m?\.? )? \s }{ }mox) {
117 3   100     35 ($hh, $mm, $ss) = ($1, $2, $4 || 0);
118 3 50       19 $merid = $ampm{ $5 } if ($5);
119             }
120             elsif ($dtstr =~ s{ \s (\d\d?) \s* ([ap]) \.?m?\.? \s }{ }mox) {
121 0         0 ($hh, $mm, $ss) = ($1, 0, 0);
122 0         0 $merid = $ampm{ $2 };
123             }
124             }
125              
126 11 50 100     100 if (defined $hh && $hh <= 12 && $dtstr =~ s{ ([ap]) \.?m?\.? \s }{ }mox) {
      66        
127 0         0 $merid = $ampm{ $1 };
128             }
129              
130 11 100       38 unless (defined $year) {
131             TRY: {
132 8 50       20 if ($dtstr =~ s{ \s (\d\d?) ([^\d_]) ($monpat) (\2(\d\d+))? \s}{ }mox) {
  8         184  
133 0         0 ($year, $month, $day) = ($5, $month{ $3 }, $1);
134 0         0 last TRY;
135             }
136              
137 8 100       52 if ($dtstr =~ s{ \s (\d+) ([\-\./]) (\d\d?) (\2(\d+))? \s }{ }mox) {
138 6         43 ($year, $month, $day) = ($5, $3 - 1, $1);
139 6 100       28 ($year, $day) = ($1, $5) if ($day > 31);
140              
141 6 50 33     43 return if (length $year > 2 and $year < 1901);
142 6         23 last TRY;
143             }
144              
145 2 50       84 if ($dtstr =~ s{ \s (\d+) \s* ($sufpat)? \s* ($monpat) }{ }mox) {
146 0         0 ($month, $day) = ($month{ $3 }, $1);
147 0         0 last TRY;
148             }
149              
150 2 50       89 if ($dtstr =~ s{ ($monpat) \s* (\d+) \s* ($sufpat)? \s }{ }mox) {
151 0         0 ($month, $day) = ($month{ $1 }, $2);
152 0         0 last TRY;
153             }
154              
155 2 50       8 if ($dtstr =~ s{ \s (\d\d) (\d\d) (\d\d) \s }{ }mox) {
156 0         0 ($year, $month, $day) = ($3, $2 - 1, $1);
157             }
158             } # TRY
159              
160 8 50 66     40 if (! defined $year && $dtstr =~ s{ \s (\d{2} (\d{2})?)[\s\.,] }{ }mox) {
161 0         0 $year = $1;
162             }
163             }
164              
165 11 50       78 $dst = 1 if ($dtstr =~ s{ \b ($dstpat) \b }{}mox);
166              
167 11 100       113 if ($dtstr =~ s{ \s \"? ([a-z]{3,4})
    50          
168             ($dstpat|\d+[a-z]*|_[a-z]+)? \"? \s }{ }mox) {
169 3   50     24 $zone = tz_offset( $1 || 0 );
170 3 50 33     187 $dst = 1 if ($2 && $2 =~ m{ $dstpat }msx);
171              
172 3 100       25 return unless (defined $zone);
173             }
174             elsif ($dtstr =~ s{ \s ([a-z]{3,4})? ([\-\+]?) -?
175             (\d\d?) :? (\d\d)? (00)? \s }{ }mox) {
176 0   0     0 $zone = tz_offset( $1 || 0 );
177              
178 0 0       0 return unless (defined $zone);
179              
180 0         0 $h = "$2$3";
181 0 0       0 $m = defined $4 ? "$2$4" : 0;
182 0         0 $zone += 60 * ($m + (60 * $h));
183             }
184              
185 9 50       39 if ($dtstr =~ m{ \S }msx) {
186 0 0       0 if ($dtstr =~ s{ \A \s*(ut?|z)\s* \z }{}msx) {
    0          
187 0         0 $zone = 0;
188             }
189             elsif ($dtstr =~ s{ \s ([a-z]{3,4})? ([\-\+]?) -?
190             (\d\d?) (\d\d)? (00)? \s }{ }mox) {
191 0   0     0 $zone = tz_offset( $1 || 0 );
192              
193 0 0       0 return unless (defined $zone);
194              
195 0         0 $h = "$2$3";
196 0 0       0 $m = defined $4 ? "$2$4" : 0;
197 0         0 $zone += 60 * ($m + (60 * $h));
198             }
199              
200 0 0       0 return if ($dtstr =~ m{ \S }mox);
201             }
202              
203 9 100       30 if (defined $hh) {
204 6 50       31 if ($hh == 12) { $hh = 0 if ($merid == $AM) }
  1 100       4  
    50          
205 0         0 elsif ($merid == $PM) { $hh += 12 }
206             }
207              
208             # This is a feature in the original code RT#53413 and RT#105031
209             # $year -= 1900 if (defined $year && $year > 1900);
210 9 50 33     52 $zone += 3600 if (defined $zone && $dst);
211 9 50       30 $month = $lt[4] unless (defined $month);
212 9 50       32 $day = $lt[3] unless (defined $day);
213              
214 9 50       30 unless (defined $year) {
215 0 0       0 $year = $month > $lt[4] ? $lt[5] - 1 : $lt[5];
216             }
217              
218 9 100       31 $hh = 0 unless (defined $hh);
219 9 100       29 $mm = 0 unless (defined $mm);
220 9 100       30 $ss = 0 unless (defined $ss);
221 9 50       28 $frac = 0 unless (defined $frac);
222              
223 9 50 33     139 return unless ($month <= 11 && $day >= 1 && $day <= 31
      33        
      33        
      33        
      33        
224             && $hh <= 23 && $mm <= 59 && $ss <= 59);
225              
226 9 50       28 if (defined $zone) {
227 9         22 $result = eval {
228 9     0   84 local $SIG{__DIE__} = sub {}; # Ick!
229 9         54 timegm( $ss, $mm, $hh, $day, $month, $year );
230             };
231              
232 9 50 33     532 return if (! defined $result ||
      33        
233             ($result == -1
234             && (join q(), $ss, $mm, $hh, $day, $month, $year)
235             ne '595923311169'));
236              
237 9         22 $result -= $zone;
238             }
239             else {
240 0         0 $result = eval {
241 0     0   0 local $SIG{__DIE__} = sub {}; # Ick!
242 0         0 timelocal( $ss, $mm, $hh, $day, $month, $year );
243             };
244              
245 0 0 0     0 return if (! defined $result ||
      0        
246             ($result == -1
247             && (join q(), $ss, $mm, $hh, $day, $month, $year)
248             ne join q(), (localtime -1)[0 .. 5]));
249             }
250              
251 9         128 return $result + $frac;
252             }
253              
254             sub str2time_piece ($;$) {
255 1     1 1 4 my ($dstr, $zone) = @_; my $time = str2time( $dstr, $zone );
  1         5  
256              
257 1 50       5 defined $time or throw DateTimeCoercion, [ $dstr ];
258              
259 1 50 50     9 $_time_piece_loaded
260             or (ensure_class_loaded 'Time::Piece' and $_time_piece_loaded = TRUE);
261              
262 1 50       9 return $zone ? Time::Piece->gmtime( $time ) : Time::Piece->localtime( $time);
263             }
264              
265             sub time2str (;$$$) {
266 4     4 1 2556 my ($format, $time, $zone) = @_;
267              
268 4   100     21 $format //= '%Y-%m-%d %H:%M:%S'; $time //= time;
  4   33     14  
269              
270 4         46 return Date::Format::Generic->time2str( $format, $time, $zone );
271             }
272              
273             1;
274              
275             __END__
276              
277             =pod
278              
279             =encoding utf-8
280              
281             =head1 Name
282              
283             Class::Usul::Time - Functions for date and time manipulation
284              
285             =head1 Synopsis
286              
287             use Class::Usul::Time qw( time2str );
288              
289             =head1 Description
290              
291             This module implements a few simple time related functions
292              
293             =head1 Subroutines/Methods
294              
295             =head2 nap
296              
297             nap( $period );
298              
299             Sleep for a given number of seconds. The sleep time can be a fraction
300             of a second
301              
302             =head2 str2date_time
303              
304             $date_time = str2date_time( $dstr, [$zone] );
305              
306             Parse a date time string and return a L<DateTime> object. The time zone is
307             optional
308              
309             =head2 str2time
310              
311             $time = str2time( $dstr, [$zone] );
312              
313             Parse a date time string and return the number of seconds elapsed
314             since the epoch. This subroutine is copyright (c) 1995 Graham
315             Barr. All rights reserved. It has been modified to treat 9/11 as the
316             ninth day in November. The time zone is optional
317              
318             =head2 str2time_piece
319              
320             $time_piece = str2time_piece( $dstr, [$zone] );
321              
322             Parse a date time string and return a L<Time::Piece> object. The time
323             zone is optional
324              
325             =head2 time2str
326              
327             $time_string = time2str( [$format], [$time], [$zone] );
328              
329             Returns a formatted string representation of the given time (supplied
330             in seconds elapsed since the epoch). Defaults to ISO format (%Y-%m-%d
331             %H:%M:%S) and current time if non supplied. The timezone defaults to
332             local time
333              
334             =head1 Diagnostics
335              
336             None
337              
338             =head1 Configuration and Environment
339              
340             None
341              
342             =head1 Dependencies
343              
344             =over 3
345              
346             =item L<DateTime::Format::Epoch>
347              
348             =item L<Time::HiRes>
349              
350             =item L<Time::Local>
351              
352             =item L<Time::Zone>
353              
354             =back
355              
356             =head1 Incompatibilities
357              
358             There are no known incompatibilities in this module.
359              
360             =head1 Bugs and Limitations
361              
362             There are no known bugs in this module.
363             Please report problems to the address below.
364             Patches are welcome
365              
366             =head1 Author
367              
368             Peter Flanigan, C<< <pjfl@cpan.org> >>
369              
370             =head1 License and Copyright
371              
372             Copyright (c) 2017 Peter Flanigan. All rights reserved
373              
374             This program is free software; you can redistribute it and/or modify it
375             under the same terms as Perl itself. See L<perlartistic>
376              
377             This program is distributed in the hope that it will be useful,
378             but WITHOUT WARRANTY; without even the implied warranty of
379             MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE
380              
381             =cut
382              
383             # Local Variables:
384             # mode: perl
385             # tab-width: 3
386             # End: