DateTime-1.21/0000775000175000017500000000000012603036061012770 5ustar autarchautarchDateTime-1.21/lib/0000775000175000017500000000000012603036061013536 5ustar autarchautarchDateTime-1.21/lib/DateTime/0000775000175000017500000000000012603036061015232 5ustar autarchautarchDateTime-1.21/lib/DateTime/Helpers.pm0000644000175000017500000000061412603036061017171 0ustar autarchautarchpackage DateTime::Helpers; use strict; use warnings; our $VERSION = '1.21'; use Scalar::Util (); sub can { my $object = shift; my $method = shift; return unless Scalar::Util::blessed($object); return $object->can($method); } sub isa { my $object = shift; my $method = shift; return unless Scalar::Util::blessed($object); return $object->isa($method); } 1; DateTime-1.21/lib/DateTime/PP.pm0000644000175000017500000001227612603036061016115 0ustar autarchautarchpackage DateTime::PP; use strict; use warnings; our $VERSION = '1.21'; $DateTime::IsPurePerl = 1; my @MonthLengths = ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 ); my @LeapYearMonthLengths = @MonthLengths; $LeapYearMonthLengths[1]++; my @EndOfLastMonthDayOfYear; { my $x = 0; foreach my $length (@MonthLengths) { push @EndOfLastMonthDayOfYear, $x; $x += $length; } } my @EndOfLastMonthDayOfLeapYear = @EndOfLastMonthDayOfYear; $EndOfLastMonthDayOfLeapYear[$_]++ for 2 .. 11; sub _time_as_seconds { shift; my ( $hour, $min, $sec ) = @_; $hour ||= 0; $min ||= 0; $sec ||= 0; my $secs = $hour * 3600 + $min * 60 + $sec; return $secs; } sub _rd2ymd { my $class = shift; use integer; my $d = shift; my $rd = $d; my $yadj = 0; my ( $c, $y, $m ); # add 306 days to make relative to Mar 1, 0 if ( ( $d += 306 ) <= 0 ) { # avoid ambiguity in C division of negatives $yadj = -( -$d / 146097 + 1 ); $d -= $yadj * 146097; } $c = ( $d * 4 - 1 ) / 146097; # calc # of centuries $d is after 29 Feb of yr 0 $d -= $c * 146097 / 4; # (4 centuries = 146097 days) $y = ( $d * 4 - 1 ) / 1461; # calc number of years into the century, $d -= $y * 1461 / 4; # again March-based (4 yrs =~ 146[01] days) $m = ( $d * 12 + 1093 ) / 367; # get the month (3..14 represent March through $d -= ( $m * 367 - 1094 ) / 12; # February of following year) $y += $c * 100 + $yadj * 400; # get the real year, which is off by ++$y, $m -= 12 if $m > 12; # one if month is January or February if ( $_[0] ) { my $dow; if ( $rd < -6 ) { $dow = ( $rd + 6 ) % 7; $dow += $dow ? 8 : 1; } else { $dow = ( ( $rd + 6 ) % 7 ) + 1; } my $doy = $class->_end_of_last_month_day_of_year( $y, $m ); $doy += $d; my $quarter; { no integer; $quarter = int( ( 1 / 3.1 ) * $m ) + 1; } my $qm = ( 3 * $quarter ) - 2; my $doq = ( $doy - $class->_end_of_last_month_day_of_year( $y, $qm ) ); return ( $y, $m, $d, $dow, $doy, $quarter, $doq ); } return ( $y, $m, $d ); } sub _ymd2rd { shift; # ignore class use integer; my ( $y, $m, $d ) = @_; my $adj; # make month in range 3..14 (treat Jan & Feb as months 13..14 of # prev year) if ( $m <= 2 ) { $y -= ( $adj = ( 14 - $m ) / 12 ); $m += 12 * $adj; } elsif ( $m > 14 ) { $y += ( $adj = ( $m - 3 ) / 12 ); $m -= 12 * $adj; } # make year positive (oh, for a use integer 'sane_div'!) if ( $y < 0 ) { $d -= 146097 * ( $adj = ( 399 - $y ) / 400 ); $y += 400 * $adj; } # add: day of month, days of previous 0-11 month period that began # w/March, days of previous 0-399 year period that began w/March # of a 400-multiple year), days of any 400-year periods before # that, and finally subtract 306 days to adjust from Mar 1, year # 0-relative to Jan 1, year 1-relative (whew) $d += ( $m * 367 - 1094 ) / 12 + $y % 100 * 1461 / 4 + ( $y / 100 * 36524 + $y / 400 ) - 306; } sub _seconds_as_components { shift; my $secs = shift; my $utc_secs = shift; my $modifier = shift || 0; use integer; $secs -= $modifier; my $hour = $secs / 3600; $secs -= $hour * 3600; my $minute = $secs / 60; my $second = $secs - ( $minute * 60 ); if ( $utc_secs && $utc_secs >= 86400 ) { # there is no such thing as +3 or more leap seconds! die "Invalid UTC RD seconds value: $utc_secs" if $utc_secs > 86401; $second += $utc_secs - 86400 + 60; $minute = 59; $hour--; $hour = 23 if $hour < 0; } return ( $hour, $minute, $second ); } sub _end_of_last_month_day_of_year { my $class = shift; my ( $y, $m ) = @_; $m--; return ( $class->_is_leap_year($y) ? $EndOfLastMonthDayOfLeapYear[$m] : $EndOfLastMonthDayOfYear[$m] ); } sub _is_leap_year { shift; my $year = shift; # According to Bjorn Tackmann, this line prevents an infinite loop # when running the tests under Qemu. I cannot reproduce this on # Ubuntu or with Strawberry Perl on Win2K. return 0 if $year == DateTime::INFINITY() || $year == DateTime::NEG_INFINITY(); return 0 if $year % 4; return 1 if $year % 100; return 0 if $year % 400; return 1; } sub _day_length { DateTime::LeapSecond::day_length( $_[1] ) } sub _accumulated_leap_seconds { DateTime::LeapSecond::leap_seconds( $_[1] ) } my @subs = qw( _time_as_seconds _rd2ymd _ymd2rd _seconds_as_components _end_of_last_month_day_of_year _is_leap_year _day_length _accumulated_leap_seconds ); for my $sub (@subs) { no strict 'refs'; *{ 'DateTime::' . $sub } = __PACKAGE__->can($sub); } # This is down here so that _ymd2rd is available when it loads, # because it will load DateTime::LeapSecond, which needs # DateTime->_ymd2rd to be available when it is loading require DateTime::PPExtra; 1; DateTime-1.21/lib/DateTime/Duration.pm0000644000175000017500000004247112603036061017363 0ustar autarchautarchpackage DateTime::Duration; use strict; use warnings; our $VERSION = '1.21'; use Carp (); use DateTime; use DateTime::Helpers; use Params::Validate qw( validate SCALAR ); use overload ( fallback => 1, '+' => '_add_overload', '-' => '_subtract_overload', '*' => '_multiply_overload', '<=>' => '_compare_overload', 'cmp' => '_compare_overload', ); use constant MAX_NANOSECONDS => 1_000_000_000; # 1E9 = almost 32 bits my @all_units = qw( months days minutes seconds nanoseconds ); # XXX - need to reject non-integers but accept infinity, NaN, & # 1.56e+18 sub new { my $class = shift; my %p = validate( @_, { years => { type => SCALAR, default => 0 }, months => { type => SCALAR, default => 0 }, weeks => { type => SCALAR, default => 0 }, days => { type => SCALAR, default => 0 }, hours => { type => SCALAR, default => 0 }, minutes => { type => SCALAR, default => 0 }, seconds => { type => SCALAR, default => 0 }, nanoseconds => { type => SCALAR, default => 0 }, end_of_month => { type => SCALAR, default => undef, regex => qr/^(?:wrap|limit|preserve)$/ }, } ); my $self = bless {}, $class; $self->{months} = ( $p{years} * 12 ) + $p{months}; $self->{days} = ( $p{weeks} * 7 ) + $p{days}; $self->{minutes} = ( $p{hours} * 60 ) + $p{minutes}; $self->{seconds} = $p{seconds}; if ( $p{nanoseconds} ) { $self->{nanoseconds} = $p{nanoseconds}; $self->_normalize_nanoseconds; } else { # shortcut - if they don't need nanoseconds $self->{nanoseconds} = 0; } $self->{end_of_month} = ( defined $p{end_of_month} ? $p{end_of_month} : $self->{months} < 0 ? 'preserve' : 'wrap' ); return $self; } # make the signs of seconds, nanos the same; 0 < abs(nanos) < MAX_NANOS # NB this requires nanoseconds != 0 (callers check this already) sub _normalize_nanoseconds { my $self = shift; return if ( $self->{nanoseconds} == DateTime::INFINITY() || $self->{nanoseconds} == DateTime::NEG_INFINITY() || $self->{nanoseconds} eq DateTime::NAN() ); my $seconds = $self->{seconds} + $self->{nanoseconds} / MAX_NANOSECONDS; $self->{seconds} = int($seconds); $self->{nanoseconds} = $self->{nanoseconds} % MAX_NANOSECONDS; $self->{nanoseconds} -= MAX_NANOSECONDS if $seconds < 0; } sub clone { bless { %{ $_[0] } }, ref $_[0] } sub years { abs( $_[0]->in_units('years') ) } sub months { abs( $_[0]->in_units( 'months', 'years' ) ) } sub weeks { abs( $_[0]->in_units('weeks') ) } sub days { abs( $_[0]->in_units( 'days', 'weeks' ) ) } sub hours { abs( $_[0]->in_units('hours') ) } sub minutes { abs( $_[0]->in_units( 'minutes', 'hours' ) ) } sub seconds { abs( $_[0]->in_units('seconds') ) } sub nanoseconds { abs( $_[0]->in_units( 'nanoseconds', 'seconds' ) ) } sub is_positive { $_[0]->_has_positive && !$_[0]->_has_negative } sub is_negative { !$_[0]->_has_positive && $_[0]->_has_negative } sub _has_positive { ( grep { $_ > 0 } @{ $_[0] }{@all_units} ) ? 1 : 0; } sub _has_negative { ( grep { $_ < 0 } @{ $_[0] }{@all_units} ) ? 1 : 0; } sub is_zero { return 0 if grep { $_ != 0 } @{ $_[0] }{@all_units}; return 1; } sub delta_months { $_[0]->{months} } sub delta_days { $_[0]->{days} } sub delta_minutes { $_[0]->{minutes} } sub delta_seconds { $_[0]->{seconds} } sub delta_nanoseconds { $_[0]->{nanoseconds} } sub deltas { map { $_ => $_[0]->{$_} } @all_units; } sub in_units { my $self = shift; my @units = @_; my %units = map { $_ => 1 } @units; my %ret; my ( $months, $days, $minutes, $seconds ) = @{$self}{qw( months days minutes seconds )}; if ( $units{years} ) { $ret{years} = int( $months / 12 ); $months -= $ret{years} * 12; } if ( $units{months} ) { $ret{months} = $months; } if ( $units{weeks} ) { $ret{weeks} = int( $days / 7 ); $days -= $ret{weeks} * 7; } if ( $units{days} ) { $ret{days} = $days; } if ( $units{hours} ) { $ret{hours} = int( $minutes / 60 ); $minutes -= $ret{hours} * 60; } if ( $units{minutes} ) { $ret{minutes} = $minutes; } if ( $units{seconds} ) { $ret{seconds} = $seconds; $seconds = 0; } if ( $units{nanoseconds} ) { $ret{nanoseconds} = $seconds * MAX_NANOSECONDS + $self->{nanoseconds}; } wantarray ? @ret{@units} : $ret{ $units[0] }; } sub is_wrap_mode { $_[0]->{end_of_month} eq 'wrap' ? 1 : 0 } sub is_limit_mode { $_[0]->{end_of_month} eq 'limit' ? 1 : 0 } sub is_preserve_mode { $_[0]->{end_of_month} eq 'preserve' ? 1 : 0 } sub end_of_month_mode { $_[0]->{end_of_month} } sub calendar_duration { my $self = shift; return ( ref $self ) ->new( map { $_ => $self->{$_} } qw( months days end_of_month ) ); } sub clock_duration { my $self = shift; return ( ref $self ) ->new( map { $_ => $self->{$_} } qw( minutes seconds nanoseconds end_of_month ) ); } sub inverse { my $self = shift; my %p = @_; my %new; foreach my $u (@all_units) { $new{$u} = $self->{$u}; # avoid -0 bug $new{$u} *= -1 if $new{$u}; } $new{end_of_month} = $p{end_of_month} if exists $p{end_of_month}; return ( ref $self )->new(%new); } sub add_duration { my ( $self, $dur ) = @_; foreach my $u (@all_units) { $self->{$u} += $dur->{$u}; } $self->_normalize_nanoseconds if $self->{nanoseconds}; return $self; } sub add { my $self = shift; return $self->add_duration( ( ref $self )->new(@_) ); } sub subtract_duration { return $_[0]->add_duration( $_[1]->inverse ) } sub subtract { my $self = shift; return $self->subtract_duration( ( ref $self )->new(@_) ); } sub multiply { my $self = shift; my $multiplier = shift; foreach my $u (@all_units) { $self->{$u} *= $multiplier; } $self->_normalize_nanoseconds if $self->{nanoseconds}; return $self; } sub compare { my ( $class, $dur1, $dur2, $dt ) = @_; $dt ||= DateTime->now; return DateTime->compare( $dt->clone->add_duration($dur1), $dt->clone->add_duration($dur2) ); } sub _add_overload { my ( $d1, $d2, $rev ) = @_; ( $d1, $d2 ) = ( $d2, $d1 ) if $rev; if ( DateTime::Helpers::isa( $d2, 'DateTime' ) ) { $d2->add_duration($d1); return; } # will also work if $d1 is a DateTime.pm object return $d1->clone->add_duration($d2); } sub _subtract_overload { my ( $d1, $d2, $rev ) = @_; ( $d1, $d2 ) = ( $d2, $d1 ) if $rev; Carp::croak( "Cannot subtract a DateTime object from a DateTime::Duration object") if DateTime::Helpers::isa( $d2, 'DateTime' ); return $d1->clone->subtract_duration($d2); } sub _multiply_overload { my $self = shift; my $new = $self->clone; return $new->multiply(@_); } sub _compare_overload { Carp::croak( 'DateTime::Duration does not overload comparison.' . ' See the documentation on the compare() method for details.' ); } 1; # ABSTRACT: Duration objects for date math __END__ =pod =head1 NAME DateTime::Duration - Duration objects for date math =head1 VERSION version 1.21 =head1 SYNOPSIS use DateTime::Duration; $dur = DateTime::Duration->new( years => 3, months => 5, weeks => 1, days => 1, hours => 6, minutes => 15, seconds => 45, nanoseconds => 12000 ); my ( $days, $hours, $seconds ) = $dur->in_units('days', 'hours', 'seconds'); # Human-readable accessors, always positive, but consider using # DateTime::Format::Duration instead $dur->years; $dur->months; $dur->weeks; $dur->days; $dur->hours; $dur->minutes; $dur->seconds; $dur->nanoseconds; $dur->is_wrap_mode $dur->is_limit_mode $dur->is_preserve_mode print $dur->end_of_month_mode; # Multiply all values by -1 my $opposite = $dur->inverse; my $bigger = $dur1 + $dur2; my $smaller = $dur1 - $dur2; # the result could be negative my $bigger = $dur1 * 3; my $base_dt = DateTime->new( year => 2000 ); my @sorted = sort { DateTime::Duration->compare( $a, $b, $base_dt ) } @durations; if ( $dur->is_positive ) { ... } if ( $dur->is_zero ) { ... } if ( $dur->is_negative ) { ... } =head1 DESCRIPTION This is a simple class for representing duration objects. These objects are used whenever you do date math with DateTime.pm. See the L section of the DateTime.pm documentation for more details. The short course: One cannot in general convert between seconds, minutes, days, and months, so this class will never do so. Instead, create the duration with the desired units to begin with, for example by calling the appropriate subtraction/delta method on a C object. =head1 METHODS Like C itself, C returns the object from mutator methods in order to make method chaining possible. C has the following methods: =head2 DateTime::Duration->new( ... ) This method takes the parameters "years", "months", "weeks", "days", "hours", "minutes", "seconds", "nanoseconds", and "end_of_month". All of these except "end_of_month" are numbers. If any of the numbers are negative, the entire duration is negative. All of the numbers B. Internally, years as just treated as 12 months. Similarly, weeks are treated as 7 days, and hours are converted to minutes. Seconds and nanoseconds are both treated separately. The "end_of_month" parameter must be either "wrap", "limit", or "preserve". This parameter specifies how date math that crosses the end of a month is handled. In "wrap" mode, adding months or years that result in days beyond the end of the new month will roll over into the following month. For instance, adding one year to Feb 29 will result in Mar 1. If you specify "end_of_month" mode as "limit", the end of the month is never crossed. Thus, adding one year to Feb 29, 2000 will result in Feb 28, 2001. If you were to then add three more years this will result in Feb 28, 2004. If you specify "end_of_month" mode as "preserve", the same calculation is done as for "limit" except that if the original date is at the end of the month the new date will also be. For instance, adding one month to Feb 29, 2000 will result in Mar 31, 2000. For positive durations, the "end_of_month" parameter defaults to wrap. For negative durations, the default is "limit". This should match how most people "intuitively" expect datetime math to work. =head2 $dur->clone() Returns a new object with the same properties as the object on which this method was called. =head2 $dur->in_units( ... ) Returns the length of the duration in the units (any of those that can be passed to C) given as arguments. All lengths are integral, but may be negative. Smaller units are computed from what remains after taking away the larger units given, so for example: my $dur = DateTime::Duration->new( years => 1, months => 15 ); $dur->in_units( 'years' ); # 2 $dur->in_units( 'months' ); # 27 $dur->in_units( 'years', 'months' ); # (2, 3) $dur->in_units( 'weeks', 'days' ); # (0, 0) ! The last example demonstrates that there will not be any conversion between units which don't have a fixed conversion rate. The only conversions possible are: =over 8 =item * years <=> months =item * weeks <=> days =item * hours <=> minutes =item * seconds <=> nanoseconds =back For the explanation of why this is the case, please see the L section of the DateTime.pm documentation Note that the numbers returned by this method may not match the values given to the constructor. In list context, in_units returns the lengths in the order of the units given. In scalar context, it returns the length in the first unit (but still computes in terms of all given units). If you need more flexibility in presenting information about durations, please take a look a C. =head2 $dur->is_positive(), $dur->is_zero(), $dur->is_negative() Indicates whether or not the duration is positive, zero, or negative. If the duration contains both positive and negative units, then it will return false for B of these methods. =head2 $dur->is_wrap_mode(), $dur->is_limit_mode(), $dur->is_preserve_mode() Indicates what mode is used for end of month wrapping. =head2 $dur->end_of_month_mode() Returns one of "wrap", "limit", or "preserve". =head2 $dur->calendar_duration() Returns a new object with the same I delta (months and days only) and end of month mode as the current object. =head2 $dur->clock_duration() Returns a new object with the same I deltas (minutes, seconds, and nanoseconds) and end of month mode as the current object. =head2 $dur->inverse( ... ) Returns a new object with the same deltas as the current object, but multiple by -1. The end of month mode for the new object will be the default end of month mode, which depends on whether the new duration is positive or negative. You can set the end of month mode in the inverted duration explicitly by passing "end_of_month => ..." to the C method. =head2 $dur->add_duration( $duration_object ), $dur->subtract_duration( $duration_object ) Adds or subtracts one duration from another. =head2 $dur->add( ... ), $dur->subtract( ... ) Syntactic sugar for addition and subtraction. The parameters given to these methods are used to create a new object, which is then passed to C or C, as appropriate. =head2 $dur->multiply( $number ) Multiplies each unit in the by the specified number. =head2 DateTime::Duration->compare( $duration1, $duration2, $base_datetime ) This is a class method that can be used to compare or sort durations. Comparison is done by adding each duration to the specified C object and comparing the resulting datetimes. This is necessary because without a base, many durations are not comparable. For example, 1 month may or may not be longer than 29 days, depending on what datetime it is added to. If no base datetime is given, then the result of C<< DateTime->now >> is used instead. Using this default will give non-repeatable results if used to compare two duration objects containing different units. It will also give non-repeatable results if the durations contain multiple types of units, such as months and days. However, if you know that both objects only consist of one type of unit (months I days I hours, etc.), and each duration contains the same type of unit, then the results of the comparison will be repeatable. =head2 $dur->delta_months(), $dur->delta_days(), $dur->delta_minutes(), $dur->delta_seconds(), $dur->delta_nanoseconds() These methods provide the information C needs for doing date math. The numbers returned may be positive or negative. This is mostly useful for doing date math in L. =head2 $dur->deltas() Returns a hash with the keys "months", "days", "minutes", "seconds", and "nanoseconds", containing all the delta information for the object. This is mostly useful for doing date math in L. =head2 $dur->years(), $dur->months(), $dur->weeks(), $dur->days(), $dur->hours(), $dur->minutes(), $dur->seconds(), $dur->nanoseconds() These methods return numbers indicating how many of the given unit the object represents, after having done a conversion to any larger units. For example, days are first converted to weeks, and then the remainder is returned. These numbers are always positive. Here's what each method returns: $dur->years() == abs( $dur->in_units('years') ) $dur->months() == abs( ( $dur->in_units( 'months', 'years' ) )[0] ) $dur->weeks() == abs( $dur->in_units( 'weeks' ) ) $dur->days() == abs( ( $dur->in_units( 'days', 'weeks' ) )[0] ) $dur->hours() == abs( $dur->in_units( 'hours' ) ) $dur->minutes == abs( ( $dur->in_units( 'minutes', 'hours' ) )[0] ) $dur->seconds == abs( $dur->in_units( 'seconds' ) ) $dur->nanoseconds() == abs( ( $dur->in_units( 'nanoseconds', 'seconds' ) )[0] ) If this seems confusing, remember that you can always use the C method to specify exactly what you want. Better yet, if you are trying to generate output suitable for humans, use the C module. =head2 Overloading This class overloads addition, subtraction, and mutiplication. Comparison is B overloaded. If you attempt to compare durations using C<< <=> >> or C, then an exception will be thrown! Use the C class method instead. =head1 SUPPORT Support for this module is provided via the datetime@perl.org email list. See http://lists.perl.org/ for more details. =head1 SEE ALSO datetime@perl.org mailing list http://datetime.perl.org/ =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2015 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut DateTime-1.21/lib/DateTime/Infinite.pm0000644000175000017500000001107712603036061017341 0ustar autarchautarchpackage DateTime::Infinite; use strict; use warnings; our $VERSION = '1.21'; use DateTime; use DateTime::TimeZone; use base qw(DateTime); foreach my $m (qw( set set_time_zone truncate )) { no strict 'refs'; *{"DateTime::Infinite::$m"} = sub { return $_[0] }; } sub is_finite {0} sub is_infinite {1} sub _rd2ymd { return $_[2] ? ( $_[1] ) x 7 : ( $_[1] ) x 3; } sub _seconds_as_components { return ( $_[1] ) x 3; } sub _stringify { $_[0]->{utc_rd_days} == DateTime::INFINITY ? DateTime::INFINITY . '' : DateTime::NEG_INFINITY . ''; } sub STORABLE_freeze {return} sub STORABLE_thaw {return} package DateTime::Infinite::Future; use strict; use warnings; use base qw(DateTime::Infinite); { my $Pos = bless { utc_rd_days => DateTime::INFINITY, utc_rd_secs => DateTime::INFINITY, local_rd_days => DateTime::INFINITY, local_rd_secs => DateTime::INFINITY, rd_nanosecs => DateTime::INFINITY, tz => DateTime::TimeZone->new( name => 'floating' ), locale => FakeLocale->instance(), }, __PACKAGE__; $Pos->_calc_utc_rd; $Pos->_calc_local_rd; sub new {$Pos} } package DateTime::Infinite::Past; use strict; use warnings; use base qw(DateTime::Infinite); { my $Neg = bless { utc_rd_days => DateTime::NEG_INFINITY, utc_rd_secs => DateTime::NEG_INFINITY, local_rd_days => DateTime::NEG_INFINITY, local_rd_secs => DateTime::NEG_INFINITY, rd_nanosecs => DateTime::NEG_INFINITY, tz => DateTime::TimeZone->new( name => 'floating' ), locale => FakeLocale->instance(), }, __PACKAGE__; $Neg->_calc_utc_rd; $Neg->_calc_local_rd; sub new {$Neg} } package # hide from PAUSE FakeLocale; use strict; use warnings; use DateTime::Locale; my $Instance; sub instance { return $Instance ||= bless { locale => DateTime::Locale->load('en_US') }, __PACKAGE__; } sub id { return 'infinite'; } sub language_id { return 'infinite'; } sub name { 'Fake locale for Infinite DateTime objects'; } sub language { 'Fake locale for Infinite DateTime objects'; } my @methods = qw( script_id territory_id variant_id script territory variant native_name native_language native_script native_territory native_variant ); for my $meth (@methods) { no strict 'refs'; *{$meth} = sub {undef}; } # Totally arbitrary sub first_day_of_week { return 1; } sub prefers_24_hour_time { return 0; } our $AUTOLOAD; sub AUTOLOAD { my $self = shift; my ($meth) = $AUTOLOAD =~ /::(\w+)$/; if ( $meth =~ /format/ && $meth !~ /^(?:day|month|quarter)/ ) { return $self->{locale}->$meth(@_); } return []; } 1; # ABSTRACT: Infinite past and future DateTime objects __END__ =pod =head1 NAME DateTime::Infinite - Infinite past and future DateTime objects =head1 VERSION version 1.21 =head1 SYNOPSIS my $future = DateTime::Infinite::Future->new(); my $past = DateTime::Infinite::Past->new(); =head1 DESCRIPTION This module provides two L subclasses, C and C. The objects are in the "floating" timezone, and this cannot be changed. =head1 BUGS There seem to be lots of problems when dealing with infinite numbers on Win32. This may be a problem with this code, Perl, or Win32's IEEE math implementation. Either way, the module may not be well-behaved on Win32 operating systems. =head1 METHODS The only constructor for these two classes is the C method, as shown in the L. This method takes no parameters. All "get" methods in this module simply return infinity, positive or negative. If the method is expected to return a string, it return the string representation of positive or negative infinity used by your system. For example, on my system calling C returns a number which when printed appears either "inf" or "-inf". The object is not mutable, so the C, C, and C methods are all do-nothing methods that simply return the object they are called with. Obviously, the C method returns false and the C method returns true. =head1 SEE ALSO datetime@perl.org mailing list http://datetime.perl.org/ =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2015 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut DateTime-1.21/lib/DateTime/LeapSecond.pm0000644000175000017500000001012312603036061017600 0ustar autarchautarchpackage DateTime::LeapSecond; use strict; use warnings; our $VERSION = '1.21'; use vars qw( @RD @LEAP_SECONDS %RD_LENGTH ); use DateTime; # Generates a Perl binary decision tree sub _make_utx { my ( $beg, $end, $tab, $op ) = @_; my $step = int( ( $end - $beg ) / 2 ); my $tmp; if ( $step <= 0 ) { $tmp = "${tab}return $LEAP_SECONDS[$beg + 1];\n"; return $tmp; } $tmp = "${tab}if (\$val < " . $RD[ $beg + $step ] . ") {\n"; $tmp .= _make_utx( $beg, $beg + $step, $tab . " ", $op ); $tmp .= "${tab}}\n"; $tmp .= "${tab}else {\n"; $tmp .= _make_utx( $beg + $step, $end, $tab . " ", $op ); $tmp .= "${tab}}\n"; return $tmp; } # Process BEGIN data and write binary tree decision table sub _init { my $value = -1; while (@_) { my ( $year, $mon, $mday, $leap_seconds ) = ( shift, shift, shift, shift ); # print "$year,$mon,$mday\n"; my $utc_epoch = DateTime->_ymd2rd( $year, ( $mon =~ /Jan/i ? 1 : 7 ), $mday ); $value++; push @LEAP_SECONDS, $value; push @RD, $utc_epoch; $RD_LENGTH{ $utc_epoch - 1 } = $leap_seconds; # warn "$year,$mon,$mday = $utc_epoch +$value"; } push @LEAP_SECONDS, ++$value; my $tmp; # write binary tree decision table $tmp = "sub leap_seconds {\n"; $tmp .= " my \$val = shift;\n"; $tmp .= _make_utx( -1, 1 + $#RD, " ", "+" ); $tmp .= "}\n"; # NOTE: uncomment the line below to see the code: #warn $tmp; eval $tmp; } sub extra_seconds { exists $RD_LENGTH{ $_[0] } ? $RD_LENGTH{ $_[0] } : 0; } sub day_length { exists $RD_LENGTH{ $_[0] } ? 86400 + $RD_LENGTH{ $_[0] } : 86400; } sub _initialize { # There are no leap seconds before 1972, because that's the # year this system was implemented. # # year month day number-of-leapseconds # _init( qw( 1972 Jul. 1 +1 1973 Jan. 1 +1 1974 Jan. 1 +1 1975 Jan. 1 +1 1976 Jan. 1 +1 1977 Jan. 1 +1 1978 Jan. 1 +1 1979 Jan. 1 +1 1980 Jan. 1 +1 1981 Jul. 1 +1 1982 Jul. 1 +1 1983 Jul. 1 +1 1985 Jul. 1 +1 1988 Jan. 1 +1 1990 Jan. 1 +1 1991 Jan. 1 +1 1992 Jul. 1 +1 1993 Jul. 1 +1 1994 Jul. 1 +1 1996 Jan. 1 +1 1997 Jul. 1 +1 1999 Jan. 1 +1 2006 Jan. 1 +1 2009 Jan. 1 +1 2012 Jun. 1 +1 2015 Jul. 1 +1 ) ); } __PACKAGE__->_initialize(); 1; # ABSTRACT: leap seconds table and utilities __END__ =pod =head1 NAME DateTime::LeapSecond - leap seconds table and utilities =head1 VERSION version 1.21 =head1 SYNOPSIS use DateTime; use DateTime::LeapSecond; print "Leap seconds between years 1990 and 2000 are "; print DateTime::Leapsecond::leap_seconds( $utc_rd_2000 ) - DateTime::Leapsecond::leap_seconds( $utc_rd_1990 ); =head1 DESCRIPTION This module is used to calculate leap seconds for a given Rata Die day. It is used when DateTime.pm cannot compile the XS version of this code. This library is known to be accurate for dates until December 2009. There are no leap seconds before 1972, because that's the year this system was implemented. =over 4 =item * leap_seconds( $rd ) Returns the number of accumulated leap seconds for a given day, in the range 0 .. 22. =item * extra_seconds( $rd ) Returns the number of leap seconds for a given day, in the range -2 .. 2. =item * day_length( $rd ) Returns the number of seconds for a given day, in the range 86398 .. 86402. =back =head1 SEE ALSO Ehttp://hpiers.obspm.fr/eop-pc/earthor/utc/leapsecond.htmlE http://datetime.perl.org =head1 AUTHOR Dave Rolsky =head1 COPYRIGHT AND LICENSE This software is Copyright (c) 2015 by Dave Rolsky. This is free software, licensed under: The Artistic License 2.0 (GPL Compatible) =cut DateTime-1.21/lib/DateTime/PPExtra.pm0000644000175000017500000000311612603036061017112 0ustar autarchautarchpackage DateTime::PPExtra; use strict; use warnings; our $VERSION = '1.21'; use DateTime::LeapSecond; sub _normalize_tai_seconds { return if grep { $_ == DateTime::INFINITY() || $_ == DateTime::NEG_INFINITY() } @_[ 1, 2 ]; # This must be after checking for infinity, because it breaks in # presence of use integer ! use integer; my $adj; if ( $_[2] < 0 ) { $adj = ( $_[2] - 86399 ) / 86400; } else { $adj = $_[2] / 86400; } $_[1] += $adj; $_[2] -= $adj * 86400; } sub _normalize_leap_seconds { # args: 0 => days, 1 => seconds my $delta_days; use integer; # rough adjust - can adjust many days if ( $_[2] < 0 ) { $delta_days = ( $_[2] - 86399 ) / 86400; } else { $delta_days = $_[2] / 86400; } my $new_day = $_[1] + $delta_days; my $delta_seconds = ( 86400 * $delta_days ) + DateTime::LeapSecond::leap_seconds($new_day) - DateTime::LeapSecond::leap_seconds( $_[1] ); $_[2] -= $delta_seconds; $_[1] = $new_day; # fine adjust - up to 1 day my $day_length = DateTime::LeapSecond::day_length($new_day); if ( $_[2] >= $day_length ) { $_[2] -= $day_length; $_[1]++; } elsif ( $_[2] < 0 ) { $day_length = DateTime::LeapSecond::day_length( $new_day - 1 ); $_[2] += $day_length; $_[1]--; } } my @subs = qw( _normalize_tai_seconds _normalize_leap_seconds ); for my $sub (@subs) { no strict 'refs'; *{ 'DateTime::' . $sub } = __PACKAGE__->can($sub); } 1; DateTime-1.21/lib/DateTime.pm0000644000175000017500000036130212603036061015573 0ustar autarchautarchpackage DateTime; use 5.008001; use strict; use warnings; use warnings::register; our $VERSION = '1.21'; use Carp; use DateTime::Duration; use DateTime::Helpers; use DateTime::Locale 0.41; use DateTime::TimeZone 1.74; use Params::Validate 1.03 qw( validate validate_pos UNDEF SCALAR BOOLEAN HASHREF OBJECT ); use POSIX qw(floor); use Try::Tiny; { my $loaded = 0; unless ( $ENV{PERL_DATETIME_PP} ) { try { require XSLoader; XSLoader::load( __PACKAGE__, exists $DateTime::{VERSION} && ${ $DateTime::{VERSION} } ? ${ $DateTime::{VERSION} } : 42 ); $loaded = 1; $DateTime::IsPurePerl = 0; } catch { die $_ if $_ && $_ !~ /object version|loadable object/; }; } if ($loaded) { require DateTime::PPExtra unless defined &DateTime::_normalize_tai_seconds; } else { require DateTime::PP; } } # 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' => '_string_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 => ( 100**100**100**100 ); use constant NEG_INFINITY => -1 * ( 100**100**100**100 ); use constant NAN => INFINITY - INFINITY; use constant SECONDS_PER_DAY => 86400; use constant duration_class => 'DateTime::Duration'; 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; $DefaultLocale = DateTime::Locale->load($lang); } return $DefaultLocale; } # backwards compat *DefaultLanguage = \&DefaultLocale; } __PACKAGE__->DefaultLocale('en_US'); my $BasicValidate = { year => { type => SCALAR, callbacks => { 'is an integer' => sub { $_[0] =~ /^-?\d+$/ } }, }, month => { type => SCALAR, default => 1, callbacks => { 'an integer between 1 and 12' => sub { $_[0] =~ /^\d+$/ && $_[0] >= 1 && $_[0] <= 12 } }, }, day => { type => SCALAR, default => 1, callbacks => { 'an integer which is a possible valid day of month' => sub { $_[0] =~ /^\d+$/ && $_[0] >= 1 && $_[0] <= 31 } }, }, hour => { type => SCALAR, default => 0, callbacks => { 'an integer between 0 and 23' => sub { $_[0] =~ /^\d+$/ && $_[0] >= 0 && $_[0] <= 23 }, }, }, minute => { type => SCALAR, default => 0, callbacks => { 'an integer between 0 and 59' => sub { $_[0] =~ /^\d+$/ && $_[0] >= 0 && $_[0] <= 59 }, }, }, second => { type => SCALAR, default => 0, callbacks => { 'an integer between 0 and 61' => sub { $_[0] =~ /^\d+$/ && $_[0] >= 0 && $_[0] <= 61 }, }, }, nanosecond => { type => SCALAR, default => 0, callbacks => { 'a positive integer' => sub { $_[0] =~ /^\d+$/ && $_[0] >= 0 }, } }, locale => { type => SCALAR | OBJECT, default => undef }, language => { type => SCALAR | OBJECT, optional => 1 }, formatter => { type => UNDEF | SCALAR | OBJECT, optional => 1, callbacks => { 'can format_datetime' => sub { defined $_[0] ? $_[0]->can('format_datetime') : 1 }, }, }, }; my $NewValidate = { %$BasicValidate, time_zone => { type => SCALAR | OBJECT, default => 'floating' }, }; sub new { my $class = shift; my %p = validate( @_, $NewValidate ); Carp::croak( "Invalid day of month (day = $p{day} - month = $p{month} - year = $p{year})\n" ) if $p{day} > 28 && $p{day} > $class->_month_length( $p{year}, $p{month} ); return $class->_new(%p); } sub _new { my $class = shift; my %p = @_; Carp::croak('Constructor called with reference, we expected a package') if ref $class; # If this method is called from somewhere other than new(), then some of # these default may not get applied. $p{month} = 1 unless exists $p{month}; $p{day} = 1 unless exists $p{day}; $p{hour} = 0 unless exists $p{hour}; $p{minute} = 0 unless exists $p{minute}; $p{second} = 0 unless exists $p{second}; $p{nanosecond} = 0 unless exists $p{nanosecond}; $p{time_zone} = 'floating' unless exists $p{time_zone}; my $self = bless {}, $class; $p{locale} = delete $p{language} if exists $p{language}; $self->_set_locale( $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->_maybe_future_dst_warning( $p{year}, $p{time_zone} ); $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 _set_locale { my $self = shift; my $locale = shift; if ( defined $locale && ref $locale ) { $self->{locale} = $locale; } else { $self->{locale} = $locale ? DateTime::Locale->load($locale) : $self->DefaultLocale(); } return; } # This method exists for the benefit of internal methods which create # a new object based on the current object, like set() and truncate(). sub _new_from_self { my $self = shift; my %p = @_; my %old = map { $_ => $self->$_() } qw( year month day hour minute second nanosecond locale time_zone ); $old{formatter} = $self->formatter() if defined $self->formatter(); my $method = delete $p{_skip_validation} ? '_new' : 'new'; return ( ref $self )->$method( %old, %p ); } 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} ); } { my $spec = { epoch => { regex => qr/^-?(?:\d+(?:\.\d*)?|\.\d+)$/ }, 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 }, }; sub from_epoch { my $class = shift; my %p = validate( @_, $spec ); my %args; # Epoch may come from Time::HiRes, so it may not be an integer. my ( $int, $dec ) = $p{epoch} =~ /^(-?\d+)?(\.\d+)?/; $int ||= 0; $args{nanosecond} = int( $dec * MAX_NANOSECONDS ) if $dec; # Note, for very large negative values this may give a # blatantly wrong answer. @args{qw( second minute hour day month year )} = ( gmtime($int) )[ 0 .. 5 ]; $args{year} += 1900; $args{month}++; my $self = $class->_new( %p, %args, time_zone => 'UTC' ); my $tz = $p{time_zone}; $self->_maybe_future_dst_warning( $self->year(), $p{time_zone} ); $self->set_time_zone( $p{time_zone} ) if exists $p{time_zone}; return $self; } } sub now { my $class = shift; return $class->from_epoch( epoch => $class->_core_time(), @_ ); } sub _maybe_future_dst_warning { shift; my $year = shift; my $tz = shift; return unless $year >= 5000 && $tz; my $tz_name = ref $tz ? $tz->name() : $tz; return if $tz_name eq 'floating' || $tz_name eq 'UTC'; warnings::warnif( "You are creating a DateTime object with a far future year ($year) and a time zone ($tz_name)." . ' If the time zone you specified has future DST changes this will be very slow.' ); } # use scalar time in case someone's loaded Time::Piece sub _core_time { return scalar time; } sub today { shift->now(@_)->truncate( to => 'day' ) } { my $spec = { 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 }, }; sub from_object { my $class = shift; my %p = validate( @_, $spec ); 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 ); Carp::croak("$p{year} is not a leap year.\n") if $p{day_of_year} == 366 && !$class->_is_leap_year( $p{year} ); my $month = 1; my $day = delete $p{day_of_year}; if ( $day > 31 ) { my $length = $class->_month_length( $p{year}, $month ); while ( $day > $length ) { $day -= $length; $month++; $length = $class->_month_length( $p{year}, $month ); } } return $class->_new( %p, month => $month, day => $day, ); } sub formatter { $_[0]->{formatter} } sub clone { bless { %{ $_[0] } }, ref $_[0] } sub year { Carp::carp('year() is a read-only accessor') if @_ > 1; return $_[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_wide->[ $_[0]->_era_index() ] } sub era_abbr { $_[0]->{locale}->era_abbreviated->[ $_[0]->_era_index() ] } # deprecated *era = \&era_abbr; sub _era_index { $_[0]->{local_c}{year} <= 0 ? 0 : 1 } 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 { Carp::carp('month() is a read-only accessor') if @_ > 1; return $_[0]->{local_c}{month}; } *mon = \&month; sub month_0 { $_[0]->{local_c}{month} - 1 } *mon_0 = \&month_0; sub month_name { $_[0]->{locale}->month_format_wide->[ $_[0]->month_0() ] } sub month_abbr { $_[0]->{locale}->month_format_abbreviated->[ $_[0]->month_0() ]; } sub day_of_month { Carp::carp('day_of_month() is a read-only accessor') if @_ > 1; $_[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_format_wide->[ $_[0]->quarter_0() ]; } sub quarter_abbr { $_[0]->{locale}->quarter_format_abbreviated->[ $_[0]->quarter_0() ]; } sub quarter_0 { $_[0]->{local_c}{quarter} - 1 } 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 local_day_of_week { my $self = shift; return 1 + ( $self->day_of_week - $self->{locale}->first_day_of_week ) % 7; } sub day_name { $_[0]->{locale}->day_format_wide->[ $_[0]->day_of_week_0() ] } sub day_abbr { $_[0]->{locale}->day_format_abbreviated->[ $_[0]->day_of_week_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 am_or_pm { $_[0]->{locale}->am_pm_abbreviated->[ $_[0]->hour() < 12 ? 0 : 1 ]; } 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 { Carp::carp('hour() is a read-only accessor') if @_ > 1; return $_[0]->{local_c}{hour}; } sub hour_1 { $_[0]->{local_c}{hour} == 0 ? 24 : $_[0]->{local_c}{hour} } sub hour_12 { my $h = $_[0]->hour % 12; return $h ? $h : 12 } sub hour_12_0 { $_[0]->hour % 12 } sub minute { Carp::carp('minute() is a read-only accessor') if @_ > 1; return $_[0]->{local_c}{minute}; } *min = \&minute; sub second { Carp::carp('second() is a read-only accessor') if @_ > 1; return $_[0]->{local_c}{second}; } *sec = \&second; sub fractional_second { $_[0]->second + $_[0]->nanosecond / MAX_NANOSECONDS } sub nanosecond { Carp::carp('nanosecond() is a read-only accessor') if @_ > 1; return $_[0]->{rd_nanosecs}; } sub millisecond { floor( $_[0]->{rd_nanosecs} / 1000000 ) } sub microsecond { floor( $_[0]->{rd_nanosecs} / 1000 ) } 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' }; } sub _weeks_in_year { my $self = shift; my $year = shift; my $dow = $self->_ymd2rd( $year, 1, 1 ) % 7; # Years starting with a Thursday and leap years starting with a Wednesday # have 53 weeks. return ( $dow == 4 || ( $dow == 3 && $self->_is_leap_year($year) ) ) ? 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. sub week_of_month { my $self = shift; my $thu = $self->day + 4 - $self->day_of_week; return int( ( $thu + 6 ) / 7 ); } sub time_zone { Carp::carp('time_zone() is a read-only accessor') if @_ > 1; return $_[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 { Carp::carp('locale() is a read-only accessor') if @_ > 1; return $_[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 MJD 678,576 - a simple offset sub mjd { my $self = shift; my $mjd = $self->{utc_rd_days} - 678_576; my $day_length = $self->_day_length( $self->{utc_rd_days} ); return ( $mjd + ( $self->{utc_rd_secs} / $day_length ) + ( $self->{rd_nanosecs} / $day_length / MAX_NANOSECONDS ) ); } sub jd { $_[0]->mjd + 2_400_000.5 } { my %strftime_patterns = ( 'a' => sub { $_[0]->day_abbr }, 'A' => sub { $_[0]->day_name }, 'b' => sub { $_[0]->month_abbr }, 'B' => sub { $_[0]->month_name }, 'c' => sub { $_[0]->format_cldr( $_[0]->{locale}->datetime_format_default() ); }, '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 { sprintf( '%03d', $_[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]->am_or_pm() }, 'P' => sub { lc $_[0]->am_or_pm() }, '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 }, 'U' => sub { my $sun = $_[0]->day_of_year - ( $_[0]->day_of_week + 7 ) % 7; return sprintf( '%02d', int( ( $sun + 6 ) / 7 ) ); }, 'V' => sub { sprintf( '%02d', $_[0]->week_number ) }, 'w' => sub { my $dow = $_[0]->day_of_week; return $dow % 7; }, 'W' => sub { my $mon = $_[0]->day_of_year - ( $_[0]->day_of_week + 6 ) % 7; return sprintf( '%02d', int( ( $mon + 6 ) / 7 ) ); }, 'x' => sub { $_[0]->format_cldr( $_[0]->{locale}->date_format_default() ); }, 'X' => sub { $_[0]->format_cldr( $_[0]->{locale}->time_format_default() ); }, '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 {'%'}, ); $strftime_patterns{h} = $strftime_patterns{b}; sub strftime { my $self = shift; # make a copy or caller's scalars get munged my @patterns = @_; my @r; foreach my $p (@patterns) { $p =~ 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 ? ( $strftime_patterns{$2} ? $strftime_patterns{$2}->($self) : "\%$2" ) : $3 ? $strftime_patterns{N}->($self, $3) : '' # this won't happen ) /sgex; return $p unless wantarray; push @r, $p; } return @r; } } { # It's an array because the order in which the regexes are checked # is important. These patterns are similar to the ones Java uses, # but not quite the same. See # http://www.unicode.org/reports/tr35/tr35-9.html#Date_Format_Patterns. my @patterns = ( qr/GGGGG/ => sub { $_[0]->{locale}->era_narrow->[ $_[0]->_era_index() ] }, qr/GGGG/ => 'era_name', qr/G{1,3}/ => 'era_abbr', qr/(y{3,5})/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->year() ) }, # yy is a weird special case, where it must be exactly 2 digits qr/yy/ => sub { my $year = $_[0]->year(); my $y2 = substr( $year, -2, 2 ) if length $year > 2; $y2 *= -1 if $year < 0; $_[0]->_zero_padded_number( 'yy', $y2 ); }, qr/y/ => sub { $_[0]->year() }, qr/(u+)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->year() ) }, qr/(Y+)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->week_year() ) }, qr/QQQQ/ => 'quarter_name', qr/QQQ/ => 'quarter_abbr', qr/(QQ?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->quarter() ) }, qr/qqqq/ => sub { $_[0]->{locale}->quarter_stand_alone_wide() ->[ $_[0]->quarter_0() ]; }, qr/qqq/ => sub { $_[0]->{locale}->quarter_stand_alone_abbreviated() ->[ $_[0]->quarter_0() ]; }, qr/(qq?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->quarter() ) }, qr/MMMMM/ => sub { $_[0]->{locale}->month_format_narrow->[ $_[0]->month_0() ] } , qr/MMMM/ => 'month_name', qr/MMM/ => 'month_abbr', qr/(MM?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->month() ) }, qr/LLLLL/ => sub { $_[0]->{locale}->month_stand_alone_narrow->[ $_[0]->month_0() ]; }, qr/LLLL/ => sub { $_[0]->{locale}->month_stand_alone_wide->[ $_[0]->month_0() ]; }, qr/LLL/ => sub { $_[0]->{locale} ->month_stand_alone_abbreviated->[ $_[0]->month_0() ]; }, qr/(LL?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->month() ) }, qr/(ww?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->week_number() ) }, qr/W/ => 'week_of_month', qr/(dd?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->day_of_month() ) }, qr/(D{1,3})/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->day_of_year() ) }, qr/F/ => 'weekday_of_month', qr/(g+)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->mjd() ) }, qr/EEEEE/ => sub { $_[0]->{locale}->day_format_narrow->[ $_[0]->day_of_week_0() ]; }, qr/EEEE/ => 'day_name', qr/E{1,3}/ => 'day_abbr', qr/eeeee/ => sub { $_[0]->{locale}->day_format_narrow->[ $_[0]->day_of_week_0() ]; }, qr/eeee/ => 'day_name', qr/eee/ => 'day_abbr', qr/(ee?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->local_day_of_week() ); }, qr/ccccc/ => sub { $_[0]->{locale} ->day_stand_alone_narrow->[ $_[0]->day_of_week_0() ]; }, qr/cccc/ => sub { $_[0]->{locale}->day_stand_alone_wide->[ $_[0]->day_of_week_0() ]; }, qr/ccc/ => sub { $_[0]->{locale} ->day_stand_alone_abbreviated->[ $_[0]->day_of_week_0() ]; }, qr/(cc?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->day_of_week() ) }, qr/a/ => 'am_or_pm', qr/(hh?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->hour_12() ) }, qr/(HH?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->hour() ) }, qr/(KK?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->hour_12_0() ) }, qr/(kk?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->hour_1() ) }, qr/(jj?)/ => sub { my $h = $_[0]->{locale}->prefers_24_hour_time() ? $_[0]->hour() : $_[0]->hour_12(); $_[0]->_zero_padded_number( $1, $h ); }, qr/(mm?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->minute() ) }, qr/(ss?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->second() ) }, # I'm not sure this is what is wanted (notably the trailing # and leading zeros it can produce), but once again the LDML # spec is not all that clear. qr/(S+)/ => sub { my $l = length $1; my $val = sprintf( "%.${l}f", $_[0]->fractional_second() - $_[0]->second() ); $val =~ s/^0\.//; $val || 0; }, qr/A+/ => sub { ( $_[0]->{local_rd_secs} * 1000 ) + $_[0]->millisecond() }, qr/zzzz/ => sub { $_[0]->time_zone_long_name() }, qr/z{1,3}/ => sub { $_[0]->time_zone_short_name() }, qr/ZZZZZ/ => sub { substr( my $z = DateTime::TimeZone->offset_as_string( $_[0]->offset() ), -2, 0, ':' ); $z; }, qr/ZZZZ/ => sub { $_[0]->time_zone_short_name() . DateTime::TimeZone->offset_as_string( $_[0]->offset() ); }, qr/Z{1,3}/ => sub { DateTime::TimeZone->offset_as_string( $_[0]->offset() ) }, qr/vvvv/ => sub { $_[0]->time_zone_long_name() }, qr/v{1,3}/ => sub { $_[0]->time_zone_short_name() }, qr/VVVV/ => sub { $_[0]->time_zone_long_name() }, qr/V{1,3}/ => sub { $_[0]->time_zone_short_name() }, ); sub _zero_padded_number { my $self = shift; my $size = length shift; my $val = shift; return sprintf( "%0${size}d", $val ); } sub _space_padded_string { my $self = shift; my $size = length shift; my $val = shift; return sprintf( "% ${size}s", $val ); } sub format_cldr { my $self = shift; # make a copy or caller's scalars get munged my @patterns = @_; my @r; foreach my $p (@patterns) { $p =~ s/\G (?: '((?:[^']|'')*)' # quote escaped bit of text # it needs to end with one # quote not followed by # another | (([a-zA-Z])\3*) # could be a pattern | (.) # anything else ) / defined $1 ? $1 : defined $2 ? $self->_cldr_pattern($2) : defined $4 ? $4 : undef # should never get here /sgex; $p =~ s/\'\'/\'/g; return $p unless wantarray; push @r, $p; } return @r; } sub _cldr_pattern { my $self = shift; my $pattern = shift; for ( my $i = 0; $i < @patterns; $i += 2 ) { if ( $pattern =~ /$patterns[$i]/ ) { my $sub = $patterns[ $i + 1 ]; return $self->$sub(); } } return $pattern; } } sub _format_nanosecs { my $self = shift; my $precision = @_ ? shift : 9; my $divide_by = 10**( 9 - $precision ); return sprintf( '%0' . $precision . 'u', floor( $self->{rd_nanosecs} / $divide_by ) ); } sub epoch { my $self = shift; return $self->{utc_c}{epoch} if exists $self->{utc_c}{epoch}; return $self->{utc_c}{epoch} = ( $self->{utc_rd_days} - 719163 ) * SECONDS_PER_DAY + $self->{utc_rd_secs}; } 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 eq $dt2->time_zone; # 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->is_dst != $smaller->is_dst ) { $bigger_min -= 60 # it's a 23 hour (local) day if ( $bigger->is_dst && do { my $prev_day = try { $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 = try { $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 $dt1->duration_class->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 $self->duration_class->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 $self->duration_class->new( months => $months, days => $days ); } sub delta_days { my $self = shift; my $dt = shift; my $days = abs( ( $self->local_rd_values )[0] - ( $dt->local_rd_values )[0] ); $self->duration_class->new( days => $days ); } 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 $self->duration_class->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 { my $self = shift; return $self->add_duration( $self->duration_class->new(@_) ); } sub subtract { my $self = shift; my %p = @_; my %eom; $eom{end_of_month} = delete $p{end_of_month} if exists $p{end_of_month}; my $dur = $self->duration_class->new(@_)->inverse(%eom); return $self->add_duration($dur); } sub subtract_duration { return $_[0]->add_duration( $_[1]->inverse ) } { my @spec = ( { isa => 'DateTime::Duration' } ); sub add_duration { my $self = shift; my ($dur) = validate_pos( @_, @spec ); # 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 undef unless defined $_[1]; return $_[2] ? -$_[0]->compare( $_[1] ) : $_[0]->compare( $_[1] ); } sub _string_compare_overload { my ( $dt1, $dt2, $flip ) = @_; # One is a DateTime object, one isn't. Just stringify and compare. if ( !DateTime::Helpers::can( $dt2, 'utc_rd_values' ) ) { my $sign = $flip ? -1 : 1; return $sign * ( "$dt1" cmp "$dt2" ); } else { my $meth = $dt1->can('_compare_overload'); goto $meth; } } 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, @_ ) : @_; if ( !DateTime::Helpers::can( $dt2, 'utc_rd_values' ) ) { return "$dt1" eq "$dt2"; } $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 $new_dt = $self->_new_from_self(%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] ) } # These two are special cased because ... if the local time is the hour of a # DST change where the same local time occurs twice then passing it through # _new() can actually change the underlying UTC time, which is bad. sub set_locale { my $self = shift; my ($locale) = validate_pos( @_, $BasicValidate->{locale} ); $self->_set_locale($locale); return $self; } sub set_formatter { my $self = shift; my ($formatter) = validate_pos( @_, $BasicValidate->{formatter} ); $self->{formatter} = $formatter; return $self; } { my %TruncateDefault = ( month => 1, day => 1, hour => 0, minute => 0, second => 0, nanosecond => 0, ); my $re = join '|', 'year', 'week', 'local_week', grep { $_ ne 'nanosecond' } keys %TruncateDefault; my $spec = { to => { regex => qr/^(?:$re)$/ } }; sub truncate { my $self = shift; my %p = validate( @_, $spec ); my %new; if ( $p{to} eq 'week' || $p{to} eq 'local_week' ) { my $first_day_of_week = ( $p{to} eq 'local_week' ) ? $self->{locale}->first_day_of_week : 1; my $day_diff = ( $self->day_of_week - $first_day_of_week ) % 7; if ($day_diff) { $self->add( days => -1 * $day_diff ); } # This can fail if the truncate ends up giving us an invalid local # date time. If that happens we need to reverse the addition we # just did. See https://rt.cpan.org/Ticket/Display.html?id=93347. try { $self->truncate( to => 'day' ); } catch { $self->add( days => $day_diff ); die $_; }; } else { my $truncate; foreach my $f (qw( year month day hour minute second nanosecond )) { $new{$f} = $truncate ? $TruncateDefault{$f} : $self->$f(); $truncate = 1 if $p{to} eq $f; } } my $new_dt = $self->_new_from_self( %new, _skip_validation => 1 ); %$self = %$new_dt; return $self; } } sub set_time_zone { my ( $self, $tz ) = @_; if ( ref $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; } else { return $self if $self->{tz}->name() eq $tz; } my $was_floating = $self->{tz}->is_floating; my $old_tz = $self->{tz}; $self->{tz} = ref $tz ? $tz : DateTime::TimeZone->new( name => $tz ); $self->_handle_offset_modifier( $self->second, 1 ); my $e; try { # 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; } } catch { $e = $_; }; # If we can't recalc the RD values then we shouldn't keep the new TZ. RT # #83940 if ($e) { $self->{tz} = $old_tz; die $e; } 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:' . ( $DateTime::VERSION || 'git' ); # 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 # hide from PAUSE DateTime::_Thawed; sub utc_rd_values { @{ $_[0]->{utc_vals} } } sub time_zone { $_[0]->{tz} } 1; # ABSTRACT: A date and time object for Perl __END__ =pod =head1 NAME DateTime - A date and time object for Perl =head1 VERSION version 1.21 =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 $day = $dt->day; # 1-31 $dow = $dt->day_of_week; # 1-7 (Monday is 1) $hour = $dt->hour; # 0-23 $minute = $dt->minute; # 0-59 $second = $dt->second; # 0-61 (leap seconds!) $doy = $dt->day_of_year; # 1-366 (leap years) $doq = $dt->day_of_quarter; # 1.. $qtr = $dt->quarter; # 1-4 # all of the start-at-1 methods above have corresponding 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 $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 $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, ... # May not work for all possible datetime, see the docs on this # method for more details. $epoch_time = $dt->epoch; $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. The DateTime site has a FAQ which may help answer many "how do I do X?" questions. The FAQ is at L. 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 module. =encoding UTF-8 =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 and C methods. The C method still treats Monday as the first day of the week. All I