PageRenderTime 1450ms CodeModel.GetById 168ms app.highlight 1081ms RepoModel.GetById 119ms app.codeStats 1ms

/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