/tags/v2-104/lib/site/DateTime.pm
Perl | 2337 lines | 1701 code | 522 blank | 114 comment | 146 complexity | 313d3930f39bfc2a27110ecca317ec65 MD5 | raw file
Large files files are truncated, but you can click here to view the full file
1package DateTime; 2 3use strict; 4 5use vars qw($VERSION); 6 7use Carp; 8use DateTime::Helpers; 9 10 11BEGIN 12{ 13 $VERSION = '0.39'; 14 15 my $loaded = 0; 16 unless ( $ENV{PERL_DATETIME_PP} ) 17 { 18 eval 19 { 20 if ( $] >= 5.006 ) 21 { 22 require XSLoader; 23 XSLoader::load( 'DateTime', $DateTime::VERSION ); 24 } 25 else 26 { 27 require DynaLoader; 28 @DateTime::ISA = 'DynaLoader'; 29 DateTime->bootstrap( $DateTime::VERSION ); 30 } 31 32 $DateTime::IsPurePerl = 0; 33 }; 34 35 die $@ if $@ && $@ !~ /object version|loadable object/; 36 37 $loaded = 1 unless $@; 38 } 39 40 if ($loaded) 41 { 42 require DateTimePPExtra 43 unless defined &DateTime::_normalize_tai_seconds; 44 } 45 else 46 { 47 require DateTimePP; 48 } 49} 50 51use DateTime::Duration; 52use DateTime::Locale; 53use DateTime::TimeZone 0.38; 54use Params::Validate qw( validate validate_pos SCALAR BOOLEAN HASHREF OBJECT ); 55use Time::Local (); 56 57# for some reason, overloading doesn't work unless fallback is listed 58# early. 59# 60# 3rd parameter ( $_[2] ) means the parameters are 'reversed'. 61# see: "Calling conventions for binary operations" in overload docs. 62# 63use overload ( 'fallback' => 1, 64 '<=>' => '_compare_overload', 65 'cmp' => '_compare_overload', 66 '""' => '_stringify', 67 '-' => '_subtract_overload', 68 '+' => '_add_overload', 69 'eq' => '_string_equals_overload', 70 'ne' => '_string_not_equals_overload', 71 ); 72 73# Have to load this after overloading is defined, after BEGIN blocks 74# or else weird crashes ensue 75require DateTime::Infinite; 76 77use constant MAX_NANOSECONDS => 1_000_000_000; # 1E9 = almost 32 bits 78 79use constant INFINITY => (9 ** 9 ** 9); 80use constant NEG_INFINITY => -1 * (9 ** 9 ** 9); 81use constant NAN => INFINITY - INFINITY; 82 83use constant SECONDS_PER_DAY => 86400; 84 85my( @MonthLengths, @LeapYearMonthLengths ); 86 87BEGIN 88{ 89 @MonthLengths = 90 ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ); 91 92 @LeapYearMonthLengths = @MonthLengths; 93 $LeapYearMonthLengths[1]++; 94} 95 96{ 97 # I'd rather use Class::Data::Inheritable for this, but there's no 98 # way to add the module-loading behavior to an accessor it 99 # creates, despite what its docs say! 100 my $DefaultLocale; 101 sub DefaultLocale 102 { 103 my $class = shift; 104 105 if (@_) 106 { 107 my $lang = shift; 108 109 DateTime::Locale->load($lang); 110 111 $DefaultLocale = $lang; 112 } 113 114 return $DefaultLocale; 115 } 116 # backwards compat 117 *DefaultLanguage = \&DefaultLocale; 118} 119__PACKAGE__->DefaultLocale('en_US'); 120 121my $BasicValidate = 122 { year => { type => SCALAR }, 123 month => { type => SCALAR, default => 1, 124 callbacks => 125 { 'is between 1 and 12' => 126 sub { $_[0] >= 1 && $_[0] <= 12 } 127 }, 128 }, 129 day => { type => SCALAR, default => 1, 130 callbacks => 131 { 'is a possible valid day of month' => 132 sub { $_[0] >= 1 && $_[0] <= 31 } 133 }, 134 }, 135 hour => { type => SCALAR, default => 0, 136 callbacks => 137 { 'is between 0 and 23' => 138 sub { $_[0] >= 0 && $_[0] <= 23 }, 139 }, 140 }, 141 minute => { type => SCALAR, default => 0, 142 callbacks => 143 { 'is between 0 and 59' => 144 sub { $_[0] >= 0 && $_[0] <= 59 }, 145 }, 146 }, 147 second => { type => SCALAR, default => 0, 148 callbacks => 149 { 'is between 0 and 61' => 150 sub { $_[0] >= 0 && $_[0] <= 61 }, 151 }, 152 }, 153 nanosecond => { type => SCALAR, default => 0, 154 callbacks => 155 { 'cannot be negative' => 156 sub { $_[0] >= 0 }, 157 } 158 }, 159 locale => { type => SCALAR | OBJECT, 160 default => undef }, 161 language => { type => SCALAR | OBJECT, 162 optional => 1 }, 163 }; 164 165my $NewValidate = 166 { %$BasicValidate, 167 time_zone => { type => SCALAR | OBJECT, 168 default => 'floating' }, 169 formatter => { type => SCALAR | OBJECT, can => 'format_datetime', optional => 1 }, 170 }; 171 172sub new 173{ 174 my $class = shift; 175 my %p = validate( @_, $NewValidate ); 176 177 Carp::croak( "Invalid day of month (day = $p{day} - month = $p{month})\n" ) 178 if $p{day} > $class->_month_length( $p{year}, $p{month} ); 179 180 my $self = bless {}, $class; 181 182 $p{locale} = delete $p{language} if exists $p{language}; 183 $p{locale} = $class->DefaultLocale unless defined $p{locale}; 184 185 if ( ref $p{locale} ) 186 { 187 $self->{locale} = $p{locale}; 188 } 189 else 190 { 191 $self->{locale} = DateTime::Locale->load( $p{locale} ); 192 } 193 194 $self->{tz} = 195 ( ref $p{time_zone} ? 196 $p{time_zone} : 197 DateTime::TimeZone->new( name => $p{time_zone} ) 198 ); 199 200 $self->{local_rd_days} = 201 $class->_ymd2rd( @p{ qw( year month day ) } ); 202 203 $self->{local_rd_secs} = 204 $class->_time_as_seconds( @p{ qw( hour minute second ) } ); 205 206 $self->{offset_modifier} = 0; 207 208 $self->{rd_nanosecs} = $p{nanosecond}; 209 $self->{formatter} = $p{formatter}; 210 211 $self->_normalize_nanoseconds( $self->{local_rd_secs}, $self->{rd_nanosecs} ); 212 213 # Set this explicitly since it can't be calculated accurately 214 # without knowing our time zone offset, and it's possible that the 215 # offset can't be calculated without having at least a rough guess 216 # of the datetime's year. This year need not be correct, as long 217 # as its equal or greater to the correct number, so we fudge by 218 # adding one to the local year given to the constructor. 219 $self->{utc_year} = $p{year} + 1; 220 221 $self->_calc_utc_rd; 222 223 $self->_handle_offset_modifier( $p{second} ); 224 225 $self->_calc_local_rd; 226 227 if ( $p{second} > 59 ) 228 { 229 if ( $self->{tz}->is_floating || 230 # If true, this means that the actual calculated leap 231 # second does not occur in the second given to new() 232 ( $self->{utc_rd_secs} - 86399 233 < 234 $p{second} - 59 ) 235 ) 236 { 237 Carp::croak( "Invalid second value ($p{second})\n" ); 238 } 239 } 240 241 return $self; 242} 243 244sub _handle_offset_modifier 245{ 246 my $self = shift; 247 248 $self->{offset_modifier} = 0; 249 250 return if $self->{tz}->is_floating; 251 252 my $second = shift; 253 my $utc_is_valid = shift; 254 255 my $utc_rd_days = $self->{utc_rd_days}; 256 257 my $offset = $utc_is_valid ? $self->offset : $self->_offset_for_local_datetime; 258 259 if ( $offset >= 0 260 && $self->{local_rd_secs} >= $offset 261 ) 262 { 263 if ( $second < 60 && $offset > 0 ) 264 { 265 $self->{offset_modifier} = 266 $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY; 267 268 $self->{local_rd_secs} += $self->{offset_modifier}; 269 } 270 elsif ( $second == 60 271 && 272 ( ( $self->{local_rd_secs} == $offset 273 && $offset > 0 ) 274 || 275 ( $offset == 0 276 && $self->{local_rd_secs} > 86399 ) ) 277 ) 278 { 279 my $mod = $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY; 280 281 unless ( $mod == 0 ) 282 { 283 $self->{utc_rd_secs} -= $mod; 284 285 $self->_normalize_seconds; 286 } 287 } 288 } 289 elsif ( $offset < 0 290 && $self->{local_rd_secs} >= SECONDS_PER_DAY + $offset ) 291 { 292 if ( $second < 60 ) 293 { 294 $self->{offset_modifier} = 295 $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY; 296 297 $self->{local_rd_secs} += $self->{offset_modifier}; 298 } 299 elsif ( $second == 60 && $self->{local_rd_secs} == SECONDS_PER_DAY + $offset ) 300 { 301 my $mod = $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY; 302 303 unless ( $mod == 0 ) 304 { 305 $self->{utc_rd_secs} -= $mod; 306 307 $self->_normalize_seconds; 308 } 309 } 310 } 311} 312 313sub _calc_utc_rd 314{ 315 my $self = shift; 316 317 delete $self->{utc_c}; 318 319 if ( $self->{tz}->is_utc || $self->{tz}->is_floating ) 320 { 321 $self->{utc_rd_days} = $self->{local_rd_days}; 322 $self->{utc_rd_secs} = $self->{local_rd_secs}; 323 } 324 else 325 { 326 my $offset = $self->_offset_for_local_datetime; 327 328 $offset += $self->{offset_modifier}; 329 330 $self->{utc_rd_days} = $self->{local_rd_days}; 331 $self->{utc_rd_secs} = $self->{local_rd_secs} - $offset; 332 } 333 334 # We account for leap seconds in the new() method and nowhere else 335 # except date math. 336 $self->_normalize_tai_seconds( $self->{utc_rd_days}, $self->{utc_rd_secs} ); 337} 338 339sub _normalize_seconds 340{ 341 my $self = shift; 342 343 return if $self->{utc_rd_secs} >= 0 && $self->{utc_rd_secs} <= 86399; 344 345 if ( $self->{tz}->is_floating ) 346 { 347 $self->_normalize_tai_seconds( $self->{utc_rd_days}, $self->{utc_rd_secs} ); 348 } 349 else 350 { 351 $self->_normalize_leap_seconds( $self->{utc_rd_days}, $self->{utc_rd_secs} ); 352 } 353} 354 355sub _calc_local_rd 356{ 357 my $self = shift; 358 359 delete $self->{local_c}; 360 361 # We must short circuit for UTC times or else we could end up with 362 # loops between DateTime.pm and DateTime::TimeZone 363 if ( $self->{tz}->is_utc || $self->{tz}->is_floating ) 364 { 365 $self->{local_rd_days} = $self->{utc_rd_days}; 366 $self->{local_rd_secs} = $self->{utc_rd_secs}; 367 } 368 else 369 { 370 my $offset = $self->offset; 371 372 $self->{local_rd_days} = $self->{utc_rd_days}; 373 $self->{local_rd_secs} = $self->{utc_rd_secs} + $offset; 374 375 # intentionally ignore leap seconds here 376 $self->_normalize_tai_seconds( $self->{local_rd_days}, $self->{local_rd_secs} ); 377 378 $self->{local_rd_secs} += $self->{offset_modifier}; 379 } 380 381 $self->_calc_local_components; 382} 383 384sub _calc_local_components 385{ 386 my $self = shift; 387 388 @{ $self->{local_c} }{ qw( year month day day_of_week 389 day_of_year quarter day_of_quarter) } = 390 $self->_rd2ymd( $self->{local_rd_days}, 1 ); 391 392 @{ $self->{local_c} }{ qw( hour minute second ) } = 393 $self->_seconds_as_components 394 ( $self->{local_rd_secs}, $self->{utc_rd_secs}, $self->{offset_modifier} ); 395} 396 397sub _calc_utc_components 398{ 399 my $self = shift; 400 401 die "Cannot get UTC components before UTC RD has been calculated\n" 402 unless defined $self->{utc_rd_days}; 403 404 @{ $self->{utc_c} }{ qw( year month day ) } = 405 $self->_rd2ymd( $self->{utc_rd_days} ); 406 407 @{ $self->{utc_c} }{ qw( hour minute second ) } = 408 $self->_seconds_as_components( $self->{utc_rd_secs} ); 409} 410 411sub _utc_ymd 412{ 413 my $self = shift; 414 415 $self->_calc_utc_components unless exists $self->{utc_c}{year}; 416 417 return @{ $self->{utc_c} }{ qw( year month day ) }; 418} 419 420sub _utc_hms 421{ 422 my $self = shift; 423 424 $self->_calc_utc_components unless exists $self->{utc_c}{hour}; 425 426 return @{ $self->{utc_c} }{ qw( hour minute second ) }; 427} 428 429sub from_epoch 430{ 431 my $class = shift; 432 my %p = validate( @_, 433 { epoch => { type => SCALAR }, 434 locale => { type => SCALAR | OBJECT, optional => 1 }, 435 language => { type => SCALAR | OBJECT, optional => 1 }, 436 time_zone => { type => SCALAR | OBJECT, optional => 1 }, 437 formatter => { type => SCALAR | OBJECT, can => 'format_datetime', 438 optional => 1 }, 439 } 440 ); 441 442 my %args; 443 444 # Because epoch may come from Time::HiRes 445 my $fraction = $p{epoch} - int( $p{epoch} ); 446 $args{nanosecond} = int( $fraction * MAX_NANOSECONDS ) 447 if $fraction; 448 449 # Note, for very large negative values this may give a blatantly 450 # wrong answer. 451 @args{ qw( second minute hour day month year ) } = 452 ( gmtime( int delete $p{epoch} ) )[ 0..5 ]; 453 $args{year} += 1900; 454 $args{month}++; 455 456 my $self = $class->new( %p, %args, time_zone => 'UTC' ); 457 458 $self->set_time_zone( $p{time_zone} ) if exists $p{time_zone}; 459 460 return $self; 461} 462 463# use scalar time in case someone's loaded Time::Piece 464sub now { shift->from_epoch( epoch => (scalar time), @_ ) } 465 466sub today { shift->now(@_)->truncate( to => 'day' ) } 467 468sub from_object 469{ 470 my $class = shift; 471 my %p = validate( @_, 472 { object => { type => OBJECT, 473 can => 'utc_rd_values', 474 }, 475 locale => { type => SCALAR | OBJECT, optional => 1 }, 476 language => { type => SCALAR | OBJECT, optional => 1 }, 477 formatter => { type => SCALAR | OBJECT, can => 'format_datetime', 478 optional => 1 }, 479 }, 480 ); 481 482 my $object = delete $p{object}; 483 484 my ( $rd_days, $rd_secs, $rd_nanosecs ) = $object->utc_rd_values; 485 486 # A kludge because until all calendars are updated to return all 487 # three values, $rd_nanosecs could be undef 488 $rd_nanosecs ||= 0; 489 490 # This is a big hack to let _seconds_as_components operate naively 491 # on the given value. If the object _is_ on a leap second, we'll 492 # add that to the generated seconds value later. 493 my $leap_seconds = 0; 494 if ( $object->can('time_zone') && ! $object->time_zone->is_floating 495 && $rd_secs > 86399 && $rd_secs <= $class->_day_length($rd_days) ) 496 { 497 $leap_seconds = $rd_secs - 86399; 498 $rd_secs -= $leap_seconds; 499 } 500 501 my %args; 502 @args{ qw( year month day ) } = $class->_rd2ymd($rd_days); 503 @args{ qw( hour minute second ) } = 504 $class->_seconds_as_components($rd_secs); 505 $args{nanosecond} = $rd_nanosecs; 506 507 $args{second} += $leap_seconds; 508 509 my $new = $class->new( %p, %args, time_zone => 'UTC' ); 510 511 if ( $object->can('time_zone') ) 512 { 513 $new->set_time_zone( $object->time_zone ); 514 } 515 else 516 { 517 $new->set_time_zone( 'floating' ); 518 } 519 520 return $new; 521} 522 523my $LastDayOfMonthValidate = { %$NewValidate }; 524foreach ( keys %$LastDayOfMonthValidate ) 525{ 526 my %copy = %{ $LastDayOfMonthValidate->{$_} }; 527 528 delete $copy{default}; 529 $copy{optional} = 1 unless $_ eq 'year' || $_ eq 'month'; 530 531 $LastDayOfMonthValidate->{$_} = \%copy; 532} 533 534sub last_day_of_month 535{ 536 my $class = shift; 537 my %p = validate( @_, $LastDayOfMonthValidate ); 538 539 my $day = $class->_month_length( $p{year}, $p{month} ); 540 541 return $class->new( %p, day => $day ); 542} 543 544sub _month_length 545{ 546 return ( $_[0]->_is_leap_year( $_[1] ) ? 547 $LeapYearMonthLengths[ $_[2] - 1 ] : 548 $MonthLengths[ $_[2] - 1 ] 549 ); 550} 551 552my $FromDayOfYearValidate = { %$NewValidate }; 553foreach ( keys %$FromDayOfYearValidate ) 554{ 555 next if $_ eq 'month' || $_ eq 'day'; 556 557 my %copy = %{ $FromDayOfYearValidate->{$_} }; 558 559 delete $copy{default}; 560 $copy{optional} = 1 unless $_ eq 'year' || $_ eq 'month'; 561 562 $FromDayOfYearValidate->{$_} = \%copy; 563} 564$FromDayOfYearValidate->{day_of_year} = 565 { type => SCALAR, 566 callbacks => 567 { 'is between 1 and 366' => 568 sub { $_[0] >= 1 && $_[0] <= 366 } 569 } 570 }; 571sub from_day_of_year 572{ 573 my $class = shift; 574 my %p = validate( @_, $FromDayOfYearValidate ); 575 576 my $is_leap_year = $class->_is_leap_year( $p{year} ); 577 578 Carp::croak( "$p{year} is not a leap year.\n" ) 579 if $p{day_of_year} == 366 && ! $is_leap_year; 580 581 my $month = 1; 582 my $day = delete $p{day_of_year}; 583 584 while ( $month <= 12 && $day > $class->_month_length( $p{year}, $month ) ) 585 { 586 $day -= $class->_month_length( $p{year}, $month ); 587 $month++; 588 } 589 590 return DateTime->new( %p, 591 month => $month, 592 day => $day, 593 ); 594} 595 596sub formatter { $_[0]->{formatter} } 597 598sub clone { bless { %{ $_[0] } }, ref $_[0] } 599 600sub year { $_[0]->{local_c}{year} } 601 602sub ce_year { $_[0]->{local_c}{year} <= 0 ? 603 $_[0]->{local_c}{year} - 1 : 604 $_[0]->{local_c}{year} } 605 606sub era_name { $_[0]->{locale}->era_name( $_[0] ) } 607 608sub era_abbr { $_[0]->{locale}->era_abbreviation( $_[0] ) } 609# deprecated 610*era = \&era_abbr; 611 612sub christian_era { $_[0]->ce_year > 0 ? 'AD' : 'BC' } 613sub secular_era { $_[0]->ce_year > 0 ? 'CE' : 'BCE' } 614 615sub year_with_era { (abs $_[0]->ce_year) . $_[0]->era_abbr } 616sub year_with_christian_era { (abs $_[0]->ce_year) . $_[0]->christian_era } 617sub year_with_secular_era { (abs $_[0]->ce_year) . $_[0]->secular_era } 618 619sub month { $_[0]->{local_c}{month} } 620*mon = \&month; 621 622sub month_0 { $_[0]->{local_c}{month} - 1 }; 623*mon_0 = \&month_0; 624 625sub month_name { $_[0]->{locale}->month_name( $_[0] ) } 626 627sub month_abbr { $_[0]->{locale}->month_abbreviation( $_[0] ) } 628 629sub day_of_month { $_[0]->{local_c}{day} } 630*day = \&day_of_month; 631*mday = \&day_of_month; 632 633sub weekday_of_month { use integer; ( ( $_[0]->day - 1 ) / 7 ) + 1 } 634 635sub quarter {$_[0]->{local_c}{quarter} }; 636 637sub quarter_name { $_[0]->{locale}->quarter_name( $_[0] ) } 638sub quarter_abbr { $_[0]->{locale}->quarter_abbreviation( $_[0] ) } 639 640sub day_of_month_0 { $_[0]->{local_c}{day} - 1 } 641*day_0 = \&day_of_month_0; 642*mday_0 = \&day_of_month_0; 643 644sub day_of_week { $_[0]->{local_c}{day_of_week} } 645*wday = \&day_of_week; 646*dow = \&day_of_week; 647 648sub day_of_week_0 { $_[0]->{local_c}{day_of_week} - 1 } 649*wday_0 = \&day_of_week_0; 650*dow_0 = \&day_of_week_0; 651 652sub day_name { $_[0]->{locale}->day_name( $_[0] ) } 653 654sub day_abbr { $_[0]->{locale}->day_abbreviation( $_[0] ) } 655 656sub day_of_quarter { $_[0]->{local_c}{day_of_quarter} } 657*doq = \&day_of_quarter; 658 659sub day_of_quarter_0 { $_[0]->day_of_quarter - 1 } 660*doq_0 = \&day_of_quarter_0; 661 662sub day_of_year { $_[0]->{local_c}{day_of_year} } 663*doy = \&day_of_year; 664 665sub day_of_year_0 { $_[0]->{local_c}{day_of_year} - 1 } 666*doy_0 = \&day_of_year_0; 667 668sub ymd 669{ 670 my ( $self, $sep ) = @_; 671 $sep = '-' unless defined $sep; 672 673 return sprintf( "%0.4d%s%0.2d%s%0.2d", 674 $self->year, $sep, 675 $self->{local_c}{month}, $sep, 676 $self->{local_c}{day} ); 677} 678*date = \&ymd; 679 680sub mdy 681{ 682 my ( $self, $sep ) = @_; 683 $sep = '-' unless defined $sep; 684 685 return sprintf( "%0.2d%s%0.2d%s%0.4d", 686 $self->{local_c}{month}, $sep, 687 $self->{local_c}{day}, $sep, 688 $self->year ); 689} 690 691sub dmy 692{ 693 my ( $self, $sep ) = @_; 694 $sep = '-' unless defined $sep; 695 696 return sprintf( "%0.2d%s%0.2d%s%0.4d", 697 $self->{local_c}{day}, $sep, 698 $self->{local_c}{month}, $sep, 699 $self->year ); 700} 701 702sub hour { $_[0]->{local_c}{hour} } 703sub hour_1 { $_[0]->{local_c}{hour} + 1 } 704 705sub hour_12 { my $h = $_[0]->hour % 12; return $h ? $h : 12 } 706sub hour_12_0 { $_[0]->hour % 12 } 707 708sub minute { $_[0]->{local_c}{minute} } 709*min = \&minute; 710 711sub second { $_[0]->{local_c}{second} } 712*sec = \&second; 713 714sub fractional_second { $_[0]->second + $_[0]->nanosecond / MAX_NANOSECONDS } 715 716sub nanosecond { $_[0]->{rd_nanosecs} } 717 718sub millisecond { _round( $_[0]->{rd_nanosecs} / 1000000 ) } 719 720sub microsecond { _round( $_[0]->{rd_nanosecs} / 1000 ) } 721 722sub _round 723{ 724 my $val = shift; 725 my $int = int $val; 726 727 return $val - $int >= 0.5 ? $int + 1 : $int; 728} 729 730sub leap_seconds 731{ 732 my $self = shift; 733 734 return 0 if $self->{tz}->is_floating; 735 736 return DateTime->_accumulated_leap_seconds( $self->{utc_rd_days} ); 737} 738 739sub _stringify 740{ 741 my $self = shift; 742 743 return $self->iso8601 unless $self->{formatter}; 744 return $self->{formatter}->format_datetime($self); 745} 746 747sub hms 748{ 749 my ( $self, $sep ) = @_; 750 $sep = ':' unless defined $sep; 751 752 return sprintf( "%0.2d%s%0.2d%s%0.2d", 753 $self->{local_c}{hour}, $sep, 754 $self->{local_c}{minute}, $sep, 755 $self->{local_c}{second} ); 756} 757# don't want to override CORE::time() 758*DateTime::time = \&hms; 759 760sub iso8601 { join 'T', $_[0]->ymd('-'), $_[0]->hms(':') } 761*datetime = \&iso8601; 762 763sub is_leap_year { $_[0]->_is_leap_year( $_[0]->year ) } 764 765sub week 766{ 767 my $self = shift; 768 769 unless ( defined $self->{local_c}{week_year} ) 770 { 771 # This algorithm was taken from Date::Calc's DateCalc.c file 772 my $jan_one_dow_m1 = 773 ( ( $self->_ymd2rd( $self->year, 1, 1 ) + 6 ) % 7 ); 774 775 $self->{local_c}{week_number} = 776 int( ( ( $self->day_of_year - 1 ) + $jan_one_dow_m1 ) / 7 ); 777 $self->{local_c}{week_number}++ if $jan_one_dow_m1 < 4; 778 779 if ( $self->{local_c}{week_number} == 0 ) 780 { 781 $self->{local_c}{week_year} = $self->year - 1; 782 $self->{local_c}{week_number} = 783 $self->_weeks_in_year( $self->{local_c}{week_year} ); 784 } 785 elsif ( $self->{local_c}{week_number} == 53 && 786 $self->_weeks_in_year( $self->year ) == 52 ) 787 { 788 $self->{local_c}{week_number} = 1; 789 $self->{local_c}{week_year} = $self->year + 1; 790 } 791 else 792 { 793 $self->{local_c}{week_year} = $self->year; 794 } 795 } 796 797 return @{ $self->{local_c} }{ 'week_year', 'week_number' } 798} 799 800# Also from DateCalc.c 801sub _weeks_in_year 802{ 803 my $self = shift; 804 my $year = shift; 805 806 my $jan_one_dow = 807 ( ( $self->_ymd2rd( $year, 1, 1 ) + 6 ) % 7 ) + 1; 808 my $dec_31_dow = 809 ( ( $self->_ymd2rd( $year, 12, 31 ) + 6 ) % 7 ) + 1; 810 811 return $jan_one_dow == 4 || $dec_31_dow == 4 ? 53 : 52; 812} 813 814sub week_year { ($_[0]->week)[0] } 815sub week_number { ($_[0]->week)[1] } 816 817# ISO says that the first week of a year is the first week containing 818# a Thursday. Extending that says that the first week of the month is 819# the first week containing a Thursday. ICU agrees. 820# 821# Algorithm supplied by Rick Measham, who doesn't understand how it 822# works. Neither do I. Please feel free to explain this to me! 823sub week_of_month 824{ 825 my $self = shift; 826 827 # Faster than cloning just to get the dow 828 my $first_wday_of_month = ( 8 - ( $self->day - $self->dow ) % 7 ) % 7; 829 $first_wday_of_month = 7 unless $first_wday_of_month; 830 831 my $wom = int( ( $self->day + $first_wday_of_month - 2 ) / 7 ); 832 return ( $first_wday_of_month <= 4 ) ? $wom + 1 : $wom; 833} 834 835sub time_zone { $_[0]->{tz} } 836 837sub offset { $_[0]->{tz}->offset_for_datetime( $_[0] ) } 838sub _offset_for_local_datetime { $_[0]->{tz}->offset_for_local_datetime( $_[0] ) } 839 840sub is_dst { $_[0]->{tz}->is_dst_for_datetime( $_[0] ) } 841 842sub time_zone_long_name { $_[0]->{tz}->name } 843sub time_zone_short_name { $_[0]->{tz}->short_name_for_datetime( $_[0] ) } 844 845sub locale { $_[0]->{locale} } 846*language = \&locale; 847 848sub utc_rd_values { @{ $_[0] }{ 'utc_rd_days', 'utc_rd_secs', 'rd_nanosecs' } } 849sub local_rd_values { @{ $_[0] }{ 'local_rd_days', 'local_rd_secs', 'rd_nanosecs' } } 850 851# NOTE: no nanoseconds, no leap seconds 852sub utc_rd_as_seconds { ( $_[0]->{utc_rd_days} * SECONDS_PER_DAY ) + $_[0]->{utc_rd_secs} } 853 854# NOTE: no nanoseconds, no leap seconds 855sub local_rd_as_seconds { ( $_[0]->{local_rd_days} * SECONDS_PER_DAY ) + $_[0]->{local_rd_secs} } 856 857# RD 1 is JD 1,721,424.5 - a simple offset 858sub jd 859{ 860 my $self = shift; 861 862 my $jd = $self->{utc_rd_days} + 1_721_424.5; 863 864 my $day_length = $self->_day_length( $self->{utc_rd_days} ); 865 866 return ( $jd + 867 ( $self->{utc_rd_secs} / $day_length ) + 868 ( $self->{rd_nanosecs} / $day_length / MAX_NANOSECONDS ) 869 ); 870} 871 872sub mjd { $_[0]->jd - 2_400_000.5 } 873 874my %formats = 875 ( 'a' => sub { $_[0]->day_abbr }, 876 'A' => sub { $_[0]->day_name }, 877 'b' => sub { $_[0]->month_abbr }, 878 'B' => sub { $_[0]->month_name }, 879 'c' => sub { $_[0]->strftime( $_[0]->{locale}->default_datetime_format ) }, 880 'C' => sub { int( $_[0]->year / 100 ) }, 881 'd' => sub { sprintf( '%02d', $_[0]->day_of_month ) }, 882 'D' => sub { $_[0]->strftime( '%m/%d/%y' ) }, 883 'e' => sub { sprintf( '%2d', $_[0]->day_of_month ) }, 884 'F' => sub { $_[0]->ymd('-') }, 885 'g' => sub { substr( $_[0]->week_year, -2 ) }, 886 'G' => sub { $_[0]->week_year }, 887 'H' => sub { sprintf( '%02d', $_[0]->hour ) }, 888 'I' => sub { sprintf( '%02d', $_[0]->hour_12 ) }, 889 'j' => sub { $_[0]->day_of_year }, 890 'k' => sub { sprintf( '%2d', $_[0]->hour ) }, 891 'l' => sub { sprintf( '%2d', $_[0]->hour_12 ) }, 892 'm' => sub { sprintf( '%02d', $_[0]->month ) }, 893 'M' => sub { sprintf( '%02d', $_[0]->minute ) }, 894 'n' => sub { "\n" }, # should this be OS-sensitive? 895 'N' => \&_format_nanosecs, 896 'p' => sub { $_[0]->{locale}->am_pm( $_[0] ) }, 897 'P' => sub { lc $_[0]->{locale}->am_pm( $_[0] ) }, 898 'r' => sub { $_[0]->strftime( '%I:%M:%S %p' ) }, 899 'R' => sub { $_[0]->strftime( '%H:%M' ) }, 900 's' => sub { $_[0]->epoch }, 901 'S' => sub { sprintf( '%02d', $_[0]->second ) }, 902 't' => sub { "\t" }, 903 'T' => sub { $_[0]->strftime( '%H:%M:%S' ) }, 904 'u' => sub { $_[0]->day_of_week }, 905 # algorithm from Date::Format::wkyr 906 'U' => sub { my $dow = $_[0]->day_of_week; 907 $dow = 0 if $dow == 7; # convert to 0-6, Sun-Sat 908 my $doy = $_[0]->day_of_year - 1; 909 return sprintf( '%02d', int( ( $doy - $dow + 13 ) / 7 - 1 ) ) 910 }, 911 'V' => sub { sprintf( '%02d', $_[0]->week_number ) }, 912 'w' => sub { my $dow = $_[0]->day_of_week; 913 return $dow % 7; 914 }, 915 'W' => sub { my $dow = $_[0]->day_of_week; 916 my $doy = $_[0]->day_of_year - 1; 917 return sprintf( '%02d', int( ( $doy - $dow + 13 ) / 7 - 1 ) ) 918 }, 919 'x' => sub { $_[0]->strftime( $_[0]->{locale}->default_date_format ) }, 920 'X' => sub { $_[0]->strftime( $_[0]->{locale}->default_time_format ) }, 921 'y' => sub { sprintf( '%02d', substr( $_[0]->year, -2 ) ) }, 922 'Y' => sub { return $_[0]->year }, 923 'z' => sub { DateTime::TimeZone::offset_as_string( $_[0]->offset ) }, 924 'Z' => sub { $_[0]->{tz}->short_name_for_datetime( $_[0] ) }, 925 '%' => sub { '%' }, 926 ); 927 928$formats{h} = $formats{b}; 929 930sub strftime 931{ 932 my $self = shift; 933 # make a copy or caller's scalars get munged 934 my @formats = @_; 935 936 my @r; 937 foreach my $f (@formats) 938 { 939 $f =~ s/ 940 (?: 941 %{(\w+)} # method name like %{day_name} 942 | 943 %([%a-zA-Z]) # single character specifier like %d 944 | 945 %(\d+)N # special case for %N 946 ) 947 / 948 ( $1 949 ? ( $self->can($1) ? $self->$1() : "\%{$1}" ) 950 : $2 951 ? ( $formats{$2} ? $formats{$2}->($self) : "\%$2" ) 952 : $3 953 ? $formats{N}->($self, $3) 954 : '' # this won't happen 955 ) 956 /sgex; 957 958 return $f unless wantarray; 959 960 push @r, $f; 961 } 962 963 return @r; 964} 965 966sub _format_nanosecs 967{ 968 my $self = shift; 969 my $precision = shift; 970 971 my $ret = sprintf( "%09d", $self->{rd_nanosecs} ); 972 return $ret unless $precision; # default = 9 digits 973 974 # rd_nanosecs might contain a fractional separator 975 my ( $int, $frac ) = split /[.,]/, $self->{rd_nanosecs}; 976 $ret .= $frac if $frac; 977 978 return substr( $ret, 0, $precision ); 979} 980 981sub epoch 982{ 983 my $self = shift; 984 985 return $self->{utc_c}{epoch} 986 if exists $self->{utc_c}{epoch}; 987 988 my ( $year, $month, $day ) = $self->_utc_ymd; 989 my @hms = $self->_utc_hms; 990 991 $self->{utc_c}{epoch} = 992 eval { Time::Local::timegm_nocheck( ( reverse @hms ), 993 $day, 994 $month - 1, 995 $year, 996 ) }; 997 998 return $self->{utc_c}{epoch}; 999} 1000 1001sub hires_epoch 1002{ 1003 my $self = shift; 1004 1005 my $epoch = $self->epoch; 1006 1007 return undef unless defined $epoch; 1008 1009 my $nano = $self->{rd_nanosecs} / MAX_NANOSECONDS; 1010 1011 return $epoch + $nano; 1012} 1013 1014sub is_finite { 1 } 1015sub is_infinite { 0 } 1016 1017# added for benefit of DateTime::TimeZone 1018sub utc_year { $_[0]->{utc_year} } 1019 1020# returns a result that is relative to the first datetime 1021sub subtract_datetime 1022{ 1023 my $dt1 = shift; 1024 my $dt2 = shift; 1025 1026 $dt2 = $dt2->clone->set_time_zone( $dt1->time_zone ) 1027 unless $dt1->time_zone->name eq $dt2->time_zone->name; 1028 1029 # We only want a negative duration if $dt2 > $dt1 ($self) 1030 my ( $bigger, $smaller, $negative ) = 1031 ( $dt1 >= $dt2 ? 1032 ( $dt1, $dt2, 0 ) : 1033 ( $dt2, $dt1, 1 ) 1034 ); 1035 1036 my $is_floating = $dt1->time_zone->is_floating && 1037 $dt2->time_zone->is_floating; 1038 1039 1040 my $minute_length = 60; 1041 unless ($is_floating) 1042 { 1043 my ( $utc_rd_days, $utc_rd_secs ) = $smaller->utc_rd_values; 1044 1045 if ( $utc_rd_secs >= 86340 && ! $is_floating ) 1046 { 1047 # If the smaller of the two datetimes occurs in the last 1048 # UTC minute of the UTC day, then that minute may not be 1049 # 60 seconds long. If we need to subtract a minute from 1050 # the larger datetime's minutes count in order to adjust 1051 # the seconds difference to be positive, we need to know 1052 # how long that minute was. If one of the datetimes is 1053 # floating, we just assume a minute is 60 seconds. 1054 1055 $minute_length = $dt1->_day_length($utc_rd_days) - 86340; 1056 } 1057 } 1058 1059 # This is a gross hack that basically figures out if the bigger of 1060 # the two datetimes is the day of a DST change. If it's a 23 hour 1061 # day (switching _to_ DST) then we subtract 60 minutes from the 1062 # local time. If it's a 25 hour day then we add 60 minutes to the 1063 # local time. 1064 # 1065 # This produces the most "intuitive" results, though there are 1066 # still reversibility problems with the resultant duration. 1067 # 1068 # However, if the two objects are on the same (local) date, and we 1069 # are not crossing a DST change, we don't want to invoke the hack 1070 # - see 38local-subtract.t 1071 my $bigger_min = $bigger->hour * 60 + $bigger->minute; 1072 if ( $bigger->time_zone->has_dst_changes 1073 && ( $bigger->ymd ne $smaller->ymd 1074 || $bigger->is_dst != $smaller->is_dst ) 1075 ) 1076 { 1077 1078 $bigger_min -= 60 1079 # it's a 23 hour (local) day 1080 if ( $bigger->is_dst 1081 && 1082 do { my $prev_day = eval { $bigger->clone->subtract( days => 1 ) }; 1083 $prev_day && ! $prev_day->is_dst ? 1 : 0 } 1084 ); 1085 1086 $bigger_min += 60 1087 # it's a 25 hour (local) day 1088 if ( ! $bigger->is_dst 1089 && 1090 do { my $prev_day = eval { $bigger->clone->subtract( days => 1 ) }; 1091 $prev_day && $prev_day->is_dst ? 1 : 0 } 1092 ); 1093 } 1094 1095 my ( $months, $days, $minutes, $seconds, $nanoseconds ) = 1096 $dt1->_adjust_for_positive_difference 1097 ( $bigger->year * 12 + $bigger->month, $smaller->year * 12 + $smaller->month, 1098 1099 $bigger->day, $smaller->day, 1100 1101 $bigger_min, $smaller->hour * 60 + $smaller->minute, 1102 1103 $bigger->second, $smaller->second, 1104 1105 $bigger->nanosecond, $smaller->nanosecond, 1106 1107 $minute_length, 1108 1109 # XXX - using the smaller as the month length is 1110 # somewhat arbitrary, we could also use the bigger - 1111 # either way we have reversibility problems 1112 $dt1->_month_length( $smaller->year, $smaller->month ), 1113 ); 1114 1115 if ($negative) 1116 { 1117 for ( $months, $days, $minutes, $seconds, $nanoseconds ) 1118 { 1119 # Some versions of Perl can end up with -0 if we do "0 * -1"!! 1120 $_ *= -1 if $_; 1121 } 1122 } 1123 1124 return 1125 DateTime::Duration->new 1126 ( months => $months, 1127 days => $days, 1128 minutes => $minutes, 1129 seconds => $seconds, 1130 nanoseconds => $nanoseconds, 1131 ); 1132} 1133 1134sub _adjust_for_positive_difference 1135{ 1136 my ( $self, 1137 $month1, $month2, 1138 $day1, $day2, 1139 $min1, $min2, 1140 $sec1, $sec2, 1141 $nano1, $nano2, 1142 $minute_length, 1143 $month_length, 1144 ) = @_; 1145 1146 if ( $nano1 < $nano2 ) 1147 { 1148 $sec1--; 1149 $nano1 += MAX_NANOSECONDS; 1150 } 1151 1152 if ( $sec1 < $sec2 ) 1153 { 1154 $min1--; 1155 $sec1 += $minute_length; 1156 } 1157 1158 # A day always has 24 * 60 minutes, though the minutes may vary in 1159 # length. 1160 if ( $min1 < $min2 ) 1161 { 1162 $day1--; 1163 $min1 += 24 * 60; 1164 } 1165 1166 if ( $day1 < $day2 ) 1167 { 1168 $month1--; 1169 $day1 += $month_length; 1170 } 1171 1172 return ( $month1 - $month2, 1173 $day1 - $day2, 1174 $min1 - $min2, 1175 $sec1 - $sec2, 1176 $nano1 - $nano2, 1177 ); 1178} 1179 1180sub subtract_datetime_absolute 1181{ 1182 my $self = shift; 1183 my $dt = shift; 1184 1185 my $utc_rd_secs1 = $self->utc_rd_as_seconds; 1186 $utc_rd_secs1 += DateTime->_accumulated_leap_seconds( $self->{utc_rd_days} ) 1187 if ! $self->time_zone->is_floating; 1188 1189 my $utc_rd_secs2 = $dt->utc_rd_as_seconds; 1190 $utc_rd_secs2 += DateTime->_accumulated_leap_seconds( $dt->{utc_rd_days} ) 1191 if ! $dt->time_zone->is_floating; 1192 1193 my $seconds = $utc_rd_secs1 - $utc_rd_secs2; 1194 my $nanoseconds = $self->nanosecond - $dt->nanosecond; 1195 1196 if ( $nanoseconds < 0 ) 1197 { 1198 $seconds--; 1199 $nanoseconds += MAX_NANOSECONDS; 1200 } 1201 1202 return 1203 DateTime::Duration->new 1204 ( seconds => $seconds, 1205 nanoseconds => $nanoseconds, 1206 ); 1207} 1208 1209sub delta_md 1210{ 1211 my $self = shift; 1212 my $dt = shift; 1213 1214 my ( $smaller, $bigger ) = sort $self, $dt; 1215 1216 my ( $months, $days, undef, undef, undef ) = 1217 $dt->_adjust_for_positive_difference 1218 ( $bigger->year * 12 + $bigger->month, $smaller->year * 12 + $smaller->month, 1219 1220 $bigger->day, $smaller->day, 1221 1222 0, 0, 1223 1224 0, 0, 1225 1226 0, 0, 1227 1228 60, 1229 1230 $smaller->_month_length( $smaller->year, $smaller->month ), 1231 ); 1232 1233 return DateTime::Duration->new( months => $months, 1234 days => $days ); 1235} 1236 1237sub delta_days 1238{ 1239 my $self = shift; 1240 my $dt = shift; 1241 1242 my ( $smaller, $bigger ) = sort( ($self->local_rd_values)[0], ($dt->local_rd_values)[0] ); 1243 1244 DateTime::Duration->new( days => $bigger - $smaller ); 1245} 1246 1247sub delta_ms 1248{ 1249 my $self = shift; 1250 my $dt = shift; 1251 1252 my ( $smaller, $greater ) = sort $self, $dt; 1253 1254 my $days = int( $greater->jd - $smaller->jd ); 1255 1256 my $dur = $greater->subtract_datetime($smaller); 1257 1258 my %p; 1259 $p{hours} = $dur->hours + ( $days * 24 ); 1260 $p{minutes} = $dur->minutes; 1261 $p{seconds} = $dur->seconds; 1262 1263 return DateTime::Duration->new(%p); 1264} 1265 1266sub _add_overload 1267{ 1268 my ( $dt, $dur, $reversed ) = @_; 1269 1270 if ($reversed) 1271 { 1272 ( $dur, $dt ) = ( $dt, $dur ); 1273 } 1274 1275 unless ( DateTime::Helpers::isa( $dur, 'DateTime::Duration' ) ) 1276 { 1277 my $class = ref $dt; 1278 my $dt_string = overload::StrVal($dt); 1279 1280 Carp::croak( "Cannot add $dur to a $class object ($dt_string).\n" 1281 . " Only a DateTime::Duration object can " 1282 . " be added to a $class object." ); 1283 } 1284 1285 return $dt->clone->add_duration($dur); 1286} 1287 1288sub _subtract_overload 1289{ 1290 my ( $date1, $date2, $reversed ) = @_; 1291 1292 if ($reversed) 1293 { 1294 ( $date2, $date1 ) = ( $date1, $date2 ); 1295 } 1296 1297 if ( DateTime::Helpers::isa( $date2, 'DateTime::Duration' ) ) 1298 { 1299 my $new = $date1->clone; 1300 $new->add_duration( $date2->inverse ); 1301 return $new; 1302 } 1303 elsif ( DateTime::Helpers::isa( $date2, 'DateTime' ) ) 1304 { 1305 return $date1->subtract_datetime($date2); 1306 } 1307 else 1308 { 1309 my $class = ref $date1; 1310 my $dt_string = overload::StrVal($date1); 1311 1312 Carp::croak( "Cannot subtract $date2 from a $class object ($dt_string).\n" 1313 . " Only a DateTime::Duration or DateTime object can " 1314 . " be subtracted from a $class object." ); 1315 } 1316} 1317 1318sub add { return shift->add_duration( DateTime::Duration->new(@_) ) } 1319 1320sub subtract { return shift->subtract_duration( DateTime::Duration->new(@_) ) } 1321 1322sub subtract_duration { return $_[0]->add_duration( $_[1]->inverse ) } 1323 1324sub add_duration 1325{ 1326 my $self = shift; 1327 my ($dur) = validate_pos( @_, { isa => 'DateTime::Duration' } ); 1328 1329 # simple optimization 1330 return $self if $dur->is_zero; 1331 1332 my %deltas = $dur->deltas; 1333 1334 # This bit isn't quite right since DateTime::Infinite::Future - 1335 # infinite duration should NaN 1336 foreach my $val ( values %deltas ) 1337 { 1338 my $inf; 1339 if ( $val == INFINITY ) 1340 { 1341 $inf = DateTime::Infinite::Future->new; 1342 } 1343 elsif ( $val == NEG_INFINITY ) 1344 { 1345 $inf = DateTime::Infinite::Past->new; 1346 } 1347 1348 if ($inf) 1349 { 1350 %$self = %$inf; 1351 bless $self, ref $inf; 1352 1353 return $self; 1354 } 1355 } 1356 1357 return $self if $self->is_infinite; 1358 1359 if ( $deltas{days} ) 1360 { 1361 $self->{local_rd_days} += $deltas{days}; 1362 1363 $self->{utc_year} += int( $deltas{days} / 365 ) + 1; 1364 } 1365 1366 if ( $deltas{months} ) 1367 { 1368 # For preserve mode, if it is the last day of the month, make 1369 # it the 0th day of the following month (which then will 1370 # normalize back to the last day of the new month). 1371 my ($y, $m, $d) = ( $dur->is_preserve_mode ? 1372 $self->_rd2ymd( $self->{local_rd_days} + 1 ) : 1373 $self->_rd2ymd( $self->{local_rd_days} ) 1374 ); 1375 1376 $d -= 1 if $dur->is_preserve_mode; 1377 1378 if ( ! $dur->is_wrap_mode && $d > 28 ) 1379 { 1380 # find the rd for the last day of our target month 1381 $self->{local_rd_days} = $self->_ymd2rd( $y, $m + $deltas{months} + 1, 0 ); 1382 1383 # what day of the month is it? (discard year and month) 1384 my $last_day = ($self->_rd2ymd( $self->{local_rd_days} ))[2]; 1385 1386 # if our original day was less than the last day, 1387 # use that instead 1388 $self->{local_rd_days} -= $last_day - $d if $last_day > $d; 1389 } 1390 else 1391 { 1392 $self->{local_rd_days} = $self->_ymd2rd( $y, $m + $deltas{months}, $d ); 1393 } 1394 1395 $self->{utc_year} += int( $deltas{months} / 12 ) + 1; 1396 } 1397 1398 if ( $deltas{days} || $deltas{months} ) 1399 { 1400 $self->_calc_utc_rd; 1401 1402 $self->_handle_offset_modifier( $self->second ); 1403 } 1404 1405 if ( $deltas{minutes} ) 1406 { 1407 $self->{utc_rd_secs} += $deltas{minutes} * 60; 1408 1409 # This intentionally ignores leap seconds 1410 $self->_normalize_tai_seconds( $self->{utc_rd_days}, $self->{utc_rd_secs} ); 1411 } 1412 1413 if ( $deltas{seconds} || $deltas{nanoseconds} ) 1414 { 1415 $self->{utc_rd_secs} += $deltas{seconds}; 1416 1417 if ( $deltas{nanoseconds} ) 1418 { 1419 $self->{rd_nanosecs} += $deltas{nanoseconds}; 1420 $self->_normalize_nanoseconds( $self->{utc_rd_secs}, $self->{rd_nanosecs} ); 1421 } 1422 1423 $self->_normalize_seconds; 1424 1425 # This might be some big number much bigger than 60, but 1426 # that's ok (there are tests in 19leap_second.t to confirm 1427 # that) 1428 $self->_handle_offset_modifier( $self->second + $deltas{seconds} ); 1429 } 1430 1431 my $new = 1432 (ref $self)->from_object 1433 ( object => $self, 1434 locale => $self->{locale}, 1435 ( $self->{formatter} ? ( formatter => $self->{formatter} ) : () ), 1436 ); 1437 1438 %$self = %$new; 1439 1440 return $self; 1441} 1442 1443sub _compare_overload 1444{ 1445 # note: $_[1]->compare( $_[0] ) is an error when $_[1] is not a 1446 # DateTime (such as the INFINITY value) 1447 return $_[2] ? - $_[0]->compare( $_[1] ) : $_[0]->compare( $_[1] ); 1448} 1449 1450sub compare 1451{ 1452 shift->_compare( @_, 0 ); 1453} 1454 1455sub compare_ignore_floating 1456{ 1457 shift->_compare( @_, 1 ); 1458} 1459 1460sub _compare 1461{ 1462 my ( $class, $dt1, $dt2, $consistent ) = ref $_[0] ? ( undef, @_ ) : @_; 1463 1464 return undef unless defined $dt2; 1465 1466 if ( ! ref $dt2 && ( $dt2 == INFINITY || $dt2 == NEG_INFINITY ) ) 1467 { 1468 return $dt1->{utc_rd_days} <=> $dt2; 1469 } 1470 1471 unless ( DateTime::Helpers::can( $dt1, 'utc_rd_values' ) 1472 && DateTime::Helpers::can( $dt2, 'utc_rd_values' ) ) 1473 { 1474 my $dt1_string = overload::StrVal($dt1); 1475 my $dt2_string = overload::StrVal($dt2); 1476 1477 Carp::croak( "A DateTime object can only be compared to" 1478 . " another DateTime object ($dt1_string, $dt2_string)." ); 1479 } 1480 1481 if ( ! $consistent && 1482 DateTime::Helpers::can( $dt1, 'time_zone' ) && 1483 DateTime::Helpers::can( $dt2, 'time_zone' ) 1484 ) 1485 { 1486 my $is_floating1 = $dt1->time_zone->is_floating; 1487 my $is_floating2 = $dt2->time_zone->is_floating; 1488 1489 if ( $is_floating1 && ! $is_floating2 ) 1490 { 1491 $dt1 = $dt1->clone->set_time_zone( $dt2->time_zone ); 1492 } 1493 elsif ( $is_floating2 && ! $is_floating1 ) 1494 { 1495 $dt2 = $dt2->clone->set_time_zone( $dt1->time_zone ); 1496 } 1497 } 1498 1499 my @dt1_components = $dt1->utc_rd_values; 1500 my @dt2_components = $dt2->utc_rd_values; 1501 1502 foreach my $i ( 0..2 ) 1503 { 1504 return $dt1_components[$i] <=> $dt2_components[$i] 1505 if $dt1_components[$i] != $dt2_components[$i] 1506 } 1507 1508 return 0; 1509} 1510 1511sub _string_equals_overload 1512{ 1513 my ( $class, $dt1, $dt2 ) = ref $_[0] ? ( undef, @_ ) : @_; 1514 1515 return unless 1516 ( DateTime::Helpers::can( $dt1, 'utc_rd_values' ) 1517 && DateTime::Helpers::can( $dt2, 'utc_rd_values' ) 1518 ); 1519 1520 $class ||= ref $dt1; 1521 return ! $class->compare( $dt1, $dt2 ); 1522} 1523 1524sub _string_not_equals_overload 1525{ 1526 return ! _string_equals_overload(@_); 1527} 1528 1529sub _normalize_nanoseconds 1530{ 1531 use integer; 1532 1533 # seconds, nanoseconds 1534 if ( $_[2] < 0 ) 1535 { 1536 my $overflow = 1 + $_[2] / MAX_NANOSECONDS; 1537 $_[2] += $overflow * MAX_NANOSECONDS; 1538 $_[1] -= $overflow; 1539 } 1540 elsif ( $_[2] >= MAX_NANOSECONDS ) 1541 { 1542 my $overflow = $_[2] / MAX_NANOSECONDS; 1543 $_[2] -= $overflow * MAX_NANOSECONDS; 1544 $_[1] += $overflow; 1545 } 1546} 1547 1548# Many of the same parameters as new() but all of them are optional, 1549# and there are no defaults. 1550my $SetValidate = 1551 { map { my %copy = %{ $BasicValidate->{$_} }; 1552 delete $copy{default}; 1553 $copy{optional} = 1; 1554 $_ => \%copy } 1555 keys %$BasicValidate }; 1556 1557sub set 1558{ 1559 my $self = shift; 1560 my %p = validate( @_, $SetValidate ); 1561 1562 my %old_p = 1563 ( map { $_ => $self->$_() } 1564 qw( year month day hour minute second nanosecond locale time_zone ) 1565 ); 1566 1567 my $new_dt = (ref $self)->new( %old_p, %p ); 1568 1569 %$self = %$new_dt; 1570 1571 return $self; 1572} 1573 1574sub set_year { $_[0]->set( year => $_[1] ) } 1575sub set_month { $_[0]->set( month => $_[1] ) } 1576sub set_day { $_[0]->set( day => $_[1] ) } 1577sub set_hour { $_[0]->set( hour => $_[1] ) } 1578sub set_minute { $_[0]->set( minute => $_[1] ) } 1579sub set_second { $_[0]->set( second => $_[1] ) } 1580sub set_nanosecond { $_[0]->set( nanosecond => $_[1] ) } 1581 1582sub set_locale { $_[0]->set( locale => $_[1] ) } 1583 1584sub set_formatter { $_[0]->{formatter} = $_[1] } 1585 1586sub truncate 1587{ 1588 my $self = shift; 1589 my %p = validate( @_, 1590 { to => 1591 { regex => qr/^(?:year|month|week|day|hour|minute|second)$/ }, 1592 }, 1593 ); 1594 1595 my %new = ( locale => $self->{locale}, 1596 time_zone => $self->{tz}, 1597 ); 1598 1599 if ( $p{to} eq 'week' ) 1600 { 1601 my $day_diff = $self->day_of_week - 1; 1602 1603 if ($day_diff) 1604 { 1605 $self->add( days => -1 * $day_diff ); 1606 } 1607 1608 return $self->truncate( to => 'day' ); 1609 } 1610 else 1611 { 1612 foreach my $f ( qw( year month day hour minute second ) ) 1613 { 1614 $new{$f} = $self->$f(); 1615 1616 last if $p{to} eq $f; 1617 } 1618 } 1619 1620 my $new_dt = (ref $self)->new(%new); 1621 1622 %$self = %$new_dt; 1623 1624 return $self; 1625} 1626 1627sub set_time_zone 1628{ 1629 my ( $self, $tz ) = @_; 1630 1631 # This is a bit of a hack but it works because time zone objects 1632 # are singletons, and if it doesn't work all we lose is a little 1633 # bit of speed. 1634 return $self if $self->{tz} eq $tz; 1635 1636 my $was_floating = $self->{tz}->is_floating; 1637 1638 $self->{tz} = ref $tz ? $tz : DateTime::TimeZone->new( name => $tz ); 1639 1640 $self->_handle_offset_modifier( $self->second, 1 ); 1641 1642 # if it either was or now is floating (but not both) 1643 if ( $self->{tz}->is_floating xor $was_floating ) 1644 { 1645 $self->_calc_utc_rd; 1646 } 1647 elsif ( ! $was_floating ) 1648 { 1649 $self->_calc_local_rd; 1650 } 1651 1652 return $self; 1653} 1654 1655sub STORABLE_freeze 1656{ 1657 my $self = shift; 1658 my $cloning = shift; 1659 1660 my $serialized = ''; 1661 foreach my $key ( qw( utc_rd_days 1662 utc_rd_secs 1663 rd_nanosecs ) ) 1664 { 1665 $serialized .= "$key:$self->{$key}|"; 1666 } 1667 1668 # not used yet, but may be handy in the future. 1669 $serialized .= "version:$VERSION"; 1670 1671 # Formatter needs to be returned as a reference since it may be 1672 # undef or a class name, and Storable will complain if extra 1673 # return values aren't refs 1674 return $serialized, $self->{locale}, $self->{tz}, \$self->{formatter}; 1675} 1676 1677sub STORABLE_thaw 1678{ 1679 my $self = shift; 1680 my $cloning = shift; 1681 my $serialized = shift; 1682 1683 my %serialized = map { split /:/ } split /\|/, $serialized; 1684 1685 my ( $locale, $tz, $formatter ); 1686 1687 # more recent code version 1688 if (@_) 1689 { 1690 ( $locale, $tz, $formatter ) = @_; 1691 } 1692 else 1693 { 1694 $tz = DateTime::TimeZone->new( name => delete $serialized{tz} ); 1695 1696 $locale = 1697 DateTime::Locale->load( exists $serialized{language} 1698 ? delete $serialized{language} 1699 : delete $serialized{locale} 1700 ); 1701 } 1702 1703 delete $serialized{version}; 1704 1705 my $object = bless { utc_vals => [ $serialized{utc_rd_days}, 1706 $serialized{utc_rd_secs}, 1707 $serialized{rd_nanosecs}, 1708 ], 1709 tz => $tz, 1710 }, 'DateTime::_Thawed'; 1711 1712 my %formatter = defined $$formatter ? ( formatter => $$formatter ) : (); 1713 my $new = (ref $self)->from_object( object => $object, 1714 locale => $locale, 1715 %formatter, 1716 ); 1717 1718 %$self = %$new; 1719 1720 return $self; 1721} 1722 1723 1724package DateTime::_Thawed; 1725 1726sub utc_rd_values { @{ $_[0]->{utc_vals} } } 1727 1728sub time_zone { $_[0]->{tz} } 1729 1730 17311; 1732 1733__END__ 1734 1735=head1 NAME 1736 1737DateTime - A date and time object 1738 1739=head1 SYNOPSIS 1740 1741 use DateTime; 1742 1743 $dt = DateTime->new( year => 1964, 1744 month => 10, 1745 day => 16, 1746 hour => 16, 1747 minute => 12, 1748 second => 47, 1749 nanosecond => 500000000, 1750 time_zone => 'Asia/Taipei', 1751 ); 1752 1753 $dt = DateTime->from_epoch( epoch => $epoch ); 1754 $dt = DateTime->now; # same as ( epoch => time() ) 1755 1756 $year = $dt->year; 1757 $month = $dt->month; # 1-12 - also mon 1758 1759 $day = $dt->day; # 1-31 - also day_of_month, mday 1760 1761 $dow = $dt->day_of_week; # 1-7 (Monday is 1) - also dow, wday 1762 1763 $hour = $dt->hour; # 0-23 1764 $minute = $dt->minute; # 0-59 - also min 1765 1766 $second = $dt->second; # 0-61 (leap seconds!) - also sec 1767 1768 $doy = $dt->day_of_year; # 1-366 (leap years) - also doy 1769 1770 $doq = $dt->day_of_quarter; # 1.. - also doq 1771 1772 $qtr = $dt->quarter; # 1-4 1773 1774 # all of the start-at-1 methods above have correponding start-at-0 1775 # methods, such as $dt->day_of_month_0, $dt->month_0 and so on 1776 1777 $ymd = $dt->ymd; # 2002-12-06 1778 $ymd = $dt->ymd('/'); # 2002/12/06 - also date 1779 1780 $mdy = $dt->mdy; # 12-06-2002 1781 $mdy = $dt->mdy('/'); # 12/06/2002 1782 1783 $dmy = $dt->dmy; # 06-12-2002 1784 $dmy = $dt->dmy('/'); # 06/12/2002 1785 1786 $hms = $dt->hms; # 14:02:29 1787 $hms = $dt->hms('!'); # 14!02!29 - also time 1788 1789 $is_leap = $dt->is_leap_year; 1790 1791 # these are localizable, see Locales section 1792 $month_name = $dt->month_name; # January, February, ... 1793 $month_abbr = $dt->month_abbr; # Jan, Feb, ... 1794 $day_name = $dt->day_name; # Monday, Tuesday, ... 1795 $day_abbr = $dt->day_abbr; # Mon, Tue, ... 1796 1797 $epoch_time = $dt->epoch; 1798 # may return undef if the datetime is outside the range that is 1799 # representable by your OS's epoch system. 1800 1801 $dt2 = $dt + $duration_object; 1802 1803 $dt3 = $dt - $duration_object; 1804 1805 $duration_object = $dt - $dt2; 1806 1807 $dt->set( year => 1882 ); 1808 1809 $dt->set_time_zone( 'America/Chicago' ); 1810 1811 $dt->set_formatter( $formatter ); 1812 1813=head1 DESCRIPTION 1814 1815DateTime is a class for the representation of date/time combinations, 1816and is part of the Perl DateTime project. For details on this project 1817please see L<http://datetime.perl.org/>. The DateTime site has a FAQ 1818which may help answer many "how do I do X?" questions. The FAQ is at 1819L<http://datetime.perl.org/?FAQ>. 1820 1821It represents the Gregorian calendar, extended backwards in time 1822before its creation (in 1582). This is sometimes known as the 1823"proleptic Gregorian calendar". In this calendar, the first day …
Large files files are truncated, but you can click here to view the full file