cpan/Time-Piece/Piece.pm

   1 package Time::Piece;
   2
   3 use strict;
   4
   5 require DynaLoader;
   6 use Time::Seconds;
   7 use Carp;
   8 use Time::Local;
   9
  10 our @ISA = qw(DynaLoader);
  11
  12 use Exporter ();
  13
  14 our @EXPORT = qw(
  15     localtime
  16     gmtime
  17 );
  18
  19 our %EXPORT_TAGS = (
  20     ':override' => 'internal',
  21     );
  22
  23 our $VERSION = '1.3202';
  24
  25 bootstrap Time::Piece $VERSION;
  26
  27 my $DATE_SEP = '-';
  28 my $TIME_SEP = ':';
  29 my @MON_LIST = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  30 my @FULLMON_LIST = qw(January February March April May June July
  31                       August September October November December);
  32 my @DAY_LIST = qw(Sun Mon Tue Wed Thu Fri Sat);
  33 my @FULLDAY_LIST = qw(Sunday Monday Tuesday Wednesday Thursday Friday Saturday);
  34 my $IS_WIN32 = ($^O =~ /Win32/);
  35
  36 my $LOCALE;
  37
  38 use constant {
  39     'c_sec' => 0,
  40     'c_min' => 1,
  41     'c_hour' => 2,
  42     'c_mday' => 3,
  43     'c_mon' => 4,
  44     'c_year' => 5,
  45     'c_wday' => 6,
  46     'c_yday' => 7,
  47     'c_isdst' => 8,
  48     'c_epoch' => 9,
  49     'c_islocal' => 10,
  50 };
  51
  52 sub localtime {
  53     unshift @_, __PACKAGE__ unless eval { $_[0]->isa('Time::Piece') };
  54     my $class = shift;
  55     my $time  = shift;
  56     $time = time if (!defined $time);
  57     $class->_mktime($time, 1);
  58 }
  59
  60 sub gmtime {
  61     unshift @_, __PACKAGE__ unless eval { $_[0]->isa('Time::Piece') };
  62     my $class = shift;
  63     my $time  = shift;
  64     $time = time if (!defined $time);
  65     $class->_mktime($time, 0);
  66 }
  67
  68 sub new {
  69     my $class = shift;
  70     my ($time) = @_;
  71
  72     my $self;
  73
  74     if (defined($time)) {
  75         $self = $class->localtime($time);
  76     }
  77     elsif (ref($class) && $class->isa(__PACKAGE__)) {
  78         $self = $class->_mktime($class->epoch, $class->[c_islocal]);
  79     }
  80     else {
  81         $self = $class->localtime();
  82     }
  83
  84     return bless $self, ref($class) || $class;
  85 }
  86
  87 sub parse {
  88     my $proto = shift;
  89     my $class = ref($proto) || $proto;
  90     my @components;
  91
  92     warnings::warnif("deprecated",
  93         "parse() is deprecated, use strptime() instead.");
  94
  95     if (@_ > 1) {
  96         @components = @_;
  97     }
  98     else {
  99         @components = shift =~ /(\d+)$DATE_SEP(\d+)$DATE_SEP(\d+)(?:(?:T|\s+)(\d+)$TIME_SEP(\d+)(?:$TIME_SEP(\d+)))/;
 100         @components = reverse(@components[0..5]);
 101     }
 102     return $class->new( timelocal(@components ));
 103 }
 104
 105 sub _mktime {
 106     my ($class, $time, $islocal) = @_;
 107
 108     $class = eval { (ref $class) && (ref $class)->isa('Time::Piece') }
 109            ? ref $class
 110            : $class;
 111     if (ref($time)) {
 112         my @tm_parts = (@{$time}[c_sec .. c_mon], $time->[c_year]+1900);
 113         $time->[c_epoch] = $islocal ? timelocal(@tm_parts) : timegm(@tm_parts);
 114
 115         return wantarray ? @$time : bless [@$time[0..9], $islocal], $class;
 116     }
 117     _tzset();
 118     my @time = $islocal ?
 119             CORE::localtime($time)
 120                 :
 121             CORE::gmtime($time);
 122     wantarray ? @time : bless [@time, $time, $islocal], $class;
 123 }
 124
 125 my %_special_exports = (
 126   localtime => sub { my $c = $_[0]; sub { $c->localtime(@_) } },
 127   gmtime    => sub { my $c = $_[0]; sub { $c->gmtime(@_)    } },
 128 );
 129
 130 sub export {
 131   my ($class, $to, @methods) = @_;
 132   for my $method (@methods) {
 133     if (exists $_special_exports{$method}) {
 134       no strict 'refs';
 135       no warnings 'redefine';
 136       *{$to . "::$method"} = $_special_exports{$method}->($class);
 137     } else {
 138       $class->Exporter::export($to, $method);
 139     }
 140   }
 141 }
 142
 143 sub import {
 144     # replace CORE::GLOBAL localtime and gmtime if passed :override
 145     my $class = shift;
 146     my %params;
 147     map($params{$_}++,@_,@EXPORT);
 148     if (delete $params{':override'}) {
 149         $class->export('CORE::GLOBAL', keys %params);
 150     }
 151     else {
 152         $class->export(scalar caller, keys %params);
 153     }
 154 }
 155
 156 ## Methods ##
 157
 158 sub sec {
 159     my $time = shift;
 160     $time->[c_sec];
 161 }
 162
 163 *second = \&sec;
 164
 165 sub min {
 166     my $time = shift;
 167     $time->[c_min];
 168 }
 169
 170 *minute = \&min;
 171
 172 sub hour {
 173     my $time = shift;
 174     $time->[c_hour];
 175 }
 176
 177 sub mday {
 178     my $time = shift;
 179     $time->[c_mday];
 180 }
 181
 182 *day_of_month = \&mday;
 183
 184 sub mon {
 185     my $time = shift;
 186     $time->[c_mon] + 1;
 187 }
 188
 189 sub _mon {
 190     my $time = shift;
 191     $time->[c_mon];
 192 }
 193
 194 sub month {
 195     my $time = shift;
 196     if (@_) {
 197         return $_[$time->[c_mon]];
 198     }
 199     elsif (@MON_LIST) {
 200         return $MON_LIST[$time->[c_mon]];
 201     }
 202     else {
 203         return $time->strftime('%b');
 204     }
 205 }
 206
 207 *monname = \&month;
 208
 209 sub fullmonth {
 210     my $time = shift;
 211     if (@_) {
 212         return $_[$time->[c_mon]];
 213     }
 214     elsif (@FULLMON_LIST) {
 215         return $FULLMON_LIST[$time->[c_mon]];
 216     }
 217     else {
 218         return $time->strftime('%B');
 219     }
 220 }
 221
 222 sub year {
 223     my $time = shift;
 224     $time->[c_year] + 1900;
 225 }
 226
 227 sub _year {
 228     my $time = shift;
 229     $time->[c_year];
 230 }
 231
 232 sub yy {
 233     my $time = shift;
 234     my $res = $time->[c_year] % 100;
 235     return $res > 9 ? $res : "0$res";
 236 }
 237
 238 sub wday {
 239     my $time = shift;
 240     $time->[c_wday] + 1;
 241 }
 242
 243 sub _wday {
 244     my $time = shift;
 245     $time->[c_wday];
 246 }
 247
 248 *day_of_week = \&_wday;
 249
 250 sub wdayname {
 251     my $time = shift;
 252     if (@_) {
 253         return $_[$time->[c_wday]];
 254     }
 255     elsif (@DAY_LIST) {
 256         return $DAY_LIST[$time->[c_wday]];
 257     }
 258     else {
 259         return $time->strftime('%a');
 260     }
 261 }
 262
 263 *day = \&wdayname;
 264
 265 sub fullday {
 266     my $time = shift;
 267     if (@_) {
 268         return $_[$time->[c_wday]];
 269     }
 270     elsif (@FULLDAY_LIST) {
 271         return $FULLDAY_LIST[$time->[c_wday]];
 272     }
 273     else {
 274         return $time->strftime('%A');
 275     }
 276 }
 277
 278 sub yday {
 279     my $time = shift;
 280     $time->[c_yday];
 281 }
 282
 283 *day_of_year = \&yday;
 284
 285 sub isdst {
 286     my $time = shift;
 287     $time->[c_isdst];
 288 }
 289
 290 *daylight_savings = \&isdst;
 291
 292 # Thanks to Tony Olekshy <olekshy@cs.ualberta.ca> for this algorithm
 293 sub tzoffset {
 294     my $time = shift;
 295
 296     return Time::Seconds->new(0) unless $time->[c_islocal];
 297
 298     my $epoch = $time->epoch;
 299
 300     my $j = sub {
 301
 302         my ($s,$n,$h,$d,$m,$y) = @_; $m += 1; $y += 1900;
 303
 304         $time->_jd($y, $m, $d, $h, $n, $s);
 305
 306     };
 307
 308     # Compute floating offset in hours.
 309     #
 310     # Note use of crt methods so the tz is properly set...
 311     # See: http://perlmonks.org/?node_id=820347
 312     my $delta = 24 * ($j->(_crt_localtime($epoch)) - $j->(_crt_gmtime($epoch)));
 313
 314     # Return value in seconds rounded to nearest minute.
 315     return Time::Seconds->new( int($delta * 60 + ($delta >= 0 ? 0.5 : -0.5)) * 60 );
 316 }
 317
 318 sub epoch {
 319     my $time = shift;
 320     if (defined($time->[c_epoch])) {
 321         return $time->[c_epoch];
 322     }
 323     else {
 324         my $epoch = $time->[c_islocal] ?
 325           timelocal(@{$time}[c_sec .. c_mon], $time->[c_year]+1900)
 326           :
 327           timegm(@{$time}[c_sec .. c_mon], $time->[c_year]+1900);
 328         $time->[c_epoch] = $epoch;
 329         return $epoch;
 330     }
 331 }
 332
 333 sub hms {
 334     my $time = shift;
 335     my $sep = @_ ? shift(@_) : $TIME_SEP;
 336     sprintf("%02d$sep%02d$sep%02d", $time->[c_hour], $time->[c_min], $time->[c_sec]);
 337 }
 338
 339 *time = \&hms;
 340
 341 sub ymd {
 342     my $time = shift;
 343     my $sep = @_ ? shift(@_) : $DATE_SEP;
 344     sprintf("%d$sep%02d$sep%02d", $time->year, $time->mon, $time->[c_mday]);
 345 }
 346
 347 *date = \&ymd;
 348
 349 sub mdy {
 350     my $time = shift;
 351     my $sep = @_ ? shift(@_) : $DATE_SEP;
 352     sprintf("%02d$sep%02d$sep%d", $time->mon, $time->[c_mday], $time->year);
 353 }
 354
 355 sub dmy {
 356     my $time = shift;
 357     my $sep = @_ ? shift(@_) : $DATE_SEP;
 358     sprintf("%02d$sep%02d$sep%d", $time->[c_mday], $time->mon, $time->year);
 359 }
 360
 361 sub datetime {
 362     my $time = shift;
 363     my %seps = (date => $DATE_SEP, T => 'T', time => $TIME_SEP, @_);
 364     return join($seps{T}, $time->date($seps{date}), $time->time($seps{time}));
 365 }
 366
 367
 368
 369 # Julian Day is always calculated for UT regardless
 370 # of local time
 371 sub julian_day {
 372     my $time = shift;
 373     # Correct for localtime
 374     $time = $time->gmtime( $time->epoch ) if $time->[c_islocal];
 375
 376     # Calculate the Julian day itself
 377     my $jd = $time->_jd( $time->year, $time->mon, $time->mday,
 378                         $time->hour, $time->min, $time->sec);
 379
 380     return $jd;
 381 }
 382
 383 # MJD is defined as JD - 2400000.5 days
 384 sub mjd {
 385     return shift->julian_day - 2_400_000.5;
 386 }
 387
 388 # Internal calculation of Julian date. Needed here so that
 389 # both tzoffset and mjd/jd methods can share the code
 390 # Algorithm from Hatcher 1984 (QJRAS 25, 53-55), and
 391 #  Hughes et al, 1989, MNRAS, 238, 15
 392 # See: http://adsabs.harvard.edu/cgi-bin/nph-bib_query?bibcode=1989MNRAS.238.1529H&db_key=AST
 393 # for more details
 394
 395 sub _jd {
 396     my $self = shift;
 397     my ($y, $m, $d, $h, $n, $s) = @_;
 398
 399     # Adjust input parameters according to the month
 400     $y = ( $m > 2 ? $y : $y - 1);
 401     $m = ( $m > 2 ? $m - 3 : $m + 9);
 402
 403     # Calculate the Julian Date (assuming Julian calendar)
 404     my $J = int( 365.25 *( $y + 4712) )
 405       + int( (30.6 * $m) + 0.5)
 406         + 59
 407           + $d
 408             - 0.5;
 409
 410     # Calculate the Gregorian Correction (since we have Gregorian dates)
 411     my $G = 38 - int( 0.75 * int(49+($y/100)));
 412
 413     # Calculate the actual Julian Date
 414     my $JD = $J + $G;
 415
 416     # Modify to include hours/mins/secs in floating portion.
 417     return $JD + ($h + ($n + $s / 60) / 60) / 24;
 418 }
 419
 420 sub week {
 421     my $self = shift;
 422
 423     my $J  = $self->julian_day;
 424     # Julian day is independent of time zone so add on tzoffset
 425     # if we are using local time here since we want the week day
 426     # to reflect the local time rather than UTC
 427     $J += ($self->tzoffset/(24*3600)) if $self->[c_islocal];
 428
 429     # Now that we have the Julian day including fractions
 430     # convert it to an integer Julian Day Number using nearest
 431     # int (since the day changes at midday we convert all Julian
 432     # dates to following midnight).
 433     $J = int($J+0.5);
 434
 435     use integer;
 436     my $d4 = ((($J + 31741 - ($J % 7)) % 146097) % 36524) % 1461;
 437     my $L  = $d4 / 1460;
 438     my $d1 = (($d4 - $L) % 365) + $L;
 439     return $d1 / 7 + 1;
 440 }
 441
 442 sub _is_leap_year {
 443     my $year = shift;
 444     return (($year %4 == 0) && !($year % 100 == 0)) || ($year % 400 == 0)
 445                ? 1 : 0;
 446 }
 447
 448 sub is_leap_year {
 449     my $time = shift;
 450     my $year = $time->year;
 451     return _is_leap_year($year);
 452 }
 453
 454 my @MON_LAST = qw(31 28 31 30 31 30 31 31 30 31 30 31);
 455
 456 sub month_last_day {
 457     my $time = shift;
 458     my $year = $time->year;
 459     my $_mon = $time->_mon;
 460     return $MON_LAST[$_mon] + ($_mon == 1 ? _is_leap_year($year) : 0);
 461 }
 462
 463 my $trans_map_common = {
 464
 465     'c' => sub {
 466         my ( $format ) = @_;
 467         if($LOCALE->{PM} && $LOCALE->{AM}){
 468             $format =~ s/%c/%a %d %b %Y %I:%M:%S %p/;
 469         }
 470         else{
 471             $format =~ s/%c/%a %d %b %Y %H:%M:%S/;
 472         }
 473         return $format;
 474     },
 475     'r' => sub {
 476         my ( $format ) = @_;
 477         if($LOCALE->{PM} && $LOCALE->{AM}){
 478             $format =~ s/%r/%I:%M:%S %p/;
 479         }
 480         else{
 481             $format =~ s/%r/%H:%M:%S/;
 482         }
 483         return $format;
 484     },
 485     'X' => sub {
 486         my ( $format ) = @_;
 487         if($LOCALE->{PM} && $LOCALE->{AM}){
 488             $format =~ s/%X/%I:%M:%S %p/;
 489         }
 490         else{
 491             $format =~ s/%X/%H:%M:%S/;
 492         }
 493         return $format;
 494     },
 495 };
 496
 497 my $strftime_trans_map = {
 498     %{$trans_map_common},
 499
 500     'e' => sub {
 501         my ( $format, $time ) = @_;
 502         $format =~ s/%e/%d/ if $IS_WIN32;
 503         return $format;
 504     },
 505     'D' => sub {
 506         my ( $format, $time ) = @_;
 507         $format =~ s/%D/%m\/%d\/%y/;
 508         return $format;
 509     },
 510     'F' => sub {
 511         my ( $format, $time ) = @_;
 512         $format =~ s/%F/%Y-%m-%d/;
 513         return $format;
 514     },
 515     'R' => sub {
 516         my ( $format, $time ) = @_;
 517         $format =~ s/%R/%H:%M/;
 518         return $format;
 519     },
 520     's' => sub {
 521         #%s not portable if time parts are from gmtime since %s will
 522         #cause a call to native mktime (and thus uses local TZ)
 523         my ( $format, $time ) = @_;
 524         $format =~ s/%s/$time->[c_epoch]/;
 525         return $format;
 526     },
 527     'T' => sub {
 528         my ( $format, $time ) = @_;
 529         $format =~ s/%T/%H:%M:%S/ if $IS_WIN32;
 530         return $format;
 531     },
 532     'u' => sub {
 533         my ( $format, $time ) = @_;
 534         $format =~ s/%u/%w/ if $IS_WIN32;
 535         return $format;
 536     },
 537     'V' => sub {
 538         my ( $format, $time ) = @_;
 539         my $week = sprintf( "%02d", $time->week() );
 540         $format =~ s/%V/$week/ if $IS_WIN32;
 541         return $format;
 542     },
 543     'x' => sub {
 544         my ( $format, $time ) = @_;
 545         $format =~ s/%x/%a %d %b %Y/;
 546         return $format;
 547     },
 548     'z' => sub {    #%[zZ] not portable if time parts are from gmtime
 549         my ( $format, $time ) = @_;
 550         $format =~ s/%z/+0000/ if not $time->[c_islocal];
 551         return $format;
 552     },
 553     'Z' => sub {
 554         my ( $format, $time ) = @_;
 555         $format =~ s/%Z/UTC/ if not $time->[c_islocal];
 556         return $format;
 557     },
 558 };
 559
 560 sub strftime {
 561     my $time = shift;
 562     my $format = @_ ? shift(@_) : '%a, %d %b %Y %H:%M:%S %Z';
 563     $format = _translate_format($format, $strftime_trans_map, $time);
 564
 565     return $format unless $format =~ /%/; #if translate removes everything
 566
 567     return _strftime($format, $time->epoch, $time->[c_islocal]);
 568 }
 569
 570 my $strptime_trans_map = {
 571     %{$trans_map_common},
 572 };
 573
 574 sub strptime {
 575     my $time = shift;
 576     my $string = shift;
 577     my $format = @_ ? shift(@_) : "%a, %d %b %Y %H:%M:%S %Z";
 578     my $islocal = (ref($time) ? $time->[c_islocal] : 0);
 579     my $locales = $LOCALE || &Time::Piece::_default_locale();
 580     $format = _translate_format($format, $strptime_trans_map);
 581     my @vals = _strptime($string, $format, $islocal, $locales);
 582 #    warn(sprintf("got vals: %d-%d-%d %d:%d:%d\n", reverse(@vals[c_sec..c_year])));
 583     return scalar $time->_mktime(\@vals, $islocal);
 584 }
 585
 586 sub day_list {
 587     shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method
 588     my @old = @DAY_LIST;
 589     if (@_) {
 590         @DAY_LIST = @_;
 591         &Time::Piece::_default_locale();
 592     }
 593     return @old;
 594 }
 595
 596 sub mon_list {
 597     shift if ref($_[0]) && $_[0]->isa(__PACKAGE__); # strip first if called as a method
 598     my @old = @MON_LIST;
 599     if (@_) {
 600         @MON_LIST = @_;
 601         &Time::Piece::_default_locale();
 602     }
 603     return @old;
 604 }
 605
 606 sub time_separator {
 607     shift if ref($_[0]) && $_[0]->isa(__PACKAGE__);
 608     my $old = $TIME_SEP;
 609     if (@_) {
 610         $TIME_SEP = $_[0];
 611     }
 612     return $old;
 613 }
 614
 615 sub date_separator {
 616     shift if ref($_[0]) && $_[0]->isa(__PACKAGE__);
 617     my $old = $DATE_SEP;
 618     if (@_) {
 619         $DATE_SEP = $_[0];
 620     }
 621     return $old;
 622 }
 623
 624 use overload '""' => \&cdate,
 625              'cmp' => \&str_compare,
 626              'fallback' => undef;
 627
 628 sub cdate {
 629     my $time = shift;
 630     if ($time->[c_islocal]) {
 631         return scalar(CORE::localtime($time->epoch));
 632     }
 633     else {
 634         return scalar(CORE::gmtime($time->epoch));
 635     }
 636 }
 637
 638 sub str_compare {
 639     my ($lhs, $rhs, $reverse) = @_;
 640     if (UNIVERSAL::isa($rhs, 'Time::Piece')) {
 641         $rhs = "$rhs";
 642     }
 643     return $reverse ? $rhs cmp $lhs->cdate : $lhs->cdate cmp $rhs;
 644 }
 645
 646 use overload
 647         '-' => \&subtract,
 648         '+' => \&add;
 649
 650 sub subtract {
 651     my $time = shift;
 652     my $rhs = shift;
 653     if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
 654         $rhs = $rhs->seconds;
 655     }
 656
 657     if (shift)
 658     {
 659         # SWAPED is set (so someone tried an expression like NOTDATE - DATE).
 660         # Imitate Perl's standard behavior and return the result as if the
 661         # string $time resolves to was subtracted from NOTDATE.  This way,
 662         # classes which override this one and which have a stringify function
 663         # that resolves to something that looks more like a number don't need
 664         # to override this function.
 665         return $rhs - "$time";
 666     }
 667
 668     if (UNIVERSAL::isa($rhs, 'Time::Piece')) {
 669         return Time::Seconds->new($time->epoch - $rhs->epoch);
 670     }
 671     else {
 672         # rhs is seconds.
 673         return $time->_mktime(($time->epoch - $rhs), $time->[c_islocal]);
 674     }
 675 }
 676
 677 sub add {
 678     my $time = shift;
 679     my $rhs = shift;
 680     if (UNIVERSAL::isa($rhs, 'Time::Seconds')) {
 681         $rhs = $rhs->seconds;
 682     }
 683     croak "Invalid rhs of addition: $rhs" if ref($rhs);
 684
 685     return $time->_mktime(($time->epoch + $rhs), $time->[c_islocal]);
 686 }
 687
 688 use overload
 689         '<=>' => \&compare;
 690
 691 sub get_epochs {
 692     my ($lhs, $rhs, $reverse) = @_;
 693     if (!UNIVERSAL::isa($rhs, 'Time::Piece')) {
 694         $rhs = $lhs->new($rhs);
 695     }
 696     if ($reverse) {
 697         return $rhs->epoch, $lhs->epoch;
 698     }
 699     return $lhs->epoch, $rhs->epoch;
 700 }
 701
 702 sub compare {
 703     my ($lhs, $rhs) = get_epochs(@_);
 704     return $lhs <=> $rhs;
 705 }
 706
 707 sub add_months {
 708     my ($time, $num_months) = @_;
 709
 710     croak("add_months requires a number of months") unless defined($num_months);
 711
 712     my $final_month = $time->_mon + $num_months;
 713     my $num_years = 0;
 714     if ($final_month > 11 || $final_month < 0) {
 715         # these two ops required because we have no POSIX::floor and don't
 716         # want to load POSIX.pm
 717         if ($final_month < 0 && $final_month % 12 == 0) {
 718             $num_years = int($final_month / 12) + 1;
 719         }
 720         else {
 721             $num_years = int($final_month / 12);
 722         }
 723         $num_years-- if ($final_month < 0);
 724
 725         $final_month = $final_month % 12;
 726     }
 727
 728     my @vals = _mini_mktime($time->sec, $time->min, $time->hour,
 729                             $time->mday, $final_month, $time->year - 1900 + $num_years);
 730     # warn(sprintf("got %d vals: %d-%d-%d %d:%d:%d [%d]\n", scalar(@vals), reverse(@vals), $time->[c_islocal]));
 731     return scalar $time->_mktime(\@vals, $time->[c_islocal]);
 732 }
 733
 734 sub add_years {
 735     my ($time, $years) = @_;
 736     $time->add_months($years * 12);
 737 }
 738
 739 sub truncate {
 740     my ($time, %params) = @_;
 741     return $time unless exists $params{to};
 742     #if ($params{to} eq 'week') { return $time->_truncate_week; }
 743     my %units = (
 744         second   => 0,
 745         minute   => 1,
 746         hour     => 2,
 747         day      => 3,
 748         month    => 4,
 749         quarter  => 5,
 750         year     => 5
 751     );
 752     my $to = $units{$params{to}};
 753     croak "Invalid value of 'to' parameter: $params{to}" unless defined $to;
 754     my $start_month = 0;
 755     if ($params{to} eq 'quarter') {
 756         $start_month = int( $time->_mon / 3 ) * 3;
 757     }
 758     my @down_to = (0, 0, 0, 1, $start_month, $time->year);
 759     return $time->_mktime([@down_to[0..$to-1], @$time[$to..c_isdst]],
 760         $time->[c_islocal]);
 761 }
 762
 763 #Given a format and a translate map, replace format flags in
 764 #accordance with the logic from the translation map subroutines
 765 sub _translate_format {
 766     my ( $format, $trans_map, $time ) = @_;
 767
 768     $format =~ s/%%/\e\e/g; #escape the escape
 769     my $lexer = _build_format_lexer($format);
 770
 771         while(my $flag = $lexer->() ){
 772         next unless exists $trans_map->{$flag};
 773                 $format = $trans_map->{$flag}($format, $time);
 774         }
 775
 776     $format =~ s/\e\e/%%/g;
 777     return $format;
 778 }
 779
 780 sub _build_format_lexer {
 781     my $format = shift();
 782
 783     #Higher Order Perl p.359 (or thereabouts)
 784     return sub {
 785         LABEL: {
 786         return $1 if $format =~ m/\G%([a-zA-Z])/gc; #return single char flags
 787
 788         redo LABEL if $format =~ m/\G(.)/gc;
 789         return; #return at empty string
 790         }
 791     };
 792 }
 793
 794 sub use_locale {
 795     #get locale month/day names from posix strftime (from Piece.xs)
 796     my $locales = _get_localization();
 797
 798     $locales->{PM} ||= '';
 799     $locales->{AM} ||= '';
 800
 801     $locales->{pm} = lc $locales->{PM};
 802     $locales->{am} = lc $locales->{AM};
 803     #should probably figure out how to get a
 804     #region specific format for %c someday
 805     $locales->{c_fmt} = '';
 806
 807     #Set globals. If anything is
 808     #weird just use original
 809     if( @{$locales->{weekday}} < 7 ){
 810         @{$locales->{weekday}} = @FULLDAY_LIST;
 811     }
 812     else {
 813         @FULLDAY_LIST = @{$locales->{weekday}};
 814     }
 815
 816     if( @{$locales->{wday}} < 7 ){
 817         @{$locales->{wday}} = @DAY_LIST;
 818     }
 819     else {
 820         @DAY_LIST = @{$locales->{wday}};
 821     }
 822
 823     if( @{$locales->{month}} < 12 ){
 824         @{$locales->{month}} = @FULLMON_LIST;
 825     }else {
 826         @FULLMON_LIST = @{$locales->{month}};
 827     }
 828
 829     if( @{$locales->{mon}} < 12 ){
 830         @{$locales->{mon}} = @MON_LIST;
 831     }
 832     else{
 833         @MON_LIST= @{$locales->{mon}};
 834     }
 835
 836     $LOCALE = $locales;
 837 }
 838
 839 #$Time::Piece::LOCALE is used by strptime and thus needs to be
 840 #in sync with what ever users change to via day_list() and mon_list().
 841 #Should probably deprecate this use of gloabl state, but oh well...
 842 sub _default_locale {
 843     my $locales = {};
 844
 845     @{ $locales->{weekday} } = @FULLDAY_LIST;
 846     @{ $locales->{wday} }    = @DAY_LIST;
 847     @{ $locales->{month} }   = @FULLMON_LIST;
 848     @{ $locales->{mon} }     = @MON_LIST;
 849     $locales->{alt_month} = $locales->{month};
 850
 851     $locales->{PM}    = 'PM';
 852     $locales->{AM}    = 'AM';
 853     $locales->{pm}    = 'pm';
 854     $locales->{am}    = 'am';
 855     $locales->{c_fmt} = '';
 856
 857     $LOCALE = $locales;
 858 }
 859
 860 sub _locale {
 861     return $LOCALE;
 862 }
 863
 864
 865 1;
 866 __END__
 867
 868 =head1 NAME
 869
 870 Time::Piece - Object Oriented time objects
 871
 872 =head1 SYNOPSIS
 873
 874     use Time::Piece;
 875
 876     my $t = localtime;
 877     print "Time is $t\n";
 878     print "Year is ", $t->year, "\n";
 879
 880 =head1 DESCRIPTION
 881
 882 This module replaces the standard C<localtime> and C<gmtime> functions with
 883 implementations that return objects. It does so in a backwards
 884 compatible manner, so that using localtime/gmtime in the way documented
 885 in perlfunc will still return what you expect.
 886
 887 The module actually implements most of an interface described by
 888 Larry Wall on the perl5-porters mailing list here:
 889 L<http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2000-01/msg00241.html>
 890
 891 =head1 USAGE
 892
 893 After importing this module, when you use localtime or gmtime in a scalar
 894 context, rather than getting an ordinary scalar string representing the
 895 date and time, you get a Time::Piece object, whose stringification happens
 896 to produce the same effect as the localtime and gmtime functions. There is
 897 also a new() constructor provided, which is the same as localtime(), except
 898 when passed a Time::Piece object, in which case it's a copy constructor. The
 899 following methods are available on the object:
 900
 901     $t->sec                 # also available as $t->second
 902     $t->min                 # also available as $t->minute
 903     $t->hour                # 24 hour
 904     $t->mday                # also available as $t->day_of_month
 905     $t->mon                 # 1 = January
 906     $t->_mon                # 0 = January
 907     $t->monname             # Feb
 908     $t->month               # same as $t->monname
 909     $t->fullmonth           # February
 910     $t->year                # based at 0 (year 0 AD is, of course 1 BC)
 911     $t->_year               # year minus 1900
 912     $t->yy                  # 2 digit year
 913     $t->wday                # 1 = Sunday
 914     $t->_wday               # 0 = Sunday
 915     $t->day_of_week         # 0 = Sunday
 916     $t->wdayname            # Tue
 917     $t->day                 # same as wdayname
 918     $t->fullday             # Tuesday
 919     $t->yday                # also available as $t->day_of_year, 0 = Jan 01
 920     $t->isdst               # also available as $t->daylight_savings
 921
 922     $t->hms                 # 12:34:56
 923     $t->hms(".")            # 12.34.56
 924     $t->time                # same as $t->hms
 925
 926     $t->ymd                 # 2000-02-29
 927     $t->date                # same as $t->ymd
 928     $t->mdy                 # 02-29-2000
 929     $t->mdy("/")            # 02/29/2000
 930     $t->dmy                 # 29-02-2000
 931     $t->dmy(".")            # 29.02.2000
 932     $t->datetime            # 2000-02-29T12:34:56 (ISO 8601)
 933     $t->cdate               # Tue Feb 29 12:34:56 2000
 934     "$t"                    # same as $t->cdate
 935
 936     $t->epoch               # seconds since the epoch
 937     $t->tzoffset            # timezone offset in a Time::Seconds object
 938
 939     $t->julian_day          # number of days since Julian period began
 940     $t->mjd                 # modified Julian date (JD-2400000.5 days)
 941
 942     $t->week                # week number (ISO 8601)
 943
 944     $t->is_leap_year        # true if it's a leap year
 945     $t->month_last_day      # 28-31
 946
 947     $t->time_separator($s)  # set the default separator (default ":")
 948     $t->date_separator($s)  # set the default separator (default "-")
 949     $t->day_list(@days)     # set the default weekdays
 950     $t->mon_list(@days)     # set the default months
 951
 952     $t->strftime(FORMAT)    # same as POSIX::strftime (without the overhead
 953                             # of the full POSIX extension)
 954     $t->strftime()          # "Tue, 29 Feb 2000 12:34:56 GMT"
 955
 956     Time::Piece->strptime(STRING, FORMAT)
 957                             # see strptime man page. Creates a new
 958                             # Time::Piece object
 959
 960 Note that C<localtime> and C<gmtime> are not listed above.  If called as
 961 methods on a Time::Piece object, they act as constructors, returning a new
 962 Time::Piece object for the current time.  In other words: they're not useful as
 963 methods.
 964
 965 =head2 Local Locales
 966
 967 Both wdayname (day) and monname (month) allow passing in a list to use
 968 to index the name of the days against. This can be useful if you need
 969 to implement some form of localisation without actually installing or
 970 using locales. Note that this is a global override and will affect
 971 all Time::Piece instances.
 972
 973   my @days = qw( Dimanche Lundi Merdi Mercredi Jeudi Vendredi Samedi );
 974
 975   my $french_day = localtime->day(@days);
 976
 977 These settings can be overridden globally too:
 978
 979   Time::Piece::day_list(@days);
 980
 981 Or for months:
 982
 983   Time::Piece::mon_list(@months);
 984
 985 And locally for months:
 986
 987   print localtime->month(@months);
 988
 989 Or to populate with your current system locale call:
 990     Time::Piece->use_locale();
 991
 992 =head2 Date Calculations
 993
 994 It's possible to use simple addition and subtraction of objects:
 995
 996     use Time::Seconds;
 997
 998     my $seconds = $t1 - $t2;
 999     $t1 += ONE_DAY; # add 1 day (constant from Time::Seconds)
