← Index
NYTProf Performance Profile   « line view »
For /usr/local/libexec/sympa/task_manager-debug.pl
  Run on Tue Jun 1 22:32:51 2021
Reported on Tue Jun 1 22:35:04 2021

Filename/usr/local/lib/perl5/site_perl/mach/5.32/DateTime.pm
StatementsExecuted 0 statements in 0s
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
0000s0sDateTime::::BEGIN@13 DateTime::BEGIN@13
0000s0sDateTime::::BEGIN@14 DateTime::BEGIN@14
0000s0sDateTime::::BEGIN@15 DateTime::BEGIN@15
0000s0sDateTime::::BEGIN@16 DateTime::BEGIN@16
0000s0sDateTime::::BEGIN@17 DateTime::BEGIN@17
0000s0sDateTime::::BEGIN@18 DateTime::BEGIN@18
0000s0sDateTime::::BEGIN@19 DateTime::BEGIN@19
0000s0sDateTime::::BEGIN@20 DateTime::BEGIN@20
0000s0sDateTime::::BEGIN@2030 DateTime::BEGIN@2030
0000s0sDateTime::::BEGIN@21 DateTime::BEGIN@21
0000s0sDateTime::::BEGIN@22 DateTime::BEGIN@22
0000s0sDateTime::::BEGIN@4 DateTime::BEGIN@4
0000s0sDateTime::::BEGIN@6 DateTime::BEGIN@6
0000s0sDateTime::::BEGIN@64 DateTime::BEGIN@64
0000s0sDateTime::::BEGIN@7 DateTime::BEGIN@7
0000s0sDateTime::::BEGIN@8 DateTime::BEGIN@8
0000s0sDateTime::::BEGIN@803 DateTime::BEGIN@803
0000s0sDateTime::::BEGIN@9 DateTime::BEGIN@9
0000s0sDateTime::::BEGIN@96 DateTime::BEGIN@96
0000s0sDateTime::::CORE:qr DateTime::CORE:qr (opcode)
0000s0sDateTime::::CORE:regcomp DateTime::CORE:regcomp (opcode)
0000s0sDateTime::::DefaultLocale DateTime::DefaultLocale
0000s0sDateTime::::STORABLE_freeze DateTime::STORABLE_freeze
0000s0sDateTime::::STORABLE_thaw DateTime::STORABLE_thaw
0000s0sDateTime::_Thawed::::time_zoneDateTime::_Thawed::time_zone
0000s0sDateTime::_Thawed::::utc_rd_valuesDateTime::_Thawed::utc_rd_values
0000s0sDateTime::::__ANON__ DateTime::__ANON__ (xsub)
0000s0sDateTime::::__ANON__[:1118] DateTime::__ANON__[:1118]
0000s0sDateTime::::__ANON__[:1119] DateTime::__ANON__[:1119]
0000s0sDateTime::::__ANON__[:1120] DateTime::__ANON__[:1120]
0000s0sDateTime::::__ANON__[:1121] DateTime::__ANON__[:1121]
0000s0sDateTime::::__ANON__[:1124] DateTime::__ANON__[:1124]
0000s0sDateTime::::__ANON__[:1125] DateTime::__ANON__[:1125]
0000s0sDateTime::::__ANON__[:1126] DateTime::__ANON__[:1126]
0000s0sDateTime::::__ANON__[:1127] DateTime::__ANON__[:1127]
0000s0sDateTime::::__ANON__[:1128] DateTime::__ANON__[:1128]
0000s0sDateTime::::__ANON__[:1129] DateTime::__ANON__[:1129]
0000s0sDateTime::::__ANON__[:1130] DateTime::__ANON__[:1130]
0000s0sDateTime::::__ANON__[:1131] DateTime::__ANON__[:1131]
0000s0sDateTime::::__ANON__[:1132] DateTime::__ANON__[:1132]
0000s0sDateTime::::__ANON__[:1133] DateTime::__ANON__[:1133]
0000s0sDateTime::::__ANON__[:1134] DateTime::__ANON__[:1134]
0000s0sDateTime::::__ANON__[:1135] DateTime::__ANON__[:1135]
0000s0sDateTime::::__ANON__[:1136] DateTime::__ANON__[:1136]
0000s0sDateTime::::__ANON__[:1137] DateTime::__ANON__[:1137]
0000s0sDateTime::::__ANON__[:1138] DateTime::__ANON__[:1138]
0000s0sDateTime::::__ANON__[:1139] DateTime::__ANON__[:1139]
0000s0sDateTime::::__ANON__[:1141] DateTime::__ANON__[:1141]
0000s0sDateTime::::__ANON__[:1142] DateTime::__ANON__[:1142]
0000s0sDateTime::::__ANON__[:1143] DateTime::__ANON__[:1143]
0000s0sDateTime::::__ANON__[:1144] DateTime::__ANON__[:1144]
0000s0sDateTime::::__ANON__[:1145] DateTime::__ANON__[:1145]
0000s0sDateTime::::__ANON__[:1146] DateTime::__ANON__[:1146]
0000s0sDateTime::::__ANON__[:1147] DateTime::__ANON__[:1147]
0000s0sDateTime::::__ANON__[:1148] DateTime::__ANON__[:1148]
0000s0sDateTime::::__ANON__[:1149] DateTime::__ANON__[:1149]
0000s0sDateTime::::__ANON__[:1153] DateTime::__ANON__[:1153]
0000s0sDateTime::::__ANON__[:1154] DateTime::__ANON__[:1154]
0000s0sDateTime::::__ANON__[:1158] DateTime::__ANON__[:1158]
0000s0sDateTime::::__ANON__[:1162] DateTime::__ANON__[:1162]
0000s0sDateTime::::__ANON__[:1165] DateTime::__ANON__[:1165]
0000s0sDateTime::::__ANON__[:1168] DateTime::__ANON__[:1168]
0000s0sDateTime::::__ANON__[:1169] DateTime::__ANON__[:1169]
0000s0sDateTime::::__ANON__[:1170] DateTime::__ANON__[:1170]
0000s0sDateTime::::__ANON__[:1171] DateTime::__ANON__[:1171]
0000s0sDateTime::::__ANON__[:1172] DateTime::__ANON__[:1172]
0000s0sDateTime::::__ANON__[:1173] DateTime::__ANON__[:1173]
0000s0sDateTime::::__ANON__[:1222] DateTime::__ANON__[:1222]
0000s0sDateTime::::__ANON__[:1226] DateTime::__ANON__[:1226]
0000s0sDateTime::::__ANON__[:1234] DateTime::__ANON__[:1234]
0000s0sDateTime::::__ANON__[:1235] DateTime::__ANON__[:1235]
0000s0sDateTime::::__ANON__[:1236] DateTime::__ANON__[:1236]
0000s0sDateTime::::__ANON__[:1238] DateTime::__ANON__[:1238]
0000s0sDateTime::::__ANON__[:1242] DateTime::__ANON__[:1242]
0000s0sDateTime::::__ANON__[:1246] DateTime::__ANON__[:1246]
0000s0sDateTime::::__ANON__[:1250] DateTime::__ANON__[:1250]
0000s0sDateTime::::__ANON__[:1251] DateTime::__ANON__[:1251]
0000s0sDateTime::::__ANON__[:1254] DateTime::__ANON__[:1254]
0000s0sDateTime::::__ANON__[:1257] DateTime::__ANON__[:1257]
0000s0sDateTime::::__ANON__[:1261] DateTime::__ANON__[:1261]
0000s0sDateTime::::__ANON__[:1264] DateTime::__ANON__[:1264]
0000s0sDateTime::::__ANON__[:1268] DateTime::__ANON__[:1268]
0000s0sDateTime::::__ANON__[:1269] DateTime::__ANON__[:1269]
0000s0sDateTime::::__ANON__[:1272] DateTime::__ANON__[:1272]
0000s0sDateTime::::__ANON__[:1276] DateTime::__ANON__[:1276]
0000s0sDateTime::::__ANON__[:1278] DateTime::__ANON__[:1278]
0000s0sDateTime::::__ANON__[:1281] DateTime::__ANON__[:1281]
0000s0sDateTime::::__ANON__[:1285] DateTime::__ANON__[:1285]
0000s0sDateTime::::__ANON__[:1291] DateTime::__ANON__[:1291]
0000s0sDateTime::::__ANON__[:1296] DateTime::__ANON__[:1296]
0000s0sDateTime::::__ANON__[:1300] DateTime::__ANON__[:1300]
0000s0sDateTime::::__ANON__[:1303] DateTime::__ANON__[:1303]
0000s0sDateTime::::__ANON__[:1307] DateTime::__ANON__[:1307]
0000s0sDateTime::::__ANON__[:1309] DateTime::__ANON__[:1309]
0000s0sDateTime::::__ANON__[:1313] DateTime::__ANON__[:1313]
0000s0sDateTime::::__ANON__[:1314] DateTime::__ANON__[:1314]
0000s0sDateTime::::__ANON__[:1316] DateTime::__ANON__[:1316]
0000s0sDateTime::::__ANON__[:1317] DateTime::__ANON__[:1317]
0000s0sDateTime::::__ANON__[:1324] DateTime::__ANON__[:1324]
0000s0sDateTime::::__ANON__[:1326] DateTime::__ANON__[:1326]
0000s0sDateTime::::__ANON__[:1328] DateTime::__ANON__[:1328]
0000s0sDateTime::::__ANON__[:1332] DateTime::__ANON__[:1332]
0000s0sDateTime::::__ANON__[:1334] DateTime::__ANON__[:1334]
0000s0sDateTime::::__ANON__[:1336] DateTime::__ANON__[:1336]
0000s0sDateTime::::__ANON__[:1337] DateTime::__ANON__[:1337]
0000s0sDateTime::::__ANON__[:1340] DateTime::__ANON__[:1340]
0000s0sDateTime::::__ANON__[:1344] DateTime::__ANON__[:1344]
0000s0sDateTime::::__ANON__[:1346] DateTime::__ANON__[:1346]
0000s0sDateTime::::__ANON__[:1347] DateTime::__ANON__[:1347]
0000s0sDateTime::::__ANON__[:1348] DateTime::__ANON__[:1348]
0000s0sDateTime::::__ANON__[:1349] DateTime::__ANON__[:1349]
0000s0sDateTime::::__ANON__[:1350] DateTime::__ANON__[:1350]
0000s0sDateTime::::__ANON__[:1523] DateTime::__ANON__[:1523]
0000s0sDateTime::::__ANON__[:1534] DateTime::__ANON__[:1534]
0000s0sDateTime::::__ANON__[:1830] DateTime::__ANON__[:1830]
0000s0sDateTime::::__ANON__[:1834] DateTime::__ANON__[:1834]
0000s0sDateTime::::__ANON__[:2198] DateTime::__ANON__[:2198]
0000s0sDateTime::::__ANON__[:2202] DateTime::__ANON__[:2202]
0000s0sDateTime::::__ANON__[:2263] DateTime::__ANON__[:2263]
0000s0sDateTime::::__ANON__[:2266] DateTime::__ANON__[:2266]
0000s0sDateTime::::__ANON__[:42] DateTime::__ANON__[:42]
0000s0sDateTime::::__ANON__[:45] DateTime::__ANON__[:45]
0000s0sDateTime::::__ANON__[:69] DateTime::__ANON__[:69]
0000s0sDateTime::::__ANON__[:868] DateTime::__ANON__[:868]
0000s0sDateTime::::__ANON__[:954] DateTime::__ANON__[:954]
0000s0sDateTime::::_add_duration DateTime::_add_duration
0000s0sDateTime::::_add_overload DateTime::_add_overload
0000s0sDateTime::::_adjust_for_positive_difference DateTime::_adjust_for_positive_difference
0000s0sDateTime::::_calc_local_components DateTime::_calc_local_components
0000s0sDateTime::::_calc_local_rd DateTime::_calc_local_rd
0000s0sDateTime::::_calc_utc_rd DateTime::_calc_utc_rd
0000s0sDateTime::::_cldr_pattern DateTime::_cldr_pattern
0000s0sDateTime::::_compare DateTime::_compare
0000s0sDateTime::::_compare_overload DateTime::_compare_overload
0000s0sDateTime::::_core_time DateTime::_core_time
0000s0sDateTime::::_default_time_zone DateTime::_default_time_zone
0000s0sDateTime::::_duration_object_from_args DateTime::_duration_object_from_args
0000s0sDateTime::::_era_index DateTime::_era_index
0000s0sDateTime::::_format_nanosecs DateTime::_format_nanosecs
0000s0sDateTime::::_handle_offset_modifier DateTime::_handle_offset_modifier
0000s0sDateTime::::_maybe_future_dst_warning DateTime::_maybe_future_dst_warning
0000s0sDateTime::::_month_length DateTime::_month_length
0000s0sDateTime::::_new DateTime::_new
0000s0sDateTime::::_new_from_self DateTime::_new_from_self
0000s0sDateTime::::_normalize_nanoseconds DateTime::_normalize_nanoseconds
0000s0sDateTime::::_normalize_seconds DateTime::_normalize_seconds
0000s0sDateTime::::_normalize_tai_seconds DateTime::_normalize_tai_seconds (xsub)
0000s0sDateTime::::_offset_for_local_datetime DateTime::_offset_for_local_datetime
0000s0sDateTime::::_set_locale DateTime::_set_locale
0000s0sDateTime::::_string_compare_overload DateTime::_string_compare_overload
0000s0sDateTime::::_string_equals_overload DateTime::_string_equals_overload
0000s0sDateTime::::_string_not_equals_overload DateTime::_string_not_equals_overload
0000s0sDateTime::::_subtract_overload DateTime::_subtract_overload
0000s0sDateTime::::_week_values DateTime::_week_values
0000s0sDateTime::::_weeks_in_year DateTime::_weeks_in_year
0000s0sDateTime::::_zero_padded_number DateTime::_zero_padded_number
0000s0sDateTime::::add DateTime::add
0000s0sDateTime::::add_duration DateTime::add_duration
0000s0sDateTime::::am_or_pm DateTime::am_or_pm
0000s0sDateTime::::catch {...} DateTime::catch {...}
0000s0sDateTime::::ce_year DateTime::ce_year
0000s0sDateTime::::christian_era DateTime::christian_era
0000s0sDateTime::::clone DateTime::clone
0000s0sDateTime::::compare DateTime::compare
0000s0sDateTime::::compare_ignore_floating DateTime::compare_ignore_floating
0000s0sDateTime::::datetime DateTime::datetime
0000s0sDateTime::::day_abbr DateTime::day_abbr
0000s0sDateTime::::day_name DateTime::day_name
0000s0sDateTime::::day_of_month DateTime::day_of_month
0000s0sDateTime::::day_of_month_0 DateTime::day_of_month_0
0000s0sDateTime::::day_of_quarter DateTime::day_of_quarter
0000s0sDateTime::::day_of_quarter_0 DateTime::day_of_quarter_0
0000s0sDateTime::::day_of_week DateTime::day_of_week
0000s0sDateTime::::day_of_week_0 DateTime::day_of_week_0
0000s0sDateTime::::day_of_year DateTime::day_of_year
0000s0sDateTime::::day_of_year_0 DateTime::day_of_year_0
0000s0sDateTime::::delta_days DateTime::delta_days
0000s0sDateTime::::delta_md DateTime::delta_md
0000s0sDateTime::::delta_ms DateTime::delta_ms
0000s0sDateTime::::dmy DateTime::dmy
0000s0sDateTime::::epoch DateTime::epoch
0000s0sDateTime::::era_abbr DateTime::era_abbr
0000s0sDateTime::::era_name DateTime::era_name
0000s0sDateTime::::format_cldr DateTime::format_cldr
0000s0sDateTime::::formatter DateTime::formatter
0000s0sDateTime::::fractional_second DateTime::fractional_second
0000s0sDateTime::::from_day_of_year DateTime::from_day_of_year
0000s0sDateTime::::from_epoch DateTime::from_epoch
0000s0sDateTime::::from_object DateTime::from_object
0000s0sDateTime::::hires_epoch DateTime::hires_epoch
0000s0sDateTime::::hms DateTime::hms
0000s0sDateTime::::hour DateTime::hour
0000s0sDateTime::::hour_1 DateTime::hour_1
0000s0sDateTime::::hour_12 DateTime::hour_12
0000s0sDateTime::::hour_12_0 DateTime::hour_12_0
0000s0sDateTime::::is_between DateTime::is_between
0000s0sDateTime::::is_dst DateTime::is_dst
0000s0sDateTime::::is_finite DateTime::is_finite
0000s0sDateTime::::is_infinite DateTime::is_infinite
0000s0sDateTime::::is_last_day_of_month DateTime::is_last_day_of_month
0000s0sDateTime::::is_last_day_of_quarter DateTime::is_last_day_of_quarter
0000s0sDateTime::::is_last_day_of_year DateTime::is_last_day_of_year
0000s0sDateTime::::is_leap_year DateTime::is_leap_year
0000s0sDateTime::::iso8601 DateTime::iso8601
0000s0sDateTime::::jd DateTime::jd
0000s0sDateTime::::last_day_of_month DateTime::last_day_of_month
0000s0sDateTime::::leap_seconds DateTime::leap_seconds
0000s0sDateTime::::local_day_of_week DateTime::local_day_of_week
0000s0sDateTime::::local_rd_as_seconds DateTime::local_rd_as_seconds
0000s0sDateTime::::local_rd_values DateTime::local_rd_values
0000s0sDateTime::::locale DateTime::locale
0000s0sDateTime::::mdy DateTime::mdy
0000s0sDateTime::::microsecond DateTime::microsecond
0000s0sDateTime::::millisecond DateTime::millisecond
0000s0sDateTime::::minute DateTime::minute
0000s0sDateTime::::mjd DateTime::mjd
0000s0sDateTime::::month DateTime::month
0000s0sDateTime::::month_0 DateTime::month_0
0000s0sDateTime::::month_abbr DateTime::month_abbr
0000s0sDateTime::::month_length DateTime::month_length
0000s0sDateTime::::month_name DateTime::month_name
0000s0sDateTime::::nanosecond DateTime::nanosecond
0000s0sDateTime::::new DateTime::new
0000s0sDateTime::::now DateTime::now
0000s0sDateTime::::offset DateTime::offset
0000s0sDateTime::::quarter DateTime::quarter
0000s0sDateTime::::quarter_0 DateTime::quarter_0
0000s0sDateTime::::quarter_abbr DateTime::quarter_abbr
0000s0sDateTime::::quarter_length DateTime::quarter_length
0000s0sDateTime::::quarter_name DateTime::quarter_name
0000s0sDateTime::::rfc3339 DateTime::rfc3339
0000s0sDateTime::::second DateTime::second
0000s0sDateTime::::secular_era DateTime::secular_era
0000s0sDateTime::::set DateTime::set
0000s0sDateTime::::set_day DateTime::set_day
0000s0sDateTime::::set_formatter DateTime::set_formatter
0000s0sDateTime::::set_hour DateTime::set_hour
0000s0sDateTime::::set_locale DateTime::set_locale
0000s0sDateTime::::set_minute DateTime::set_minute
0000s0sDateTime::::set_month DateTime::set_month
0000s0sDateTime::::set_nanosecond DateTime::set_nanosecond
0000s0sDateTime::::set_second DateTime::set_second
0000s0sDateTime::::set_time_zone DateTime::set_time_zone
0000s0sDateTime::::set_year DateTime::set_year
0000s0sDateTime::::strftime DateTime::strftime
0000s0sDateTime::::stringify DateTime::stringify
0000s0sDateTime::::subtract DateTime::subtract
0000s0sDateTime::::subtract_datetime DateTime::subtract_datetime
0000s0sDateTime::::subtract_datetime_absolute DateTime::subtract_datetime_absolute
0000s0sDateTime::::subtract_duration DateTime::subtract_duration
0000s0sDateTime::::time_zone DateTime::time_zone
0000s0sDateTime::::time_zone_long_name DateTime::time_zone_long_name
0000s0sDateTime::::time_zone_short_name DateTime::time_zone_short_name
0000s0sDateTime::::today DateTime::today
0000s0sDateTime::::truncate DateTime::truncate
0000s0sDateTime::::try {...} DateTime::try {...}
0000s0sDateTime::::utc_rd_as_seconds DateTime::utc_rd_as_seconds
0000s0sDateTime::::utc_rd_values DateTime::utc_rd_values
0000s0sDateTime::::utc_year DateTime::utc_year
0000s0sDateTime::::week DateTime::week
0000s0sDateTime::::week_number DateTime::week_number
0000s0sDateTime::::week_of_month DateTime::week_of_month
0000s0sDateTime::::week_year DateTime::week_year
0000s0sDateTime::::weekday_of_month DateTime::weekday_of_month
0000s0sDateTime::::year DateTime::year
0000s0sDateTime::::year_length DateTime::year_length
0000s0sDateTime::::year_with_christian_era DateTime::year_with_christian_era
0000s0sDateTime::::year_with_era DateTime::year_with_era
0000s0sDateTime::::year_with_secular_era DateTime::year_with_secular_era
0000s0sDateTime::::ymd DateTime::ymd
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments
Time
on line
Calls Time
in subs
Code
1## no critic (Modules::ProhibitExcessMainComplexity)
2package DateTime;
3
4use 5.008004;
5
6use strict;
7use warnings;
8use warnings::register;
9use namespace::autoclean 0.19;
10
11our $VERSION = '1.54';
12
13use Carp;
14use DateTime::Duration;
15use DateTime::Helpers;
16use DateTime::Locale 1.06;
17use DateTime::TimeZone 2.44;
18use DateTime::Types;
19use POSIX qw( floor fmod );
20use Params::ValidationCompiler 0.26 qw( validation_for );
21use Scalar::Util qw( blessed );
22use Try::Tiny;
23
24## no critic (Variables::ProhibitPackageVars)
25our $IsPurePerl;
26
27{
28 my $loaded = 0;
29
30 unless ( $ENV{PERL_DATETIME_PP} ) {
31 try {
32 require XSLoader;
33 XSLoader::load(
34 __PACKAGE__,
35 exists $DateTime::{VERSION} && ${ $DateTime::{VERSION} }
36 ? ${ $DateTime::{VERSION} }
37 : 42
38 );
39
40 $loaded = 1;
41 $IsPurePerl = 0;
42 }
43 catch {
44 die $_ if $_ && $_ !~ /object version|loadable object/;
45 };
46 }
47
48 if ($loaded) {
49 ## no critic (Variables::ProtectPrivateVars)
50 require DateTime::PPExtra
51 unless defined &DateTime::_normalize_tai_seconds;
52 }
53 else {
54 require DateTime::PP;
55 }
56}
57
58# for some reason, overloading doesn't work unless fallback is listed
59# early.
60#
61# 3rd parameter ( $_[2] ) means the parameters are 'reversed'.
62# see: "Calling conventions for binary operations" in overload docs.
63#
64use overload (
65 fallback => 1,
66 '<=>' => '_compare_overload',
67 'cmp' => '_string_compare_overload',
68 q{""} => 'stringify',
69 bool => sub {1},
70 '-' => '_subtract_overload',
71 '+' => '_add_overload',
72 'eq' => '_string_equals_overload',
73 'ne' => '_string_not_equals_overload',
74);
75
76# Have to load this after overloading is defined, after BEGIN blocks
77# or else weird crashes ensue
78require DateTime::Infinite;
79
80sub MAX_NANOSECONDS () {1_000_000_000} # 1E9 = almost 32 bits
81sub INFINITY () { 100**100**100**100 }
82sub NEG_INFINITY () { -1 * ( 100**100**100**100 ) }
83sub NAN () { INFINITY - INFINITY }
84
85sub SECONDS_PER_DAY () {86400}
86
87sub duration_class () {'DateTime::Duration'}
88
89my (
90 @MonthLengths,
91 @LeapYearMonthLengths,
92 @QuarterLengths,
93 @LeapYearQuarterLengths,
94);
95
96BEGIN {
97 @MonthLengths = ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
98
99 @LeapYearMonthLengths = @MonthLengths;
100 $LeapYearMonthLengths[1]++;
101
102 @QuarterLengths = ( 90, 91, 92, 92 );
103
104 @LeapYearQuarterLengths = @QuarterLengths;
105 $LeapYearQuarterLengths[0]++;
106}
107
108{
109
110 # I'd rather use Class::Data::Inheritable for this, but there's no
111 # way to add the module-loading behavior to an accessor it
112 # creates, despite what its docs say!
113 my $DefaultLocale;
114
115 sub DefaultLocale {
116 shift;
117
118 if (@_) {
119 my $lang = shift;
120
121 $DefaultLocale = DateTime::Locale->load($lang);
122 }
123
124 return $DefaultLocale;
125 }
126}
127__PACKAGE__->DefaultLocale('en-US');
128
129{
130 my $validator = validation_for(
131 name => '_check_new_params',
132 name_is_optional => 1,
133 params => {
134 year => { type => t('Year') },
135 month => {
136 type => t('Month'),
137 default => 1,
138 },
139 day => {
140 type => t('DayOfMonth'),
141 default => 1,
142 },
143 hour => {
144 type => t('Hour'),
145 default => 0,
146 },
147 minute => {
148 type => t('Minute'),
149 default => 0,
150 },
151 second => {
152 type => t('Second'),
153 default => 0,
154 },
155 nanosecond => {
156 type => t('Nanosecond'),
157 default => 0,
158 },
159 locale => {
160 type => t('Locale'),
161 optional => 1,
162 },
163 formatter => {
164 type => t('Formatter'),
165 optional => 1,
166 },
167 time_zone => {
168 type => t('TimeZone'),
169 optional => 1,
170 },
171 },
172 );
173
174 sub new {
175 my $class = shift;
176 my %p = $validator->(@_);
177
178 Carp::croak(
179 "Invalid day of month (day = $p{day} - month = $p{month} - year = $p{year})\n"
180 )
181 if $p{day} > 28
182 && $p{day} > $class->_month_length( $p{year}, $p{month} );
183
184 return $class->_new(%p);
185 }
186}
187
188sub _new {
189 my $class = shift;
190 my %p = @_;
191
192 Carp::croak('Constructor called with reference, we expected a package')
193 if ref $class;
194
195 # If this method is called from somewhere other than new(), then some of
196 # these defaults may not get applied.
197 $p{month} = 1 unless exists $p{month};
198 $p{day} = 1 unless exists $p{day};
199 $p{hour} = 0 unless exists $p{hour};
200 $p{minute} = 0 unless exists $p{minute};
201 $p{second} = 0 unless exists $p{second};
202 $p{nanosecond} = 0 unless exists $p{nanosecond};
203 $p{time_zone} = $class->_default_time_zone unless exists $p{time_zone};
204
205 my $self = bless {}, $class;
206
207 $self->_set_locale( $p{locale} );
208
209 $self->{tz} = (
210 ref $p{time_zone}
211 ? $p{time_zone}
212 : DateTime::TimeZone->new( name => $p{time_zone} )
213 );
214
215 $self->{local_rd_days} = $class->_ymd2rd( @p{qw( year month day )} );
216
217 $self->{local_rd_secs}
218 = $class->_time_as_seconds( @p{qw( hour minute second )} );
219
220 $self->{offset_modifier} = 0;
221
222 $self->{rd_nanosecs} = $p{nanosecond};
223 $self->{formatter} = $p{formatter};
224
225 $self->_normalize_nanoseconds(
226 $self->{local_rd_secs},
227 $self->{rd_nanosecs}
228 );
229
230 # Set this explicitly since it can't be calculated accurately
231 # without knowing our time zone offset, and it's possible that the
232 # offset can't be calculated without having at least a rough guess
233 # of the datetime's year. This year need not be correct, as long
234 # as its equal or greater to the correct number, so we fudge by
235 # adding one to the local year given to the constructor.
236 $self->{utc_year} = $p{year} + 1;
237
238 $self->_maybe_future_dst_warning( $p{year}, $p{time_zone} );
239
240 $self->_calc_utc_rd;
241
242 $self->_handle_offset_modifier( $p{second} );
243
244 $self->_calc_local_rd;
245
246 if ( $p{second} > 59 ) {
247 if (
248 $self->{tz}->is_floating
249 ||
250
251 # If true, this means that the actual calculated leap
252 # second does not occur in the second given to new()
253 ( $self->{utc_rd_secs} - 86399 < $p{second} - 59 )
254 ) {
255 Carp::croak("Invalid second value ($p{second})\n");
256 }
257 }
258
259 return $self;
260}
261
262# Warning: do not use this environment variable unless you have no choice in
263# the matter.
264sub _default_time_zone {
265 return $ENV{PERL_DATETIME_DEFAULT_TZ} || 'floating';
266}
267
268sub _set_locale {
269 my $self = shift;
270 my $locale = shift;
271
272 if ( defined $locale && ref $locale ) {
273 $self->{locale} = $locale;
274 }
275 else {
276 $self->{locale}
277 = $locale
278 ? DateTime::Locale->load($locale)
279 : $self->DefaultLocale;
280 }
281
282 return;
283}
284
285# This method exists for the benefit of internal methods which create
286# a new object based on the current object, like set() and truncate().
287sub _new_from_self {
288 my $self = shift;
289 my %p = @_;
290
291 my %old = map { $_ => $self->$_() } qw(
292 year month day
293 hour minute second
294 nanosecond
295 locale time_zone
296 );
297 $old{formatter} = $self->formatter
298 if defined $self->formatter;
299
300 my $method = delete $p{_skip_validation} ? '_new' : 'new';
301
302 return ( ref $self )->$method( %old, %p );
303}
304
305sub _handle_offset_modifier {
306 my $self = shift;
307
308 $self->{offset_modifier} = 0;
309
310 return if $self->{tz}->is_floating;
311
312 my $second = shift;
313 my $utc_is_valid = shift;
314
315 my $utc_rd_days = $self->{utc_rd_days};
316
317 my $offset
318 = $utc_is_valid ? $self->offset : $self->_offset_for_local_datetime;
319
320 if ( $offset >= 0
321 && $self->{local_rd_secs} >= $offset ) {
322 if ( $second < 60 && $offset > 0 ) {
323 $self->{offset_modifier}
324 = $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY;
325
326 $self->{local_rd_secs} += $self->{offset_modifier};
327 }
328 elsif (
329 $second == 60
330 && (
331 ( $self->{local_rd_secs} == $offset && $offset > 0 )
332 || ( $offset == 0
333 && $self->{local_rd_secs} > 86399 )
334 )
335 ) {
336 my $mod
337 = $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY;
338
339 unless ( $mod == 0 ) {
340 $self->{utc_rd_secs} -= $mod;
341
342 $self->_normalize_seconds;
343 }
344 }
345 }
346 elsif ($offset < 0
347 && $self->{local_rd_secs} >= SECONDS_PER_DAY + $offset ) {
348 if ( $second < 60 ) {
349 $self->{offset_modifier}
350 = $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY;
351
352 $self->{local_rd_secs} += $self->{offset_modifier};
353 }
354 elsif ($second == 60
355 && $self->{local_rd_secs} == SECONDS_PER_DAY + $offset ) {
356 my $mod
357 = $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY;
358
359 unless ( $mod == 0 ) {
360 $self->{utc_rd_secs} -= $mod;
361
362 $self->_normalize_seconds;
363 }
364 }
365 }
366}
367
368sub _calc_utc_rd {
369 my $self = shift;
370
371 delete $self->{utc_c};
372
373 if ( $self->{tz}->is_utc || $self->{tz}->is_floating ) {
374 $self->{utc_rd_days} = $self->{local_rd_days};
375 $self->{utc_rd_secs} = $self->{local_rd_secs};
376 }
377 else {
378 my $offset = $self->_offset_for_local_datetime;
379
380 $offset += $self->{offset_modifier};
381
382 $self->{utc_rd_days} = $self->{local_rd_days};
383 $self->{utc_rd_secs} = $self->{local_rd_secs} - $offset;
384 }
385
386 # We account for leap seconds in the new() method and nowhere else
387 # except date math.
388 $self->_normalize_tai_seconds(
389 $self->{utc_rd_days},
390 $self->{utc_rd_secs}
391 );
392}
393
394sub _normalize_seconds {
395 my $self = shift;
396
397 return if $self->{utc_rd_secs} >= 0 && $self->{utc_rd_secs} <= 86399;
398
399 if ( $self->{tz}->is_floating ) {
400 $self->_normalize_tai_seconds(
401 $self->{utc_rd_days},
402 $self->{utc_rd_secs}
403 );
404 }
405 else {
406 $self->_normalize_leap_seconds(
407 $self->{utc_rd_days},
408 $self->{utc_rd_secs}
409 );
410 }
411}
412
413sub _calc_local_rd {
414 my $self = shift;
415
416 delete $self->{local_c};
417
418 # We must short circuit for UTC times or else we could end up with
419 # loops between DateTime.pm and DateTime::TimeZone
420 if ( $self->{tz}->is_utc || $self->{tz}->is_floating ) {
421 $self->{local_rd_days} = $self->{utc_rd_days};
422 $self->{local_rd_secs} = $self->{utc_rd_secs};
423 }
424 else {
425 my $offset = $self->offset;
426
427 $self->{local_rd_days} = $self->{utc_rd_days};
428 $self->{local_rd_secs} = $self->{utc_rd_secs} + $offset;
429
430 # intentionally ignore leap seconds here
431 $self->_normalize_tai_seconds(
432 $self->{local_rd_days},
433 $self->{local_rd_secs}
434 );
435
436 $self->{local_rd_secs} += $self->{offset_modifier};
437 }
438
439 $self->_calc_local_components;
440}
441
442sub _calc_local_components {
443 my $self = shift;
444
445 @{ $self->{local_c} }{
446 qw( year month day day_of_week
447 day_of_year quarter day_of_quarter)
448 }
449 = $self->_rd2ymd( $self->{local_rd_days}, 1 );
450
451 @{ $self->{local_c} }{qw( hour minute second )}
452 = $self->_seconds_as_components(
453 $self->{local_rd_secs},
454 $self->{utc_rd_secs}, $self->{offset_modifier}
455 );
456}
457
458{
459 my $validator = validation_for(
460 name => '_check_from_epoch_params',
461 name_is_optional => 1,
462 params => {
463 epoch => { type => t('Num') },
464 formatter => {
465 type => t('Formatter'),
466 optional => 1
467 },
468 locale => {
469 type => t('Locale'),
470 optional => 1
471 },
472 time_zone => {
473 type => t('TimeZone'),
474 optional => 1
475 },
476 },
477 );
478
479 sub from_epoch {
480 my $class = shift;
481 my %p = $validator->(@_);
482
483 my %args;
484
485 # This does two things. First, if given a negative non-integer epoch,
486 # it will round the epoch _down_ to the next second and then adjust
487 # the nanoseconds to be positive. In other words, -0.5 corresponds to
488 # a second of -1 and a nanosecond value of 500,000. Before this code
489 # was implemented our handling of negative non-integer epochs was
490 # quite broken, and would end up rounding some values up, so that -0.5
491 # become 0.5 (which is obviously wrong!).
492 #
493 # Second, it rounds any decimal values to the nearest microsecond
494 # (1E6). Here's what Christian Hansen, who wrote this patch, says:
495 #
496 # Perl is typically compiled with NV as a double. A double with a
497 # significand precision of 53 bits can only represent a nanosecond
498 # epoch without loss of precision if the duration from zero epoch
499 # is less than ≈ ±104 days. With microseconds the duration is
500 # ±104,000 days, which is ≈ ±285 years.
501 if ( int $p{epoch} != $p{epoch} ) {
502 my ( $floor, $nano, $second );
503
504 $floor = $nano = fmod( $p{epoch}, 1.0 );
505 $second = floor( $p{epoch} - $floor );
506 if ( $nano < 0 ) {
507 $nano += 1;
508 }
509 $p{epoch} = $second + floor( $floor - $nano );
510 $args{nanosecond} = floor( $nano * 1E6 + 0.5 ) * 1E3;
511 }
512
513 # Note, for very large negative values this may give a
514 # blatantly wrong answer.
515 @args{qw( second minute hour day month year )}
516 = ( gmtime( $p{epoch} ) )[ 0 .. 5 ];
517 $args{year} += 1900;
518 $args{month}++;
519
520 my $self = $class->_new( %p, %args, time_zone => 'UTC' );
521
522 $self->_maybe_future_dst_warning( $self->year, $p{time_zone} );
523
524 $self->set_time_zone( $p{time_zone} ) if exists $p{time_zone};
525
526 return $self;
527 }
528}
529
530sub now {
531 my $class = shift;
532 return $class->from_epoch( epoch => $class->_core_time, @_ );
533}
534
535sub _maybe_future_dst_warning {
536 shift;
537 my $year = shift;
538 my $tz = shift;
539
540 return unless $year >= 5000 && $tz;
541
542 my $tz_name = ref $tz ? $tz->name : $tz;
543 return if $tz_name eq 'floating' || $tz_name eq 'UTC';
544
545 warnings::warnif(
546 "You are creating a DateTime object with a far future year ($year) and a time zone ($tz_name)."
547 . ' If the time zone you specified has future DST changes this will be very slow.'
548 );
549}
550
551# use scalar time in case someone's loaded Time::Piece
552sub _core_time {
553 return scalar time;
554}
555
556sub today { shift->now(@_)->truncate( to => 'day' ) }
557
558{
559 my $validator = validation_for(
560 name => '_check_from_object_params',
561 name_is_optional => 1,
562 params => {
563 object => { type => t('ConvertibleObject') },
564 locale => {
565 type => t('Locale'),
566 optional => 1,
567 },
568 formatter => {
569 type => t('Formatter'),
570 optional => 1,
571 },
572 },
573 );
574
575 sub from_object {
576 my $class = shift;
577 my %p = $validator->(@_);
578
579 my $object = delete $p{object};
580
581 if ( $object->isa('DateTime::Infinite') ) {
582 return $object->clone;
583 }
584
585 my ( $rd_days, $rd_secs, $rd_nanosecs ) = $object->utc_rd_values;
586
587 # A kludge because until all calendars are updated to return all
588 # three values, $rd_nanosecs could be undef
589 $rd_nanosecs ||= 0;
590
591 # This is a big hack to let _seconds_as_components operate naively
592 # on the given value. If the object _is_ on a leap second, we'll
593 # add that to the generated seconds value later.
594 my $leap_seconds = 0;
595 if ( $object->can('time_zone')
596 && !$object->time_zone->is_floating
597 && $rd_secs > 86399
598 && $rd_secs <= $class->_day_length($rd_days) ) {
599 $leap_seconds = $rd_secs - 86399;
600 $rd_secs -= $leap_seconds;
601 }
602
603 my %args;
604 @args{qw( year month day )} = $class->_rd2ymd($rd_days);
605 @args{qw( hour minute second )}
606 = $class->_seconds_as_components($rd_secs);
607 $args{nanosecond} = $rd_nanosecs;
608
609 $args{second} += $leap_seconds;
610
611 my $new = $class->new( %p, %args, time_zone => 'UTC' );
612
613 if ( $object->can('time_zone') ) {
614 $new->set_time_zone( $object->time_zone );
615 }
616 else {
617 $new->set_time_zone( $class->_default_time_zone );
618 }
619
620 return $new;
621 }
622}
623
624{
625 my $validator = validation_for(
626 name => '_check_last_day_of_month_params',
627 name_is_optional => 1,
628 params => {
629 year => { type => t('Year') },
630 month => { type => t('Month') },
631 day => {
632 type => t('DayOfMonth'),
633 default => 1,
634 },
635 hour => {
636 type => t('Hour'),
637 default => 0,
638 },
639 minute => {
640 type => t('Minute'),
641 default => 0,
642 },
643 second => {
644 type => t('Second'),
645 default => 0,
646 },
647 nanosecond => {
648 type => t('Nanosecond'),
649 default => 0,
650 },
651 locale => {
652 type => t('Locale'),
653 optional => 1,
654 },
655 formatter => {
656 type => t('Formatter'),
657 optional => 1,
658 },
659 time_zone => {
660 type => t('TimeZone'),
661 optional => 1,
662 },
663 },
664 );
665
666 sub last_day_of_month {
667 my $class = shift;
668 my %p = $validator->(@_);
669
670 my $day = $class->_month_length( $p{year}, $p{month} );
671
672 return $class->_new( %p, day => $day );
673 }
674}
675
676sub _month_length {
677 return (
678 $_[0]->_is_leap_year( $_[1] )
679 ? $LeapYearMonthLengths[ $_[2] - 1 ]
680 : $MonthLengths[ $_[2] - 1 ]
681 );
682}
683
684{
685 my $validator = validation_for(
686 name => '_check_from_day_of_year_params',
687 name_is_optional => 1,
688 params => {
689 year => { type => t('Year') },
690 day_of_year => { type => t('DayOfYear') },
691 hour => {
692 type => t('Hour'),
693 default => 0,
694 },
695 minute => {
696 type => t('Minute'),
697 default => 0,
698 },
699 second => {
700 type => t('Second'),
701 default => 0,
702 },
703 nanosecond => {
704 type => t('Nanosecond'),
705 default => 0,
706 },
707 locale => {
708 type => t('Locale'),
709 optional => 1,
710 },
711 formatter => {
712 type => t('Formatter'),
713 optional => 1,
714 },
715 time_zone => {
716 type => t('TimeZone'),
717 optional => 1,
718 },
719 },
720 );
721
722 sub from_day_of_year {
723 my $class = shift;
724 my %p = $validator->(@_);
725
726 Carp::croak("$p{year} is not a leap year.\n")
727 if $p{day_of_year} == 366 && !$class->_is_leap_year( $p{year} );
728
729 my $month = 1;
730 my $day = delete $p{day_of_year};
731
732 if ( $day > 31 ) {
733 my $length = $class->_month_length( $p{year}, $month );
734
735 while ( $day > $length ) {
736 $day -= $length;
737 $month++;
738 $length = $class->_month_length( $p{year}, $month );
739 }
740 }
741
742 return $class->_new(
743 %p,
744 month => $month,
745 day => $day,
746 );
747 }
748}
749
750sub formatter { $_[0]->{formatter} }
751
752sub clone { bless { %{ $_[0] } }, ref $_[0] }
753
754sub year {
755 Carp::carp('year() is a read-only accessor') if @_ > 1;
756 return $_[0]->{local_c}{year};
757}
758
759sub ce_year {
760 $_[0]->{local_c}{year} <= 0
761 ? $_[0]->{local_c}{year} - 1
762 : $_[0]->{local_c}{year};
763}
764
765sub era_name { $_[0]->{locale}->era_wide->[ $_[0]->_era_index ] }
766
767sub era_abbr { $_[0]->{locale}->era_abbreviated->[ $_[0]->_era_index ] }
768
769# deprecated
770*era = \&era_abbr;
771
772sub _era_index { $_[0]->{local_c}{year} <= 0 ? 0 : 1 }
773
774sub christian_era { $_[0]->ce_year > 0 ? 'AD' : 'BC' }
775sub secular_era { $_[0]->ce_year > 0 ? 'CE' : 'BCE' }
776
777sub year_with_era { ( abs $_[0]->ce_year ) . $_[0]->era_abbr }
778sub year_with_christian_era { ( abs $_[0]->ce_year ) . $_[0]->christian_era }
779sub year_with_secular_era { ( abs $_[0]->ce_year ) . $_[0]->secular_era }
780
781sub month {
782 Carp::carp('month() is a read-only accessor') if @_ > 1;
783 return $_[0]->{local_c}{month};
784}
785*mon = \&month;
786
787sub month_0 { $_[0]->{local_c}{month} - 1 }
788*mon_0 = \&month_0;
789
790sub month_name { $_[0]->{locale}->month_format_wide->[ $_[0]->month_0 ] }
791
792sub month_abbr {
793 $_[0]->{locale}->month_format_abbreviated->[ $_[0]->month_0 ];
794}
795
796sub day_of_month {
797 Carp::carp('day_of_month() is a read-only accessor') if @_ > 1;
798 $_[0]->{local_c}{day};
799}
800*day = \&day_of_month;
801*mday = \&day_of_month;
802
803sub weekday_of_month { use integer; ( ( $_[0]->day - 1 ) / 7 ) + 1 }
804
805sub quarter { $_[0]->{local_c}{quarter} }
806
807sub quarter_name {
808 $_[0]->{locale}->quarter_format_wide->[ $_[0]->quarter_0 ];
809}
810
811sub quarter_abbr {
812 $_[0]->{locale}->quarter_format_abbreviated->[ $_[0]->quarter_0 ];
813}
814
815sub quarter_0 { $_[0]->{local_c}{quarter} - 1 }
816
817sub day_of_month_0 { $_[0]->{local_c}{day} - 1 }
818*day_0 = \&day_of_month_0;
819*mday_0 = \&day_of_month_0;
820
821sub day_of_week { $_[0]->{local_c}{day_of_week} }
822*wday = \&day_of_week;
823*dow = \&day_of_week;
824
825sub day_of_week_0 { $_[0]->{local_c}{day_of_week} - 1 }
826*wday_0 = \&day_of_week_0;
827*dow_0 = \&day_of_week_0;
828
829sub local_day_of_week {
830 my $self = shift;
831 return 1
832 + ( $self->day_of_week - $self->{locale}->first_day_of_week ) % 7;
833}
834
835sub day_name { $_[0]->{locale}->day_format_wide->[ $_[0]->day_of_week_0 ] }
836
837sub day_abbr {
838 $_[0]->{locale}->day_format_abbreviated->[ $_[0]->day_of_week_0 ];
839}
840
841sub day_of_quarter { $_[0]->{local_c}{day_of_quarter} }
842*doq = \&day_of_quarter;
843
844sub day_of_quarter_0 { $_[0]->day_of_quarter - 1 }
845*doq_0 = \&day_of_quarter_0;
846
847sub day_of_year { $_[0]->{local_c}{day_of_year} }
848*doy = \&day_of_year;
849
850sub day_of_year_0 { $_[0]->{local_c}{day_of_year} - 1 }
851*doy_0 = \&day_of_year_0;
852
853sub am_or_pm {
854 $_[0]->{locale}->am_pm_abbreviated->[ $_[0]->hour < 12 ? 0 : 1 ];
855}
856
857sub ymd {
858 my ( $self, $sep ) = @_;
859 $sep = '-' unless defined $sep;
860
861 return sprintf(
862 '%0.4d%s%0.2d%s%0.2d',
863 $self->year, $sep,
864 $self->{local_c}{month}, $sep,
865 $self->{local_c}{day}
866 );
867}
868*date = sub { shift->ymd(@_) };
869
870sub mdy {
871 my ( $self, $sep ) = @_;
872 $sep = '-' unless defined $sep;
873
874 return sprintf(
875 '%0.2d%s%0.2d%s%0.4d',
876 $self->{local_c}{month}, $sep,
877 $self->{local_c}{day}, $sep,
878 $self->year
879 );
880}
881
882sub dmy {
883 my ( $self, $sep ) = @_;
884 $sep = '-' unless defined $sep;
885
886 return sprintf(
887 '%0.2d%s%0.2d%s%0.4d',
888 $self->{local_c}{day}, $sep,
889 $self->{local_c}{month}, $sep,
890 $self->year
891 );
892}
893
894sub hour {
895 Carp::carp('hour() is a read-only accessor') if @_ > 1;
896 return $_[0]->{local_c}{hour};
897}
898sub hour_1 { $_[0]->{local_c}{hour} == 0 ? 24 : $_[0]->{local_c}{hour} }
899
900sub hour_12 { my $h = $_[0]->hour % 12; return $h ? $h : 12 }
901sub hour_12_0 { $_[0]->hour % 12 }
902
903sub minute {
904 Carp::carp('minute() is a read-only accessor') if @_ > 1;
905 return $_[0]->{local_c}{minute};
906}
907*min = \&minute;
908
909sub second {
910 Carp::carp('second() is a read-only accessor') if @_ > 1;
911 return $_[0]->{local_c}{second};
912}
913*sec = \&second;
914
915sub fractional_second { $_[0]->second + $_[0]->nanosecond / MAX_NANOSECONDS }
916
917sub nanosecond {
918 Carp::carp('nanosecond() is a read-only accessor') if @_ > 1;
919 return $_[0]->{rd_nanosecs};
920}
921
922sub millisecond { floor( $_[0]->{rd_nanosecs} / 1000000 ) }
923
924sub microsecond { floor( $_[0]->{rd_nanosecs} / 1000 ) }
925
926sub leap_seconds {
927 my $self = shift;
928
929 return 0 if $self->{tz}->is_floating;
930
931 return $self->_accumulated_leap_seconds( $self->{utc_rd_days} );
932}
933
934sub stringify {
935 my $self = shift;
936
937 return $self->iso8601 unless $self->{formatter};
938 return $self->{formatter}->format_datetime($self);
939}
940
941sub hms {
942 my ( $self, $sep ) = @_;
943 $sep = ':' unless defined $sep;
944
945 return sprintf(
946 '%0.2d%s%0.2d%s%0.2d',
947 $self->{local_c}{hour}, $sep,
948 $self->{local_c}{minute}, $sep,
949 $self->{local_c}{second}
950 );
951}
952
953# don't want to override CORE::time()
954*DateTime::time = sub { shift->hms(@_) };
955
956sub iso8601 { $_[0]->datetime('T') }
957
958sub rfc3339 {
959 my $self = shift;
960
961 return $self->datetime('T')
962 if $self->{tz}->is_floating;
963
964 my $secs = $self->offset;
965 my $offset
966 = $secs
967 ? DateTime::TimeZone->offset_as_string( $secs, q{:} )
968 : 'Z';
969
970 return $self->datetime('T') . $offset;
971}
972
973sub datetime {
974 my ( $self, $sep ) = @_;
975 $sep = 'T' unless defined $sep;
976 return join $sep, $self->ymd('-'), $self->hms(':');
977}
978
979sub is_leap_year { $_[0]->_is_leap_year( $_[0]->year ) }
980
981sub month_length {
982 $_[0]->_month_length( $_[0]->year, $_[0]->month );
983}
984
985sub quarter_length {
986 return (
987 $_[0]->_is_leap_year( $_[0]->year )
988 ? $LeapYearQuarterLengths[ $_[0]->quarter - 1 ]
989 : $QuarterLengths[ $_[0]->quarter - 1 ]
990 );
991}
992
993sub year_length {
994 $_[0]->_is_leap_year( $_[0]->year ) ? 366 : 365;
995}
996
997sub is_last_day_of_month {
998 $_[0]->day == $_[0]->_month_length( $_[0]->year, $_[0]->month );
999}
1000
1001sub is_last_day_of_quarter {
1002 $_[0]->day_of_quarter == $_[0]->quarter_length;
1003}
1004
1005sub is_last_day_of_year {
1006 $_[0]->day_of_year == $_[0]->year_length;
1007}
1008
1009sub week {
1010 my $self = shift;
1011
1012 $self->{utc_c}{week_year} ||= $self->_week_values;
1013
1014 return @{ $self->{utc_c}{week_year} }[ 0, 1 ];
1015}
1016
1017# This algorithm comes from
1018# https://en.wikipedia.org/wiki/ISO_week_date#Calculating_the_week_number_of_a_given_date
1019sub _week_values {
1020 my $self = shift;
1021
1022 my $week
1023 = int( ( ( $self->day_of_year - $self->day_of_week ) + 10 ) / 7 );
1024
1025 my $year = $self->year;
1026 if ( $week == 0 ) {
1027 $year--;
1028 return [ $year, $self->_weeks_in_year($year) ];
1029 }
1030 elsif ( $week == 53 && $self->_weeks_in_year($year) == 52 ) {
1031 return [ $year + 1, 1 ];
1032 }
1033
1034 return [ $year, $week ];
1035}
1036
1037sub _weeks_in_year {
1038 my $self = shift;
1039 my $year = shift;
1040
1041 my $dow = $self->_ymd2rd( $year, 1, 1 ) % 7;
1042
1043 # Years starting with a Thursday and leap years starting with a Wednesday
1044 # have 53 weeks.
1045 return ( $dow == 4 || ( $dow == 3 && $self->_is_leap_year($year) ) )
1046 ? 53
1047 : 52;
1048}
1049
1050sub week_year { ( $_[0]->week )[0] }
1051sub week_number { ( $_[0]->week )[1] }
1052
1053# ISO says that the first week of a year is the first week containing
1054# a Thursday. Extending that says that the first week of the month is
1055# the first week containing a Thursday. ICU agrees.
1056sub week_of_month {
1057 my $self = shift;
1058 my $thu = $self->day + 4 - $self->day_of_week;
1059 return int( ( $thu + 6 ) / 7 );
1060}
1061
1062sub time_zone {
1063 Carp::carp('time_zone() is a read-only accessor') if @_ > 1;
1064 return $_[0]->{tz};
1065}
1066
1067sub offset { $_[0]->{tz}->offset_for_datetime( $_[0] ) }
1068
1069sub _offset_for_local_datetime {
1070 $_[0]->{tz}->offset_for_local_datetime( $_[0] );
1071}
1072
1073sub is_dst { $_[0]->{tz}->is_dst_for_datetime( $_[0] ) }
1074
1075sub time_zone_long_name { $_[0]->{tz}->name }
1076sub time_zone_short_name { $_[0]->{tz}->short_name_for_datetime( $_[0] ) }
1077
1078sub locale {
1079 Carp::carp('locale() is a read-only accessor') if @_ > 1;
1080 return $_[0]->{locale};
1081}
1082
1083sub utc_rd_values {
1084 @{ $_[0] }{ 'utc_rd_days', 'utc_rd_secs', 'rd_nanosecs' };
1085}
1086
1087sub local_rd_values {
1088 @{ $_[0] }{ 'local_rd_days', 'local_rd_secs', 'rd_nanosecs' };
1089}
1090
1091# NOTE: no nanoseconds, no leap seconds
1092sub utc_rd_as_seconds {
1093 ( $_[0]->{utc_rd_days} * SECONDS_PER_DAY ) + $_[0]->{utc_rd_secs};
1094}
1095
1096# NOTE: no nanoseconds, no leap seconds
1097sub local_rd_as_seconds {
1098 ( $_[0]->{local_rd_days} * SECONDS_PER_DAY ) + $_[0]->{local_rd_secs};
1099}
1100
1101# RD 1 is MJD 678,576 - a simple offset
1102sub mjd {
1103 my $self = shift;
1104
1105 my $mjd = $self->{utc_rd_days} - 678_576;
1106
1107 my $day_length = $self->_day_length( $self->{utc_rd_days} );
1108
1109 return ( $mjd
1110 + ( $self->{utc_rd_secs} / $day_length )
1111 + ( $self->{rd_nanosecs} / $day_length / MAX_NANOSECONDS ) );
1112}
1113
1114sub jd { $_[0]->mjd + 2_400_000.5 }
1115
1116{
1117 my %strftime_patterns = (
1118 'a' => sub { $_[0]->day_abbr },
1119 'A' => sub { $_[0]->day_name },
1120 'b' => sub { $_[0]->month_abbr },
1121 'B' => sub { $_[0]->month_name },
1122 'c' => sub {
1123 $_[0]->format_cldr( $_[0]->{locale}->datetime_format_default );
1124 },
1125 'C' => sub { int( $_[0]->year / 100 ) },
1126 'd' => sub { sprintf( '%02d', $_[0]->day_of_month ) },
1127 'D' => sub { $_[0]->strftime('%m/%d/%y') },
1128 'e' => sub { sprintf( '%2d', $_[0]->day_of_month ) },
1129 'F' => sub { $_[0]->strftime('%Y-%m-%d') },
1130 'g' => sub { substr( $_[0]->week_year, -2 ) },
1131 'G' => sub { $_[0]->week_year },
1132 'H' => sub { sprintf( '%02d', $_[0]->hour ) },
1133 'I' => sub { sprintf( '%02d', $_[0]->hour_12 ) },
1134 'j' => sub { sprintf( '%03d', $_[0]->day_of_year ) },
1135 'k' => sub { sprintf( '%2d', $_[0]->hour ) },
1136 'l' => sub { sprintf( '%2d', $_[0]->hour_12 ) },
1137 'm' => sub { sprintf( '%02d', $_[0]->month ) },
1138 'M' => sub { sprintf( '%02d', $_[0]->minute ) },
1139 'n' => sub {"\n"}, # should this be OS-sensitive?
1140 'N' => \&_format_nanosecs,
1141 'p' => sub { $_[0]->am_or_pm },
1142 'P' => sub { lc $_[0]->am_or_pm },
1143 'r' => sub { $_[0]->strftime('%I:%M:%S %p') },
1144 'R' => sub { $_[0]->strftime('%H:%M') },
1145 's' => sub { $_[0]->epoch },
1146 'S' => sub { sprintf( '%02d', $_[0]->second ) },
1147 't' => sub {"\t"},
1148 'T' => sub { $_[0]->strftime('%H:%M:%S') },
1149 'u' => sub { $_[0]->day_of_week },
1150 'U' => sub {
1151 my $sun = $_[0]->day_of_year - ( $_[0]->day_of_week + 7 ) % 7;
1152 return sprintf( '%02d', int( ( $sun + 6 ) / 7 ) );
1153 },
1154 'V' => sub { sprintf( '%02d', $_[0]->week_number ) },
1155 'w' => sub {
1156 my $dow = $_[0]->day_of_week;
1157 return $dow % 7;
1158 },
1159 'W' => sub {
1160 my $mon = $_[0]->day_of_year - ( $_[0]->day_of_week + 6 ) % 7;
1161 return sprintf( '%02d', int( ( $mon + 6 ) / 7 ) );
1162 },
1163 'x' => sub {
1164 $_[0]->format_cldr( $_[0]->{locale}->date_format_default );
1165 },
1166 'X' => sub {
1167 $_[0]->format_cldr( $_[0]->{locale}->time_format_default );
1168 },
1169 'y' => sub { sprintf( '%02d', substr( $_[0]->year, -2 ) ) },
1170 'Y' => sub { return $_[0]->year },
1171 'z' => sub { DateTime::TimeZone->offset_as_string( $_[0]->offset ) },
1172 'Z' => sub { $_[0]->{tz}->short_name_for_datetime( $_[0] ) },
1173 '%' => sub {'%'},
1174 );
1175
1176 $strftime_patterns{h} = $strftime_patterns{b};
1177
1178 sub strftime {
1179 my $self = shift;
1180
1181 # make a copy or caller's scalars get munged
1182 my @patterns = @_;
1183
1184 my @r;
1185 foreach my $p (@patterns) {
1186 $p =~ s/
1187 ( $1
1188 ? ( $self->can($1) ? $self->$1() : "\%{$1}" )
1189 : $2
1190 ? ( $strftime_patterns{$2} ? $strftime_patterns{$2}->($self) : "\%$2" )
1191 : $3
1192 ? $strftime_patterns{N}->($self, $3)
1193 : '' # this won't happen
1194 )
1195 /sgex;
1196
- -
1205 return $p unless wantarray;
1206
1207 push @r, $p;
1208 }
1209
1210 return @r;
1211 }
1212}
1213
1214{
1215
1216 # It's an array because the order in which the regexes are checked
1217 # is important. These patterns are similar to the ones Java uses,
1218 # but not quite the same. See
1219 # http://www.unicode.org/reports/tr35/tr35-9.html#Date_Format_Patterns.
1220 my @patterns = (
1221 qr/GGGGG/ =>
1222 sub { $_[0]->{locale}->era_narrow->[ $_[0]->_era_index ] },
1223 qr/GGGG/ => 'era_name',
1224 qr/G{1,3}/ => 'era_abbr',
1225
1226 qr/(y{3,5})/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->year ) },
1227
1228 # yy is a weird special case, where it must be exactly 2 digits
1229 qr/yy/ => sub {
1230 my $year = $_[0]->year;
1231 my $y2 = length $year > 2 ? substr( $year, -2, 2 ) : $year;
1232 $y2 *= -1 if $year < 0;
1233 $_[0]->_zero_padded_number( 'yy', $y2 );
1234 },
1235 qr/y/ => sub { $_[0]->year },
1236 qr/(u+)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->year ) },
1237 qr/(Y+)/ =>
1238 sub { $_[0]->_zero_padded_number( $1, $_[0]->week_year ) },
1239
1240 qr/QQQQ/ => 'quarter_name',
1241 qr/QQQ/ => 'quarter_abbr',
1242 qr/(QQ?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->quarter ) },
1243
1244 qr/qqqq/ => sub {
1245 $_[0]->{locale}->quarter_stand_alone_wide->[ $_[0]->quarter_0 ];
1246 },
1247 qr/qqq/ => sub {
1248 $_[0]->{locale}
1249 ->quarter_stand_alone_abbreviated->[ $_[0]->quarter_0 ];
1250 },
1251 qr/(qq?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->quarter ) },
1252
1253 qr/MMMMM/ =>
1254 sub { $_[0]->{locale}->month_format_narrow->[ $_[0]->month_0 ] },
1255 qr/MMMM/ => 'month_name',
1256 qr/MMM/ => 'month_abbr',
1257 qr/(MM?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->month ) },
1258
1259 qr/LLLLL/ => sub {
1260 $_[0]->{locale}->month_stand_alone_narrow->[ $_[0]->month_0 ];
1261 },
1262 qr/LLLL/ => sub {
1263 $_[0]->{locale}->month_stand_alone_wide->[ $_[0]->month_0 ];
1264 },
1265 qr/LLL/ => sub {
1266 $_[0]->{locale}
1267 ->month_stand_alone_abbreviated->[ $_[0]->month_0 ];
1268 },
1269 qr/(LL?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->month ) },
1270
1271 qr/(ww?)/ =>
1272 sub { $_[0]->_zero_padded_number( $1, $_[0]->week_number ) },
1273 qr/W/ => 'week_of_month',
1274
1275 qr/(dd?)/ =>
1276 sub { $_[0]->_zero_padded_number( $1, $_[0]->day_of_month ) },
1277 qr/(D{1,3})/ =>
1278 sub { $_[0]->_zero_padded_number( $1, $_[0]->day_of_year ) },
1279
1280 qr/F/ => 'weekday_of_month',
1281 qr/(g+)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->mjd ) },
1282
1283 qr/EEEEE/ => sub {
1284 $_[0]->{locale}->day_format_narrow->[ $_[0]->day_of_week_0 ];
1285 },
1286 qr/EEEE/ => 'day_name',
1287 qr/E{1,3}/ => 'day_abbr',
1288
1289 qr/eeeee/ => sub {
1290 $_[0]->{locale}->day_format_narrow->[ $_[0]->day_of_week_0 ];
1291 },
1292 qr/eeee/ => 'day_name',
1293 qr/eee/ => 'day_abbr',
1294 qr/(ee?)/ => sub {
1295 $_[0]->_zero_padded_number( $1, $_[0]->local_day_of_week );
1296 },
1297
1298 qr/ccccc/ => sub {
1299 $_[0]->{locale}->day_stand_alone_narrow->[ $_[0]->day_of_week_0 ];
1300 },
1301 qr/cccc/ => sub {
1302 $_[0]->{locale}->day_stand_alone_wide->[ $_[0]->day_of_week_0 ];
1303 },
1304 qr/ccc/ => sub {
1305 $_[0]->{locale}
1306 ->day_stand_alone_abbreviated->[ $_[0]->day_of_week_0 ];
1307 },
1308 qr/(cc?)/ =>
1309 sub { $_[0]->_zero_padded_number( $1, $_[0]->day_of_week ) },
1310
1311 qr/a/ => 'am_or_pm',
1312
1313 qr/(hh?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->hour_12 ) },
1314 qr/(HH?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->hour ) },
1315 qr/(KK?)/ =>
1316 sub { $_[0]->_zero_padded_number( $1, $_[0]->hour_12_0 ) },
1317 qr/(kk?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->hour_1 ) },
1318 qr/(jj?)/ => sub {
1319 my $h
1320 = $_[0]->{locale}->prefers_24_hour_time
1321 ? $_[0]->hour
1322 : $_[0]->hour_12;
1323 $_[0]->_zero_padded_number( $1, $h );
1324 },
1325
1326 qr/(mm?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->minute ) },
1327
1328 qr/(ss?)/ => sub { $_[0]->_zero_padded_number( $1, $_[0]->second ) },
1329
1330 # The LDML spec is not 100% clear on how to truncate this field, but
1331 # this way seems as good as anything.
1332 qr/(S+)/ => sub { $_[0]->_format_nanosecs( length($1) ) },
1333 qr/A+/ =>
1334 sub { ( $_[0]->{local_rd_secs} * 1000 ) + $_[0]->millisecond },
1335
1336 qr/zzzz/ => sub { $_[0]->time_zone_long_name },
1337 qr/z{1,3}/ => sub { $_[0]->time_zone_short_name },
1338 qr/ZZZZZ/ => sub {
1339 DateTime::TimeZone->offset_as_string( $_[0]->offset, q{:} );
1340 },
1341 qr/ZZZZ/ => sub {
1342 $_[0]->time_zone_short_name
1343 . DateTime::TimeZone->offset_as_string( $_[0]->offset );
1344 },
1345 qr/Z{1,3}/ =>
1346 sub { DateTime::TimeZone->offset_as_string( $_[0]->offset ) },
1347 qr/vvvv/ => sub { $_[0]->time_zone_long_name },
1348 qr/v{1,3}/ => sub { $_[0]->time_zone_short_name },
1349 qr/VVVV/ => sub { $_[0]->time_zone_long_name },
1350 qr/V{1,3}/ => sub { $_[0]->time_zone_short_name },
1351 );
1352
1353 sub _zero_padded_number {
1354 my $self = shift;
1355 my $size = length shift;
1356 my $val = shift;
1357
1358 return sprintf( "%0${size}d", $val );
1359 }
1360
1361 sub format_cldr {
1362 my $self = shift;
1363
1364 # make a copy or caller's scalars get munged
1365 my @p = @_;
1366
1367 my @r;
1368 foreach my $p (@p) {
1369 $p =~ s/\G
1370 defined $1
1371 ? $1
1372 : defined $2
1373 ? $self->_cldr_pattern($2)
1374 : defined $4
1375 ? $4
1376 : undef # should never get here
1377 /sgex;
1378 (.) # anything else
1379 )
1380 /
1381
- -
1390 $p =~ s/\'\'/\'/g;
1391
1392 return $p unless wantarray;
1393
1394 push @r, $p;
1395 }
1396
1397 return @r;
1398 }
1399
1400 sub _cldr_pattern {
1401 my $self = shift;
1402 my $pattern = shift;
1403
1404 ## no critic (ControlStructures::ProhibitCStyleForLoops)
1405 for ( my $i = 0; $i < @patterns; $i += 2 ) {
1406 if ( $pattern =~ /$patterns[$i]/ ) {
1407 my $sub = $patterns[ $i + 1 ];
1408
1409 return $self->$sub();
1410 }
1411 }
1412
1413 return $pattern;
1414 }
1415}
1416
1417sub _format_nanosecs {
1418 my $self = shift;
1419 my $precision = @_ ? shift : 9;
1420
1421 my $exponent = 9 - $precision;
1422 my $formatted_ns = floor(
1423 (
1424 $exponent < 0
1425 ? $self->{rd_nanosecs} * 10**-$exponent
1426 : $self->{rd_nanosecs} / 10**$exponent
1427 )
1428 );
1429
1430 return sprintf(
1431 '%0' . $precision . 'u',
1432 $formatted_ns
1433 );
1434}
1435
1436sub epoch {
1437 my $self = shift;
1438
1439 return $self->{utc_c}{epoch}
1440 if exists $self->{utc_c}{epoch};
1441
1442 return $self->{utc_c}{epoch}
1443 = ( $self->{utc_rd_days} - 719163 ) * SECONDS_PER_DAY
1444 + $self->{utc_rd_secs};
1445}
1446
1447sub hires_epoch {
1448 my $self = shift;
1449
1450 my $epoch = $self->epoch;
1451
1452 return undef unless defined $epoch;
1453
1454 my $nano = $self->{rd_nanosecs} / MAX_NANOSECONDS;
1455
1456 return $epoch + $nano;
1457}
1458
1459sub is_finite {1}
1460sub is_infinite {0}
1461
1462# added for benefit of DateTime::TimeZone
1463sub utc_year { $_[0]->{utc_year} }
1464
1465# returns a result that is relative to the first datetime
1466sub subtract_datetime {
1467 my $dt1 = shift;
1468 my $dt2 = shift;
1469
1470 $dt2 = $dt2->clone->set_time_zone( $dt1->time_zone )
1471 unless $dt1->time_zone eq $dt2->time_zone;
1472
1473 # We only want a negative duration if $dt2 > $dt1 ($self)
1474 my ( $bigger, $smaller, $negative ) = (
1475 $dt1 >= $dt2
1476 ? ( $dt1, $dt2, 0 )
1477 : ( $dt2, $dt1, 1 )
1478 );
1479
1480 my $is_floating = $dt1->time_zone->is_floating
1481 && $dt2->time_zone->is_floating;
1482
1483 my $minute_length = 60;
1484 unless ($is_floating) {
1485 my ( $utc_rd_days, $utc_rd_secs ) = $smaller->utc_rd_values;
1486
1487 if ( $utc_rd_secs >= 86340 && !$is_floating ) {
1488
1489 # If the smaller of the two datetimes occurs in the last
1490 # UTC minute of the UTC day, then that minute may not be
1491 # 60 seconds long. If we need to subtract a minute from
1492 # the larger datetime's minutes count in order to adjust
1493 # the seconds difference to be positive, we need to know
1494 # how long that minute was. If one of the datetimes is
1495 # floating, we just assume a minute is 60 seconds.
1496
1497 $minute_length = $dt1->_day_length($utc_rd_days) - 86340;
1498 }
1499 }
1500
1501 # This is a gross hack that basically figures out if the bigger of
1502 # the two datetimes is the day of a DST change. If it's a 23 hour
1503 # day (switching _to_ DST) then we subtract 60 minutes from the
1504 # local time. If it's a 25 hour day then we add 60 minutes to the
1505 # local time.
1506 #
1507 # This produces the most "intuitive" results, though there are
1508 # still reversibility problems with the resultant duration.
1509 #
1510 # However, if the two objects are on the same (local) date, and we
1511 # are not crossing a DST change, we don't want to invoke the hack
1512 # - see 38local-subtract.t
1513 my $bigger_min = $bigger->hour * 60 + $bigger->minute;
1514 if ( $bigger->time_zone->has_dst_changes
1515 && $bigger->is_dst != $smaller->is_dst ) {
1516
1517 $bigger_min -= 60
1518
1519 # it's a 23 hour (local) day
1520 if (
1521 $bigger->is_dst
1522 && do {
1523 my $prev_day = try { $bigger->clone->subtract( days => 1 ) };
1524 $prev_day && !$prev_day->is_dst ? 1 : 0;
1525 }
1526 );
1527
1528 $bigger_min += 60
1529
1530 # it's a 25 hour (local) day
1531 if (
1532 !$bigger->is_dst
1533 && do {
1534 my $prev_day = try { $bigger->clone->subtract( days => 1 ) };
1535 $prev_day && $prev_day->is_dst ? 1 : 0;
1536 }
1537 );
1538 }
1539
1540 my ( $months, $days, $minutes, $seconds, $nanoseconds )
1541 = $dt1->_adjust_for_positive_difference(
1542 $bigger->year * 12 + $bigger->month,
1543 $smaller->year * 12 + $smaller->month,
1544
1545 $bigger->day, $smaller->day,
1546
1547 $bigger_min, $smaller->hour * 60 + $smaller->minute,
1548
1549 $bigger->second, $smaller->second,
1550
1551 $bigger->nanosecond, $smaller->nanosecond,
1552
1553 $minute_length,
1554
1555 # XXX - using the smaller as the month length is
1556 # somewhat arbitrary, we could also use the bigger -
1557 # either way we have reversibility problems
1558 $dt1->_month_length( $smaller->year, $smaller->month ),
1559 );
1560
1561 if ($negative) {
1562 for ( $months, $days, $minutes, $seconds, $nanoseconds ) {
1563
1564 # Some versions of Perl can end up with -0 if we do "0 * -1"!!
1565 $_ *= -1 if $_;
1566 }
1567 }
1568
1569 return $dt1->duration_class->new(
1570 months => $months,
1571 days => $days,
1572 minutes => $minutes,
1573 seconds => $seconds,
1574 nanoseconds => $nanoseconds,
1575 );
1576}
1577
1578sub _adjust_for_positive_difference
1579{ ## no critic (Subroutines::ProhibitManyArgs)
1580 my (
1581 $self,
1582 $month1, $month2,
1583 $day1, $day2,
1584 $min1, $min2,
1585 $sec1, $sec2,
1586 $nano1, $nano2,
1587 $minute_length,
1588 $month_length,
1589 ) = @_;
1590
1591 if ( $nano1 < $nano2 ) {
1592 $sec1--;
1593 $nano1 += MAX_NANOSECONDS;
1594 }
1595
1596 if ( $sec1 < $sec2 ) {
1597 $min1--;
1598 $sec1 += $minute_length;
1599 }
1600
1601 # A day always has 24 * 60 minutes, though the minutes may vary in
1602 # length.
1603 if ( $min1 < $min2 ) {
1604 $day1--;
1605 $min1 += 24 * 60;
1606 }
1607
1608 if ( $day1 < $day2 ) {
1609 $month1--;
1610 $day1 += $month_length;
1611 }
1612
1613 return (
1614 $month1 - $month2,
1615 $day1 - $day2,
1616 $min1 - $min2,
1617 $sec1 - $sec2,
1618 $nano1 - $nano2,
1619 );
1620}
1621
1622sub subtract_datetime_absolute {
1623 my $self = shift;
1624 my $dt = shift;
1625
1626 my $utc_rd_secs1 = $self->utc_rd_as_seconds;
1627 $utc_rd_secs1 += $self->_accumulated_leap_seconds( $self->{utc_rd_days} )
1628 if !$self->time_zone->is_floating;
1629
1630 my $utc_rd_secs2 = $dt->utc_rd_as_seconds;
1631 $utc_rd_secs2 += $self->_accumulated_leap_seconds( $dt->{utc_rd_days} )
1632 if !$dt->time_zone->is_floating;
1633
1634 my $seconds = $utc_rd_secs1 - $utc_rd_secs2;
1635 my $nanoseconds = $self->nanosecond - $dt->nanosecond;
1636
1637 if ( $nanoseconds < 0 ) {
1638 $seconds--;
1639 $nanoseconds += MAX_NANOSECONDS;
1640 }
1641
1642 return $self->duration_class->new(
1643 seconds => $seconds,
1644 nanoseconds => $nanoseconds,
1645 );
1646}
1647
1648sub delta_md {
1649 my $self = shift;
1650 my $dt = shift;
1651
1652 my ( $smaller, $bigger ) = sort $self, $dt;
1653
1654 my ( $months, $days, undef, undef, undef )
1655 = $dt->_adjust_for_positive_difference(
1656 $bigger->year * 12 + $bigger->month,
1657 $smaller->year * 12 + $smaller->month,
1658
1659 $bigger->day, $smaller->day,
1660
1661 0, 0,
1662
1663 0, 0,
1664
1665 0, 0,
1666
1667 60,
1668
1669 $smaller->_month_length( $smaller->year, $smaller->month ),
1670 );
1671
1672 return $self->duration_class->new(
1673 months => $months,
1674 days => $days
1675 );
1676}
1677
1678sub delta_days {
1679 my $self = shift;
1680 my $dt = shift;
1681
1682 my $days
1683 = abs( ( $self->local_rd_values )[0] - ( $dt->local_rd_values )[0] );
1684
1685 $self->duration_class->new( days => $days );
1686}
1687
1688sub delta_ms {
1689 my $self = shift;
1690 my $dt = shift;
1691
1692 my ( $smaller, $greater ) = sort $self, $dt;
1693
1694 my $days = int( $greater->jd - $smaller->jd );
1695
1696 my $dur = $greater->subtract_datetime($smaller);
1697
1698 my %p;
1699 $p{hours} = $dur->hours + ( $days * 24 );
1700 $p{minutes} = $dur->minutes;
1701 $p{seconds} = $dur->seconds;
1702
1703 return $self->duration_class->new(%p);
1704}
1705
1706sub _add_overload {
1707 my ( $dt, $dur, $reversed ) = @_;
1708
1709 if ($reversed) {
1710 ( $dur, $dt ) = ( $dt, $dur );
1711 }
1712
1713 unless ( DateTime::Helpers::isa( $dur, 'DateTime::Duration' ) ) {
1714 my $class = ref $dt;
1715 my $dt_string = overload::StrVal($dt);
1716
1717 Carp::croak( "Cannot add $dur to a $class object ($dt_string).\n"
1718 . ' Only a DateTime::Duration object can '
1719 . " be added to a $class object." );
1720 }
1721
1722 return $dt->clone->add_duration($dur);
1723}
1724
1725sub _subtract_overload {
1726 my ( $date1, $date2, $reversed ) = @_;
1727
1728 if ($reversed) {
1729 ( $date2, $date1 ) = ( $date1, $date2 );
1730 }
1731
1732 if ( DateTime::Helpers::isa( $date2, 'DateTime::Duration' ) ) {
1733 my $new = $date1->clone;
1734 $new->add_duration( $date2->inverse );
1735 return $new;
1736 }
1737 elsif ( DateTime::Helpers::isa( $date2, 'DateTime' ) ) {
1738 return $date1->subtract_datetime($date2);
1739 }
1740 else {
1741 my $class = ref $date1;
1742 my $dt_string = overload::StrVal($date1);
1743
1744 Carp::croak(
1745 "Cannot subtract $date2 from a $class object ($dt_string).\n"
1746 . ' Only a DateTime::Duration or DateTime object can '
1747 . " be subtracted from a $class object." );
1748 }
1749}
1750
1751sub add {
1752 my $self = shift;
1753
1754 return $self->add_duration( $self->_duration_object_from_args(@_) );
1755}
1756
1757sub subtract {
1758 my $self = shift;
1759
1760 my %eom;
1761 if ( @_ % 2 == 0 ) {
1762 my %p = @_;
1763
1764 $eom{end_of_month} = delete $p{end_of_month}
1765 if exists $p{end_of_month};
1766 }
1767
1768 my $dur = $self->_duration_object_from_args(@_)->inverse(%eom);
1769
1770 return $self->add_duration($dur);
1771}
1772
1773# Syntactic sugar for add and subtract: use a duration object if it's
1774# supplied, otherwise build a new one from the arguments.
1775
1776sub _duration_object_from_args {
1777 my $self = shift;
1778
1779 return $_[0]
1780 if @_ == 1 && blessed( $_[0] ) && $_[0]->isa( $self->duration_class );
1781
1782 return $self->duration_class->new(@_);
1783}
1784
1785sub subtract_duration { return $_[0]->add_duration( $_[1]->inverse ) }
1786
1787{
1788 my $validator = validation_for(
1789 name => '_check_add_duration_params',
1790 name_is_optional => 1,
1791 params => [
1792 { type => t('Duration') },
1793 ],
1794 );
1795
1796 ## no critic (Subroutines::ProhibitExcessComplexity)
1797 sub add_duration {
1798 my $self = shift;
1799 my ($dur) = $validator->(@_);
1800
1801 # simple optimization
1802 return $self if $dur->is_zero;
1803
1804 my %deltas = $dur->deltas;
1805
1806 # This bit isn't quite right since DateTime::Infinite::Future -
1807 # infinite duration should NaN
1808 foreach my $val ( values %deltas ) {
1809 my $inf;
1810 if ( $val == INFINITY ) {
1811 $inf = DateTime::Infinite::Future->new;
1812 }
1813 elsif ( $val == NEG_INFINITY ) {
1814 $inf = DateTime::Infinite::Past->new;
1815 }
1816
1817 if ($inf) {
1818 %$self = %$inf;
1819 bless $self, ref $inf;
1820
1821 return $self;
1822 }
1823 }
1824
1825 return $self if $self->is_infinite;
1826
1827 my %orig = %{$self};
1828 try {
1829 $self->_add_duration($dur);
1830 }
1831 catch {
1832 %{$self} = %orig;
1833 die $_;
1834 };
1835 }
1836}
1837
1838sub _add_duration {
1839 my $self = shift;
1840 my $dur = shift;
1841
1842 my %deltas = $dur->deltas;
1843
1844 if ( $deltas{days} ) {
1845 $self->{local_rd_days} += $deltas{days};
1846
1847 $self->{utc_year} += int( $deltas{days} / 365 ) + 1;
1848 }
1849
1850 if ( $deltas{months} ) {
1851
1852 # For preserve mode, if it is the last day of the month, make
1853 # it the 0th day of the following month (which then will
1854 # normalize back to the last day of the new month).
1855 my ( $y, $m, $d ) = (
1856 $dur->is_preserve_mode
1857 ? $self->_rd2ymd( $self->{local_rd_days} + 1 )
1858 : $self->_rd2ymd( $self->{local_rd_days} )
1859 );
1860
1861 $d -= 1 if $dur->is_preserve_mode;
1862
1863 if ( !$dur->is_wrap_mode && $d > 28 ) {
1864
1865 # find the rd for the last day of our target month
1866 $self->{local_rd_days}
1867 = $self->_ymd2rd( $y, $m + $deltas{months} + 1, 0 );
1868
1869 # what day of the month is it? (discard year and month)
1870 my $last_day
1871 = ( $self->_rd2ymd( $self->{local_rd_days} ) )[2];
1872
1873 # if our original day was less than the last day,
1874 # use that instead
1875 $self->{local_rd_days} -= $last_day - $d if $last_day > $d;
1876 }
1877 else {
1878 $self->{local_rd_days}
1879 = $self->_ymd2rd( $y, $m + $deltas{months}, $d );
1880 }
1881
1882 $self->{utc_year} += int( $deltas{months} / 12 ) + 1;
1883 }
1884
1885 if ( $deltas{days} || $deltas{months} ) {
1886 $self->_calc_utc_rd;
1887
1888 $self->_handle_offset_modifier( $self->second );
1889 }
1890
1891 if ( $deltas{minutes} ) {
1892 $self->{utc_rd_secs} += $deltas{minutes} * 60;
1893
1894 # This intentionally ignores leap seconds
1895 $self->_normalize_tai_seconds(
1896 $self->{utc_rd_days},
1897 $self->{utc_rd_secs}
1898 );
1899 }
1900
1901 if ( $deltas{seconds} || $deltas{nanoseconds} ) {
1902 $self->{utc_rd_secs} += $deltas{seconds};
1903
1904 if ( $deltas{nanoseconds} ) {
1905 $self->{rd_nanosecs} += $deltas{nanoseconds};
1906 $self->_normalize_nanoseconds(
1907 $self->{utc_rd_secs},
1908 $self->{rd_nanosecs}
1909 );
1910 }
1911
1912 $self->_normalize_seconds;
1913
1914 # This might be some big number much bigger than 60, but
1915 # that's ok (there are tests in 19leap_second.t to confirm
1916 # that)
1917 $self->_handle_offset_modifier( $self->second + $deltas{seconds} );
1918 }
1919
1920 my $new = ( ref $self )->from_object(
1921 object => $self,
1922 locale => $self->{locale},
1923 ( $self->{formatter} ? ( formatter => $self->{formatter} ) : () ),
1924 );
1925
1926 %$self = %$new;
1927
1928 return $self;
1929}
1930
1931sub _compare_overload {
1932
1933 # note: $_[1]->compare( $_[0] ) is an error when $_[1] is not a
1934 # DateTime (such as the INFINITY value)
1935
1936 return undef unless defined $_[1];
1937
1938 return $_[2] ? -$_[0]->compare( $_[1] ) : $_[0]->compare( $_[1] );
1939}
1940
1941sub _string_compare_overload {
1942 my ( $dt1, $dt2, $flip ) = @_;
1943
1944 # One is a DateTime object, one isn't. Just stringify and compare.
1945 if ( !DateTime::Helpers::can( $dt2, 'utc_rd_values' ) ) {
1946 my $sign = $flip ? -1 : 1;
1947 return $sign * ( "$dt1" cmp "$dt2" );
1948 }
1949 else {
1950 my $meth = $dt1->can('_compare_overload');
1951 goto $meth;
1952 }
1953}
1954
1955sub compare {
1956 shift->_compare( @_, 0 );
1957}
1958
1959sub compare_ignore_floating {
1960 shift->_compare( @_, 1 );
1961}
1962
1963sub _compare {
1964 my ( undef, $dt1, $dt2, $consistent ) = ref $_[0] ? ( undef, @_ ) : @_;
1965
1966 return undef unless defined $dt2;
1967
1968 if ( !ref $dt2 && ( $dt2 == INFINITY || $dt2 == NEG_INFINITY ) ) {
1969 return $dt1->{utc_rd_days} <=> $dt2;
1970 }
1971
1972 unless ( DateTime::Helpers::can( $dt1, 'utc_rd_values' )
1973 && DateTime::Helpers::can( $dt2, 'utc_rd_values' ) ) {
1974 my $dt1_string = overload::StrVal($dt1);
1975 my $dt2_string = overload::StrVal($dt2);
1976
1977 Carp::croak( 'A DateTime object can only be compared to'
1978 . " another DateTime object ($dt1_string, $dt2_string)." );
1979 }
1980
1981 if ( !$consistent
1982 && DateTime::Helpers::can( $dt1, 'time_zone' )
1983 && DateTime::Helpers::can( $dt2, 'time_zone' ) ) {
1984 my $is_floating1 = $dt1->time_zone->is_floating;
1985 my $is_floating2 = $dt2->time_zone->is_floating;
1986
1987 if ( $is_floating1 && !$is_floating2 ) {
1988 $dt1 = $dt1->clone->set_time_zone( $dt2->time_zone );
1989 }
1990 elsif ( $is_floating2 && !$is_floating1 ) {
1991 $dt2 = $dt2->clone->set_time_zone( $dt1->time_zone );
1992 }
1993 }
1994
1995 my @dt1_components = $dt1->utc_rd_values;
1996 my @dt2_components = $dt2->utc_rd_values;
1997
1998 foreach my $i ( 0 .. 2 ) {
1999 return $dt1_components[$i] <=> $dt2_components[$i]
2000 if $dt1_components[$i] != $dt2_components[$i];
2001 }
2002
2003 return 0;
2004}
2005
2006sub is_between {
2007 my $self = shift;
2008 my $lower = shift;
2009 my $upper = shift;
2010
2011 return $self->compare($lower) > 0 && $self->compare($upper) < 0;
2012}
2013
2014sub _string_equals_overload {
2015 my ( $class, $dt1, $dt2 ) = ref $_[0] ? ( undef, @_ ) : @_;
2016
2017 if ( !DateTime::Helpers::can( $dt2, 'utc_rd_values' ) ) {
2018 return "$dt1" eq "$dt2";
2019 }
2020
2021 $class ||= ref $dt1;
2022 return !$class->compare( $dt1, $dt2 );
2023}
2024
2025sub _string_not_equals_overload {
2026 return !_string_equals_overload(@_);
2027}
2028
2029sub _normalize_nanoseconds {
2030 use integer;
2031
2032 # seconds, nanoseconds
2033 if ( $_[2] < 0 ) {
2034 my $overflow = 1 + $_[2] / MAX_NANOSECONDS;
2035 $_[2] += $overflow * MAX_NANOSECONDS;
2036 $_[1] -= $overflow;
2037 }
2038 elsif ( $_[2] >= MAX_NANOSECONDS ) {
2039 my $overflow = $_[2] / MAX_NANOSECONDS;
2040 $_[2] -= $overflow * MAX_NANOSECONDS;
2041 $_[1] += $overflow;
2042 }
2043}
2044
2045{
2046 my $validator = validation_for(
2047 name => '_check_set_params',
2048 name_is_optional => 1,
2049 params => {
2050 year => {
2051 type => t('Year'),
2052 optional => 1,
2053 },
2054 month => {
2055 type => t('Month'),
2056 optional => 1,
2057 },
2058 day => {
2059 type => t('DayOfMonth'),
2060 optional => 1,
2061 },
2062 hour => {
2063 type => t('Hour'),
2064 optional => 1,
2065 },
2066 minute => {
2067 type => t('Minute'),
2068 optional => 1,
2069 },
2070 second => {
2071 type => t('Second'),
2072 optional => 1,
2073 },
2074 nanosecond => {
2075 type => t('Nanosecond'),
2076 optional => 1,
2077 },
2078 locale => {
2079 type => t('Locale'),
2080 optional => 1,
2081 },
2082 },
2083 );
2084
2085 ## no critic (NamingConventions::ProhibitAmbiguousNames)
2086 sub set {
2087 my $self = shift;
2088 my %p = $validator->(@_);
2089
2090 if ( $p{locale} ) {
2091 carp 'You passed a locale to the set() method.'
2092 . ' You should use set_locale() instead, as using set() may alter the local time near a DST boundary.';
2093 }
2094
2095 my $new_dt = $self->_new_from_self(%p);
2096
2097 %$self = %$new_dt;
2098
2099 return $self;
2100 }
2101}
2102
2103sub set_year { $_[0]->set( year => $_[1] ) }
2104sub set_month { $_[0]->set( month => $_[1] ) }
2105sub set_day { $_[0]->set( day => $_[1] ) }
2106sub set_hour { $_[0]->set( hour => $_[1] ) }
2107sub set_minute { $_[0]->set( minute => $_[1] ) }
2108sub set_second { $_[0]->set( second => $_[1] ) }
2109sub set_nanosecond { $_[0]->set( nanosecond => $_[1] ) }
2110
2111# These two are special cased because ... if the local time is the hour of a
2112# DST change where the same local time occurs twice then passing it through
2113# _new() can actually change the underlying UTC time, which is bad.
2114
2115{
2116 my $validator = validation_for(
2117 name => '_check_set_locale_params',
2118 name_is_optional => 1,
2119 params => [
2120 { type => t( 'Maybe', of => t('Locale') ) },
2121 ],
2122 );
2123
2124 sub set_locale {
2125 my $self = shift;
2126 my ($locale) = $validator->(@_);
2127
2128 $self->_set_locale($locale);
2129
2130 return $self;
2131 }
2132}
2133
2134{
2135 my $validator = validation_for(
2136 name => '_check_set_formatter_params',
2137 name_is_optional => 1,
2138 params => [
2139 { type => t( 'Maybe', of => t('Formatter') ) },
2140 ],
2141 );
2142
2143 sub set_formatter {
2144 my $self = shift;
2145 my ($formatter) = $validator->(@_);
2146
2147 $self->{formatter} = $formatter;
2148
2149 return $self;
2150 }
2151}
2152
2153{
2154 my %TruncateDefault = (
2155 month => 1,
2156 day => 1,
2157 hour => 0,
2158 minute => 0,
2159 second => 0,
2160 nanosecond => 0,
2161 );
2162
2163 my $validator = validation_for(
2164 name => '_check_truncate_params',
2165 name_is_optional => 1,
2166 params => {
2167 to => { type => t('TruncationLevel') },
2168 },
2169 );
2170
2171 my $re = join '|', 'year', 'week', 'local_week', 'quarter',
2172 grep { $_ ne 'nanosecond' } keys %TruncateDefault;
2173 my $spec = { to => { regex => qr/^(?:$re)$/ } };
2174
2175 ## no critic (Subroutines::ProhibitBuiltinHomonyms)
2176 sub truncate {
2177 my $self = shift;
2178 my %p = $validator->(@_);
2179
2180 my %new;
2181 if ( $p{to} eq 'week' || $p{to} eq 'local_week' ) {
2182 my $first_day_of_week
2183 = ( $p{to} eq 'local_week' )
2184 ? $self->{locale}->first_day_of_week
2185 : 1;
2186
2187 my $day_diff = ( $self->day_of_week - $first_day_of_week ) % 7;
2188
2189 if ($day_diff) {
2190 $self->add( days => -1 * $day_diff );
2191 }
2192
2193 # This can fail if the truncate ends up giving us an invalid local
2194 # date time. If that happens we need to reverse the addition we
2195 # just did. See https://rt.cpan.org/Ticket/Display.html?id=93347.
2196 try {
2197 $self->truncate( to => 'day' );
2198 }
2199 catch {
2200 $self->add( days => $day_diff );
2201 die $_;
2202 };
2203 }
2204 elsif ( $p{to} eq 'quarter' ) {
2205 %new = (
2206 year => $self->year,
2207 month => int( ( $self->month - 1 ) / 3 ) * 3 + 1,
2208 day => 1,
2209 hour => 0,
2210 minute => 0,
2211 second => 0,
2212 nanosecond => 0,
2213 );
2214 }
2215 else {
2216 my $truncate;
2217 foreach my $f (qw( year month day hour minute second nanosecond ))
2218 {
2219 $new{$f} = $truncate ? $TruncateDefault{$f} : $self->$f();
2220
2221 $truncate = 1 if $p{to} eq $f;
2222 }
2223 }
2224
2225 my $new_dt = $self->_new_from_self( %new, _skip_validation => 1 );
2226
2227 %$self = %$new_dt;
2228
2229 return $self;
2230 }
2231}
2232
2233sub set_time_zone {
2234 my ( $self, $tz ) = @_;
2235
2236 if ( ref $tz ) {
2237
2238 # This is a bit of a hack but it works because time zone objects
2239 # are singletons, and if it doesn't work all we lose is a little
2240 # bit of speed.
2241 return $self if $self->{tz} eq $tz;
2242 }
2243 else {
2244 return $self if $self->{tz}->name eq $tz;
2245 }
2246
2247 my $was_floating = $self->{tz}->is_floating;
2248
2249 my $old_tz = $self->{tz};
2250 $self->{tz} = ref $tz ? $tz : DateTime::TimeZone->new( name => $tz );
2251
2252 $self->_handle_offset_modifier( $self->second, 1 );
2253
2254 my $e;
2255 try {
2256 # if it either was or now is floating (but not both)
2257 if ( $self->{tz}->is_floating xor $was_floating ) {
2258 $self->_calc_utc_rd;
2259 }
2260 elsif ( !$was_floating ) {
2261 $self->_calc_local_rd;
2262 }
2263 }
2264 catch {
2265 $e = $_;
2266 };
2267
2268 # If we can't recalc the RD values then we shouldn't keep the new TZ. RT
2269 # #83940
2270 if ($e) {
2271 $self->{tz} = $old_tz;
2272 die $e;
2273 }
2274
2275 return $self;
2276}
2277
2278sub STORABLE_freeze {
2279 my $self = shift;
2280
2281 my $serialized = q{};
2282 foreach my $key (
2283 qw( utc_rd_days
2284 utc_rd_secs
2285 rd_nanosecs )
2286 ) {
2287 $serialized .= "$key:$self->{$key}|";
2288 }
2289
2290 # not used yet, but may be handy in the future.
2291 $serialized .= 'version:' . ( $DateTime::VERSION || 'git' );
2292
2293 # Formatter needs to be returned as a reference since it may be
2294 # undef or a class name, and Storable will complain if extra
2295 # return values aren't refs
2296 return $serialized, $self->{locale}, $self->{tz}, \$self->{formatter};
2297}
2298
2299sub STORABLE_thaw {
2300 my $self = shift;
2301 shift;
2302 my $serialized = shift;
2303
2304 my %serialized = map { split /:/ } split /\|/, $serialized;
2305
2306 my ( $locale, $tz, $formatter );
2307
2308 # more recent code version
2309 if (@_) {
2310 ( $locale, $tz, $formatter ) = @_;
2311 }
2312 else {
2313 $tz = DateTime::TimeZone->new( name => delete $serialized{tz} );
2314
2315 $locale = DateTime::Locale->load( delete $serialized{locale} );
2316 }
2317
2318 delete $serialized{version};
2319
2320 my $object = bless {
2321 utc_vals => [
2322 $serialized{utc_rd_days},
2323 $serialized{utc_rd_secs},
2324 $serialized{rd_nanosecs},
2325 ],
2326 tz => $tz,
2327 },
2328 'DateTime::_Thawed';
2329
2330 my %formatter = defined $$formatter ? ( formatter => $$formatter ) : ();
2331 my $new = ( ref $self )->from_object(
2332 object => $object,
2333 locale => $locale,
2334 %formatter,
2335 );
2336
2337 %$self = %$new;
2338
2339 return $self;
2340}
2341
2342## no critic (Modules::ProhibitMultiplePackages)
2343package # hide from PAUSE
2344 DateTime::_Thawed;
2345
2346sub utc_rd_values { @{ $_[0]->{utc_vals} } }
2347
2348sub time_zone { $_[0]->{tz} }
2349
23501;
2351
2352# ABSTRACT: A date and time object for Perl
2353
2354__END__