This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Time::Piece & matherr on qnx4
[perl5.git] / ext / Time / Piece / Piece.pm
CommitLineData
16433e2b
SP
1# $Id: Piece.pm 70 2006-09-07 17:43:38Z matt $
2
3package Time::Piece;
4
5use strict;
6
7require Exporter;
8require DynaLoader;
9use Time::Seconds;
10use Carp;
11use Time::Local;
12use UNIVERSAL qw(isa);
13
14our @ISA = qw(Exporter DynaLoader);
15
16our @EXPORT = qw(
17 localtime
18 gmtime
19);
20
21our %EXPORT_TAGS = (
22 ':override' => 'internal',
23 );
24
be8a15fc 25our $VERSION = '1.11_03';
16433e2b
SP
26
27bootstrap Time::Piece $VERSION;
28
29my $DATE_SEP = '-';
30my $TIME_SEP = ':';
31my @MON_LIST = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
32my @FULLMON_LIST = qw(January February March April May June July
33 August September October November December);
34my @DAY_LIST = qw(Sun Mon Tue Wed Thu Fri Sat);
35my @FULLDAY_LIST = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
36
37use constant 'c_sec' => 0;
38use constant 'c_min' => 1;
39use constant 'c_hour' => 2;
40use constant 'c_mday' => 3;
41use constant 'c_mon' => 4;
42use constant 'c_year' => 5;
43use constant 'c_wday' => 6;
44use constant 'c_yday' => 7;
45use constant 'c_isdst' => 8;
46use constant 'c_epoch' => 9;
47use constant 'c_islocal' => 10;
48
49sub localtime {
50 unshift @_, __PACKAGE__ unless eval { $_[0]->isa('Time::Piece') };
51 my $class = shift;
52 my $time = shift;
53 $time = time if (!defined $time);
54 $class->_mktime($time, 1);
55}
56
57sub gmtime {
58 unshift @_, __PACKAGE__ unless eval { $_[0]->isa('Time::Piece') };
59 my $class = shift;
60 my $time = shift;
61 $time = time if (!defined $time);
62 $class->_mktime($time, 0);
63}
64
65sub new {
66 my $class = shift;
67 my ($time) = @_;
68
69 my $self;
70
71 if (defined($time)) {
72 $self = $class->localtime($time);
73 }
74 elsif (ref($class) && $class->isa(__PACKAGE__)) {
75 $self = $class->_mktime($class->epoch, $class->[c_islocal]);
76 }
77 else {
78 $self = $class->localtime();
79 }
80
81 return bless $self, $class;
82}
83
84sub parse {
85 my $proto = shift;
86 my $class = ref($proto) || $proto;
87 my @components;
88 if (@_ > 1) {
89 @components = @_;
90 }
91 else {
92 @components = shift =~ /(\d+)$DATE_SEP(\d+)$DATE_SEP(\d+)(?:(?:T|\s+)(\d+)$TIME_SEP(\d+)(?:$TIME_SEP(\d+)))/;
93 @components = reverse(@components[0..5]);
94 }
95 return $class->new(_strftime("%s", @components));
96}
97
98sub _mktime {
99 my ($class, $time, $islocal) = @_;
100 $class = eval { (ref $class) && (ref $class)->isa('Time::Piece') }
101 ? ref $class
102 : $class;
103 if (ref($time)) {
104 $time->[c_epoch] = undef;
105 return wantarray ? @$time : bless [@$time, $islocal], $class;
106 }
107 _tzset();
108 my @time = $islocal ?
109 CORE::localtime($time)
110 :
111 CORE::gmtime($time);
112 wantarray ? @time : bless [@time, $time, $islocal], $class;
113}
114
115my %_special_exports = (
116 localtime => sub { my $c = $_[0]; sub { $c->localtime(@_) } },
117 gmtime => sub { my $c = $_[0]; sub { $c->gmtime(@_) } },
118);
119
120sub export {
121 my ($class, $to, @methods) = @_;
122 for my $method (@methods) {
123 if (exists $_special_exports{$method}) {
124 no strict 'refs';
125 no warnings 'redefine';
126 *{$to . "::$method"} = $_special_exports{$method}->($class);
127 } else {
128 $class->SUPER::export($to, $method);
129 }
130 }
131}
132
133sub import {
134 # replace CORE::GLOBAL localtime and gmtime if required
135 my $class = shift;
136 my %params;
137 map($params{$_}++,@_,@EXPORT);
138 if (delete $params{':override'}) {
139 $class->export('CORE::GLOBAL', keys %params);
140 }
141 else {
142 $class->export((caller)[0], keys %params);
143 }
144}
145
146## Methods ##
147
148sub sec {
149 my $time = shift;
150 $time->[c_sec];
151}
152
153*second = \&sec;
154
155sub min {
156 my $time = shift;
157 $time->[c_min];
158}
159
160*minute = \&min;
161
162sub hour {
163 my $time = shift;
164 $time->[c_hour];
165}
166
167sub mday {
168 my $time = shift;
169 $time->[c_mday];
170}
171
172*day_of_month = \&mday;
173
174sub mon {
175 my $time = shift;
176 $time->[c_mon] + 1;
177}
178
179sub _mon {
180 my $time = shift;
181 $time->[c_mon];
182}
183
184sub month {
185 my $time = shift;
186 if (@_) {
187 return $_[$time->[c_mon]];
188 }
189 elsif (@MON_LIST) {
190 return $MON_LIST[$time->[c_mon]];
191 }
192 else {
193 return $time->strftime('%b');
194 }
195}
196
197*monname = \&month;
198
199sub fullmonth {
200 my $time = shift;
201 if (@_) {
202 return $_[$time->[c_mon]];
203 }
204 elsif (@FULLMON_LIST) {
205 return $FULLMON_LIST[$time->[c_mon]];
206 }
207 else {
208 return $time->strftime('%B');
209 }
210}
211
212sub year {
213 my $time = shift;
214 $time->[c_year] + 1900;
215}
216
217sub _year {
218 my $time = shift;
219 $time->[c_year];
220}
221
222sub yy {
223 my $time = shift;
224 my $res = $time->[c_year] % 100;
225 return $res > 9 ? $res : "0$res";
226}
227
228sub wday {
229 my $time = shift;
230 $time->[c_wday] + 1;
231}
232
233sub _wday {
234 my $time = shift;
235 $time->[c_wday];
236}
237
238*day_of_week = \&_wday;
239
240sub wdayname {
241 my $time = shift;
242 if (@_) {
243 return $_[$time->[c_wday]];
244 }
245 elsif (@DAY_LIST) {
246 return $DAY_LIST[$time->[c_wday]];
247 }
248 else {
249 return $time->strftime('%a');
250 }
251}
252
253*day = \&wdayname;
254
255sub fullday {
256 my $time = shift;
257 if (@_) {
258 return $_[$time->[c_wday]];
259 }
260 elsif (@FULLDAY_LIST) {
261 return $FULLDAY_LIST[$time->[c_wday]];
262 }
263 else {
264 return $time->strftime('%A');
265 }
266}
267
268sub yday {
269 my $time = shift;
270 $time->[c_yday];
271}
272
273*day_of_year = \&yday;
274
275sub isdst {
276 my $time = shift;
277 $time->[c_isdst];
278}
279
280*daylight_savings = \&isdst;
281
282# Thanks to Tony Olekshy <olekshy@cs.ualberta.ca> for this algorithm
283sub tzoffset {
284 my $time = shift;
285
286 return Time::Seconds->new(0) unless $time->[c_islocal];
287
288 my $epoch = $time->epoch;
289
290 my $j = sub {
291
292 my ($s,$n,$h,$d,$m,$y) = @_; $m += 1; $y += 1900;
293
294 $time->_jd($y, $m, $d, $h, $n, $s);
295
296 };
297
298 # Compute floating offset in hours.
299 #
300 my $delta = 24 * (&$j(CORE::localtime $epoch) - &$j(CORE::gmtime $epoch));
301
302 # Return value in seconds rounded to nearest minute.
303 return Time::Seconds->new( int($delta * 60 + ($delta >= 0 ? 0.5 : -0.5)) * 60 );
304}
305
306sub epoch {
307 my $time = shift;
308 if (defined($time->[c_epoch])) {
309 return $time->[c_epoch];
310 }
311 else {
312 my $epoch = $time->[c_islocal] ?
313 timelocal(@{$time}[c_sec .. c_mon], $time->[c_year]+1900)
314 :
315 timegm(@{$time}[c_sec .. c_mon], $time->[c_year]+1900);
316 $time->[c_epoch] = $epoch;
317 return $epoch;
318 }
319}
320
321sub hms {
322 my $time = shift;
323 my $sep = @_ ? shift(@_) : $TIME_SEP;
324 sprintf("%02d$sep%02d$sep%02d", $time->[c_hour], $time->[c_min], $time->[c_sec]);
325}
326
327*time = \&hms;
328
329sub ymd {
330 my $time = shift;
331 my $sep = @_ ? shift(@_) : $DATE_SEP;
332 sprintf("%d$sep%02d$sep%02d", $time->year, $time->mon, $time->[c_mday]);
333}
334
335*date = \&ymd;
336
337sub mdy {
338 my $time = shift;
339 my $sep = @_ ? shift(@_) : $DATE_SEP;
340 sprintf("%02d$sep%02d$sep%d", $time->mon, $time->[c_mday], $time->year);
341}
342
343sub dmy {
344 my $time = shift;
345 my $sep = @_ ? shift(@_) : $DATE_SEP;
346 sprintf("%02d$sep%02d$sep%d", $time->[c_mday], $time->mon, $time->year);
347}
348
349sub datetime {
350 my $time = shift;
351 my %seps = (date => $DATE_SEP, T => 'T', time => $TIME_SEP, @_);
352 return join($seps{T}, $time->date($seps{date}), $time->time($seps{time}));
353}
354
355
356
357# Julian Day is always calculated for UT regardless
358# of local time
359sub julian_day {
360 my $time = shift;
361 # Correct for localtime
362 $time = $time->gmtime( $time->epoch ) if $time->[c_islocal];
363
364 # Calculate the Julian day itself
365 my $jd = $time->_jd( $time->year, $time->mon, $time->mday,
366 $time->hour, $time->min, $time->sec);
367
368 return $jd;
369}
370
371# MJD is defined as JD - 2400000.5 days
372sub mjd {
373 return shift->julian_day - 2_400_000.5;
374}
375
376# Internal calculation of Julian date. Needed here so that
377# both tzoffset and mjd/jd methods can share the code
378# Algorithm from Hatcher 1984 (QJRAS 25, 53-55), and
379# Hughes et al, 1989, MNRAS, 238, 15
380# See: http://adsabs.harvard.edu/cgi-bin/nph-bib_query?bibcode=1989MNRAS.238.1529H&db_key=AST
381# for more details
382
383sub _jd {
384 my $self = shift;
385 my ($y, $m, $d, $h, $n, $s) = @_;
386
387 # Adjust input parameters according to the month
388 $y = ( $m > 2 ? $y : $y - 1);
389 $m = ( $m > 2 ? $m - 3 : $m + 9);
390
391 # Calculate the Julian Date (assuming Julian calendar)
392 my $J = int( 365.25 *( $y + 4712) )
393 + int( (30.6 * $m) + 0.5)
394 + 59
395 + $d
396 - 0.5;
397
398 # Calculate the Gregorian Correction (since we have Gregorian dates)
399 my $G = 38 - int( 0.75 * int(49+($y/100)));
400
401 # Calculate the actual Julian Date
402 my $JD = $J + $G;
403
404 # Modify to include hours/mins/secs in floating portion.
405 return $JD + ($h + ($n + $s / 60) / 60) / 24;
406}
407
408sub week {
409 my $self = shift;
410
411 my $J = $self->julian_day;
412 # Julian day is independent of time zone so add on tzoffset
413 # if we are using local time here since we want the week day
414 # to reflect the local time rather than UTC
415 $J += ($self->tzoffset/(24*3600)) if $self->[c_islocal];
416
417 # Now that we have the Julian day including fractions
418 # convert it to an integer Julian Day Number using nearest
419 # int (since the day changes at midday we oconvert all Julian
420 # dates to following midnight).
421 $J = int($J+0.5);
422
423 use integer;
424 my $d4 = ((($J + 31741 - ($J % 7)) % 146097) % 36524) % 1461;
425 my $L = $d4 / 1460;
426 my $d1 = (($d4 - $L) % 365) + $L;
427 return $d1 / 7 + 1;
428}
429
430sub _is_leap_year {
431 my $year = shift;
432 return (($year %4 == 0) && !($year % 100 == 0)) || ($year % 400 == 0)
433 ? 1 : 0;
434}
435
436sub is_leap_year {
437 my $time = shift;
438 my $year = $time->year;
439 return _is_leap_year($year);
440}
441
442my @MON_LAST = qw(31 28 31 30 31 30 31 31 30 31 30 31);
443
444sub month_last_day {
445 my $time = shift;
446 my $year = $time->year;
447 my $_mon = $time->_mon;
448 return $MON_LAST[$_mon] + ($_mon == 1 ? _is_leap_year($year) : 0);
449}
450
451sub strftime {
452 my $time = shift;
453 my $tzname = $time->[c_islocal] ? '%Z' : 'UTC';
454 my $format = @_ ? shift(@_) : "%a, %d %b %Y %H:%M:%S $tzname";
455 if (!defined $time->[c_wday]) {
456 if ($time->[c_islocal]) {
457 return _strftime($format, CORE::localtime($time->epoch));
458 }
459 else {
460 return _strftime($format, CORE::gmtime($time->epoch));
461 }
462 }
463 return _strftime($format, (@$time)[c_sec..c_isdst]);
464}
465
466sub strptime {
467 my $time = shift;
468 my $string = shift;
469 my $format = @_ ? shift(@_) : "%a, %d %b %Y %H:%M:%S %Z";
470 my @vals = _strptime($string, $format);
471# warn(sprintf("got vals: %d-%d-%d %d:%d:%d\n", reverse(@vals)));
472 return scalar $time->_mktime(\@vals, (ref($time) ? $time->[c_islocal] : 0));
473}
474
475sub day_list {
476 shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method
477 my @old = @DAY_LIST;
478 if (@_) {
479 @DAY_LIST = @_;
480 }
481 return @old;
482}
483
484sub mon_list {
485 shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method
486 my @old = @MON_LIST;
487 if (@_) {
488 @MON_LIST = @_;
489 }
490 return @old;
491}
492
493sub time_separator {
494 shift if ref($_[0]) && $_[0]->isa(__PACKAGE__);
495 my $old = $TIME_SEP;
496 if (@_) {
497 $TIME_SEP = $_[0];
498 }
499 return $old;
500}
501
502sub date_separator {
503 shift if ref($_[0]) && $_[0]->isa(__PACKAGE__);
504 my $old = $DATE_SEP;
505 if (@_) {
506 $DATE_SEP = $_[0];
507 }
508 return $old;
509}
510
511use overload '""' => \&cdate,
512 'cmp' => \&str_compare,
513 'fallback' => undef;
514
515sub cdate {
516 my $time = shift;
517 if ($time->[c_islocal]) {
518 return scalar(CORE::localtime($time->epoch));
519 }
520 else {
521 return scalar(CORE::gmtime($time->epoch));
522 }
523}
524
525sub str_compare {
526 my ($lhs, $rhs, $reverse) = @_;
527 if (UNIVERSAL::isa($rhs, 'Time::Piece')) {
528 $rhs = "$rhs";
529 }
530 return $reverse ? $rhs cmp $lhs->cdate : $lhs->cdate cmp $rhs;
531}
532
533use overload
534 '-' => \&subtract,
535 '+' => \&add;
536
537sub subtract {
538 my $time = shift;
539 my $rhs = shift;
540 if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
541 $rhs = $rhs->seconds;
542 }
e3db0d81
RGS
543
544 if (shift)
545 {
546 # SWAPED is set (so someone tried an expression like NOTDATE - DATE).
547 # Imitate Perl's standard behavior and return the result as if the
548 # string $time resolves to was subtracted from NOTDATE. This way,
549 # classes which override this one and which have a stringify function
550 # that resolves to something that looks more like a number don't need
551 # to override this function.
552 return $rhs - "$time";
553 }
16433e2b
SP
554
555 if (UNIVERSAL::isa($rhs, 'Time::Piece')) {
556 return Time::Seconds->new($time->epoch - $rhs->epoch);
557 }
558 else {
559 # rhs is seconds.
560 return $time->_mktime(($time->epoch - $rhs), $time->[c_islocal]);
561 }
562}
563
564sub add {
565 my $time = shift;
566 my $rhs = shift;
567 if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
568 $rhs = $rhs->seconds;
569 }
570 croak "Invalid rhs of addition: $rhs" if ref($rhs);
571
572 return $time->_mktime(($time->epoch + $rhs), $time->[c_islocal]);
573}
574
575use overload
576 '<=>' => \&compare;
577
578sub get_epochs {
579 my ($lhs, $rhs, $reverse) = @_;
580 if (!UNIVERSAL::isa($rhs, 'Time::Piece')) {
581 $rhs = $lhs->new($rhs);
582 }
583 if ($reverse) {
584 return $rhs->epoch, $lhs->epoch;
585 }
586 return $lhs->epoch, $rhs->epoch;
587}
588
589sub compare {
590 my ($lhs, $rhs) = get_epochs(@_);
591 return $lhs <=> $rhs;
592}
593
5941;
595__END__
596
597=head1 NAME
598
599Time::Piece - Object Oriented time objects
600
601=head1 SYNOPSIS
602
603 use Time::Piece;
604
605 my $t = localtime;
606 print "Time is $t\n";
607 print "Year is ", $t->year, "\n";
608
609=head1 DESCRIPTION
610
611This module replaces the standard localtime and gmtime functions with
612implementations that return objects. It does so in a backwards
613compatible manner, so that using localtime/gmtime in the way documented
614in perlfunc will still return what you expect.
615
616The module actually implements most of an interface described by
617Larry Wall on the perl5-porters mailing list here:
618http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2000-01/msg00241.html
619
620=head1 USAGE
621
622After importing this module, when you use localtime or gmtime in a scalar
623context, rather than getting an ordinary scalar string representing the
624date and time, you get a Time::Piece object, whose stringification happens
625to produce the same effect as the localtime and gmtime functions. There is
626also a new() constructor provided, which is the same as localtime(), except
627when passed a Time::Piece object, in which case it's a copy constructor. The
628following methods are available on the object:
629
630 $t->sec # also available as $t->second
631 $t->min # also available as $t->minute
632 $t->hour # 24 hour
633 $t->mday # also available as $t->day_of_month
634 $t->mon # 1 = January
635 $t->_mon # 0 = January
636 $t->monname # Feb
637 $t->month # same as $t->monname
638 $t->fullmonth # February
639 $t->year # based at 0 (year 0 AD is, of course 1 BC)
640 $t->_year # year minus 1900
641 $t->yy # 2 digit year
642 $t->wday # 1 = Sunday
643 $t->_wday # 0 = Sunday
644 $t->day_of_week # 0 = Sunday
645 $t->wdayname # Tue
646 $t->day # same as wdayname
647 $t->fullday # Tuesday
648 $t->yday # also available as $t->day_of_year, 0 = Jan 01
649 $t->isdst # also available as $t->daylight_savings
650
651 $t->hms # 12:34:56
652 $t->hms(".") # 12.34.56
653 $t->time # same as $t->hms
654
655 $t->ymd # 2000-02-29
656 $t->date # same as $t->ymd
657 $t->mdy # 02-29-2000
658 $t->mdy("/") # 02/29/2000
659 $t->dmy # 29-02-2000
660 $t->dmy(".") # 29.02.2000
661 $t->datetime # 2000-02-29T12:34:56 (ISO 8601)
662 $t->cdate # Tue Feb 29 12:34:56 2000
663 "$t" # same as $t->cdate
664
665 $t->epoch # seconds since the epoch
666 $t->tzoffset # timezone offset in a Time::Seconds object
667
668 $t->julian_day # number of days since Julian period began
669 $t->mjd # modified Julian date (JD-2400000.5 days)
670
671 $t->week # week number (ISO 8601)
672
673 $t->is_leap_year # true if it its
674 $t->month_last_day # 28-31
675
676 $t->time_separator($s) # set the default separator (default ":")
677 $t->date_separator($s) # set the default separator (default "-")
678 $t->day_list(@days) # set the default weekdays
679 $t->mon_list(@days) # set the default months
680
681 $t->strftime(FORMAT) # same as POSIX::strftime (without the overhead
682 # of the full POSIX extension)
683 $t->strftime() # "Tue, 29 Feb 2000 12:34:56 GMT"
684
685 Time::Piece->strptime(STRING, FORMAT)
686 # see strptime man page. Creates a new
687 # Time::Piece object
688
689=head2 Local Locales
690
691Both wdayname (day) and monname (month) allow passing in a list to use
692to index the name of the days against. This can be useful if you need
693to implement some form of localisation without actually installing or
694using locales.
695
696 my @days = qw( Dimanche Lundi Merdi Mercredi Jeudi Vendredi Samedi );
697
698 my $french_day = localtime->day(@days);
699
700These settings can be overriden globally too:
701
702 Time::Piece::day_list(@days);
703
704Or for months:
705
706 Time::Piece::mon_list(@months);
707
708And locally for months:
709
710 print localtime->month(@months);
711
712=head2 Date Calculations
713
714It's possible to use simple addition and subtraction of objects:
715
716 use Time::Seconds;
717
718 my $seconds = $t1 - $t2;
719 $t1 += ONE_DAY; # add 1 day (constant from Time::Seconds)
720
721The following are valid ($t1 and $t2 are Time::Piece objects):
722
723 $t1 - $t2; # returns Time::Seconds object
724 $t1 - 42; # returns Time::Piece object
725 $t1 + 533; # returns Time::Piece object
726
727However adding a Time::Piece object to another Time::Piece object
728will cause a runtime error.
729
730Note that the first of the above returns a Time::Seconds object, so
731while examining the object will print the number of seconds (because
732of the overloading), you can also get the number of minutes, hours,
733days, weeks and years in that delta, using the Time::Seconds API.
734
735=head2 Date Comparisons
736
737Date comparisons are also possible, using the full suite of "<", ">",
738"<=", ">=", "<=>", "==" and "!=".
739
740=head2 Date Parsing
741
742Time::Piece links to your C library's strptime() function, allowing
743you incredibly flexible date parsing routines. For example:
744
745 my $t = Time::Piece->strptime("Sun 3rd Nov, 1943",
746 "%A %drd %b, %Y");
747
748 print $t->strftime("%a, %d %b %Y");
749
750Outputs:
751
752 Wed, 03 Nov 1943
753
754(see, it's even smart enough to fix my obvious date bug)
755
756For more information see "man strptime", which should be on all unix
757systems.
758
759=head2 YYYY-MM-DDThh:mm:ss
760
761The ISO 8601 standard defines the date format to be YYYY-MM-DD, and
762the time format to be hh:mm:ss (24 hour clock), and if combined, they
763should be concatenated with date first and with a capital 'T' in front
764of the time.
765
766=head2 Week Number
767
768The I<week number> may be an unknown concept to some readers. The ISO
7698601 standard defines that weeks begin on a Monday and week 1 of the
770year is the week that includes both January 4th and the first Thursday
771of the year. In other words, if the first Monday of January is the
7722nd, 3rd, or 4th, the preceding days of the January are part of the
773last week of the preceding year. Week numbers range from 1 to 53.
774
775=head2 Global Overriding
776
777Finally, it's possible to override localtime and gmtime everywhere, by
778including the ':override' tag in the import list:
779
780 use Time::Piece ':override';
781
782=head1 AUTHOR
783
784Matt Sergeant, matt@sergeant.org
785Jarkko Hietaniemi, jhi@iki.fi (while creating Time::Piece for core perl)
786
787=head1 License
788
789This module is free software, you may distribute it under the same terms
790as Perl.
791
792=head1 SEE ALSO
793
794The excellent Calendar FAQ at http://www.tondering.dk/claus/calendar.html
795
796=head1 BUGS
797
798The test harness leaves much to be desired. Patches welcome.
799
800=cut