1000
1001 The following are valid ($t1 and $t2 are Time::Piece objects):
1002
1003     $t1 - $t2; # returns Time::Seconds object
1004     $t1 - 42; # returns Time::Piece object
1005     $t1 + 533; # returns Time::Piece object
1006
1007 However adding a Time::Piece object to another Time::Piece object
1008 will cause a runtime error.
1009
1010 Note that the first of the above returns a Time::Seconds object, so
1011 while examining the object will print the number of seconds (because
1012 of the overloading), you can also get the number of minutes, hours,
1013 days, weeks and years in that delta, using the Time::Seconds API.
1014
1015 In addition to adding seconds, there are two APIs for adding months and
1016 years:
1017
1018     $t = $t->add_months(6);
1019     $t = $t->add_years(5);
1020
1021 The months and years can be negative for subtractions. Note that there
1022 is some "strange" behaviour when adding and subtracting months at the
1023 ends of months. Generally when the resulting month is shorter than the
1024 starting month then the number of overlap days is added. For example
1025 subtracting a month from 2008-03-31 will not result in 2008-02-31 as this
1026 is an impossible date. Instead you will get 2008-03-02. This appears to
1027 be consistent with other date manipulation tools.
1028
1029 =head2 Truncation
1030
1031 Calling the C<truncate> method returns a copy of the object but with the
1032 time truncated to the start of the supplied unit.
1033
1034     $t = $t->truncate(to => 'day');
1035
1036 This example will set the time to midnight on the same date which C<$t>
1037 had previously. Allowed values for the "to" parameter are: "year",
1038 "quarter", "month", "day", "hour", "minute" and "second".
1039
1040 =head2 Date Comparisons
1041
1042 Date comparisons are also possible, using the full suite of "<", ">",
1043 "<=", ">=", "<=>", "==" and "!=".
1044
1045 =head2 Date Parsing
1046
1047 Time::Piece has a built-in strptime() function (from FreeBSD), allowing
1048 you incredibly flexible date parsing routines. For example:
1049
1050   my $t = Time::Piece->strptime("Sunday 3rd Nov, 1943",
1051                                 "%A %drd %b, %Y");
1052
1053   print $t->strftime("%a, %d %b %Y");
1054
1055 Outputs:
1056
1057   Wed, 03 Nov 1943
1058
1059 (see, it's even smart enough to fix my obvious date bug)
1060
1061 For more information see "man strptime", which should be on all unix
1062 systems.
1063
1064 Alternatively look here: L<http://www.unix.com/man-page/FreeBSD/3/strftime/>
1065
1066 =head3 CAVEAT %A, %a, %B, %b, and friends
1067
1068 Time::Piece::strptime by default can only parse American English date names.
1069 Meanwhile, Time::Piece->strftime() will return date names that use the current
1070 configured system locale. This means dates returned by strftime might not be
1071 able to be parsed by strptime. This is the default behavior and can be
1072 overridden by calling Time::Piece->use_locale(). This builds a list of the
1073 current locale's day and month names which strptime will use to parse with.
1074 Note this is a global override and will affect all Time::Piece instances.
1075
1076 For instance with a German locale:
1077
1078     localtime->day_list();
1079
1080 Returns
1081
1082     ( 'Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat' )
1083
1084 While:
1085
1086     Time::Piece->use_locale();
1087     localtime->day_list();
1088
1089 Returns
1090
1091     ( 'So', 'Mo', 'Di', 'Mi', 'Do', 'Fr', 'Sa' )
1092
1093 =head2 YYYY-MM-DDThh:mm:ss
1094
1095 The ISO 8601 standard defines the date format to be YYYY-MM-DD, and
1096 the time format to be hh:mm:ss (24 hour clock), and if combined, they
1097 should be concatenated with date first and with a capital 'T' in front
1098 of the time.
1099
1100 =head2 Week Number
1101
1102 The I<week number> may be an unknown concept to some readers.  The ISO
1103 8601 standard defines that weeks begin on a Monday and week 1 of the
1104 year is the week that includes both January 4th and the first Thursday
1105 of the year.  In other words, if the first Monday of January is the
1106 2nd, 3rd, or 4th, the preceding days of the January are part of the
1107 last week of the preceding year.  Week numbers range from 1 to 53.
1108
1109 =head2 Global Overriding
1110
1111 Finally, it's possible to override localtime and gmtime everywhere, by
1112 including the ':override' tag in the import list:
1113
1114     use Time::Piece ':override';
1115
1116 =head1 CAVEATS
1117
1118 =head2 Setting $ENV{TZ} in Threads on Win32
1119
1120 Note that when using perl in the default build configuration on Win32
1121 (specifically, when perl is built with PERL_IMPLICIT_SYS), each perl
1122 interpreter maintains its own copy of the environment and only the main
1123 interpreter will update the process environment seen by strftime.
1124
1125 Therefore, if you make changes to $ENV{TZ} from inside a thread other than
1126 the main thread then those changes will not be seen by strftime if you
1127 subsequently call that with the %Z formatting code. You must change $ENV{TZ}
1128 in the main thread to have the desired effect in this case (and you must
1129 also call _tzset() in the main thread to register the environment change).
1130
1131 Furthermore, remember that this caveat also applies to fork(), which is
1132 emulated by threads on Win32.
1133
1134 =head2 Use of epoch seconds
1135
1136 This module internally uses the epoch seconds system that is provided via
1137 the perl C<time()> function and supported by C<gmtime()> and C<localtime()>.
1138
1139 If your perl does not support times larger than C<2^31> seconds then this
1140 module is likely to fail at processing dates beyond the year 2038. There are
1141 moves afoot to fix that in perl. Alternatively use 64 bit perl. Or if none
1142 of those are options, use the L<DateTime> module which has support for years
1143 well into the future and past.
1144
1145 =head1 AUTHOR
1146
1147 Matt Sergeant, matt@sergeant.org
1148 Jarkko Hietaniemi, jhi@iki.fi (while creating Time::Piece for core perl)
1149
1150 =head1 COPYRIGHT AND LICENSE
1151
1152 Copyright 2001, Larry Wall.
1153
1154 This module is free software, you may distribute it under the same terms
1155 as Perl.
1156
1157 =head1 SEE ALSO
1158
1159 The excellent Calendar FAQ at L<http://www.tondering.dk/claus/calendar.html>
1160
1161 =head1 BUGS
1162
1163 The test harness leaves much to be desired. Patches welcome.
1164
1165 =cut