ext/Time/Piece/Piece.pm

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