Commit | Line | Data |
302d38aa |
1 | package Time::Piece; |
2 | |
3 | use strict; |
4 | use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS); |
5 | |
6 | require Exporter; |
7 | require DynaLoader; |
8 | use Time::Seconds; |
9 | use Carp; |
302d38aa |
10 | |
11 | @ISA = qw(Exporter DynaLoader); |
12 | |
13 | @EXPORT = qw( |
14 | localtime |
15 | gmtime |
16 | ); |
17 | |
18 | %EXPORT_TAGS = ( |
19 | ':override' => 'internal', |
20 | ); |
21 | |
22 | $VERSION = '0.13'; |
23 | |
24 | bootstrap Time::Piece $VERSION; |
25 | |
26 | my $DATE_SEP = '-'; |
27 | my $TIME_SEP = ':'; |
d0369dd1 |
28 | my @MON_NAMES = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec); |
29 | my @WDAY_NAMES = qw(Sun Mon Tue Wed Thu Fri Sat); |
30 | my @MONTH_NAMES = qw(January February March April May June |
31 | July August September October Novemeber December); |
32 | my @WEEKDAY_NAMES = qw(Sunday Monday Tuesday Wednesday |
33 | Thursday Friday Saturday); |
302d38aa |
34 | |
35 | use constant 'c_sec' => 0; |
36 | use constant 'c_min' => 1; |
37 | use constant 'c_hour' => 2; |
38 | use constant 'c_mday' => 3; |
39 | use constant 'c_mon' => 4; |
40 | use constant 'c_year' => 5; |
41 | use constant 'c_wday' => 6; |
42 | use constant 'c_yday' => 7; |
43 | use constant 'c_isdst' => 8; |
44 | use constant 'c_epoch' => 9; |
45 | use constant 'c_islocal' => 10; |
46 | |
47 | sub localtime { |
48 | my $time = shift; |
49 | $time = time if (!defined $time); |
50 | _mktime($time, 1); |
51 | } |
52 | |
53 | sub gmtime { |
54 | my $time = shift; |
55 | $time = time if (!defined $time); |
56 | _mktime($time, 0); |
57 | } |
58 | |
59 | sub new { |
60 | my $proto = shift; |
61 | my $class = ref($proto) || $proto; |
62 | my $time = shift; |
63 | |
64 | my $self; |
65 | |
66 | if (defined($time)) { |
67 | $self = &localtime($time); |
68 | } |
69 | elsif (ref($proto) && $proto->isa('Time::Piece')) { |
70 | $self = _mktime($proto->[c_epoch], $proto->[c_islocal]); |
71 | } |
72 | else { |
73 | $self = &localtime(); |
74 | } |
75 | |
76 | return bless $self, $class; |
77 | } |
78 | |
79 | sub _mktime { |
80 | my ($time, $islocal) = @_; |
81 | my @time = $islocal ? |
82 | CORE::localtime($time) |
83 | : |
84 | CORE::gmtime($time); |
85 | wantarray ? @time : bless [@time, $time, $islocal], 'Time::Piece'; |
86 | } |
87 | |
88 | sub import { |
89 | # replace CORE::GLOBAL localtime and gmtime if required |
90 | my $class = shift; |
91 | my %params; |
92 | map($params{$_}++,@_,@EXPORT); |
93 | if (delete $params{':override'}) { |
94 | $class->export('CORE::GLOBAL', keys %params); |
95 | } |
96 | else { |
97 | $class->export((caller)[0], keys %params); |
98 | } |
99 | } |
100 | |
101 | ## Methods ## |
102 | |
d0369dd1 |
103 | sub s { |
302d38aa |
104 | my $time = shift; |
105 | $time->[c_sec]; |
106 | } |
107 | |
d0369dd1 |
108 | *sec = \&s; |
109 | *second = \&s; |
302d38aa |
110 | |
111 | sub min { |
112 | my $time = shift; |
113 | $time->[c_min]; |
114 | } |
115 | |
d0369dd1 |
116 | *minute = \&min; |
302d38aa |
117 | |
d0369dd1 |
118 | sub h { |
302d38aa |
119 | my $time = shift; |
120 | $time->[c_hour]; |
121 | } |
122 | |
d0369dd1 |
123 | *hour = \&h; |
124 | |
125 | sub d { |
302d38aa |
126 | my $time = shift; |
127 | $time->[c_mday]; |
128 | } |
129 | |
d0369dd1 |
130 | *mday = \&d; |
131 | *day_of_month = \&d; |
302d38aa |
132 | |
133 | sub mon { |
134 | my $time = shift; |
135 | $time->[c_mon] + 1; |
136 | } |
137 | |
138 | sub _mon { |
139 | my $time = shift; |
140 | $time->[c_mon]; |
141 | } |
142 | |
79d09e5e |
143 | sub has_mon_names { |
144 | my $time = shift; |
145 | return 0; |
146 | } |
147 | |
d0369dd1 |
148 | sub monname { |
302d38aa |
149 | my $time = shift; |
150 | if (@_) { |
151 | return $_[$time->[c_mon]]; |
152 | } |
79d09e5e |
153 | elsif ($time->has_mon_names) { |
154 | return $time->mon_name($time->[c_mon]); |
d0369dd1 |
155 | } |
79d09e5e |
156 | return $MON_NAMES[$time->[c_mon]]; |
157 | } |
158 | |
159 | sub has_month_names { |
160 | my $time = shift; |
161 | return 0; |
d0369dd1 |
162 | } |
163 | |
164 | sub monthname { |
165 | my $time = shift; |
166 | if (@_) { |
167 | return $_[$time->[c_mon]]; |
168 | } |
79d09e5e |
169 | elsif ($time->has_month_names) { |
170 | return $time->month_name($time->[c_mon]); |
302d38aa |
171 | } |
79d09e5e |
172 | return $MONTH_NAMES[$time->[c_mon]]; |
302d38aa |
173 | } |
174 | |
d0369dd1 |
175 | *month = \&monthname; |
176 | |
177 | sub y { |
302d38aa |
178 | my $time = shift; |
179 | $time->[c_year] + 1900; |
180 | } |
181 | |
d0369dd1 |
182 | *year = \&y; |
183 | |
302d38aa |
184 | sub _year { |
185 | my $time = shift; |
186 | $time->[c_year]; |
187 | } |
188 | |
189 | sub wday { |
190 | my $time = shift; |
191 | $time->[c_wday] + 1; |
192 | } |
193 | |
194 | sub _wday { |
195 | my $time = shift; |
196 | $time->[c_wday]; |
197 | } |
198 | |
199 | *day_of_week = \&_wday; |
200 | |
79d09e5e |
201 | sub has_wday_names { |
202 | my $time = shift; |
203 | return 0; |
204 | } |
205 | |
302d38aa |
206 | sub wdayname { |
207 | my $time = shift; |
208 | if (@_) { |
209 | return $_[$time->[c_wday]]; |
210 | } |
79d09e5e |
211 | elsif ($time->has_wday_names) { |
212 | return $time->wday_name($time->[c_mon]); |
d0369dd1 |
213 | } |
79d09e5e |
214 | return $WDAY_NAMES[$time->[c_wday]]; |
215 | } |
216 | |
217 | sub has_weekday_names { |
218 | my $time = shift; |
219 | return 0; |
d0369dd1 |
220 | } |
221 | |
222 | sub weekdayname { |
223 | my $time = shift; |
224 | if (@_) { |
225 | return $_[$time->[c_wday]]; |
226 | } |
79d09e5e |
227 | elsif ($time->has_weekday_names) { |
228 | return $time->weekday_name($time->[c_mon]); |
302d38aa |
229 | } |
79d09e5e |
230 | return $WEEKDAY_NAMES[$time->[c_wday]]; |
302d38aa |
231 | } |
232 | |
d0369dd1 |
233 | *weekdayname = \&weekdayname; |
234 | *weekday = \&weekdayname; |
302d38aa |
235 | |
236 | sub yday { |
237 | my $time = shift; |
238 | $time->[c_yday]; |
239 | } |
240 | |
241 | *day_of_year = \&yday; |
242 | |
243 | sub isdst { |
244 | my $time = shift; |
245 | $time->[c_isdst]; |
246 | } |
247 | |
248 | *daylight_savings = \&isdst; |
249 | |
250 | # Thanks to Tony Olekshy <olekshy@cs.ualberta.ca> for this algorithm |
251 | sub tzoffset { |
252 | my $time = shift; |
253 | |
254 | my $epoch = $time->[c_epoch]; |
255 | |
256 | my $j = sub { # Tweaked Julian day number algorithm. |
257 | |
258 | my ($s,$n,$h,$d,$m,$y) = @_; $m += 1; $y += 1900; |
259 | |
260 | # Standard Julian day number algorithm without constant. |
261 | # |
262 | my $y1 = $m > 2 ? $y : $y - 1; |
263 | |
264 | my $m1 = $m > 2 ? $m + 1 : $m + 13; |
265 | |
266 | my $day = int(365.25 * $y1) + int(30.6001 * $m1) + $d; |
267 | |
268 | # Modify to include hours/mins/secs in floating portion. |
269 | # |
270 | return $day + ($h + ($n + $s / 60) / 60) / 24; |
271 | }; |
272 | |
273 | # Compute floating offset in hours. |
274 | # |
275 | my $delta = 24 * (&$j(CORE::localtime $epoch) - &$j(CORE::gmtime $epoch)); |
276 | |
277 | # Return value in seconds rounded to nearest minute. |
278 | return Time::Seconds->new( int($delta * 60 + ($delta >= 0 ? 0.5 : -0.5)) * 60); |
279 | } |
280 | |
281 | sub epoch { |
282 | my $time = shift; |
283 | $time->[c_epoch]; |
284 | } |
285 | |
286 | sub hms { |
287 | my $time = shift; |
2a74cb2d |
288 | my $sep = @_ ? shift(@_) : $TIME_SEP; |
302d38aa |
289 | sprintf("%02d$sep%02d$sep%02d", $time->[c_hour], $time->[c_min], $time->[c_sec]); |
290 | } |
291 | |
292 | *time = \&hms; |
293 | |
294 | sub ymd { |
295 | my $time = shift; |
2a74cb2d |
296 | my $sep = @_ ? shift(@_) : $DATE_SEP; |
302d38aa |
297 | sprintf("%d$sep%02d$sep%02d", $time->year, $time->mon, $time->[c_mday]); |
298 | } |
299 | |
300 | *date = \&ymd; |
301 | |
302 | sub mdy { |
303 | my $time = shift; |
2a74cb2d |
304 | my $sep = @_ ? shift(@_) : $DATE_SEP; |
302d38aa |
305 | sprintf("%02d$sep%02d$sep%d", $time->mon, $time->[c_mday], $time->year); |
306 | } |
307 | |
308 | sub dmy { |
309 | my $time = shift; |
2a74cb2d |
310 | my $sep = @_ ? shift(@_) : $DATE_SEP; |
302d38aa |
311 | sprintf("%02d$sep%02d$sep%d", $time->[c_mday], $time->mon, $time->year); |
312 | } |
313 | |
314 | sub datetime { |
315 | my $time = shift; |
2a74cb2d |
316 | my %seps = (date => $DATE_SEP, T => 'T', time => $TIME_SEP, @_); |
317 | return join($seps{T}, $time->date($seps{date}), $time->time($seps{time})); |
302d38aa |
318 | } |
319 | |
320 | # taken from Time::JulianDay |
321 | sub julian_day { |
322 | my $time = shift; |
323 | my ($year, $month, $day) = ($time->year, $time->mon, $time->mday); |
324 | my ($tmp, $secs); |
325 | |
326 | $tmp = $day - 32075 |
327 | + 1461 * ( $year + 4800 - ( 14 - $month ) / 12 )/4 |
328 | + 367 * ( $month - 2 + ( ( 14 - $month ) / 12 ) * 12 ) / 12 |
329 | - 3 * ( ( $year + 4900 - ( 14 - $month ) / 12 ) / 100 ) / 4 |
330 | ; |
331 | |
332 | return $tmp; |
333 | } |
334 | |
2a74cb2d |
335 | # Hi Mark-Jason! |
302d38aa |
336 | sub mjd { |
302d38aa |
337 | return shift->julian_day - 2_400_000.5; |
338 | } |
339 | |
2a74cb2d |
340 | sub week { |
341 | # taken from the Calendar FAQ |
342 | use integer; |
343 | my $J = shift->julian_day; |
344 | my $d4 = ((($J + 31741 - ($J % 7)) % 146097) % 36524) % 1461; |
345 | my $L = $d4 / 1460; |
346 | my $d1 = (($d4 - $L) % 365) + $L; |
347 | return $d1 / 7 + 1; |
348 | } |
349 | |
350 | sub _is_leap_year { |
351 | my $year = shift; |
352 | return (($year %4 == 0) && !($year % 100 == 0)) || ($year % 400 == 0) |
353 | ? 1 : 0; |
354 | } |
355 | |
356 | sub is_leap_year { |
357 | my $time = shift; |
358 | my $year = $time->year; |
359 | return _is_leap_year($year); |
360 | } |
361 | |
362 | my @MON_LAST = qw(31 28 31 30 31 30 31 31 30 31 30 31); |
363 | |
364 | sub month_last_day { |
365 | my $time = shift; |
366 | my $year = $time->year; |
367 | my $_mon = $time->_mon; |
368 | return $MON_LAST[$_mon] + ($_mon == 1 ? _is_leap_year($year) : 0); |
369 | } |
370 | |
d0369dd1 |
371 | use vars qw($_ftime); |
372 | |
373 | $_ftime = |
374 | { |
375 | '%' => sub { |
376 | return "%"; |
377 | }, |
378 | 'a' => sub { |
79d09e5e |
379 | my ($format, $time) = @_; |
380 | $time->wdayname(); |
d0369dd1 |
381 | }, |
382 | 'A' => sub { |
79d09e5e |
383 | my ($format, $time) = @_; |
384 | $time->weekdayname(); |
d0369dd1 |
385 | }, |
386 | 'b' => sub { |
79d09e5e |
387 | my ($format, $time) = @_; |
388 | $time->monname(); |
d0369dd1 |
389 | }, |
390 | 'B' => sub { |
79d09e5e |
391 | my ($format, $time) = @_; |
392 | $time->monthname(); |
d0369dd1 |
393 | }, |
394 | 'c' => sub { |
79d09e5e |
395 | my ($format, $time) = @_; |
396 | $time->cdate(); |
d0369dd1 |
397 | }, |
398 | 'C' => sub { |
79d09e5e |
399 | my ($format, $time) = @_; |
400 | sprintf("%02d", int($time->y() / 100)); |
d0369dd1 |
401 | }, |
402 | 'd' => sub { |
79d09e5e |
403 | my ($format, $time) = @_; |
404 | sprintf("%02d", $time->d()); |
d0369dd1 |
405 | }, |
406 | 'D' => sub { |
79d09e5e |
407 | my ($format, $time) = @_; |
d0369dd1 |
408 | join("/", |
79d09e5e |
409 | $_ftime->{'m'}->('m', $time), |
410 | $_ftime->{'d'}->('d', $time), |
411 | $_ftime->{'y'}->('y', $time)); |
d0369dd1 |
412 | }, |
413 | 'e' => sub { |
79d09e5e |
414 | my ($format, $time) = @_; |
415 | sprintf("%2d", $time->d()); |
d0369dd1 |
416 | }, |
79d09e5e |
417 | 'h' => sub { |
d0369dd1 |
418 | my ($format, $time, @rest) = @_; |
419 | $time->monname(@rest); |
420 | }, |
421 | 'H' => sub { |
79d09e5e |
422 | my ($format, $time) = @_; |
423 | sprintf("%02d", $time->h()); |
d0369dd1 |
424 | }, |
425 | 'I' => sub { |
79d09e5e |
426 | my ($format, $time) = @_; |
427 | my $h = $time->h(); |
d0369dd1 |
428 | sprintf("%02d", $h == 0 ? 12 : ($h < 13 ? $h : $h % 12)); |
429 | }, |
430 | 'j' => sub { |
79d09e5e |
431 | my ($format, $time) = @_; |
432 | sprintf("%03d", $time->yday()); |
d0369dd1 |
433 | }, |
434 | 'm' => sub { |
79d09e5e |
435 | my ($format, $time) = @_; |
436 | sprintf("%02d", $time->mon()); |
d0369dd1 |
437 | }, |
438 | 'M' => sub { |
79d09e5e |
439 | my ($format, $time) = @_; |
440 | sprintf("%02d", $time->min()); |
d0369dd1 |
441 | }, |
442 | 'n' => sub { |
443 | return "\n"; |
444 | }, |
445 | 'p' => sub { |
79d09e5e |
446 | my ($format, $time) = @_; |
447 | my $h = $time->h(); |
d0369dd1 |
448 | $h == 0 ? 'pm' : ($h < 13 ? 'am' : 'pm'); |
449 | }, |
450 | 'r' => sub { |
79d09e5e |
451 | my ($format, $time) = @_; |
d0369dd1 |
452 | join(":", |
79d09e5e |
453 | $_ftime->{'I'}->('I', $time), |
454 | $_ftime->{'M'}->('M', $time), |
455 | $_ftime->{'S'}->('S', $time)) . |
456 | " " . $_ftime->{'p'}->('p', $time); |
d0369dd1 |
457 | }, |
458 | 'R' => sub { |
79d09e5e |
459 | my ($format, $time) = @_; |
d0369dd1 |
460 | join(":", |
79d09e5e |
461 | $_ftime->{'H'}->('H', $time), |
462 | $_ftime->{'M'}->('M', $time)); |
d0369dd1 |
463 | }, |
464 | 'S' => sub { |
79d09e5e |
465 | my ($format, $time) = @_; |
466 | sprintf("%02d", $time->s()); |
d0369dd1 |
467 | }, |
468 | 't' => sub { |
469 | return "\t"; |
470 | }, |
471 | 'T' => sub { |
79d09e5e |
472 | my ($format, $time) = @_; |
d0369dd1 |
473 | join(":", |
79d09e5e |
474 | $_ftime->{'H'}->('H', $time), |
475 | $_ftime->{'M'}->('M', $time), |
476 | $_ftime->{'S'}->('S', $time)); |
d0369dd1 |
477 | }, |
478 | 'u' => sub { |
79d09e5e |
479 | my ($format, $time) = @_; |
480 | ($time->wday() + 5) % 7 + 1; |
d0369dd1 |
481 | }, |
79d09e5e |
482 | # U taken care by libc |
d0369dd1 |
483 | 'V' => sub { |
79d09e5e |
484 | my ($format, $time) = @_; |
485 | sprintf("%02d", $time->week()); |
d0369dd1 |
486 | }, |
487 | 'w' => sub { |
79d09e5e |
488 | my ($format, $time) = @_; |
489 | $time->_wday(); |
d0369dd1 |
490 | }, |
79d09e5e |
491 | # W taken care by libc |
d0369dd1 |
492 | 'x' => sub { |
79d09e5e |
493 | my ($format, $time) = @_; |
d0369dd1 |
494 | join("/", |
79d09e5e |
495 | $_ftime->{'m'}->('m', $time), |
496 | $_ftime->{'d'}->('d', $time), |
497 | $_ftime->{'y'}->('y', $time)); |
d0369dd1 |
498 | }, |
499 | 'y' => sub { |
79d09e5e |
500 | my ($format, $time) = @_; |
501 | sprintf("%02d", $time->y() % 100); |
d0369dd1 |
502 | }, |
503 | 'Y' => sub { |
79d09e5e |
504 | my ($format, $time) = @_; |
505 | sprintf("%4d", $time->y()); |
d0369dd1 |
506 | }, |
79d09e5e |
507 | # Z taken care by libc |
d0369dd1 |
508 | }; |
509 | |
79d09e5e |
510 | sub has_ftime { |
511 | my ($format) = @_; |
512 | exists $_ftime->{$format}; |
513 | } |
514 | |
515 | sub has_ftimes { |
516 | keys %$_ftime; |
517 | } |
518 | |
519 | sub delete_ftime { |
520 | delete $_ftime->{@_}; |
521 | } |
522 | |
523 | sub ftime { |
524 | my ($format) = $_[0]; |
525 | if (@_ == 1) { |
526 | return $_ftime->{$format}; |
527 | } elsif (@_ == 2) { |
528 | if (ref $_[0] eq 'CODE') { |
529 | $_ftime->{$format} = $_[1]; |
530 | } else { |
531 | require Carp; |
532 | Carp::croak "ftime: second argument not a code ref"; |
533 | } |
534 | } else { |
535 | require Carp; |
536 | Carp::croak "ftime: want one or two arguments"; |
537 | } |
538 | } |
539 | |
d0369dd1 |
540 | sub _ftime { |
541 | my ($format, $time, @rest) = @_; |
79d09e5e |
542 | if (has_ftime($format)) { |
d0369dd1 |
543 | # We are passing format to the anonsubs so that |
544 | # one can share the same sub among several formats. |
545 | return $_ftime->{$format}->($format, $time, @rest); |
546 | } |
79d09e5e |
547 | # If we don't know it, pass it down to the libc layer. |
548 | # (In other words, cheat.) |
549 | # This pays for for '%Z', though, and for all the |
550 | # locale-specific %Ex and %Oy formats. |
551 | return $time->_strftime("%$format"); |
d0369dd1 |
552 | } |
553 | |
302d38aa |
554 | sub strftime { |
555 | my $time = shift; |
2a74cb2d |
556 | my $format = @_ ? shift(@_) : "%a, %d %b %Y %H:%M:%S %Z"; |
d0369dd1 |
557 | $format =~ s/%(.)/_ftime($1, $time, @_)/ge; |
558 | return $format; |
559 | } |
560 | |
561 | sub _strftime { |
562 | my $time = shift; |
563 | my $format = @_ ? shift(@_) : "%a, %d %b %Y %H:%M:%S %Z"; |
564 | return __strftime($format, (@$time)[c_sec..c_isdst]); |
565 | } |
566 | |
79d09e5e |
567 | use vars qw($_ptime); |
568 | |
569 | $_ptime = |
570 | { |
571 | '%' => sub { |
e8be01ad |
572 | $_[1] =~ s/^%// && $1; |
573 | }, |
574 | # a unimplemented |
575 | # A unimplemented |
576 | # b unimplemented |
577 | # B unimplemented |
578 | # c unimplemented |
579 | 'C' => sub { |
580 | $_[1] =~ s/^(0[0-9])// && $1; |
79d09e5e |
581 | }, |
582 | 'd' => sub { |
e8be01ad |
583 | $_[1] =~ s/^(0[1-9]|2[0-9]|3[01])// && $1; |
584 | }, |
585 | 'D' => sub { |
586 | my %D; |
587 | my $D; |
588 | if (defined ($D = $_ptime->{'m'}->($_[0], $_[1]))) { |
589 | $D{m} = $D; |
590 | } else { |
591 | return; |
592 | } |
593 | $_[1] =~ s:^/:: || return; |
594 | if (defined ($D = $_ptime->{'d'}->($_[0], $_[1]))) { |
595 | $D{d} = $D; |
596 | } else { |
597 | return; |
598 | } |
599 | $_[1] =~ s:^/:: || return; |
600 | if (defined ($D = $_ptime->{'y'}->($_[0], $_[1]))) { |
601 | $D{y} = $D; |
602 | } else { |
603 | return; |
604 | } |
605 | return { %D }; |
79d09e5e |
606 | }, |
e8be01ad |
607 | 'e' => sub { |
608 | $_[1] =~ s/^( [1-9]|2[0-9]|3[01])// && $1; |
609 | }, |
610 | # h unimplemented |
79d09e5e |
611 | 'H' => sub { |
e8be01ad |
612 | $_[1] =~ s/^([0-1][0-9]|2[0-3])// && $1; |
613 | }, |
614 | 'I' => sub { |
615 | $_[1] =~ s/^(0[1-9]|1[012])// && $1; |
616 | }, |
617 | 'j' => sub { |
618 | $_[1] =~ s/^([0-9][0-9][0-9])// && $1 >= 1 && $1 <= 366 && $1; |
79d09e5e |
619 | }, |
620 | 'm' => sub { |
e8be01ad |
621 | $_[1] =~ s/^(0[1-9]|1[012])// && $1; |
79d09e5e |
622 | }, |
623 | 'M' => sub { |
e8be01ad |
624 | $_[1] =~ s/^([0-5][0-9])// && $1; |
625 | }, |
626 | 't' => sub { |
627 | $_[1] =~ s/^\n// && $1; |
628 | }, |
629 | 'p' => sub { |
630 | $_[1] =~ s/^(am|pm)// && $1; |
631 | }, |
632 | 'r' => sub { |
633 | my %r; |
634 | my $r; |
635 | if (defined ($r = $_ptime->{'I'}->($_[0], $_[1]))) { |
636 | $r{I} = $r; |
637 | } else { |
638 | return; |
639 | } |
640 | $_[1] =~ s/^:// || return; |
641 | if (defined ($r = $_ptime->{'M'}->($_[0], $_[1]))) { |
642 | $r{M} = $r; |
643 | } else { |
644 | return; |
645 | } |
646 | $_[1] =~ s/^:// || return; |
647 | if (defined ($r = $_ptime->{'S'}->($_[0], $_[1]))) { |
648 | $r{S} = $r; |
649 | } else { |
650 | return; |
651 | } |
652 | $_[1] =~ s/^ // || return; |
653 | if (defined ($r = $_ptime->{'p'}->($_[0], $_[1]))) { |
654 | $r{p} = $r; |
655 | } else { |
656 | return; |
657 | } |
658 | return { %r }; |
659 | }, |
660 | 'R' => sub { |
661 | my %R; |
662 | my $R; |
663 | if (defined ($R = $_ptime->{'H'}->($_[0], $_[1]))) { |
664 | $R{H} = $R; |
665 | } else { |
666 | return; |
667 | } |
668 | $_[1] =~ s/^:// || return; |
669 | if (defined ($R = $_ptime->{'M'}->($_[0], $_[1]))) { |
670 | $R{M} = $R; |
671 | } else { |
672 | return; |
673 | } |
674 | return { %R }; |
79d09e5e |
675 | }, |
676 | 'S' => sub { |
e8be01ad |
677 | $_[1] =~ s/^([0-5][0-9])// && $1; |
678 | }, |
679 | 't' => sub { |
680 | $_[1] =~ s/^\t// && $1; |
681 | }, |
682 | 'T' => sub { |
683 | my %T; |
684 | my $T; |
685 | if (defined ($T = $_ptime->{'H'}->($_[0], $_[1]))) { |
686 | $T{H} = $T; |
687 | } else { |
688 | return; |
689 | } |
690 | $_[1] =~ s/^:// || return; |
691 | if (defined ($T = $_ptime->{'M'}->($_[0], $_[1]))) { |
692 | $T{M} = $T; |
693 | } else { |
694 | return; |
695 | } |
696 | $_[1] =~ s/^:// || return; |
697 | if (defined ($T = $_ptime->{'S'}->($_[0], $_[1]))) { |
698 | $T{S} = $T; |
699 | } else { |
700 | return; |
701 | } |
702 | return { %T }; |
703 | }, |
704 | # u unimplemented |
705 | # U unimplemented |
706 | # w unimplemented |
707 | # W unimplemented |
708 | 'x' => sub { |
709 | my %x; |
710 | my $x; |
711 | if (defined ($x = $_ptime->{'m'}->($_[0], $_[1]))) { |
712 | $x{m} = $x; |
713 | } else { |
714 | return; |
715 | } |
716 | $_[1] =~ s:^/:: || return; |
717 | if (defined ($x = $_ptime->{'d'}->($_[0], $_[1]))) { |
718 | $x{d} = $x; |
719 | } else { |
720 | return; |
721 | } |
722 | $_[1] =~ s:^/:: || return; |
723 | if (defined ($x = $_ptime->{'y'}->($_[0], $_[1]))) { |
724 | $x{y} = $x; |
725 | } else { |
726 | return; |
727 | } |
728 | return { %x }; |
729 | }, |
730 | 'y' => sub { |
731 | $_[1] =~ s/^([0-9][0-9])// && $1; |
79d09e5e |
732 | }, |
733 | 'Y' => sub { |
734 | $_[1] =~ s/^([1-9][0-9][0-9][0-9])// && $1; |
735 | }, |
e8be01ad |
736 | # Z too unportable |
79d09e5e |
737 | }; |
738 | |
739 | sub has_ptime { |
740 | my ($format) = @_; |
741 | exists $_ptime->{$format}; |
742 | } |
743 | |
744 | sub has_ptimes { |
745 | keys %$_ptime; |
746 | } |
747 | |
748 | sub delete_ptime { |
749 | delete $_ptime->{@_}; |
750 | } |
751 | |
752 | sub ptime { |
753 | my ($format) = $_[0]; |
754 | if (@_ == 1) { |
755 | return $_ptime->{$format}; |
756 | } elsif (@_ == 2) { |
757 | if (ref $_[0] eq 'CODE') { |
758 | $_ptime->{$format} = $_[1]; |
759 | } else { |
760 | require Carp; |
761 | Carp::croak "ptime: second argument not a code ref"; |
762 | } |
763 | } else { |
764 | require Carp; |
765 | Carp::croak "ptime: want one or two arguments"; |
766 | } |
767 | } |
768 | |
769 | sub _ptime { |
770 | my ($format, $stime) = @_; |
771 | if (has_ptime($format)) { |
772 | # We are passing format to the anonsubs so that |
773 | # one can share the same sub among several formats. |
e8be01ad |
774 | return $_ptime->{$format}->($format, $_[1]); |
79d09e5e |
775 | } |
776 | die "strptime: unknown format %$format (time '$stime')\n"; |
777 | } |
778 | |
779 | sub strptime { |
780 | my $time = shift; |
781 | my $format = shift; |
782 | my $stime = @_ ? shift : "$time"; |
783 | my %ptime; |
e8be01ad |
784 | |
79d09e5e |
785 | while ($format ne '') { |
786 | if ($format =~ s/^([^%]+)//) { |
787 | my $skip = $1; |
788 | last unless $stime =~ s/^\Q$skip//; |
789 | } |
790 | while ($format =~ s/^%(.)//) { |
e8be01ad |
791 | my $f = $1; |
792 | my $t = _ptime($f, $stime); |
79d09e5e |
793 | if (defined $t) { |
e8be01ad |
794 | if (ref $t eq 'HASH') { |
795 | @ptime{keys %$t} = values %$t; |
796 | } else { |
797 | $ptime{$f} = $t; |
798 | } |
79d09e5e |
799 | } |
800 | } |
801 | } |
e8be01ad |
802 | |
79d09e5e |
803 | return %ptime; |
804 | } |
805 | |
d0369dd1 |
806 | sub wday_names { |
807 | shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method |
808 | my @old = @WDAY_NAMES; |
809 | if (@_) { |
810 | @WDAY_NAMES = @_; |
811 | } |
812 | return @old; |
813 | } |
814 | |
815 | sub weekday_names { |
816 | shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method |
817 | my @old = @WEEKDAY_NAMES; |
818 | if (@_) { |
819 | @WEEKDAY_NAMES = @_; |
820 | } |
821 | return @old; |
302d38aa |
822 | } |
823 | |
d0369dd1 |
824 | sub mon_names { |
302d38aa |
825 | shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method |
d0369dd1 |
826 | my @old = @MON_NAMES; |
302d38aa |
827 | if (@_) { |
d0369dd1 |
828 | @MON_NAMES = @_; |
302d38aa |
829 | } |
830 | return @old; |
831 | } |
832 | |
d0369dd1 |
833 | sub month_names { |
302d38aa |
834 | shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method |
d0369dd1 |
835 | my @old = @MONTH_NAMES; |
302d38aa |
836 | if (@_) { |
d0369dd1 |
837 | @MONTH_NAMES = @_; |
302d38aa |
838 | } |
839 | return @old; |
840 | } |
841 | |
842 | sub time_separator { |
843 | shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); |
844 | my $old = $TIME_SEP; |
845 | if (@_) { |
846 | $TIME_SEP = $_[0]; |
847 | } |
848 | return $old; |
849 | } |
850 | |
851 | sub date_separator { |
852 | shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); |
853 | my $old = $DATE_SEP; |
854 | if (@_) { |
855 | $DATE_SEP = $_[0]; |
856 | } |
857 | return $old; |
858 | } |
859 | |
860 | use overload '""' => \&cdate; |
861 | |
862 | sub cdate { |
863 | my $time = shift; |
864 | if ($time->[c_islocal]) { |
865 | return scalar(CORE::localtime($time->[c_epoch])); |
866 | } |
867 | else { |
868 | return scalar(CORE::gmtime($time->[c_epoch])); |
869 | } |
870 | } |
871 | |
872 | use overload |
873 | '-' => \&subtract, |
874 | '+' => \&add; |
875 | |
876 | sub subtract { |
877 | my $time = shift; |
878 | my $rhs = shift; |
879 | die "Can't subtract a date from something!" if shift; |
880 | |
881 | if (ref($rhs) && $rhs->isa('Time::Piece')) { |
882 | return Time::Seconds->new($time->[c_epoch] - $rhs->epoch); |
883 | } |
884 | else { |
885 | # rhs is seconds. |
886 | return _mktime(($time->[c_epoch] - $rhs), $time->[c_islocal]); |
887 | } |
888 | } |
889 | |
890 | sub add { |
891 | warn "add\n"; |
892 | my $time = shift; |
893 | my $rhs = shift; |
894 | croak "Invalid rhs of addition: $rhs" if ref($rhs); |
895 | |
896 | return _mktime(($time->[c_epoch] + $rhs), $time->[c_islocal]); |
897 | } |
898 | |
899 | use overload |
900 | '<=>' => \&compare; |
901 | |
902 | sub get_epochs { |
903 | my ($time, $rhs, $reverse) = @_; |
904 | $time = $time->epoch; |
905 | if (UNIVERSAL::isa($rhs, 'Time::Piece')) { |
906 | $rhs = $rhs->epoch; |
907 | } |
908 | if ($reverse) { |
909 | return $rhs, $time; |
910 | } |
911 | return $time, $rhs; |
912 | } |
913 | |
914 | sub compare { |
915 | my ($lhs, $rhs) = get_epochs(@_); |
916 | return $lhs <=> $rhs; |
917 | } |
918 | |
919 | 1; |
920 | __END__ |
921 | |
922 | =head1 NAME |
923 | |
924 | Time::Piece - Object Oriented time objects |
925 | |
926 | =head1 SYNOPSIS |
927 | |
928 | use Time::Piece; |
929 | |
930 | my $t = localtime; |
931 | print "Time is $t\n"; |
932 | print "Year is ", $t->year, "\n"; |
933 | |
934 | =head1 DESCRIPTION |
935 | |
936 | This module replaces the standard localtime and gmtime functions with |
937 | implementations that return objects. It does so in a backwards |
938 | compatible manner, so that using localtime/gmtime in the way documented |
939 | in perlfunc will still return what you expect. |
940 | |
941 | The module actually implements most of an interface described by |
942 | Larry Wall on the perl5-porters mailing list here: |
943 | http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2000-01/msg00241.html |
944 | |
945 | =head1 USAGE |
946 | |
947 | After importing this module, when you use localtime or gmtime in a scalar |
948 | context, rather than getting an ordinary scalar string representing the |
949 | date and time, you get a Time::Piece object, whose stringification happens |
950 | to produce the same effect as the localtime and gmtime functions. There is |
951 | also a new() constructor provided, which is the same as localtime(), except |
952 | when passed a Time::Piece object, in which case it's a copy constructor. The |
953 | following methods are available on the object: |
954 | |
d0369dd1 |
955 | $t->s # 0..61 [1] |
956 | # and 61: leap second and double leap second |
957 | $t->sec # same as $t->s |
958 | $t->second # same as $t->s |
959 | $t->min # 0..59 |
960 | $t->h # 0..24 |
961 | $t->hour # same as $t->h |
962 | $t->d # 1..31 |
963 | $t->mday # same as $t->d |
964 | $t->mon # 1 = January |
965 | $t->_mon # 0 = January |
966 | $t->monname # Feb |
967 | $t->monthname # February |
968 | $t->month # same as $t->monthname |
969 | $t->y # based at 0 (year 0 AD is, of course 1 BC) |
970 | $t->year # same as $t->y |
971 | $t->_year # year minus 1900 |
972 | $t->wday # 1 = Sunday |
973 | $t->day_of_week # 0 = Sunday |
974 | $t->_wday # 0 = Sunday |
975 | $t->wdayname # Tue |
976 | $t->weekdayname # Tuesday |
977 | $t->weekday # same as weekdayname |
978 | $t->yday # also available as $t->day_of_year, 0 = Jan 01 |
979 | $t->isdst # also available as $t->daylight_savings |
980 | $t->daylight_savings # same as $t->isdst |
981 | |
982 | $t->hms # 12:34:56 |
983 | $t->hms(".") # 12.34.56 |
984 | $t->time # same as $t->hms |
985 | |
986 | $t->ymd # 2000-02-29 |
987 | $t->date # same as $t->ymd |
988 | $t->mdy # 02-29-2000 |
989 | $t->mdy("/") # 02/29/2000 |
990 | $t->dmy # 29-02-2000 |
991 | $t->dmy(".") # 29.02.2000 |
992 | $t->datetime # 2000-02-29T12:34:56 (ISO 8601) |
993 | $t->cdate # Tue Feb 29 12:34:56 2000 |
994 | "$t" # same as $t->cdate |
2a74cb2d |
995 | |
d0369dd1 |
996 | $t->epoch # seconds since the epoch |
997 | $t->tzoffset # timezone offset in a Time::Seconds object |
998 | |
999 | $t->julian_day # number of days since Julian period began |
1000 | $t->mjd # modified Julian day |
2a74cb2d |
1001 | |
d0369dd1 |
1002 | $t->week # week number (ISO 8601) |
2a74cb2d |
1003 | |
d0369dd1 |
1004 | $t->is_leap_year # true if it its |
1005 | $t->month_last_day # 28-31 |
2a74cb2d |
1006 | |
d0369dd1 |
1007 | $t->time_separator($s) # set the default separator (default ":") |
1008 | $t->date_separator($s) # set the default separator (default "-") |
1009 | $t->wday(@days) # set the default weekdays, abbreviated |
1010 | $t->weekday_names(@days) # set the default weekdays |
1011 | $t->mon_names(@days) # set the default months, abbreviated |
1012 | $t->month_names(@days) # set the default months |
2a74cb2d |
1013 | |
d0369dd1 |
1014 | $t->strftime($format) # data and time formatting |
1015 | $t->strftime() # "Tue, 29 Feb 2000 12:34:56 GMT" |
2a74cb2d |
1016 | |
d0369dd1 |
1017 | $t->_strftime($format) # same as POSIX::strftime (without the |
1018 | # overhead of the full POSIX extension), |
1019 | # calls the operating system libraries, |
1020 | # as opposed to $t->strftime() |
302d38aa |
1021 | |
1022 | =head2 Local Locales |
1023 | |
2a74cb2d |
1024 | Both wdayname (day) and monname (month) allow passing in a list to use |
1025 | to index the name of the days against. This can be useful if you need |
1026 | to implement some form of localisation without actually installing or |
1027 | using locales. |
302d38aa |
1028 | |
1029 | my @days = qw( Dimanche Lundi Merdi Mercredi Jeudi Vendredi Samedi ); |
1030 | |
1031 | my $french_day = localtime->day(@days); |
1032 | |
1033 | These settings can be overriden globally too: |
1034 | |
d0369dd1 |
1035 | Time::Piece::weekday_names(@days); |
302d38aa |
1036 | |
1037 | Or for months: |
1038 | |
d0369dd1 |
1039 | Time::Piece::month_names(@months); |
302d38aa |
1040 | |
1041 | And locally for months: |
1042 | |
1043 | print localtime->month(@months); |
1044 | |
1045 | =head2 Date Calculations |
1046 | |
1047 | It's possible to use simple addition and subtraction of objects: |
1048 | |
1049 | use Time::Seconds; |
1050 | |
1051 | my $seconds = $t1 - $t2; |
1052 | $t1 += ONE_DAY; # add 1 day (constant from Time::Seconds) |
1053 | |
1054 | The following are valid ($t1 and $t2 are Time::Piece objects): |
1055 | |
1056 | $t1 - $t2; # returns Time::Seconds object |
1057 | $t1 - 42; # returns Time::Piece object |
1058 | $t1 + 533; # returns Time::Piece object |
1059 | |
1060 | However adding a Time::Piece object to another Time::Piece object |
1061 | will cause a runtime error. |
1062 | |
1063 | Note that the first of the above returns a Time::Seconds object, so |
1064 | while examining the object will print the number of seconds (because |
1065 | of the overloading), you can also get the number of minutes, hours, |
1066 | days, weeks and years in that delta, using the Time::Seconds API. |
1067 | |
1068 | =head2 Date Comparisons |
1069 | |
1070 | Date comparisons are also possible, using the full suite of "<", ">", |
1071 | "<=", ">=", "<=>", "==" and "!=". |
1072 | |
2a74cb2d |
1073 | =head2 YYYY-MM-DDThh:mm:ss |
1074 | |
1075 | The ISO 8601 standard defines the date format to be YYYY-MM-DD, and |
1076 | the time format to be hh:mm:ss (24 hour clock), and if combined, they |
1077 | should be concatenated with date first and with a capital 'T' in front |
1078 | of the time. |
1079 | |
1080 | =head2 Week Number |
1081 | |
1082 | The I<week number> may be an unknown concept to some readers. The ISO |
1083 | 8601 standard defines that weeks begin on a Monday and week 1 of the |
1084 | year is the week that includes both January 4th and the first Thursday |
1085 | of the year. In other words, if the first Monday of January is the |
1086 | 2nd, 3rd, or 4th, the preceding days of the January are part of the |
1087 | last week of the preceding year. Week numbers range from 1 to 53. |
1088 | |
302d38aa |
1089 | =head2 Global Overriding |
1090 | |
1091 | Finally, it's possible to override localtime and gmtime everywhere, by |
1092 | including the ':override' tag in the import list: |
1093 | |
1094 | use Time::Piece ':override'; |
1095 | |
2a74cb2d |
1096 | =head1 SEE ALSO |
1097 | |
1098 | The excellent Calendar FAQ at http://www.tondering.dk/claus/calendar.html |
1099 | |
302d38aa |
1100 | =head1 AUTHOR |
1101 | |
1102 | Matt Sergeant, matt@sergeant.org |
1103 | |
2a74cb2d |
1104 | This module is based on Time::Object, with changes suggested by Jarkko |
302d38aa |
1105 | Hietaniemi before including in core perl. |
1106 | |
1107 | =head2 License |
1108 | |
1109 | This module is free software, you may distribute it under the same terms |
1110 | as Perl. |
1111 | |
1112 | =head2 Bugs |
1113 | |
1114 | The test harness leaves much to be desired. Patches welcome. |
1115 | |
1116 | =cut |