/tags/v2-104/lib/site/DateTime.pm
Perl | 2337 lines | 1701 code | 522 blank | 114 comment | 146 complexity | 313d3930f39bfc2a27110ecca317ec65 MD5 | raw file
Possible License(s): GPL-2.0, LGPL-2.0, GPL-3.0
- package DateTime;
- use strict;
- use vars qw($VERSION);
- use Carp;
- use DateTime::Helpers;
- BEGIN
- {
- $VERSION = '0.39';
- my $loaded = 0;
- unless ( $ENV{PERL_DATETIME_PP} )
- {
- eval
- {
- if ( $] >= 5.006 )
- {
- require XSLoader;
- XSLoader::load( 'DateTime', $DateTime::VERSION );
- }
- else
- {
- require DynaLoader;
- @DateTime::ISA = 'DynaLoader';
- DateTime->bootstrap( $DateTime::VERSION );
- }
- $DateTime::IsPurePerl = 0;
- };
- die $@ if $@ && $@ !~ /object version|loadable object/;
- $loaded = 1 unless $@;
- }
- if ($loaded)
- {
- require DateTimePPExtra
- unless defined &DateTime::_normalize_tai_seconds;
- }
- else
- {
- require DateTimePP;
- }
- }
- use DateTime::Duration;
- use DateTime::Locale;
- use DateTime::TimeZone 0.38;
- use Params::Validate qw( validate validate_pos SCALAR BOOLEAN HASHREF OBJECT );
- use Time::Local ();
- # for some reason, overloading doesn't work unless fallback is listed
- # early.
- #
- # 3rd parameter ( $_[2] ) means the parameters are 'reversed'.
- # see: "Calling conventions for binary operations" in overload docs.
- #
- use overload ( 'fallback' => 1,
- '<=>' => '_compare_overload',
- 'cmp' => '_compare_overload',
- '""' => '_stringify',
- '-' => '_subtract_overload',
- '+' => '_add_overload',
- 'eq' => '_string_equals_overload',
- 'ne' => '_string_not_equals_overload',
- );
- # Have to load this after overloading is defined, after BEGIN blocks
- # or else weird crashes ensue
- require DateTime::Infinite;
- use constant MAX_NANOSECONDS => 1_000_000_000; # 1E9 = almost 32 bits
- use constant INFINITY => (9 ** 9 ** 9);
- use constant NEG_INFINITY => -1 * (9 ** 9 ** 9);
- use constant NAN => INFINITY - INFINITY;
- use constant SECONDS_PER_DAY => 86400;
- my( @MonthLengths, @LeapYearMonthLengths );
- BEGIN
- {
- @MonthLengths =
- ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
- @LeapYearMonthLengths = @MonthLengths;
- $LeapYearMonthLengths[1]++;
- }
- {
- # I'd rather use Class::Data::Inheritable for this, but there's no
- # way to add the module-loading behavior to an accessor it
- # creates, despite what its docs say!
- my $DefaultLocale;
- sub DefaultLocale
- {
- my $class = shift;
- if (@_)
- {
- my $lang = shift;
- DateTime::Locale->load($lang);
- $DefaultLocale = $lang;
- }
- return $DefaultLocale;
- }
- # backwards compat
- *DefaultLanguage = \&DefaultLocale;
- }
- __PACKAGE__->DefaultLocale('en_US');
- my $BasicValidate =
- { year => { type => SCALAR },
- month => { type => SCALAR, default => 1,
- callbacks =>
- { 'is between 1 and 12' =>
- sub { $_[0] >= 1 && $_[0] <= 12 }
- },
- },
- day => { type => SCALAR, default => 1,
- callbacks =>
- { 'is a possible valid day of month' =>
- sub { $_[0] >= 1 && $_[0] <= 31 }
- },
- },
- hour => { type => SCALAR, default => 0,
- callbacks =>
- { 'is between 0 and 23' =>
- sub { $_[0] >= 0 && $_[0] <= 23 },
- },
- },
- minute => { type => SCALAR, default => 0,
- callbacks =>
- { 'is between 0 and 59' =>
- sub { $_[0] >= 0 && $_[0] <= 59 },
- },
- },
- second => { type => SCALAR, default => 0,
- callbacks =>
- { 'is between 0 and 61' =>
- sub { $_[0] >= 0 && $_[0] <= 61 },
- },
- },
- nanosecond => { type => SCALAR, default => 0,
- callbacks =>
- { 'cannot be negative' =>
- sub { $_[0] >= 0 },
- }
- },
- locale => { type => SCALAR | OBJECT,
- default => undef },
- language => { type => SCALAR | OBJECT,
- optional => 1 },
- };
- my $NewValidate =
- { %$BasicValidate,
- time_zone => { type => SCALAR | OBJECT,
- default => 'floating' },
- formatter => { type => SCALAR | OBJECT, can => 'format_datetime', optional => 1 },
- };
- sub new
- {
- my $class = shift;
- my %p = validate( @_, $NewValidate );
- Carp::croak( "Invalid day of month (day = $p{day} - month = $p{month})\n" )
- if $p{day} > $class->_month_length( $p{year}, $p{month} );
- my $self = bless {}, $class;
- $p{locale} = delete $p{language} if exists $p{language};
- $p{locale} = $class->DefaultLocale unless defined $p{locale};
- if ( ref $p{locale} )
- {
- $self->{locale} = $p{locale};
- }
- else
- {
- $self->{locale} = DateTime::Locale->load( $p{locale} );
- }
- $self->{tz} =
- ( ref $p{time_zone} ?
- $p{time_zone} :
- DateTime::TimeZone->new( name => $p{time_zone} )
- );
- $self->{local_rd_days} =
- $class->_ymd2rd( @p{ qw( year month day ) } );
- $self->{local_rd_secs} =
- $class->_time_as_seconds( @p{ qw( hour minute second ) } );
- $self->{offset_modifier} = 0;
- $self->{rd_nanosecs} = $p{nanosecond};
- $self->{formatter} = $p{formatter};
- $self->_normalize_nanoseconds( $self->{local_rd_secs}, $self->{rd_nanosecs} );
- # Set this explicitly since it can't be calculated accurately
- # without knowing our time zone offset, and it's possible that the
- # offset can't be calculated without having at least a rough guess
- # of the datetime's year. This year need not be correct, as long
- # as its equal or greater to the correct number, so we fudge by
- # adding one to the local year given to the constructor.
- $self->{utc_year} = $p{year} + 1;
- $self->_calc_utc_rd;
- $self->_handle_offset_modifier( $p{second} );
- $self->_calc_local_rd;
- if ( $p{second} > 59 )
- {
- if ( $self->{tz}->is_floating ||
- # If true, this means that the actual calculated leap
- # second does not occur in the second given to new()
- ( $self->{utc_rd_secs} - 86399
- <
- $p{second} - 59 )
- )
- {
- Carp::croak( "Invalid second value ($p{second})\n" );
- }
- }
- return $self;
- }
- sub _handle_offset_modifier
- {
- my $self = shift;
- $self->{offset_modifier} = 0;
- return if $self->{tz}->is_floating;
- my $second = shift;
- my $utc_is_valid = shift;
- my $utc_rd_days = $self->{utc_rd_days};
- my $offset = $utc_is_valid ? $self->offset : $self->_offset_for_local_datetime;
- if ( $offset >= 0
- && $self->{local_rd_secs} >= $offset
- )
- {
- if ( $second < 60 && $offset > 0 )
- {
- $self->{offset_modifier} =
- $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY;
- $self->{local_rd_secs} += $self->{offset_modifier};
- }
- elsif ( $second == 60
- &&
- ( ( $self->{local_rd_secs} == $offset
- && $offset > 0 )
- ||
- ( $offset == 0
- && $self->{local_rd_secs} > 86399 ) )
- )
- {
- my $mod = $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY;
- unless ( $mod == 0 )
- {
- $self->{utc_rd_secs} -= $mod;
- $self->_normalize_seconds;
- }
- }
- }
- elsif ( $offset < 0
- && $self->{local_rd_secs} >= SECONDS_PER_DAY + $offset )
- {
- if ( $second < 60 )
- {
- $self->{offset_modifier} =
- $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY;
- $self->{local_rd_secs} += $self->{offset_modifier};
- }
- elsif ( $second == 60 && $self->{local_rd_secs} == SECONDS_PER_DAY + $offset )
- {
- my $mod = $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY;
- unless ( $mod == 0 )
- {
- $self->{utc_rd_secs} -= $mod;
- $self->_normalize_seconds;
- }
- }
- }
- }
- sub _calc_utc_rd
- {
- my $self = shift;
- delete $self->{utc_c};
- if ( $self->{tz}->is_utc || $self->{tz}->is_floating )
- {
- $self->{utc_rd_days} = $self->{local_rd_days};
- $self->{utc_rd_secs} = $self->{local_rd_secs};
- }
- else
- {
- my $offset = $self->_offset_for_local_datetime;
- $offset += $self->{offset_modifier};
- $self->{utc_rd_days} = $self->{local_rd_days};
- $self->{utc_rd_secs} = $self->{local_rd_secs} - $offset;
- }
- # We account for leap seconds in the new() method and nowhere else
- # except date math.
- $self->_normalize_tai_seconds( $self->{utc_rd_days}, $self->{utc_rd_secs} );
- }
- sub _normalize_seconds
- {
- my $self = shift;
- return if $self->{utc_rd_secs} >= 0 && $self->{utc_rd_secs} <= 86399;
- if ( $self->{tz}->is_floating )
- {
- $self->_normalize_tai_seconds( $self->{utc_rd_days}, $self->{utc_rd_secs} );
- }
- else
- {
- $self->_normalize_leap_seconds( $self->{utc_rd_days}, $self->{utc_rd_secs} );
- }
- }
- sub _calc_local_rd
- {
- my $self = shift;
- delete $self->{local_c};
- # We must short circuit for UTC times or else we could end up with
- # loops between DateTime.pm and DateTime::TimeZone
- if ( $self->{tz}->is_utc || $self->{tz}->is_floating )
- {
- $self->{local_rd_days} = $self->{utc_rd_days};
- $self->{local_rd_secs} = $self->{utc_rd_secs};
- }
- else
- {
- my $offset = $self->offset;
- $self->{local_rd_days} = $self->{utc_rd_days};
- $self->{local_rd_secs} = $self->{utc_rd_secs} + $offset;
- # intentionally ignore leap seconds here
- $self->_normalize_tai_seconds( $self->{local_rd_days}, $self->{local_rd_secs} );
- $self->{local_rd_secs} += $self->{offset_modifier};
- }
- $self->_calc_local_components;
- }
- sub _calc_local_components
- {
- my $self = shift;
- @{ $self->{local_c} }{ qw( year month day day_of_week
- day_of_year quarter day_of_quarter) } =
- $self->_rd2ymd( $self->{local_rd_days}, 1 );
- @{ $self->{local_c} }{ qw( hour minute second ) } =
- $self->_seconds_as_components
- ( $self->{local_rd_secs}, $self->{utc_rd_secs}, $self->{offset_modifier} );
- }
- sub _calc_utc_components
- {
- my $self = shift;
- die "Cannot get UTC components before UTC RD has been calculated\n"
- unless defined $self->{utc_rd_days};
- @{ $self->{utc_c} }{ qw( year month day ) } =
- $self->_rd2ymd( $self->{utc_rd_days} );
- @{ $self->{utc_c} }{ qw( hour minute second ) } =
- $self->_seconds_as_components( $self->{utc_rd_secs} );
- }
- sub _utc_ymd
- {
- my $self = shift;
- $self->_calc_utc_components unless exists $self->{utc_c}{year};
- return @{ $self->{utc_c} }{ qw( year month day ) };
- }
- sub _utc_hms
- {
- my $self = shift;
- $self->_calc_utc_components unless exists $self->{utc_c}{hour};
- return @{ $self->{utc_c} }{ qw( hour minute second ) };
- }
- sub from_epoch
- {
- my $class = shift;
- my %p = validate( @_,
- { epoch => { type => SCALAR },
- locale => { type => SCALAR | OBJECT, optional => 1 },
- language => { type => SCALAR | OBJECT, optional => 1 },
- time_zone => { type => SCALAR | OBJECT, optional => 1 },
- formatter => { type => SCALAR | OBJECT, can => 'format_datetime',
- optional => 1 },
- }
- );
- my %args;
- # Because epoch may come from Time::HiRes
- my $fraction = $p{epoch} - int( $p{epoch} );
- $args{nanosecond} = int( $fraction * MAX_NANOSECONDS )
- if $fraction;
- # Note, for very large negative values this may give a blatantly
- # wrong answer.
- @args{ qw( second minute hour day month year ) } =
- ( gmtime( int delete $p{epoch} ) )[ 0..5 ];
- $args{year} += 1900;
- $args{month}++;
- my $self = $class->new( %p, %args, time_zone => 'UTC' );
- $self->set_time_zone( $p{time_zone} ) if exists $p{time_zone};
- return $self;
- }
- # use scalar time in case someone's loaded Time::Piece
- sub now { shift->from_epoch( epoch => (scalar time), @_ ) }
- sub today { shift->now(@_)->truncate( to => 'day' ) }
- sub from_object
- {
- my $class = shift;
- my %p = validate( @_,
- { object => { type => OBJECT,
- can => 'utc_rd_values',
- },
- locale => { type => SCALAR | OBJECT, optional => 1 },
- language => { type => SCALAR | OBJECT, optional => 1 },
- formatter => { type => SCALAR | OBJECT, can => 'format_datetime',
- optional => 1 },
- },
- );
- my $object = delete $p{object};
- my ( $rd_days, $rd_secs, $rd_nanosecs ) = $object->utc_rd_values;
- # A kludge because until all calendars are updated to return all
- # three values, $rd_nanosecs could be undef
- $rd_nanosecs ||= 0;
- # This is a big hack to let _seconds_as_components operate naively
- # on the given value. If the object _is_ on a leap second, we'll
- # add that to the generated seconds value later.
- my $leap_seconds = 0;
- if ( $object->can('time_zone') && ! $object->time_zone->is_floating
- && $rd_secs > 86399 && $rd_secs <= $class->_day_length($rd_days) )
- {
- $leap_seconds = $rd_secs - 86399;
- $rd_secs -= $leap_seconds;
- }
- my %args;
- @args{ qw( year month day ) } = $class->_rd2ymd($rd_days);
- @args{ qw( hour minute second ) } =
- $class->_seconds_as_components($rd_secs);
- $args{nanosecond} = $rd_nanosecs;
- $args{second} += $leap_seconds;
- my $new = $class->new( %p, %args, time_zone => 'UTC' );
- if ( $object->can('time_zone') )
- {
- $new->set_time_zone( $object->time_zone );
- }
- else
- {
- $new->set_time_zone( 'floating' );
- }
- return $new;
- }
- my $LastDayOfMonthValidate = { %$NewValidate };
- foreach ( keys %$LastDayOfMonthValidate )
- {
- my %copy = %{ $LastDayOfMonthValidate->{$_} };
- delete $copy{default};
- $copy{optional} = 1 unless $_ eq 'year' || $_ eq 'month';
- $LastDayOfMonthValidate->{$_} = \%copy;
- }
- sub last_day_of_month
- {
- my $class = shift;
- my %p = validate( @_, $LastDayOfMonthValidate );
- my $day = $class->_month_length( $p{year}, $p{month} );
- return $class->new( %p, day => $day );
- }
- sub _month_length
- {
- return ( $_[0]->_is_leap_year( $_[1] ) ?
- $LeapYearMonthLengths[ $_[2] - 1 ] :
- $MonthLengths[ $_[2] - 1 ]
- );
- }
- my $FromDayOfYearValidate = { %$NewValidate };
- foreach ( keys %$FromDayOfYearValidate )
- {
- next if $_ eq 'month' || $_ eq 'day';
- my %copy = %{ $FromDayOfYearValidate->{$_} };
- delete $copy{default};
- $copy{optional} = 1 unless $_ eq 'year' || $_ eq 'month';
- $FromDayOfYearValidate->{$_} = \%copy;
- }
- $FromDayOfYearValidate->{day_of_year} =
- { type => SCALAR,
- callbacks =>
- { 'is between 1 and 366' =>
- sub { $_[0] >= 1 && $_[0] <= 366 }
- }
- };
- sub from_day_of_year
- {
- my $class = shift;
- my %p = validate( @_, $FromDayOfYearValidate );
- my $is_leap_year = $class->_is_leap_year( $p{year} );
- Carp::croak( "$p{year} is not a leap year.\n" )
- if $p{day_of_year} == 366 && ! $is_leap_year;
- my $month = 1;
- my $day = delete $p{day_of_year};
- while ( $month <= 12 && $day > $class->_month_length( $p{year}, $month ) )
- {
- $day -= $class->_month_length( $p{year}, $month );
- $month++;
- }
- return DateTime->new( %p,
- month => $month,
- day => $day,
- );
- }
- sub formatter { $_[0]->{formatter} }
- sub clone { bless { %{ $_[0] } }, ref $_[0] }
- sub year { $_[0]->{local_c}{year} }
- sub ce_year { $_[0]->{local_c}{year} <= 0 ?
- $_[0]->{local_c}{year} - 1 :
- $_[0]->{local_c}{year} }
- sub era_name { $_[0]->{locale}->era_name( $_[0] ) }
- sub era_abbr { $_[0]->{locale}->era_abbreviation( $_[0] ) }
- # deprecated
- *era = \&era_abbr;
- sub christian_era { $_[0]->ce_year > 0 ? 'AD' : 'BC' }
- sub secular_era { $_[0]->ce_year > 0 ? 'CE' : 'BCE' }
- sub year_with_era { (abs $_[0]->ce_year) . $_[0]->era_abbr }
- sub year_with_christian_era { (abs $_[0]->ce_year) . $_[0]->christian_era }
- sub year_with_secular_era { (abs $_[0]->ce_year) . $_[0]->secular_era }
- sub month { $_[0]->{local_c}{month} }
- *mon = \&month;
- sub month_0 { $_[0]->{local_c}{month} - 1 };
- *mon_0 = \&month_0;
- sub month_name { $_[0]->{locale}->month_name( $_[0] ) }
- sub month_abbr { $_[0]->{locale}->month_abbreviation( $_[0] ) }
- sub day_of_month { $_[0]->{local_c}{day} }
- *day = \&day_of_month;
- *mday = \&day_of_month;
- sub weekday_of_month { use integer; ( ( $_[0]->day - 1 ) / 7 ) + 1 }
- sub quarter {$_[0]->{local_c}{quarter} };
- sub quarter_name { $_[0]->{locale}->quarter_name( $_[0] ) }
- sub quarter_abbr { $_[0]->{locale}->quarter_abbreviation( $_[0] ) }
- sub day_of_month_0 { $_[0]->{local_c}{day} - 1 }
- *day_0 = \&day_of_month_0;
- *mday_0 = \&day_of_month_0;
- sub day_of_week { $_[0]->{local_c}{day_of_week} }
- *wday = \&day_of_week;
- *dow = \&day_of_week;
- sub day_of_week_0 { $_[0]->{local_c}{day_of_week} - 1 }
- *wday_0 = \&day_of_week_0;
- *dow_0 = \&day_of_week_0;
- sub day_name { $_[0]->{locale}->day_name( $_[0] ) }
- sub day_abbr { $_[0]->{locale}->day_abbreviation( $_[0] ) }
- sub day_of_quarter { $_[0]->{local_c}{day_of_quarter} }
- *doq = \&day_of_quarter;
- sub day_of_quarter_0 { $_[0]->day_of_quarter - 1 }
- *doq_0 = \&day_of_quarter_0;
- sub day_of_year { $_[0]->{local_c}{day_of_year} }
- *doy = \&day_of_year;
- sub day_of_year_0 { $_[0]->{local_c}{day_of_year} - 1 }
- *doy_0 = \&day_of_year_0;
- sub ymd
- {
- my ( $self, $sep ) = @_;
- $sep = '-' unless defined $sep;
- return sprintf( "%0.4d%s%0.2d%s%0.2d",
- $self->year, $sep,
- $self->{local_c}{month}, $sep,
- $self->{local_c}{day} );
- }
- *date = \&ymd;
- sub mdy
- {
- my ( $self, $sep ) = @_;
- $sep = '-' unless defined $sep;
- return sprintf( "%0.2d%s%0.2d%s%0.4d",
- $self->{local_c}{month}, $sep,
- $self->{local_c}{day}, $sep,
- $self->year );
- }
- sub dmy
- {
- my ( $self, $sep ) = @_;
- $sep = '-' unless defined $sep;
- return sprintf( "%0.2d%s%0.2d%s%0.4d",
- $self->{local_c}{day}, $sep,
- $self->{local_c}{month}, $sep,
- $self->year );
- }
- sub hour { $_[0]->{local_c}{hour} }
- sub hour_1 { $_[0]->{local_c}{hour} + 1 }
- sub hour_12 { my $h = $_[0]->hour % 12; return $h ? $h : 12 }
- sub hour_12_0 { $_[0]->hour % 12 }
- sub minute { $_[0]->{local_c}{minute} }
- *min = \&minute;
- sub second { $_[0]->{local_c}{second} }
- *sec = \&second;
- sub fractional_second { $_[0]->second + $_[0]->nanosecond / MAX_NANOSECONDS }
- sub nanosecond { $_[0]->{rd_nanosecs} }
- sub millisecond { _round( $_[0]->{rd_nanosecs} / 1000000 ) }
- sub microsecond { _round( $_[0]->{rd_nanosecs} / 1000 ) }
- sub _round
- {
- my $val = shift;
- my $int = int $val;
- return $val - $int >= 0.5 ? $int + 1 : $int;
- }
- sub leap_seconds
- {
- my $self = shift;
- return 0 if $self->{tz}->is_floating;
- return DateTime->_accumulated_leap_seconds( $self->{utc_rd_days} );
- }
- sub _stringify
- {
- my $self = shift;
- return $self->iso8601 unless $self->{formatter};
- return $self->{formatter}->format_datetime($self);
- }
- sub hms
- {
- my ( $self, $sep ) = @_;
- $sep = ':' unless defined $sep;
- return sprintf( "%0.2d%s%0.2d%s%0.2d",
- $self->{local_c}{hour}, $sep,
- $self->{local_c}{minute}, $sep,
- $self->{local_c}{second} );
- }
- # don't want to override CORE::time()
- *DateTime::time = \&hms;
- sub iso8601 { join 'T', $_[0]->ymd('-'), $_[0]->hms(':') }
- *datetime = \&iso8601;
- sub is_leap_year { $_[0]->_is_leap_year( $_[0]->year ) }
- sub week
- {
- my $self = shift;
- unless ( defined $self->{local_c}{week_year} )
- {
- # This algorithm was taken from Date::Calc's DateCalc.c file
- my $jan_one_dow_m1 =
- ( ( $self->_ymd2rd( $self->year, 1, 1 ) + 6 ) % 7 );
- $self->{local_c}{week_number} =
- int( ( ( $self->day_of_year - 1 ) + $jan_one_dow_m1 ) / 7 );
- $self->{local_c}{week_number}++ if $jan_one_dow_m1 < 4;
- if ( $self->{local_c}{week_number} == 0 )
- {
- $self->{local_c}{week_year} = $self->year - 1;
- $self->{local_c}{week_number} =
- $self->_weeks_in_year( $self->{local_c}{week_year} );
- }
- elsif ( $self->{local_c}{week_number} == 53 &&
- $self->_weeks_in_year( $self->year ) == 52 )
- {
- $self->{local_c}{week_number} = 1;
- $self->{local_c}{week_year} = $self->year + 1;
- }
- else
- {
- $self->{local_c}{week_year} = $self->year;
- }
- }
- return @{ $self->{local_c} }{ 'week_year', 'week_number' }
- }
- # Also from DateCalc.c
- sub _weeks_in_year
- {
- my $self = shift;
- my $year = shift;
- my $jan_one_dow =
- ( ( $self->_ymd2rd( $year, 1, 1 ) + 6 ) % 7 ) + 1;
- my $dec_31_dow =
- ( ( $self->_ymd2rd( $year, 12, 31 ) + 6 ) % 7 ) + 1;
- return $jan_one_dow == 4 || $dec_31_dow == 4 ? 53 : 52;
- }
- sub week_year { ($_[0]->week)[0] }
- sub week_number { ($_[0]->week)[1] }
- # ISO says that the first week of a year is the first week containing
- # a Thursday. Extending that says that the first week of the month is
- # the first week containing a Thursday. ICU agrees.
- #
- # Algorithm supplied by Rick Measham, who doesn't understand how it
- # works. Neither do I. Please feel free to explain this to me!
- sub week_of_month
- {
- my $self = shift;
- # Faster than cloning just to get the dow
- my $first_wday_of_month = ( 8 - ( $self->day - $self->dow ) % 7 ) % 7;
- $first_wday_of_month = 7 unless $first_wday_of_month;
- my $wom = int( ( $self->day + $first_wday_of_month - 2 ) / 7 );
- return ( $first_wday_of_month <= 4 ) ? $wom + 1 : $wom;
- }
- sub time_zone { $_[0]->{tz} }
- sub offset { $_[0]->{tz}->offset_for_datetime( $_[0] ) }
- sub _offset_for_local_datetime { $_[0]->{tz}->offset_for_local_datetime( $_[0] ) }
- sub is_dst { $_[0]->{tz}->is_dst_for_datetime( $_[0] ) }
- sub time_zone_long_name { $_[0]->{tz}->name }
- sub time_zone_short_name { $_[0]->{tz}->short_name_for_datetime( $_[0] ) }
- sub locale { $_[0]->{locale} }
- *language = \&locale;
- sub utc_rd_values { @{ $_[0] }{ 'utc_rd_days', 'utc_rd_secs', 'rd_nanosecs' } }
- sub local_rd_values { @{ $_[0] }{ 'local_rd_days', 'local_rd_secs', 'rd_nanosecs' } }
- # NOTE: no nanoseconds, no leap seconds
- sub utc_rd_as_seconds { ( $_[0]->{utc_rd_days} * SECONDS_PER_DAY ) + $_[0]->{utc_rd_secs} }
- # NOTE: no nanoseconds, no leap seconds
- sub local_rd_as_seconds { ( $_[0]->{local_rd_days} * SECONDS_PER_DAY ) + $_[0]->{local_rd_secs} }
- # RD 1 is JD 1,721,424.5 - a simple offset
- sub jd
- {
- my $self = shift;
- my $jd = $self->{utc_rd_days} + 1_721_424.5;
- my $day_length = $self->_day_length( $self->{utc_rd_days} );
- return ( $jd +
- ( $self->{utc_rd_secs} / $day_length ) +
- ( $self->{rd_nanosecs} / $day_length / MAX_NANOSECONDS )
- );
- }
- sub mjd { $_[0]->jd - 2_400_000.5 }
- my %formats =
- ( 'a' => sub { $_[0]->day_abbr },
- 'A' => sub { $_[0]->day_name },
- 'b' => sub { $_[0]->month_abbr },
- 'B' => sub { $_[0]->month_name },
- 'c' => sub { $_[0]->strftime( $_[0]->{locale}->default_datetime_format ) },
- 'C' => sub { int( $_[0]->year / 100 ) },
- 'd' => sub { sprintf( '%02d', $_[0]->day_of_month ) },
- 'D' => sub { $_[0]->strftime( '%m/%d/%y' ) },
- 'e' => sub { sprintf( '%2d', $_[0]->day_of_month ) },
- 'F' => sub { $_[0]->ymd('-') },
- 'g' => sub { substr( $_[0]->week_year, -2 ) },
- 'G' => sub { $_[0]->week_year },
- 'H' => sub { sprintf( '%02d', $_[0]->hour ) },
- 'I' => sub { sprintf( '%02d', $_[0]->hour_12 ) },
- 'j' => sub { $_[0]->day_of_year },
- 'k' => sub { sprintf( '%2d', $_[0]->hour ) },
- 'l' => sub { sprintf( '%2d', $_[0]->hour_12 ) },
- 'm' => sub { sprintf( '%02d', $_[0]->month ) },
- 'M' => sub { sprintf( '%02d', $_[0]->minute ) },
- 'n' => sub { "\n" }, # should this be OS-sensitive?
- 'N' => \&_format_nanosecs,
- 'p' => sub { $_[0]->{locale}->am_pm( $_[0] ) },
- 'P' => sub { lc $_[0]->{locale}->am_pm( $_[0] ) },
- 'r' => sub { $_[0]->strftime( '%I:%M:%S %p' ) },
- 'R' => sub { $_[0]->strftime( '%H:%M' ) },
- 's' => sub { $_[0]->epoch },
- 'S' => sub { sprintf( '%02d', $_[0]->second ) },
- 't' => sub { "\t" },
- 'T' => sub { $_[0]->strftime( '%H:%M:%S' ) },
- 'u' => sub { $_[0]->day_of_week },
- # algorithm from Date::Format::wkyr
- 'U' => sub { my $dow = $_[0]->day_of_week;
- $dow = 0 if $dow == 7; # convert to 0-6, Sun-Sat
- my $doy = $_[0]->day_of_year - 1;
- return sprintf( '%02d', int( ( $doy - $dow + 13 ) / 7 - 1 ) )
- },
- 'V' => sub { sprintf( '%02d', $_[0]->week_number ) },
- 'w' => sub { my $dow = $_[0]->day_of_week;
- return $dow % 7;
- },
- 'W' => sub { my $dow = $_[0]->day_of_week;
- my $doy = $_[0]->day_of_year - 1;
- return sprintf( '%02d', int( ( $doy - $dow + 13 ) / 7 - 1 ) )
- },
- 'x' => sub { $_[0]->strftime( $_[0]->{locale}->default_date_format ) },
- 'X' => sub { $_[0]->strftime( $_[0]->{locale}->default_time_format ) },
- 'y' => sub { sprintf( '%02d', substr( $_[0]->year, -2 ) ) },
- 'Y' => sub { return $_[0]->year },
- 'z' => sub { DateTime::TimeZone::offset_as_string( $_[0]->offset ) },
- 'Z' => sub { $_[0]->{tz}->short_name_for_datetime( $_[0] ) },
- '%' => sub { '%' },
- );
- $formats{h} = $formats{b};
- sub strftime
- {
- my $self = shift;
- # make a copy or caller's scalars get munged
- my @formats = @_;
- my @r;
- foreach my $f (@formats)
- {
- $f =~ s/
- (?:
- %{(\w+)} # method name like %{day_name}
- |
- %([%a-zA-Z]) # single character specifier like %d
- |
- %(\d+)N # special case for %N
- )
- /
- ( $1
- ? ( $self->can($1) ? $self->$1() : "\%{$1}" )
- : $2
- ? ( $formats{$2} ? $formats{$2}->($self) : "\%$2" )
- : $3
- ? $formats{N}->($self, $3)
- : '' # this won't happen
- )
- /sgex;
- return $f unless wantarray;
- push @r, $f;
- }
- return @r;
- }
- sub _format_nanosecs
- {
- my $self = shift;
- my $precision = shift;
- my $ret = sprintf( "%09d", $self->{rd_nanosecs} );
- return $ret unless $precision; # default = 9 digits
- # rd_nanosecs might contain a fractional separator
- my ( $int, $frac ) = split /[.,]/, $self->{rd_nanosecs};
- $ret .= $frac if $frac;
- return substr( $ret, 0, $precision );
- }
- sub epoch
- {
- my $self = shift;
- return $self->{utc_c}{epoch}
- if exists $self->{utc_c}{epoch};
- my ( $year, $month, $day ) = $self->_utc_ymd;
- my @hms = $self->_utc_hms;
- $self->{utc_c}{epoch} =
- eval { Time::Local::timegm_nocheck( ( reverse @hms ),
- $day,
- $month - 1,
- $year,
- ) };
- return $self->{utc_c}{epoch};
- }
- sub hires_epoch
- {
- my $self = shift;
- my $epoch = $self->epoch;
- return undef unless defined $epoch;
- my $nano = $self->{rd_nanosecs} / MAX_NANOSECONDS;
- return $epoch + $nano;
- }
- sub is_finite { 1 }
- sub is_infinite { 0 }
- # added for benefit of DateTime::TimeZone
- sub utc_year { $_[0]->{utc_year} }
- # returns a result that is relative to the first datetime
- sub subtract_datetime
- {
- my $dt1 = shift;
- my $dt2 = shift;
- $dt2 = $dt2->clone->set_time_zone( $dt1->time_zone )
- unless $dt1->time_zone->name eq $dt2->time_zone->name;
- # We only want a negative duration if $dt2 > $dt1 ($self)
- my ( $bigger, $smaller, $negative ) =
- ( $dt1 >= $dt2 ?
- ( $dt1, $dt2, 0 ) :
- ( $dt2, $dt1, 1 )
- );
- my $is_floating = $dt1->time_zone->is_floating &&
- $dt2->time_zone->is_floating;
- my $minute_length = 60;
- unless ($is_floating)
- {
- my ( $utc_rd_days, $utc_rd_secs ) = $smaller->utc_rd_values;
- if ( $utc_rd_secs >= 86340 && ! $is_floating )
- {
- # If the smaller of the two datetimes occurs in the last
- # UTC minute of the UTC day, then that minute may not be
- # 60 seconds long. If we need to subtract a minute from
- # the larger datetime's minutes count in order to adjust
- # the seconds difference to be positive, we need to know
- # how long that minute was. If one of the datetimes is
- # floating, we just assume a minute is 60 seconds.
- $minute_length = $dt1->_day_length($utc_rd_days) - 86340;
- }
- }
- # This is a gross hack that basically figures out if the bigger of
- # the two datetimes is the day of a DST change. If it's a 23 hour
- # day (switching _to_ DST) then we subtract 60 minutes from the
- # local time. If it's a 25 hour day then we add 60 minutes to the
- # local time.
- #
- # This produces the most "intuitive" results, though there are
- # still reversibility problems with the resultant duration.
- #
- # However, if the two objects are on the same (local) date, and we
- # are not crossing a DST change, we don't want to invoke the hack
- # - see 38local-subtract.t
- my $bigger_min = $bigger->hour * 60 + $bigger->minute;
- if ( $bigger->time_zone->has_dst_changes
- && ( $bigger->ymd ne $smaller->ymd
- || $bigger->is_dst != $smaller->is_dst )
- )
- {
- $bigger_min -= 60
- # it's a 23 hour (local) day
- if ( $bigger->is_dst
- &&
- do { my $prev_day = eval { $bigger->clone->subtract( days => 1 ) };
- $prev_day && ! $prev_day->is_dst ? 1 : 0 }
- );
- $bigger_min += 60
- # it's a 25 hour (local) day
- if ( ! $bigger->is_dst
- &&
- do { my $prev_day = eval { $bigger->clone->subtract( days => 1 ) };
- $prev_day && $prev_day->is_dst ? 1 : 0 }
- );
- }
- my ( $months, $days, $minutes, $seconds, $nanoseconds ) =
- $dt1->_adjust_for_positive_difference
- ( $bigger->year * 12 + $bigger->month, $smaller->year * 12 + $smaller->month,
- $bigger->day, $smaller->day,
- $bigger_min, $smaller->hour * 60 + $smaller->minute,
- $bigger->second, $smaller->second,
- $bigger->nanosecond, $smaller->nanosecond,
- $minute_length,
- # XXX - using the smaller as the month length is
- # somewhat arbitrary, we could also use the bigger -
- # either way we have reversibility problems
- $dt1->_month_length( $smaller->year, $smaller->month ),
- );
- if ($negative)
- {
- for ( $months, $days, $minutes, $seconds, $nanoseconds )
- {
- # Some versions of Perl can end up with -0 if we do "0 * -1"!!
- $_ *= -1 if $_;
- }
- }
- return
- DateTime::Duration->new
- ( months => $months,
- days => $days,
- minutes => $minutes,
- seconds => $seconds,
- nanoseconds => $nanoseconds,
- );
- }
- sub _adjust_for_positive_difference
- {
- my ( $self,
- $month1, $month2,
- $day1, $day2,
- $min1, $min2,
- $sec1, $sec2,
- $nano1, $nano2,
- $minute_length,
- $month_length,
- ) = @_;
- if ( $nano1 < $nano2 )
- {
- $sec1--;
- $nano1 += MAX_NANOSECONDS;
- }
- if ( $sec1 < $sec2 )
- {
- $min1--;
- $sec1 += $minute_length;
- }
- # A day always has 24 * 60 minutes, though the minutes may vary in
- # length.
- if ( $min1 < $min2 )
- {
- $day1--;
- $min1 += 24 * 60;
- }
- if ( $day1 < $day2 )
- {
- $month1--;
- $day1 += $month_length;
- }
- return ( $month1 - $month2,
- $day1 - $day2,
- $min1 - $min2,
- $sec1 - $sec2,
- $nano1 - $nano2,
- );
- }
- sub subtract_datetime_absolute
- {
- my $self = shift;
- my $dt = shift;
- my $utc_rd_secs1 = $self->utc_rd_as_seconds;
- $utc_rd_secs1 += DateTime->_accumulated_leap_seconds( $self->{utc_rd_days} )
- if ! $self->time_zone->is_floating;
- my $utc_rd_secs2 = $dt->utc_rd_as_seconds;
- $utc_rd_secs2 += DateTime->_accumulated_leap_seconds( $dt->{utc_rd_days} )
- if ! $dt->time_zone->is_floating;
- my $seconds = $utc_rd_secs1 - $utc_rd_secs2;
- my $nanoseconds = $self->nanosecond - $dt->nanosecond;
- if ( $nanoseconds < 0 )
- {
- $seconds--;
- $nanoseconds += MAX_NANOSECONDS;
- }
- return
- DateTime::Duration->new
- ( seconds => $seconds,
- nanoseconds => $nanoseconds,
- );
- }
- sub delta_md
- {
- my $self = shift;
- my $dt = shift;
- my ( $smaller, $bigger ) = sort $self, $dt;
- my ( $months, $days, undef, undef, undef ) =
- $dt->_adjust_for_positive_difference
- ( $bigger->year * 12 + $bigger->month, $smaller->year * 12 + $smaller->month,
- $bigger->day, $smaller->day,
- 0, 0,
- 0, 0,
- 0, 0,
- 60,
- $smaller->_month_length( $smaller->year, $smaller->month ),
- );
- return DateTime::Duration->new( months => $months,
- days => $days );
- }
- sub delta_days
- {
- my $self = shift;
- my $dt = shift;
- my ( $smaller, $bigger ) = sort( ($self->local_rd_values)[0], ($dt->local_rd_values)[0] );
- DateTime::Duration->new( days => $bigger - $smaller );
- }
- sub delta_ms
- {
- my $self = shift;
- my $dt = shift;
- my ( $smaller, $greater ) = sort $self, $dt;
- my $days = int( $greater->jd - $smaller->jd );
- my $dur = $greater->subtract_datetime($smaller);
- my %p;
- $p{hours} = $dur->hours + ( $days * 24 );
- $p{minutes} = $dur->minutes;
- $p{seconds} = $dur->seconds;
- return DateTime::Duration->new(%p);
- }
- sub _add_overload
- {
- my ( $dt, $dur, $reversed ) = @_;
- if ($reversed)
- {
- ( $dur, $dt ) = ( $dt, $dur );
- }
- unless ( DateTime::Helpers::isa( $dur, 'DateTime::Duration' ) )
- {
- my $class = ref $dt;
- my $dt_string = overload::StrVal($dt);
- Carp::croak( "Cannot add $dur to a $class object ($dt_string).\n"
- . " Only a DateTime::Duration object can "
- . " be added to a $class object." );
- }
- return $dt->clone->add_duration($dur);
- }
- sub _subtract_overload
- {
- my ( $date1, $date2, $reversed ) = @_;
- if ($reversed)
- {
- ( $date2, $date1 ) = ( $date1, $date2 );
- }
- if ( DateTime::Helpers::isa( $date2, 'DateTime::Duration' ) )
- {
- my $new = $date1->clone;
- $new->add_duration( $date2->inverse );
- return $new;
- }
- elsif ( DateTime::Helpers::isa( $date2, 'DateTime' ) )
- {
- return $date1->subtract_datetime($date2);
- }
- else
- {
- my $class = ref $date1;
- my $dt_string = overload::StrVal($date1);
- Carp::croak( "Cannot subtract $date2 from a $class object ($dt_string).\n"
- . " Only a DateTime::Duration or DateTime object can "
- . " be subtracted from a $class object." );
- }
- }
- sub add { return shift->add_duration( DateTime::Duration->new(@_) ) }
- sub subtract { return shift->subtract_duration( DateTime::Duration->new(@_) ) }
- sub subtract_duration { return $_[0]->add_duration( $_[1]->inverse ) }
- sub add_duration
- {
- my $self = shift;
- my ($dur) = validate_pos( @_, { isa => 'DateTime::Duration' } );
- # simple optimization
- return $self if $dur->is_zero;
- my %deltas = $dur->deltas;
- # This bit isn't quite right since DateTime::Infinite::Future -
- # infinite duration should NaN
- foreach my $val ( values %deltas )
- {
- my $inf;
- if ( $val == INFINITY )
- {
- $inf = DateTime::Infinite::Future->new;
- }
- elsif ( $val == NEG_INFINITY )
- {
- $inf = DateTime::Infinite::Past->new;
- }
- if ($inf)
- {
- %$self = %$inf;
- bless $self, ref $inf;
- return $self;
- }
- }
- return $self if $self->is_infinite;
- if ( $deltas{days} )
- {
- $self->{local_rd_days} += $deltas{days};
- $self->{utc_year} += int( $deltas{days} / 365 ) + 1;
- }
- if ( $deltas{months} )
- {
- # For preserve mode, if it is the last day of the month, make
- # it the 0th day of the following month (which then will
- # normalize back to the last day of the new month).
- my ($y, $m, $d) = ( $dur->is_preserve_mode ?
- $self->_rd2ymd( $self->{local_rd_days} + 1 ) :
- $self->_rd2ymd( $self->{local_rd_days} )
- );
- $d -= 1 if $dur->is_preserve_mode;
- if ( ! $dur->is_wrap_mode && $d > 28 )
- {
- # find the rd for the last day of our target month
- $self->{local_rd_days} = $self->_ymd2rd( $y, $m + $deltas{months} + 1, 0 );
- # what day of the month is it? (discard year and month)
- my $last_day = ($self->_rd2ymd( $self->{local_rd_days} ))[2];
- # if our original day was less than the last day,
- # use that instead
- $self->{local_rd_days} -= $last_day - $d if $last_day > $d;
- }
- else
- {
- $self->{local_rd_days} = $self->_ymd2rd( $y, $m + $deltas{months}, $d );
- }
- $self->{utc_year} += int( $deltas{months} / 12 ) + 1;
- }
- if ( $deltas{days} || $deltas{months} )
- {
- $self->_calc_utc_rd;
- $self->_handle_offset_modifier( $self->second );
- }
- if ( $deltas{minutes} )
- {
- $self->{utc_rd_secs} += $deltas{minutes} * 60;
- # This intentionally ignores leap seconds
- $self->_normalize_tai_seconds( $self->{utc_rd_days}, $self->{utc_rd_secs} );
- }
- if ( $deltas{seconds} || $deltas{nanoseconds} )
- {
- $self->{utc_rd_secs} += $deltas{seconds};
- if ( $deltas{nanoseconds} )
- {
- $self->{rd_nanosecs} += $deltas{nanoseconds};
- $self->_normalize_nanoseconds( $self->{utc_rd_secs}, $self->{rd_nanosecs} );
- }
- $self->_normalize_seconds;
- # This might be some big number much bigger than 60, but
- # that's ok (there are tests in 19leap_second.t to confirm
- # that)
- $self->_handle_offset_modifier( $self->second + $deltas{seconds} );
- }
- my $new =
- (ref $self)->from_object
- ( object => $self,
- locale => $self->{locale},
- ( $self->{formatter} ? ( formatter => $self->{formatter} ) : () ),
- );
- %$self = %$new;
- return $self;
- }
- sub _compare_overload
- {
- # note: $_[1]->compare( $_[0] ) is an error when $_[1] is not a
- # DateTime (such as the INFINITY value)
- return $_[2] ? - $_[0]->compare( $_[1] ) : $_[0]->compare( $_[1] );
- }
- sub compare
- {
- shift->_compare( @_, 0 );
- }
- sub compare_ignore_floating
- {
- shift->_compare( @_, 1 );
- }
- sub _compare
- {
- my ( $class, $dt1, $dt2, $consistent ) = ref $_[0] ? ( undef, @_ ) : @_;
- return undef unless defined $dt2;
- if ( ! ref $dt2 && ( $dt2 == INFINITY || $dt2 == NEG_INFINITY ) )
- {
- return $dt1->{utc_rd_days} <=> $dt2;
- }
- unless ( DateTime::Helpers::can( $dt1, 'utc_rd_values' )
- && DateTime::Helpers::can( $dt2, 'utc_rd_values' ) )
- {
- my $dt1_string = overload::StrVal($dt1);
- my $dt2_string = overload::StrVal($dt2);
- Carp::croak( "A DateTime object can only be compared to"
- . " another DateTime object ($dt1_string, $dt2_string)." );
- }
- if ( ! $consistent &&
- DateTime::Helpers::can( $dt1, 'time_zone' ) &&
- DateTime::Helpers::can( $dt2, 'time_zone' )
- )
- {
- my $is_floating1 = $dt1->time_zone->is_floating;
- my $is_floating2 = $dt2->time_zone->is_floating;
- if ( $is_floating1 && ! $is_floating2 )
- {
- $dt1 = $dt1->clone->set_time_zone( $dt2->time_zone );
- }
- elsif ( $is_floating2 && ! $is_floating1 )
- {
- $dt2 = $dt2->clone->set_time_zone( $dt1->time_zone );
- }
- }
- my @dt1_components = $dt1->utc_rd_values;
- my @dt2_components = $dt2->utc_rd_values;
- foreach my $i ( 0..2 )
- {
- return $dt1_components[$i] <=> $dt2_components[$i]
- if $dt1_components[$i] != $dt2_components[$i]
- }
- return 0;
- }
- sub _string_equals_overload
- {
- my ( $class, $dt1, $dt2 ) = ref $_[0] ? ( undef, @_ ) : @_;
- return unless
- ( DateTime::Helpers::can( $dt1, 'utc_rd_values' )
- && DateTime::Helpers::can( $dt2, 'utc_rd_values' )
- );
- $class ||= ref $dt1;
- return ! $class->compare( $dt1, $dt2 );
- }
- sub _string_not_equals_overload
- {
- return ! _string_equals_overload(@_);
- }
- sub _normalize_nanoseconds
- {
- use integer;
- # seconds, nanoseconds
- if ( $_[2] < 0 )
- {
- my $overflow = 1 + $_[2] / MAX_NANOSECONDS;
- $_[2] += $overflow * MAX_NANOSECONDS;
- $_[1] -= $overflow;
- }
- elsif ( $_[2] >= MAX_NANOSECONDS )
- {
- my $overflow = $_[2] / MAX_NANOSECONDS;
- $_[2] -= $overflow * MAX_NANOSECONDS;
- $_[1] += $overflow;
- }
- }
- # Many of the same parameters as new() but all of them are optional,
- # and there are no defaults.
- my $SetValidate =
- { map { my %copy = %{ $BasicValidate->{$_} };
- delete $copy{default};
- $copy{optional} = 1;
- $_ => \%copy }
- keys %$BasicValidate };
- sub set
- {
- my $self = shift;
- my %p = validate( @_, $SetValidate );
- my %old_p =
- ( map { $_ => $self->$_() }
- qw( year month day hour minute second nanosecond locale time_zone )
- );
- my $new_dt = (ref $self)->new( %old_p, %p );
- %$self = %$new_dt;
- return $self;
- }
- sub set_year { $_[0]->set( year => $_[1] ) }
- sub set_month { $_[0]->set( month => $_[1] ) }
- sub set_day { $_[0]->set( day => $_[1] ) }
- sub set_hour { $_[0]->set( hour => $_[1] ) }
- sub set_minute { $_[0]->set( minute => $_[1] ) }
- sub set_second { $_[0]->set( second => $_[1] ) }
- sub set_nanosecond { $_[0]->set( nanosecond => $_[1] ) }
- sub set_locale { $_[0]->set( locale => $_[1] ) }
- sub set_formatter { $_[0]->{formatter} = $_[1] }
- sub truncate
- {
- my $self = shift;
- my %p = validate( @_,
- { to =>
- { regex => qr/^(?:year|month|week|day|hour|minute|second)$/ },
- },
- );
- my %new = ( locale => $self->{locale},
- time_zone => $self->{tz},
- );
- if ( $p{to} eq 'week' )
- {
- my $day_diff = $self->day_of_week - 1;
- if ($day_diff)
- {
- $self->add( days => -1 * $day_diff );
- }
- return $self->truncate( to => 'day' );
- }
- else
- {
- foreach my $f ( qw( year month day hour minute second ) )
- {
- $new{$f} = $self->$f();
- last if $p{to} eq $f;
- }
- }
- my $new_dt = (ref $self)->new(%new);
- %$self = %$new_dt;
- return $self;
- }
- sub set_time_zone
- {
- my ( $self, $tz ) = @_;
- # This is a bit of a hack but it works because time zone objects
- # are singletons, and if it doesn't work all we lose is a little
- # bit of speed.
- return $self if $self->{tz} eq $tz;
- my $was_floating = $self->{tz}->is_floating;
- $self->{tz} = ref $tz ? $tz : DateTime::TimeZone->new( name => $tz );
- $self->_handle_offset_modifier( $self->second, 1 );
- # if it either was or now is floating (but not both)
- if ( $self->{tz}->is_floating xor $was_floating )
- {
- $self->_calc_utc_rd;
- }
- elsif ( ! $was_floating )
- {
- $self->_calc_local_rd;
- }
- return $self;
- }
- sub STORABLE_freeze
- {
- my $self = shift;
- my $cloning = shift;
- my $serialized = '';
- foreach my $key ( qw( utc_rd_days
- utc_rd_secs
- rd_nanosecs ) )
- {
- $serialized .= "$key:$self->{$key}|";
- }
- # not used yet, but may be handy in the future.
- $serialized .= "version:$VERSION";
- # Formatter needs to be returned as a reference since it may be
- # undef or a class name, and Storable will complain if extra
- # return values aren't refs
- return $serialized, $self->{locale}, $self->{tz}, \$self->{formatter};
- }
- sub STORABLE_thaw
- {
- my $self = shift;
- my $cloning = shift;
- my $serialized = shift;
- my %serialized = map { split /:/ } split /\|/, $serialized;
- my ( $locale, $tz, $formatter );
- # more recent code version
- if (@_)
- {
- ( $locale, $tz, $formatter ) = @_;
- }
- else
- {
- $tz = DateTime::TimeZone->new( name => delete $serialized{tz} );
- $locale =
- DateTime::Locale->load( exists $serialized{language}
- ? delete $serialized{language}
- : delete $serialized{locale}
- );
- }
- delete $serialized{version};
- my $object = bless { utc_vals => [ $serialized{utc_rd_days},
- $serialized{utc_rd_secs},
- $serialized{rd_nanosecs},
- ],
- tz => $tz,
- }, 'DateTime::_Thawed';
- my %formatter = defined $$formatter ? ( formatter => $$formatter ) : ();
- my $new = (ref $self)->from_object( object => $object,
- locale => $locale,
- %formatter,
- );
- %$self = %$new;
- return $self;
- }
- package DateTime::_Thawed;
- sub utc_rd_values { @{ $_[0]->{utc_vals} } }
- sub time_zone { $_[0]->{tz} }
- 1;
- __END__
- =head1 NAME
- DateTime - A date and time object
- =head1 SYNOPSIS
- use DateTime;
- $dt = DateTime->new( year => 1964,
- month => 10,
- day => 16,
- hour => 16,
- minute => 12,
- second => 47,
- nanosecond => 500000000,
- time_zone => 'Asia/Taipei',
- );
- $dt = DateTime->from_epoch( epoch => $epoch );
- $dt = DateTime->now; # same as ( epoch => time() )
- $year = $dt->year;
- $month = $dt->month; # 1-12 - also mon
- $day = $dt->day; # 1-31 - also day_of_month, mday
- $dow = $dt->day_of_week; # 1-7 (Monday is 1) - also dow, wday
- $hour = $dt->hour; # 0-23
- $minute = $dt->minute; # 0-59 - also min
- $second = $dt->second; # 0-61 (leap seconds!) - also sec
- $doy = $dt->day_of_year; # 1-366 (leap years) - also doy
- $doq = $dt->day_of_quarter; # 1.. - also doq
- $qtr = $dt->quarter; # 1-4
- # all of the start-at-1 methods above have correponding start-at-0
- # methods, such as $dt->day_of_month_0, $dt->month_0 and so on
- $ymd = $dt->ymd; # 2002-12-06
- $ymd = $dt->ymd('/'); # 2002/12/06 - also date
- $mdy = $dt->mdy; # 12-06-2002
- $mdy = $dt->mdy('/'); # 12/06/2002
- $dmy = $dt->dmy; # 06-12-2002
- $dmy = $dt->dmy('/'); # 06/12/2002
- $hms = $dt->hms; # 14:02:29
- $hms = $dt->hms('!'); # 14!02!29 - also time
- $is_leap = $dt->is_leap_year;
- # these are localizable, see Locales section
- $month_name = $dt->month_name; # January, February, ...
- $month_abbr = $dt->month_abbr; # Jan, Feb, ...
- $day_name = $dt->day_name; # Monday, Tuesday, ...
- $day_abbr = $dt->day_abbr; # Mon, Tue, ...
- $epoch_time = $dt->epoch;
- # may return undef if the datetime is outside the range that is
- # representable by your OS's epoch system.
- $dt2 = $dt + $duration_object;
- $dt3 = $dt - $duration_object;
- $duration_object = $dt - $dt2;
- $dt->set( year => 1882 );
- $dt->set_time_zone( 'America/Chicago' );
- $dt->set_formatter( $formatter );
- =head1 DESCRIPTION
- DateTime is a class for the representation of date/time combinations,
- and is part of the Perl DateTime project. For details on this project
- please see L<http://datetime.perl.org/>. The DateTime site has a FAQ
- which may help answer many "how do I do X?" questions. The FAQ is at
- L<http://datetime.perl.org/?FAQ>.
- It represents the Gregorian calendar, extended backwards in time
- before its creation (in 1582). This is sometimes known as the
- "proleptic Gregorian calendar". In this calendar, the first day of
- the calendar (the epoch), is the first day of year 1, which
- corresponds to the date which was (incorrectly) believed to be the
- birth of Jesus Christ.
- The calendar represented does have a year 0, and in that way differs
- from how dates are often written using "BCE/CE" or "BC/AD".
- For infinite datetimes, please see the
- L<DateTime::Infinite|DateTime::Infinite> module.
- =head1 USAGE
- =head2 0-based Versus 1-based Numbers
- The DateTime.pm module follows a simple consistent logic for
- determining whether or not a given number is 0-based or 1-based.
- Month, day of month, day of week, and day of year are 1-based. Any
- method that is 1-based also has an equivalent 0-based method ending in
- "_0". So for example, this class provides both C<day_of_week()> and
- C<day_of_week_0()> methods.
- The C<day_of_week_0()> method still treats Monday as the first day of
- the week.
- All I<time>-related numbers such as hour, minute, and second are
- 0-based.
- Years are neither, as they can be both positive or negative, unlike
- any other datetime component. There I<is> a year 0.
- There is no C<quarter_0()> method.
- =head2 Error Handling
- Some errors may cause this module to die with an error string. This
- can only happen when calling constructor methods, methods that change
- the object, such as C<set()>, or methods that take parameters.
- Methods that retrieve information about the object, such as C<year()>
- or C<epoch()>, will never die.
- =head2 Locales
- All the object methods which return names or abbreviations return data
- based on a locale. This is done by setting the locale when
- constructing a DateTime object. There is also a C<DefaultLocale()>
- class method which may be used to set the default locale for all
- DateTime objects created. If this is not set, then "en_US" is used.
- Some locales may return data as Unicode. When using Perl 5.6.0 or
- greater, this will be a native Perl Unicode string. When using older
- Perls, this will be a sequence of bytes representing the Unicode
- character.
- =head2 Floating DateTimes
- The default time zone for new DateTime objects, except where stated
- otherwise, is the "floating" time zone. This concept comes from the
- iCal standard. A floating datetime is one which is not anchored to
- any particular time zone. In addition, floating datetimes do not
- include leap seconds, since we cannot apply them without knowing the
- datetime's time zone.
- The results of date math and comparison between a floating datetime
- and one with a real time zone are not really valid, because one
- includes leap seconds and the other does not. Similarly, the results
- of datetime math between two floating datetimes and two datetimes with
- time zones are not really comparable.
- If you are planning to use any objects with a real time zone, it is
- strongly recommended that you B<do not> mix these with floating
- datetimes.
- =head2 Math
- If you are going to be using doing date math, please read the section
- L<How Datetime Math is Done>.
- =head2 Time Zone Warning
- Do not try to use named time zones (like "America/Chicago") with dates
- very far in the future (thousands of years). The current
- implementation of C<DateTime::TimeZone> will use a huge amount of
- memory calculating all the DST changes from now until the future
- date. Use UTC or the floating time zone and you will be safe.
- =head2 Methods
- =head3 Constructors
- All constructors can die when invalid parameters are given.
- =over 4
- =item * new( ... )
- This class method accepts parameters for each date and time component:
- "year", "month", "day", "hour", "minute", "second", "nanosecond".
- It also accepts "locale", "time_zone", and "formatter" parameters.
- my $dt = DateTime->new( year => 1066,
- month => 10,
- day => 25,
- hour => 7,
- minute => 15,
- second => 47,
- nanosecond => 500000000,
- time_zone => 'America/Chicago',
- );
- DateTime validates the "month", "day", "hour", "minute", and "second",
- and "nanosecond" parameters. The valid values for these parameters are:
- =over 8
- =item * month
- 1-12
- =item * day
- 1-31, and it must be within the valid range of days for the specified
- month
- =item * hour
- 0-23
- =item * minute
- 0-59
- =item * second
- 0-61 (to allow for leap seconds). Values of 60 or 61 are only allowed
- when they match actual leap seconds.
- =item * nanosecond
- >= 0
- =back
- =back
- Invalid parameter types (like an array reference) will cause the
- constructor to die.
- The value for seconds may be from 0 to 61, to account for leap
- seconds. If you give a value greater than 59, DateTime does check to
- see that it really matches a valid leap second.
- All of the parameters are optional except for "year". The "month" and
- "day" parameters both default to 1, while the "hour", "minute",
- "second", and "nanosecond" parameters all default to 0.
- The "locale" parameter should be a string matching one of the valid
- locales, or a C<DateTime::Locale> object. See the
- L<DateTime::Locale|DateTime::Locale> documentation for details.
- The time_zone parameter can be either a scalar or a
- C<DateTime::TimeZone> object. A string will simply be passed to the
- C<< DateTime::TimeZone->new >> method as its "name" parameter. This
- string may be an Olson DB time zone name ("America/Chicago"), an
- offset string ("+0630"), or the words "floating" or "local". See the
- C<DateTime::TimeZone> documentation for more details.
- The default time zone is "floating".
- The "formatter" can be either a scalar or an object, but the class
- specified by the scalar or the object must implement a
- C<format_datetime()> method.
- =head4 Ambiguous Local Times
- Because of Daylight Saving Time, it is possible to specify a local
- time that is ambiguous. For example, in the US in 2003, the
- transition from to saving to standard time occurred on October 26, at
- 02:00:00 local time. The local clock changed from 01:59:59 (saving
- time) to 01:00:00 (standard time). This means that the hour from
- 01:00:00 through 01:59:59 actually occurs twice, though the UTC time
- continues to move forward.
- If you specify an ambiguous time, then the latest UTC time is always
- used, in effect always choosing standard time. In this case, you can
- simply subtract an hour to the object in order to move to saving time,
- for example:
- # This object represent 01:30:00 standard time
- my $dt = DateTime->new( year => 2003,
- month => 10,
- day => 26,
- hour => 1,
- minute => 30,
- second => 0,
- time_zone => 'America/Chicago',
- );
- print $dt->hms; # prints 01:30:00
- # Now the object represent 01:30:00 saving time
- $dt->subtract( hours => 1 );
- print $dt->hms; # still prints 01:30:00
- Alternately, you could create the object with the UTC time zone, and
- then call the C<set_time_zone()> method to change the time zone. This
- is a good way to ensure that the time is not ambiguous.
- =head4 Invalid Local Times
- Another problem introduced by Daylight Saving Time is that certain
- local times just do not exist. For example, in the US in 2003, the
- transition from standard to saving time occurred on April 6, at the
- change to 2:00:00 local time. The local clock changes from 01:59:59
- (standard time) to 03:00:00 (saving time). This means that there is
- no 02:00:00 through 02:59:59 on April 6!
- Attempting to create an invalid time currently causes a fatal error.
- This may change in future version of this module.
- =over 4
- =item * from_epoch( epoch => $epoch, ... )
- This class method can be used to construct a new DateTime object from
- an epoch time instead of components. Just as with the C<new()>
- method, it accepts "time_zone", "locale", and "formatter" parameters.
- If the epoch value is not an integer, the part after the decimal will
- be converted to nanoseconds. This is done in order to be compatible
- with C<Time::HiRes>. If the floating portion extends past 9 decimal
- places, it will be truncated to nine, so that 1.1234567891 will become
- 1 second and 123,456,789 nanoseconds.
- By default, the returned object will be in the UTC time zone.
- =item * now( ... )
- This class method is equivalent to calling C<from_epoch()> with the
- value returned from Perl's C<time()> function. Just as with the
- C<new()> method, it accepts "time_zone" and "locale" parameters.
- By default, the returned object will be in the UTC time zone.
- =item * today( ... )
- This class method is equivalent to:
- DateTime->now->truncate( to => 'day' );
- =item * from_object( object => $object, ... )
- This class method can be used to construct a new DateTime object from
- any object that implements the C<utc_rd_values()> method. All
- C<DateTime::Calendar> modules must implement this method in order to
- provide cross-calendar compatibility. This method accepts a
- "locale" and "formatter" parameter
- If the object passed to this method has a C<time_zone()> method, that
- is used to set the time zone of the newly created C<DateTime.pm>
- object.
- Otherwise, the returned object will be in the floating time zone.
- =item * last_day_of_month( ... )
- This constructor takes the same arguments as can be given to the
- C<new()> method, except for "day". Additionally, both "year" and
- "month" are required.
- =item * from_day_of_year( ... )
- This constructor takes the same arguments as can be given to the
- C<new()> method, except that it does not accept a "month" or "day"
- argument. Instead, it requires both "year" and "day_of_year". The
- day of year must be between 1 and 366, and 366 is only allowed for
- leap years.
- =item * clone
- This object method returns a new object that is replica of the object
- upon which the method is called.
- =back
- =head3 "Get" Methods
- This class has many methods for retrieving information about an
- object.
- =over 4
- =item * year
- Returns the year.
- =item * ce_year
- Returns the year according to the BCE/CE numbering system. The year
- before year 1 in this system is year -1, aka "1 BCE".
- =item * era_name
- Returns the long name of the current era, something like "Before
- Christ". See the L<Locales|/Locales> section for more details.
- =item * era_abbr
- Returns the abbreviated name of the current era, something like "BC".
- See the L<Locales|/Locales> section for more details.
- =item * christian_era
- Returns a string, either "BC" or "AD", according to the year.
- =item * secular_era
- Returns a string, either "BCE" or "CE", according to the year.
- =item * year_with_era
- Returns a string containing the year immediately followed by its era
- abbreviation. The year is the absolute value of C<ce_year()>, so that
- year 1 is "1BC" and year 0 is "1AD".
- =item * year_with_christian_era
- Like C<year_with_era()>, but uses the christian_era() to get the era
- name.
- =item * year_with_secular_era
- Like C<year_with_era()>, but uses the secular_era() method to get the
- era name.
- =item * month, mon
- Returns the month of the year, from 1..12.
- =item * month_name
- Returns the name of the current month. See the
- L<Locales|/Locales> section for more details.
- =item * month_abbr
- Returns the abbreviated name of the current month. See the
- L<Locales|/Locales> section for more details.
- =item * day_of_month, day, mday
- Returns the day of the month, from 1..31.
- =item * day_of_week, wday, dow
- Returns the day of the week as a number, from 1..7, with 1 being
- Monday and 7 being Sunday.
- =item * day_name
- Returns the name of the current day of the week. See the
- L<Locales|/Locales> section for more details.
- =item * day_abbr
- Returns the abbreviated name of the current day of the week. See the
- L<Locales|/Locales> section for more details.
- =item * day_of_year, doy
- Returns the day of the year.
- =item * quarter
- Returns the quarter of the year, from 1..4.
- =item * quarter_name
- Returns the name of the current quarter. See the
- L<Locales|/Locales> section for more details.
- =item * quarter_abbr
- Returns the abbreviated name of the current quarter. See the
- L<Locales|/Locales> section for more details.
- =item * day_of_quarter, doq
- Returns the day of the quarter.
- =item * weekday_of_month
- Returns a number from 1..5 indicating which week day of the month this
- is. For example, June 9, 2003 is the second Monday of the month, and
- so this method returns 2 for that day.
- =item * ymd( $optional_separator ), date
- =item * mdy( $optional_separator )
- =item * dmy( $optional_separator )
- Each method returns the year, month, and day, in the order indicated
- by the method name. Years are zero-padded to four digits. Months and
- days are 0-padded to two digits.
- By default, the values are separated by a dash (-), but this can be
- overridden by passing a value to the method.
- =item * hour
- Returns the hour of the day, from 0..23.
- =item * hour_1
- Returns the hour of the day, from 1..24.
- =item * hour_12
- Returns the hour of the day, from 1..12.
- =item * hour_12_0
- Returns the hour of the day, from 0..11.
- =item * minute, min
- Returns the minute of the hour, from 0..59.
- =item * second, sec
- Returns the second, from 0..61. The values 60 and 61 are used for
- leap seconds.
- =item * fractional_second
- Returns the second, as a real number from 0.0 until 61.999999999
- The values 60 and 61 are used for leap seconds.
- =item * millisecond
- Returns the fractional part of the second as milliseconds (1E-3 seconds).
- Half a second is 500 milliseconds.
- =item * microsecond
- Returns the fractional part of the second as microseconds (1E-6
- seconds). This value will be rounded to an integer.
- Half a second is 500_000 microseconds. This value will be rounded to
- an integer.
- =item * nanosecond
- Returns the fractional part of the second as nanoseconds (1E-9 seconds).
- Half a second is 500_000_000 nanoseconds.
- =item * hms( $optional_separator ), time
- Returns the hour, minute, and second, all zero-padded to two digits.
- If no separator is specified, a colon (:) is used by default.
- =item * datetime, iso8601
- This method is equivalent to:
- $dt->ymd('-') . 'T' . $dt->hms(':')
- =item * is_leap_year
- This method returns a true or false indicating whether or not the
- datetime object is in a leap year.
- =item * week
- ($week_year, $week_number) = $dt->week;
- Returns information about the calendar week which contains this
- datetime object. The values returned by this method are also available
- separately through the week_year and week_number methods.
- The first week of the year is defined by ISO as the one which contains
- the fourth day of January, which is equivalent to saying that it's the
- first week to overlap the new year by at least four days.
- Typically the week year will be the same as the year that the object
- is in, but dates at the very beginning of a calendar year often end up
- in the last week of the prior year, and similarly, the final few days
- of the year may be placed in the first week of the next year.
- =item * week_year
- Returns the year of the week.
- =item * week_number
- Returns the week of the year, from 1..53.
- =item * week_of_month
- The week of the month, from 0..5. The first week of the month is the
- first week that contains a Thursday. This is based on the ICU
- definition of week of month, and correlates to the ISO8601 week of
- year definition. A day in the week I<before> the week with the first
- Thursday will be week 0.
- =item * jd, mjd
- These return the Julian Day and Modified Julian Day, respectively.
- The value returned is a floating point n