This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Silence 4 "unreferenced local variable" warnings from VC++
[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
9331e88f 25our $VERSION = '1.11_01';
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 }
543 die "Can't subtract a date from something!" if shift;
544
545 if (UNIVERSAL::isa($rhs, 'Time::Piece')) {
546 return Time::Seconds->new($time->epoch - $rhs->epoch);
547 }
548 else {
549 # rhs is seconds.
550 return $time->_mktime(($time->epoch - $rhs), $time->[c_islocal]);
551 }
552}
553
554sub add {
555 my $time = shift;
556 my $rhs = shift;
557 if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
558 $rhs = $rhs->seconds;
559 }
560 croak "Invalid rhs of addition: $rhs" if ref($rhs);
561
562 return $time->_mktime(($time->epoch + $rhs), $time->[c_islocal]);
563}
564
565use overload
566 '<=>' => \&compare;
567
568sub get_epochs {
569 my ($lhs, $rhs, $reverse) = @_;
570 if (!UNIVERSAL::isa($rhs, 'Time::Piece')) {
571 $rhs = $lhs->new($rhs);
572 }
573 if ($reverse) {
574 return $rhs->epoch, $lhs->epoch;
575 }
576 return $lhs->epoch, $rhs->epoch;
577}
578
579sub compare {
580 my ($lhs, $rhs) = get_epochs(@_);
581 return $lhs <=> $rhs;
582}
583
5841;
585__END__
586
587=head1 NAME
588
589Time::Piece - Object Oriented time objects
590
591=head1 SYNOPSIS
592
593 use Time::Piece;
594
595 my $t = localtime;
596 print "Time is $t\n";
597 print "Year is ", $t->year, "\n";
598
599=head1 DESCRIPTION
600
601This module replaces the standard localtime and gmtime functions with
602implementations that return objects. It does so in a backwards
603compatible manner, so that using localtime/gmtime in the way documented
604in perlfunc will still return what you expect.
605
606The module actually implements most of an interface described by
607Larry Wall on the perl5-porters mailing list here:
608http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2000-01/msg00241.html
609
610=head1 USAGE
611
612After importing this module, when you use localtime or gmtime in a scalar
613context, rather than getting an ordinary scalar string representing the
614date and time, you get a Time::Piece object, whose stringification happens
615to produce the same effect as the localtime and gmtime functions. There is
616also a new() constructor provided, which is the same as localtime(), except
617when passed a Time::Piece object, in which case it's a copy constructor. The
618following methods are available on the object:
619
620 $t->sec # also available as $t->second
621 $t->min # also available as $t->minute
622 $t->hour # 24 hour
623 $t->mday # also available as $t->day_of_month
624 $t->mon # 1 = January
625 $t->_mon # 0 = January
626 $t->monname # Feb
627 $t->month # same as $t->monname
628 $t->fullmonth # February
629 $t->year # based at 0 (year 0 AD is, of course 1 BC)
630 $t->_year # year minus 1900
631 $t->yy # 2 digit year
632 $t->wday # 1 = Sunday
633 $t->_wday # 0 = Sunday
634 $t->day_of_week # 0 = Sunday
635 $t->wdayname # Tue
636 $t->day # same as wdayname
637 $t->fullday # Tuesday
638 $t->yday # also available as $t->day_of_year, 0 = Jan 01
639 $t->isdst # also available as $t->daylight_savings
640
641 $t->hms # 12:34:56
642 $t->hms(".") # 12.34.56
643 $t->time # same as $t->hms
644
645 $t->ymd # 2000-02-29
646 $t->date # same as $t->ymd
647 $t->mdy # 02-29-2000
648 $t->mdy("/") # 02/29/2000
649 $t->dmy # 29-02-2000
650 $t->dmy(".") # 29.02.2000
651 $t->datetime # 2000-02-29T12:34:56 (ISO 8601)
652 $t->cdate # Tue Feb 29 12:34:56 2000
653 "$t" # same as $t->cdate
654
655 $t->epoch # seconds since the epoch
656 $t->tzoffset # timezone offset in a Time::Seconds object
657
658 $t->julian_day # number of days since Julian period began
659 $t->mjd # modified Julian date (JD-2400000.5 days)
660
661 $t->week # week number (ISO 8601)
662
663 $t->is_leap_year # true if it its
664 $t->month_last_day # 28-31
665
666 $t->time_separator($s) # set the default separator (default ":")
667 $t->date_separator($s) # set the default separator (default "-")
668 $t->day_list(@days) # set the default weekdays
669 $t->mon_list(@days) # set the default months
670
671 $t->strftime(FORMAT) # same as POSIX::strftime (without the overhead
672 # of the full POSIX extension)
673 $t->strftime() # "Tue, 29 Feb 2000 12:34:56 GMT"
674
675 Time::Piece->strptime(STRING, FORMAT)
676 # see strptime man page. Creates a new
677 # Time::Piece object
678
679=head2 Local Locales
680
681Both wdayname (day) and monname (month) allow passing in a list to use
682to index the name of the days against. This can be useful if you need
683to implement some form of localisation without actually installing or
684using locales.
685
686 my @days = qw( Dimanche Lundi Merdi Mercredi Jeudi Vendredi Samedi );
687
688 my $french_day = localtime->day(@days);
689
690These settings can be overriden globally too:
691
692 Time::Piece::day_list(@days);
693
694Or for months:
695
696 Time::Piece::mon_list(@months);
697
698And locally for months:
699
700 print localtime->month(@months);
701
702=head2 Date Calculations
703
704It's possible to use simple addition and subtraction of objects:
705
706 use Time::Seconds;
707
708 my $seconds = $t1 - $t2;
709 $t1 += ONE_DAY; # add 1 day (constant from Time::Seconds)
710
711The following are valid ($t1 and $t2 are Time::Piece objects):
712
713 $t1 - $t2; # returns Time::Seconds object
714 $t1 - 42; # returns Time::Piece object
715 $t1 + 533; # returns Time::Piece object
716
717However adding a Time::Piece object to another Time::Piece object
718will cause a runtime error.
719
720Note that the first of the above returns a Time::Seconds object, so
721while examining the object will print the number of seconds (because
722of the overloading), you can also get the number of minutes, hours,
723days, weeks and years in that delta, using the Time::Seconds API.
724
725=head2 Date Comparisons
726
727Date comparisons are also possible, using the full suite of "<", ">",
728"<=", ">=", "<=>", "==" and "!=".
729
730=head2 Date Parsing
731
732Time::Piece links to your C library's strptime() function, allowing
733you incredibly flexible date parsing routines. For example:
734
735 my $t = Time::Piece->strptime("Sun 3rd Nov, 1943",
736 "%A %drd %b, %Y");
737
738 print $t->strftime("%a, %d %b %Y");
739
740Outputs:
741
742 Wed, 03 Nov 1943
743
744(see, it's even smart enough to fix my obvious date bug)
745
746For more information see "man strptime", which should be on all unix
747systems.
748
749=head2 YYYY-MM-DDThh:mm:ss
750
751The ISO 8601 standard defines the date format to be YYYY-MM-DD, and
752the time format to be hh:mm:ss (24 hour clock), and if combined, they
753should be concatenated with date first and with a capital 'T' in front
754of the time.
755
756=head2 Week Number
757
758The I<week number> may be an unknown concept to some readers. The ISO
7598601 standard defines that weeks begin on a Monday and week 1 of the
760year is the week that includes both January 4th and the first Thursday
761of the year. In other words, if the first Monday of January is the
7622nd, 3rd, or 4th, the preceding days of the January are part of the
763last week of the preceding year. Week numbers range from 1 to 53.
764
765=head2 Global Overriding
766
767Finally, it's possible to override localtime and gmtime everywhere, by
768including the ':override' tag in the import list:
769
770 use Time::Piece ':override';
771
772=head1 AUTHOR
773
774Matt Sergeant, matt@sergeant.org
775Jarkko Hietaniemi, jhi@iki.fi (while creating Time::Piece for core perl)
776
777=head1 License
778
779This module is free software, you may distribute it under the same terms
780as Perl.
781
782=head1 SEE ALSO
783
784The excellent Calendar FAQ at http://www.tondering.dk/claus/calendar.html
785
786=head1 BUGS
787
788The test harness leaves much to be desired. Patches welcome.
789
790=cut