← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:48 2015

Filename/usr/share/perl5/Date/Manip/Date.pm
StatementsExecuted 62 statements in 21.8ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11114.7ms15.4msDate::Manip::Date::::BEGIN@27Date::Manip::Date::BEGIN@27
11110.5ms21.9msDate::Manip::Date::::BEGIN@26Date::Manip::Date::BEGIN@26
1111.75ms6.39msDate::Manip::Date::::BEGIN@14Date::Manip::Date::BEGIN@14
111673µs876µsDate::Manip::Date::::BEGIN@428Date::Manip::Date::BEGIN@428
11128µs28µsDate::Manip::Date::::BEGIN@622Date::Manip::Date::BEGIN@622
31122µs22µsDate::Manip::Date::::_initDate::Manip::Date::_init
11122µs22µsDate::Manip::Date::::BEGIN@4116Date::Manip::Date::BEGIN@4116
11113µs15µsDate::Manip::Date::::BEGIN@1255Date::Manip::Date::BEGIN@1255
11111µs14µsDate::Manip::Date::::BEGIN@3019Date::Manip::Date::BEGIN@3019
1119µs14µsDate::Manip::Date::::BEGIN@18Date::Manip::Date::BEGIN@18
1119µs10µsDate::Manip::Date::::BEGIN@3430Date::Manip::Date::BEGIN@3430
1117µs9µsDate::Manip::Date::::BEGIN@1285Date::Manip::Date::BEGIN@1285
1117µs9µsDate::Manip::Date::::BEGIN@21Date::Manip::Date::BEGIN@21
1117µs96µsDate::Manip::Date::::BEGIN@22Date::Manip::Date::BEGIN@22
1116µs6µsDate::Manip::Date::::BEGIN@2397Date::Manip::Date::BEGIN@2397
1116µs7µsDate::Manip::Date::::BEGIN@20Date::Manip::Date::BEGIN@20
1116µs8µsDate::Manip::Date::::BEGIN@3440Date::Manip::Date::BEGIN@3440
1116µs14µsDate::Manip::Date::::BEGIN@19Date::Manip::Date::BEGIN@19
1116µs22µsDate::Manip::Date::::BEGIN@23Date::Manip::Date::BEGIN@23
1114µs4µsDate::Manip::Date::::ENDDate::Manip::Date::END
0000s0sDate::Manip::Date::::__calc_date_dateDate::Manip::Date::__calc_date_date
0000s0sDate::Manip::Date::::__calc_date_deltaDate::Manip::Date::__calc_date_delta
0000s0sDate::Manip::Date::::__calc_date_delta_approxDate::Manip::Date::__calc_date_delta_approx
0000s0sDate::Manip::Date::::__calc_date_delta_exactDate::Manip::Date::__calc_date_delta_exact
0000s0sDate::Manip::Date::::__calc_date_delta_inverseDate::Manip::Date::__calc_date_delta_inverse
0000s0sDate::Manip::Date::::__is_business_dayDate::Manip::Date::__is_business_day
0000s0sDate::Manip::Date::::__nearest_business_dayDate::Manip::Date::__nearest_business_day
0000s0sDate::Manip::Date::::__next_prevDate::Manip::Date::__next_prev
0000s0sDate::Manip::Date::::__nextprev_business_dayDate::Manip::Date::__nextprev_business_day
0000s0sDate::Manip::Date::::_calc_date_check_dstDate::Manip::Date::_calc_date_check_dst
0000s0sDate::Manip::Date::::_calc_date_dateDate::Manip::Date::_calc_date_date
0000s0sDate::Manip::Date::::_calc_date_deltaDate::Manip::Date::_calc_date_delta
0000s0sDate::Manip::Date::::_cmp_dateDate::Manip::Date::_cmp_date
0000s0sDate::Manip::Date::::_def_dateDate::Manip::Date::_def_date
0000s0sDate::Manip::Date::::_def_date_dowDate::Manip::Date::_def_date_dow
0000s0sDate::Manip::Date::::_def_date_doyDate::Manip::Date::_def_date_doy
0000s0sDate::Manip::Date::::_def_timeDate::Manip::Date::_def_time
0000s0sDate::Manip::Date::::_event_objsDate::Manip::Date::_event_objs
0000s0sDate::Manip::Date::::_events_yearDate::Manip::Date::_events_year
0000s0sDate::Manip::Date::::_format_regexpDate::Manip::Date::_format_regexp
0000s0sDate::Manip::Date::::_holiday_objsDate::Manip::Date::_holiday_objs
0000s0sDate::Manip::Date::::_holidaysDate::Manip::Date::_holidays
0000s0sDate::Manip::Date::::_holidays_yearDate::Manip::Date::_holidays_year
0000s0sDate::Manip::Date::::_init_argsDate::Manip::Date::_init_args
0000s0sDate::Manip::Date::::_iso8601_rxDate::Manip::Date::_iso8601_rx
0000s0sDate::Manip::Date::::_other_rxDate::Manip::Date::_other_rx
0000s0sDate::Manip::Date::::_parse_checkDate::Manip::Date::_parse_check
0000s0sDate::Manip::Date::::_parse_dateDate::Manip::Date::_parse_date
0000s0sDate::Manip::Date::::_parse_date_commonDate::Manip::Date::_parse_date_common
0000s0sDate::Manip::Date::::_parse_date_iso8601Date::Manip::Date::_parse_date_iso8601
0000s0sDate::Manip::Date::::_parse_date_otherDate::Manip::Date::_parse_date_other
0000s0sDate::Manip::Date::::_parse_datetime_iso8601Date::Manip::Date::_parse_datetime_iso8601
0000s0sDate::Manip::Date::::_parse_datetime_otherDate::Manip::Date::_parse_datetime_other
0000s0sDate::Manip::Date::::_parse_deltaDate::Manip::Date::_parse_delta
0000s0sDate::Manip::Date::::_parse_dowDate::Manip::Date::_parse_dow
0000s0sDate::Manip::Date::::_parse_holidaysDate::Manip::Date::_parse_holidays
0000s0sDate::Manip::Date::::_parse_timeDate::Manip::Date::_parse_time
0000s0sDate::Manip::Date::::_parse_tzDate::Manip::Date::_parse_tz
0000s0sDate::Manip::Date::::_timeDate::Manip::Date::_time
0000s0sDate::Manip::Date::::calcDate::Manip::Date::calc
0000s0sDate::Manip::Date::::cmpDate::Manip::Date::cmp
0000s0sDate::Manip::Date::::completeDate::Manip::Date::complete
0000s0sDate::Manip::Date::::convertDate::Manip::Date::convert
0000s0sDate::Manip::Date::::holidayDate::Manip::Date::holiday
0000s0sDate::Manip::Date::::inputDate::Manip::Date::input
0000s0sDate::Manip::Date::::is_business_dayDate::Manip::Date::is_business_day
0000s0sDate::Manip::Date::::list_eventsDate::Manip::Date::list_events
0000s0sDate::Manip::Date::::list_holidaysDate::Manip::Date::list_holidays
0000s0sDate::Manip::Date::::nearest_business_dayDate::Manip::Date::nearest_business_day
0000s0sDate::Manip::Date::::nextDate::Manip::Date::next
0000s0sDate::Manip::Date::::next_business_dayDate::Manip::Date::next_business_day
0000s0sDate::Manip::Date::::parseDate::Manip::Date::parse
0000s0sDate::Manip::Date::::parse_dateDate::Manip::Date::parse_date
0000s0sDate::Manip::Date::::parse_formatDate::Manip::Date::parse_format
0000s0sDate::Manip::Date::::parse_timeDate::Manip::Date::parse_time
0000s0sDate::Manip::Date::::prevDate::Manip::Date::prev
0000s0sDate::Manip::Date::::prev_business_dayDate::Manip::Date::prev_business_day
0000s0sDate::Manip::Date::::printfDate::Manip::Date::printf
0000s0sDate::Manip::Date::::secs_since_1970_GMTDate::Manip::Date::secs_since_1970_GMT
0000s0sDate::Manip::Date::::setDate::Manip::Date::set
0000s0sDate::Manip::Date::::valueDate::Manip::Date::value
0000s0sDate::Manip::Date::::week_of_yearDate::Manip::Date::week_of_year
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Date::Manip::Date;
2# Copyright (c) 1995-2014 Sullivan Beck. All rights reserved.
3# This program is free software; you can redistribute it and/or modify it
4# under the same terms as Perl itself.
5
6########################################################################
7# Any routine that starts with an underscore (_) is NOT intended for
8# public use. They are for internal use in the the Date::Manip
9# modules and are subject to change without warning or notice.
10#
11# ABSOLUTELY NO USER SUPPORT IS OFFERED FOR THESE ROUTINES!
12########################################################################
13
142690µs16.39ms
# spent 6.39ms (1.75+4.63) within Date::Manip::Date::BEGIN@14 which was called: # once (1.75ms+4.63ms) by Date::Manip::DM6::BEGIN@62 at line 14
use Date::Manip::Obj;
# spent 6.39ms making 1 call to Date::Manip::Date::BEGIN@14
1519µs@ISA = ('Date::Manip::Obj');
16
1719µsrequire 5.010000;
18221µs219µs
# spent 14µs (9+5) within Date::Manip::Date::BEGIN@18 which was called: # once (9µs+5µs) by Date::Manip::DM6::BEGIN@62 at line 18
use warnings;
# spent 14µs making 1 call to Date::Manip::Date::BEGIN@18 # spent 5µs making 1 call to warnings::import
19218µs223µs
# spent 14µs (6+9) within Date::Manip::Date::BEGIN@19 which was called: # once (6µs+9µs) by Date::Manip::DM6::BEGIN@62 at line 19
use strict;
# spent 14µs making 1 call to Date::Manip::Date::BEGIN@19 # spent 9µs making 1 call to strict::import
20217µs28µs
# spent 7µs (6+1) within Date::Manip::Date::BEGIN@20 which was called: # once (6µs+1µs) by Date::Manip::DM6::BEGIN@62 at line 20
use integer;
# spent 7µs making 1 call to Date::Manip::Date::BEGIN@20 # spent 1µs making 1 call to integer::import
21219µs211µs
# spent 9µs (7+2) within Date::Manip::Date::BEGIN@21 which was called: # once (7µs+2µs) by Date::Manip::DM6::BEGIN@62 at line 21
use utf8;
# spent 9µs making 1 call to Date::Manip::Date::BEGIN@21 # spent 2µs making 1 call to utf8::import
22224µs2185µs
# spent 96µs (7+89) within Date::Manip::Date::BEGIN@22 which was called: # once (7µs+89µs) by Date::Manip::DM6::BEGIN@62 at line 22
use IO::File;
# spent 96µs making 1 call to Date::Manip::Date::BEGIN@22 # spent 89µs making 1 call to Exporter::import
23220µs238µs
# spent 22µs (6+16) within Date::Manip::Date::BEGIN@23 which was called: # once (6µs+16µs) by Date::Manip::DM6::BEGIN@62 at line 23
use Storable qw(dclone);
# spent 22µs making 1 call to Date::Manip::Date::BEGIN@23 # spent 16µs making 1 call to Exporter::import
24#use re 'debug';
25
262673µs121.9ms
# spent 21.9ms (10.5+11.4) within Date::Manip::Date::BEGIN@26 which was called: # once (10.5ms+11.4ms) by Date::Manip::DM6::BEGIN@62 at line 26
use Date::Manip::Base;
# spent 21.9ms making 1 call to Date::Manip::Date::BEGIN@26
2722.40ms115.4ms
# spent 15.4ms (14.7+674µs) within Date::Manip::Date::BEGIN@27 which was called: # once (14.7ms+674µs) by Date::Manip::DM6::BEGIN@62 at line 27
use Date::Manip::TZ;
# spent 15.4ms making 1 call to Date::Manip::Date::BEGIN@27
28
291100nsour $VERSION;
301300ns$VERSION='6.47';
3115µs
# spent 4µs within Date::Manip::Date::END which was called: # once (4µs+0s) by main::RUNTIME at line 131 of C4/Service.pm
END { undef $VERSION; }
32
33########################################################################
34# BASE METHODS
35########################################################################
36
37# Call this every time a new date is put in to make sure everything is
38# correctly initialized.
39#
40
# spent 22µs within Date::Manip::Date::_init which was called 3 times, avg 7µs/call: # 3 times (22µs+0s) by Date::Manip::Obj::new at line 162 of Date/Manip/Obj.pm, avg 7µs/call
sub _init {
4131µs my($self) = @_;
42
4334µs $$self{'err'} = '';
44
45324µs $$self{'data'} =
46 {
47 'set' => 0, # 1 if the date has been set
48 # 2 if the date is in the process of being set
49
50 # The date as input
51 'in' => '', # the string that was parsed (if any)
52 'zin' => '', # the timezone that was parsed (if any)
53
54 # The date in the parsed timezone
55 'date' => [], # the parsed date split
56 'def' => [0,0,0,0,0,0],
57
58 # 1 for each field that came from
59 # defaults rather than parsed
60 # '' for an implied field
61 'tz' => '', # the timezone of the date
62 'isdst' => '', # 1 if the date is in DST.
63 'offset' => [], # The offset from GMT
64 'abb' => '', # The timezone abbreviation.
65 'f' => {}, # fields used in printing a date
66
67 # The date in GMT
68 'gmt' => [], # the date converted to GMT
69
70 # The date in local timezone
71 'loc' => [], # the date converted to local timezone
72 };
73}
74
75sub _init_args {
76 my($self) = @_;
77
78 my @args = @{ $$self{'args'} };
79 if (@args) {
80 if ($#args == 0) {
81 $self->parse($args[0]);
82 } else {
83 warn "WARNING: [new] invalid arguments: @args\n";
84 }
85 }
86}
87
88sub input {
89 my($self) = @_;
90 return $$self{'data'}{'in'};
91}
92
93########################################################################
94# DATE PARSING
95########################################################################
96
97sub parse {
98 my($self,$instring,@opts) = @_;
99 $self->_init();
100 my $noupdate = 0;
101
102 if (! $instring) {
103 $$self{'err'} = '[parse] Empty date string';
104 return 1;
105 }
106
107 my %opts = map { $_,1 } @opts;
108
109 my $dmt = $$self{'tz'};
110 my $dmb = $$dmt{'base'};
111
112 my($done,$y,$m,$d,$h,$mn,$s,$tzstring,$zone,$abb,$off,$dow,$got_time,
113 $default_time,$firsterr);
114
115 ENCODING:
116 foreach my $string ($dmb->_encoding($instring)) {
117 $got_time = 0;
118 $default_time = 0;
119
120 # Put parse in a simple loop for an easy exit.
121 PARSE:
122 {
123 my(@tmp,$tmp);
124 $$self{'err'} = '';
125
126 # Check the standard date format
127
128 $tmp = $dmb->split('date',$string);
129 if (defined($tmp)) {
130 ($y,$m,$d,$h,$mn,$s) = @$tmp;
131 $got_time = 1;
132 last PARSE;
133 }
134
135 # Parse ISO 8601 dates now (which may have a timezone).
136
137 if (! exists $opts{'noiso8601'}) {
138 ($done,@tmp) = $self->_parse_datetime_iso8601($string,\$noupdate);
139 if ($done) {
140 ($y,$m,$d,$h,$mn,$s,$tzstring,$zone,$abb,$off) = @tmp;
141 $got_time = 1;
142 last PARSE;
143 }
144 }
145
146 # There's lots of ways that commas may be included. Remove
147 # them.
148
149 $string =~ s/,/ /g;
150
151 # Some special full date/time formats ('now', 'epoch')
152
153 if (! exists $opts{'nospecial'}) {
154 ($done,@tmp) = $self->_parse_datetime_other($string,\$noupdate);
155 if ($done) {
156 ($y,$m,$d,$h,$mn,$s,$tzstring,$zone,$abb,$off) = @tmp;
157 $got_time = 1;
158 last PARSE;
159 }
160 }
161
162 # Parse (and remove) the time (and an immediately following timezone).
163
164 ($got_time,@tmp) = $self->_parse_time('parse',$string,\$noupdate,%opts);
165 if ($got_time) {
166 ($string,$h,$mn,$s,$tzstring,$zone,$abb,$off) = @tmp;
167 }
168
169 if (! $string) {
170 ($y,$m,$d) = $self->_def_date($y,$m,$d,\$noupdate);
171 last;
172 }
173
174 # Parse (and remove) the day of week. Also, handle the simple DoW
175 # formats.
176
177 if (! exists $opts{'nodow'}) {
178 ($done,@tmp) = $self->_parse_dow($string,\$noupdate);
179 if (@tmp) {
180 if ($done) {
181 ($y,$m,$d) = @tmp;
182 $default_time = 1;
183 last PARSE;
184 } else {
185 ($string,$dow) = @tmp;
186 }
187 }
188 }
189 $dow = 0 if (! $dow);
190
191 # At this point, the string might contain the following dates:
192 #
193 # OTHER
194 # OTHER ZONE
195 # ZONE OTHER
196 # DELTA
197 # HOLIDAY
198 #
199 # ZONE is only allowed if it wasn't parsed with the time
200 # (and only occurs if the timezone is separate from the time).
201
202 # Other formats
203
204 {
205 my $string_bak = $string;
206
207 # Due to conflicts, we'll first try parsing the entire
208 # string as a date.
209
210 (@tmp) = $self->_parse_date($string,$dow,\$noupdate,%opts);
211 if (@tmp) {
212 ($y,$m,$d,$dow) = @tmp;
213 $default_time = 1;
214 last PARSE;
215 }
216
217 # Otherwise, we'll try parsing a timezone and then the remainder
218 # of the string.
219
220 if (! $tzstring) {
221 ($string,@tmp) = $self->_parse_tz($string,\$noupdate);
222 ($tzstring,$zone,$abb,$off) = @tmp if (@tmp);
223 last PARSE if (! $string);
224 }
225
226 if ($tzstring) {
227 (@tmp) = $self->_parse_date($string,$dow,\$noupdate,%opts);
228 if (@tmp) {
229 ($y,$m,$d,$dow) = @tmp;
230 $default_time = 1;
231 last PARSE;
232 }
233 }
234
235 # Restore the previous values if we didn't get an
236 # entire date.
237
238 $string = $string_bak;
239 }
240
241 # Parse deltas
242 #
243 # Occasionally, a delta is entered for a date (which is
244 # interpreted as the date relative to now). There can be some
245 # confusion between a date and a delta, but the most
246 # important conflicts are the ISO 8601 dates (many of which
247 # could be interpreted as a delta), but those have already
248 # been taken care of.
249 #
250 # We may have already gotten the time:
251 # 3 days ago at midnight UTC
252 # (we already stripped off the 'at midnight UTC' above).
253
254 if (! exists $opts{'nodelta'}) {
255 ($done,@tmp) =
256 $self->_parse_delta($string,$dow,$got_time,$h,$mn,$s,\$noupdate);
257 if (@tmp) {
258 ($y,$m,$d,$h,$mn,$s) = @tmp;
259 $got_time = 1;
260 $dow = '';
261 }
262 last PARSE if ($done);
263 }
264
265 # Parse holidays
266
267 unless (exists $opts{'noholidays'}) {
268 ($done,@tmp) =
269 $self->_parse_holidays($string,\$noupdate);
270 if (@tmp) {
271 ($y,$m,$d) = @tmp;
272 }
273 last PARSE if ($done);
274 }
275
276 $$self{'err'} = '[parse] Invalid date string';
277 last PARSE;
278 }
279
280 # We got an error parsing this encoding of the string. It could
281 # be that it is a genuine error, or it may be that we simply
282 # need to try a different encoding. If ALL encodings fail, we'll
283 # return the error from the first one.
284
285 if ($$self{'err'}) {
286 if (! $firsterr) {
287 $firsterr = $$self{'err'};
288 }
289 next ENCODING;
290 }
291
292 # If we didn't get an error, this is the string to use.
293
294 last ENCODING;
295 }
296
297 if ($$self{'err'}) {
298 $$self{'err'} = $firsterr;
299 return 1;
300 }
301
302 # Make sure that a time is set
303
304 if (! $got_time) {
305 if ($default_time) {
306 if ($dmb->_config('defaulttime') eq 'midnight') {
307 ($h,$mn,$s) = (0,0,0);
308 } else {
309 ($h,$mn,$s) = $dmt->_now('time',$noupdate);
310 $noupdate = 1;
311 }
312 $got_time = 1;
313 } else {
314 ($h,$mn,$s) = $self->_def_time(undef,undef,undef,\$noupdate);
315 }
316 }
317
318 $$self{'data'}{'set'} = 2;
319 return $self->_parse_check('parse',$instring,
320 $y,$m,$d,$h,$mn,$s,$dow,$tzstring,$zone,$abb,$off);
321}
322
323sub parse_time {
324 my($self,$string) = @_;
325 my $noupdate = 0;
326
327 if (! $string) {
328 $$self{'err'} = '[parse_time] Empty time string';
329 return 1;
330 }
331
332 my($y,$m,$d,$h,$mn,$s);
333
334 if ($$self{'err'}) {
335 $self->_init();
336 }
337 if ($$self{'data'}{'set'}) {
338 ($y,$m,$d,$h,$mn,$s) = @{ $$self{'data'}{'date'} };
339 } else {
340 my $dmt = $$self{'tz'};
341 ($y,$m,$d,$h,$mn,$s) = $dmt->_now('now',$noupdate);
342 $noupdate = 1;
343 }
344 my($tzstring,$zone,$abb,$off);
345
346 ($h,$mn,$s,$tzstring,$zone,$abb,$off) =
347 $self->_parse_time('parse_time',$string,\$noupdate);
348
349 return 1 if ($$self{'err'});
350
351 $$self{'data'}{'set'} = 2;
352 return $self->_parse_check('parse_time','',
353 $y,$m,$d,$h,$mn,$s,'',$tzstring,$zone,$abb,$off);
354}
355
356sub parse_date {
357 my($self,$string,@opts) = @_;
358 my %opts = map { $_,1 } @opts;
359 my $noupdate = 0;
360
361 if (! $string) {
362 $$self{'err'} = '[parse_date] Empty date string';
363 return 1;
364 }
365
366 my $dmt = $$self{'tz'};
367 my $dmb = $$dmt{'base'};
368 my($y,$m,$d,$h,$mn,$s);
369
370 if ($$self{'err'}) {
371 $self->_init();
372 }
373 if ($$self{'data'}{'set'}) {
374 ($y,$m,$d,$h,$mn,$s) = @{ $$self{'data'}{'date'} };
375 } else {
376 ($h,$mn,$s) = (0,0,0);
377 }
378
379 # Put parse in a simple loop for an easy exit.
380 my($done,@tmp,$dow);
381 PARSE:
382 {
383
384 # Parse ISO 8601 dates now
385
386 unless (exists $opts{'noiso8601'}) {
387 ($done,@tmp) = $self->_parse_date_iso8601($string,\$noupdate);
388 if ($done) {
389 ($y,$m,$d) = @tmp;
390 last PARSE;
391 }
392 }
393
394 (@tmp) = $self->_parse_date($string,undef,\$noupdate,%opts);
395 if (@tmp) {
396 ($y,$m,$d,$dow) = @tmp;
397 last PARSE;
398 }
399
400 $$self{'err'} = '[parse_date] Invalid date string';
401 return 1;
402 }
403
404 return 1 if ($$self{'err'});
405
406 $y = $dmt->_fix_year($y);
407
408 $$self{'data'}{'set'} = 2;
409 return $self->_parse_check('parse_date','',$y,$m,$d,$h,$mn,$s,$dow);
410}
411
412sub _parse_date {
413 my($self,$string,$dow,$noupdate,%opts) = @_;
414
415 # There's lots of ways that commas may be included. Remove
416 # them.
417 #
418 # Also remove some words we should ignore.
419
420 $string =~ s/,/ /g;
421
422 my $dmt = $$self{'tz'};
423 my $dmb = $$dmt{'base'};
424 my $ign = (exists $$dmb{'data'}{'rx'}{'other'}{'ignore'} ?
425 $$dmb{'data'}{'rx'}{'other'}{'ignore'} :
426 $self->_other_rx('ignore'));
427 $string =~ s/$ign/ /g;
42822.23ms1876µs
# spent 876µs (673+203) within Date::Manip::Date::BEGIN@428 which was called: # once (673µs+203µs) by Date::Manip::DM6::BEGIN@62 at line 428
my $of = $+{'of'};
# spent 876µs making 1 call to Date::Manip::Date::BEGIN@428
429
430 $string =~ s/\s*$//;
431 return () if (! $string);
432
433 my($done,$y,$m,$d,@tmp);
434
435 # Put parse in a simple loop for an easy exit.
436 PARSE:
437 {
438
439 # Parse (and remove) the day of week. Also, handle the simple DoW
440 # formats.
441
442 unless (exists $opts{'nodow'}) {
443 if (! defined($dow)) {
444 ($done,@tmp) = $self->_parse_dow($string,$noupdate);
445 if (@tmp) {
446 if ($done) {
447 ($y,$m,$d) = @tmp;
448 last PARSE;
449 } else {
450 ($string,$dow) = @tmp;
451 }
452 }
453 $dow = 0 if (! $dow);
454 }
455 }
456
457 # Parse common dates
458
459 unless (exists $opts{'nocommon'}) {
460 (@tmp) = $self->_parse_date_common($string,$noupdate);
461 if (@tmp) {
462 ($y,$m,$d) = @tmp;
463 last PARSE;
464 }
465 }
466
467 # Parse less common dates
468
469 unless (exists $opts{'noother'}) {
470 (@tmp) = $self->_parse_date_other($string,$dow,$of,$noupdate);
471 if (@tmp) {
472 ($y,$m,$d,$dow) = @tmp;
473 last PARSE;
474 }
475 }
476
477 return ();
478 }
479
480 return($y,$m,$d,$dow);
481}
482
483sub parse_format {
484 my($self,$format,$string) = @_;
485 $self->_init();
486 my $noupdate = 0;
487
488 if (! $string) {
489 $$self{'err'} = '[parse_format] Empty date string';
490 return 1;
491 }
492
493 my $dmt = $$self{'tz'};
494 my $dmb = $$dmt{'base'};
495
496 my($err,$re) = $self->_format_regexp($format);
497 return $err if ($err);
498 return 1 if ($string !~ $re);
499
500 my($y,$m,$d,$h,$mn,$s,
501 $mon_name,$mon_abb,$dow_name,$dow_abb,$dow_char,$dow_num,
502 $doy,$nth,$ampm,$epochs,$epocho,
503 $tzstring,$off,$abb,$zone,
504 $g,$w,$l,$u) =
505 @+{qw(y m d h mn s
506 mon_name mon_abb dow_name dow_abb dow_char dow_num doy
507 nth ampm epochs epocho tzstring off abb zone g w l u)};
508
509 while (1) {
510 # Get y/m/d/h/mn/s from:
511 # $epochs,$epocho
512
513 if (defined($epochs)) {
514 ($y,$m,$d,$h,$mn,$s) = @{ $dmb->secs_since_1970($epochs) };
515 my $z;
516 if ($zone) {
517 $z = $dmt->_zone($zone);
518 return 'Invalid zone' if (! $z);
519 } elsif ($abb || $off) {
520 $z = $dmt->zone($off,$abb);
521 return 'Invalid zone' if (! $z);
522 } else {
523 $z = $dmt->_now('tz',$noupdate);
524 $noupdate = 1;
525 }
526 my($err,$date) = $dmt->convert_from_gmt([$y,$m,$d,$h,$mn,$s],$z);
527 ($y,$m,$d,$h,$mn,$s) = @$date;
528 last;
529 }
530
531 if (defined($epocho)) {
532 ($y,$m,$d,$h,$mn,$s) = @{ $dmb->secs_since_1970($epocho) };
533 last;
534 }
535
536 # Get y/m/d from:
537 # $y,$m,$d,
538 # $mon_name,$mon_abb
539 # $doy,$nth
540 # $g/$w,$l/$u
541
542 if ($mon_name) {
543 $m = $$dmb{'data'}{'wordmatch'}{'month_name'}{lc($mon_name)};
544 } elsif ($mon_abb) {
545 $m = $$dmb{'data'}{'wordmatch'}{'month_abb'}{lc($mon_abb)};
546 }
547
548 if ($nth) {
549 $d = $$dmb{'data'}{'wordmatch'}{'nth'}{lc($nth)};
550 }
551
552 if ($doy) {
553 $y = $dmt->_now('y',$noupdate) if (! $y);
554 $noupdate = 1;
555 ($y,$m,$d) = @{ $dmb->day_of_year($y,$doy) };
556
557 } elsif ($g) {
558 $y = $dmt->_now('y',$noupdate) if (! $y);
559 $noupdate = 1;
560 ($y,$m,$d) = @{ $dmb->_week_of_year($g,$w,1) };
561
562 } elsif ($l) {
563 $y = $dmt->_now('y',$noupdate) if (! $y);
564 $noupdate = 1;
565 ($y,$m,$d) = @{ $dmb->_week_of_year($l,$u,7) };
566
567 } elsif ($m) {
568 ($y,$m,$d) = $self->_def_date($y,$m,$d,\$noupdate);
569 }
570
571 # Get h/mn/s from:
572 # $h,$mn,$s,$ampm
573
574 if (defined($h)) {
575 ($h,$mn,$s) = $self->_def_time($h,$mn,$s,\$noupdate);
576 }
577
578 if ($ampm) {
579 if ($$dmb{'data'}{'wordmatch'}{'ampm'}{lc($ampm)} == 2) {
580 # pm times
581 $h+=12 unless ($h==12);
582 } else {
583 # am times
584 $h=0 if ($h==12);
585 }
586 }
587
588 # Get dow from:
589 # $dow_name,$dow_abb,$dow_char,$dow_num
590
591 if ($dow_name) {
592 $dow_num = $$dmb{'data'}{'wordmatch'}{'day_name'}{lc($dow_name)};
593 } elsif ($dow_abb) {
594 $dow_num = $$dmb{'data'}{'wordmatch'}{'day_abb'}{lc($dow_abb)};
595 } elsif ($dow_char) {
596 $dow_num = $$dmb{'data'}{'wordmatch'}{'day_char'}{lc($dow_char)};
597 }
598
599 last;
600 }
601
602 if (! $m) {
603 ($y,$m,$d) = $dmt->_now('now',$noupdate);
604 $noupdate = 1;
605 }
606 if (! defined($h)) {
607 ($h,$mn,$s) = (0,0,0);
608 }
609
610 $$self{'data'}{'set'} = 2;
611 $err = $self->_parse_check('parse_format',$string,
612 $y,$m,$d,$h,$mn,$s,$dow_num,
613 $tzstring,$zone,$abb,$off);
614
615 if (wantarray) {
616 my %tmp = %{ dclone(\%+) };
617 return ($err,%tmp);
618 }
619 return $err;
620}
621
622
# spent 28µs within Date::Manip::Date::BEGIN@622 which was called: # once (28µs+0s) by Date::Manip::DM6::BEGIN@62 at line 923
BEGIN {
62316µs my %y_form = map { $_,1 } qw( Y y s o G L );
62414µs my %m_form = map { $_,1 } qw( m f b h B j s o W U );
62513µs my %d_form = map { $_,1 } qw( j d e E s o W U );
62612µs my %h_form = map { $_,1 } qw( H I k i s o );
62711µs my %mn_form = map { $_,1 } qw( M s o );
62811µs my %s_form = map { $_,1 } qw( S s o );
629
63012µs my %dow_form = map { $_,1 } qw( v a A w );
63111µs my %am_form = map { $_,1 } qw( p s o );
63212µs my %z_form = map { $_,1 } qw( Z z N );
63311µs my %mon_form = map { $_,1 } qw( b h B );
63416µs my %day_form = map { $_,1 } qw( v a A );
635
636 sub _format_regexp {
637 my($self,$format) = @_;
638 my $dmt = $$self{'tz'};
639 my $dmb = $$dmt{'base'};
640
641 if (exists $$dmb{'data'}{'format'}{$format}) {
642 return @{ $$dmb{'data'}{'format'}{$format} };
643 }
644
645 my $re;
646 my $err;
647 my($y,$m,$d,$h,$mn,$s) = (0,0,0,0,0,0);
648 my($dow,$ampm,$zone,$G,$W,$L,$U) = (0,0,0,0,0,0,0);
649
650 while ($format) {
651 last if ($format eq '%');
652
653 if ($format =~ s/^([^%]+)//) {
654 $re .= $1;
655 next;
656 }
657
658 $format =~ s/^%(.)//;
659 my $f = $1;
660
661 if (exists $y_form{$f}) {
662 if ($y) {
663 $err = 'Year specified multiple times';
664 last;
665 }
666 $y = 1;
667 }
668
669 if (exists $m_form{$f}) {
670 if ($m) {
671 $err = 'Month specified multiple times';
672 last;
673 }
674 $m = 1;
675 }
676
677 if (exists $d_form{$f}) {
678 if ($d) {
679 $err = 'Day specified multiple times';
680 last;
681 }
682 $d = 1;
683 }
684
685 if (exists $h_form{$f}) {
686 if ($h) {
687 $err = 'Hour specified multiple times';
688 last;
689 }
690 $h = 1;
691 }
692
693 if (exists $mn_form{$f}) {
694 if ($mn) {
695 $err = 'Minutes specified multiple times';
696 last;
697 }
698 $mn = 1;
699 }
700
701 if (exists $s_form{$f}) {
702 if ($s) {
703 $err = 'Seconds specified multiple times';
704 last;
705 }
706 $s = 1;
707 }
708
709 if (exists $dow_form{$f}) {
710 if ($dow) {
711 $err = 'Day-of-week specified multiple times';
712 last;
713 }
714 $dow = 1;
715 }
716
717 if (exists $am_form{$f}) {
718 if ($ampm) {
719 $err = 'AM/PM specified multiple times';
720 last;
721 }
722 $ampm = 1;
723 }
724
725 if (exists $z_form{$f}) {
726 if ($zone) {
727 $err = 'Zone specified multiple times';
728 last;
729 }
730 $zone = 1;
731 }
732
733 if ($f eq 'G') {
734 if ($G) {
735 $err = 'G specified multiple times';
736 last;
737 }
738 $G = 1;
739
740 } elsif ($f eq 'W') {
741 if ($W) {
742 $err = 'W specified multiple times';
743 last;
744 }
745 $W = 1;
746
747 } elsif ($f eq 'L') {
748 if ($L) {
749 $err = 'L specified multiple times';
750 last;
751 }
752 $L = 1;
753
754 } elsif ($f eq 'U') {
755 if ($U) {
756 $err = 'U specified multiple times';
757 last;
758 }
759 $U = 1;
760 }
761
762 ###
763
764 if ($f eq 'Y') {
765 $re .= '(?<y>\d\d\d\d)';
766
767 } elsif ($f eq 'y') {
768 $re .= '(?<y>\d\d)';
769
770 } elsif ($f eq 'm') {
771 $re .= '(?<m>\d\d)';
772
773 } elsif ($f eq 'f') {
774 $re .= '(?:(?<m>\d\d)| ?(?<m>\d))';
775
776 } elsif (exists $mon_form{$f}) {
777 my $abb = $$dmb{'data'}{'rx'}{'month_abb'}[0];
778 my $nam = $$dmb{'data'}{'rx'}{'month_name'}[0];
779 $re .= "(?:(?<mon_name>$nam)|(?<mon_abb>$abb))";
780
781 } elsif ($f eq 'j') {
782 $re .= '(?<doy>\d\d\d)';
783
784 } elsif ($f eq 'd') {
785 $re .= '(?<d>\d\d)';
786
787 } elsif ($f eq 'e') {
788 $re .= '(?:(?<d>\d\d)| ?(?<d>\d))';
789
790 } elsif (exists $day_form{$f}) {
791 my $abb = $$dmb{'data'}{'rx'}{'day_abb'}[0];
792 my $name = $$dmb{'data'}{'rx'}{'day_name'}[0];
793 my $char = $$dmb{'data'}{'rx'}{'day_char'}[0];
794 $re .= "(?:(?<dow_name>$name)|(?<dow_abb>$abb)|(?<dow_char>$char))";
795
796 } elsif ($f eq 'w') {
797 $re .= '(?<dow_num>[1-7])';
798
799 } elsif ($f eq 'E') {
800 my $nth = $$dmb{'data'}{'rx'}{'nth'}[0];
801 $re .= "(?<nth>$nth)"
802
803 } elsif ($f eq 'H' || $f eq 'I') {
804 $re .= '(?<h>\d\d)';
805
806 } elsif ($f eq 'k' || $f eq 'i') {
807 $re .= '(?:(?<h>\d\d)| ?(?<h>\d))';
808
809 } elsif ($f eq 'p') {
810 my $ampm = $$dmb{data}{rx}{ampm}[0];
811 $re .= "(?<ampm>$ampm)";
812
813 } elsif ($f eq 'M') {
814 $re .= '(?<mn>\d\d)';
815
816 } elsif ($f eq 'S') {
817 $re .= '(?<s>\d\d)';
818
819 } elsif (exists $z_form{$f}) {
820 $re .= $dmt->_zrx();
821
822 } elsif ($f eq 's') {
823 $re .= '(?<epochs>\d+)';
824
825 } elsif ($f eq 'o') {
826 $re .= '(?<epocho>\d+)';
827
828 } elsif ($f eq 'G') {
829 $re .= '(?<g>\d\d\d\d)';
830
831 } elsif ($f eq 'W') {
832 $re .= '(?<w>\d\d)';
833
834 } elsif ($f eq 'L') {
835 $re .= '(?<l>\d\d\d\d)';
836
837 } elsif ($f eq 'U') {
838 $re .= '(?<u>\d\d)';
839
840 } elsif ($f eq 'c') {
841 $format = '%a %b %e %H:%M:%S %Y' . $format;
842
843 } elsif ($f eq 'C' || $f eq 'u') {
844 $format = '%a %b %e %H:%M:%S %Z %Y' . $format;
845
846 } elsif ($f eq 'g') {
847 $format = '%a, %d %b %Y %H:%M:%S %Z' . $format;
848
849 } elsif ($f eq 'D') {
850 $format = '%m/%d/%y' . $format;
851
852 } elsif ($f eq 'r') {
853 $format = '%I:%M:%S %p' . $format;
854
855 } elsif ($f eq 'R') {
856 $format = '%H:%M' . $format;
857
858 } elsif ($f eq 'T' || $f eq 'X') {
859 $format = '%H:%M:%S' . $format;
860
861 } elsif ($f eq 'V') {
862 $format = '%m%d%H%M%y' . $format;
863
864 } elsif ($f eq 'Q') {
865 $format = '%Y%m%d' . $format;
866
867 } elsif ($f eq 'q') {
868 $format = '%Y%m%d%H%M%S' . $format;
869
870 } elsif ($f eq 'P') {
871 $format = '%Y%m%d%H:%M:%S' . $format;
872
873 } elsif ($f eq 'O') {
874 $format = '%Y\\-%m\\-%dT%H:%M:%S' . $format;
875
876 } elsif ($f eq 'F') {
877 $format = '%A, %B %e, %Y' . $format;
878
879 } elsif ($f eq 'K') {
880 $format = '%Y-%j' . $format;
881
882 } elsif ($f eq 'J') {
883 $format = '%G-W%W-%w' . $format;
884
885 } elsif ($f eq 'x') {
886 if ($dmb->_config('dateformat') eq 'US') {
887 $format = '%m/%d/%y' . $format;
888 } else {
889 $format = '%d/%m/%y' . $format;
890 }
891
892 } elsif ($f eq 't') {
893 $re .= "\t";
894
895 } elsif ($f eq '%') {
896 $re .= '%';
897
898 } elsif ($f eq '+') {
899 $re .= '\\+';
900 }
901 }
902
903 if ($m != $d) {
904 $err = 'Date not fully specified';
905 } elsif ( ($h || $mn || $s) && (! $h || ! $mn) ) {
906 $err = 'Time not fully specified';
907 } elsif ($ampm && ! $h) {
908 $err = 'Time not fully specified';
909 } elsif ($G != $W) {
910 $err = 'G/W must both be specified';
911 } elsif ($L != $U) {
912 $err = 'L/U must both be specified';
913 }
914
915 if ($err) {
916 $$dmb{'data'}{'format'}{$format} = [$err];
917 return ($err);
918 }
919
920 $$dmb{'data'}{'format'}{$format} = [0, qr/$re/i];
921 return @{ $$dmb{'data'}{'format'}{$format} };
922 }
92311.11ms128µs}
# spent 28µs making 1 call to Date::Manip::Date::BEGIN@622
924
925########################################################################
926# DATE FORMATS
927########################################################################
928
929sub _parse_check {
930 my($self,$caller,$instring,
931 $y,$m,$d,$h,$mn,$s,$dow,$tzstring,$zone,$abb,$off) = @_;
932 my $dmt = $$self{'tz'};
933 my $dmb = $$dmt{'base'};
934
935 # Check day_of_week for validity BEFORE converting 24:00:00 to the
936 # next day
937
938 if ($dow) {
939 my $tmp = $dmb->day_of_week([$y,$m,$d]);
940 if ($tmp != $dow) {
941 $$self{'err'} = "[$caller] Day of week invalid";
942 return 1;
943 }
944 }
945
946 # Handle 24:00:00 times.
947
948 if ($h == 24) {
949 ($h,$mn,$s) = (0,0,0);
950 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],1) };
951 }
952
953 if (! $dmb->check([$y,$m,$d,$h,$mn,$s])) {
954 $$self{'err'} = "[$caller] Invalid date";
955 return 1;
956 }
957
958 # Interpret timezone information and check that date is valid
959 # in the timezone.
960
961 my ($zonename,$isdst);
962 if (defined($zone)) {
963 $zonename = $dmt->_zone($zone);
964
965 if (! $zonename) {
966 $$self{'err'} = "[$caller] Unable to determine timezone: $zone";
967 return 1;
968 }
969
970 } elsif (defined($abb) || defined($off)) {
971 my (@tmp,$err);
972 push(@tmp,[$y,$m,$d,$h,$mn,$s]);
973 push(@tmp,$off) if (defined $off);
974 push(@tmp,$abb) if (defined $abb);
975 $zonename = $dmt->zone(@tmp);
976
977 if (! $zonename) {
978 $$self{'err'} = 'Unable to determine timezone';
979 return 1;
980 }
981
982 # Figure out $isdst from $abb/$off (for everything else, we'll
983 # try both values).
984
985 if (defined $off || defined $abb) {
986 my @off = @{ $dmb->split('offset',$off) } if (defined($off));
987 my $err = 1;
988 foreach my $i (0,1) {
989 my $per = $dmt->date_period([$y,$m,$d,$h,$mn,$s],$zonename,1,$i);
990 next if (! $per);
991 my $a = $$per[4];
992 my $o = $$per[3];
993 if (defined $abb && lc($a) eq lc($abb)) {
994 $err = 0;
995 $isdst = $i;
996 $abb = $a;
997 last;
998 }
999 if (defined ($off)) {
1000 if ($off[0] == $$o[0] &&
1001 $off[1] == $$o[1] &&
1002 $off[2] == $$o[2]) {
1003 $err = 0;
1004 $isdst = $i;
1005 last;
1006 }
1007 }
1008 }
1009 if ($err) {
1010 $$self{'err'} = 'Invalid timezone';
1011 return 1;
1012 }
1013 }
1014
1015 } else {
1016 $zonename = $dmt->_now('tz');
1017 }
1018
1019 # Store the date
1020
1021 $self->set('zdate',$zonename,[$y,$m,$d,$h,$mn,$s],$isdst);
1022 return 1 if ($$self{'err'});
1023
1024 $$self{'data'}{'in'} = $instring;
1025 $$self{'data'}{'zin'} = $zone if (defined($zone));
1026
1027 return 0;
1028}
1029
1030# Set up the regular expressions for ISO 8601 parsing. Returns the
1031# requested regexp. $rx can be:
1032# cdate : regular expression for a complete date
1033# tdate : regular expression for a truncated date
1034# ctime : regular expression for a complete time
1035# ttime : regular expression for a truncated time
1036# date : regular expression for a date only
1037# time : regular expression for a time only
1038# UNDEF : regular expression for a valid date and/or time
1039#
1040# Date matches are:
1041# y m d doy w dow yod c
1042# Time matches are:
1043# h h24 mn s fh fm
1044#
1045sub _iso8601_rx {
1046 my($self,$rx) = @_;
1047 my $dmt = $$self{'tz'};
1048 my $dmb = $$dmt{'base'};
1049
1050 return $$dmb{'data'}{'rx'}{'iso'}{$rx}
1051 if (exists $$dmb{'data'}{'rx'}{'iso'}{$rx});
1052
1053 if ($rx eq 'cdate' || $rx eq 'tdate') {
1054
1055 my $y4 = '(?<y>\d\d\d\d)';
1056 my $y2 = '(?<y>\d\d)';
1057 my $m = '(?<m>0[1-9]|1[0-2])';
1058 my $d = '(?<d>0[1-9]|[12][0-9]|3[01])';
1059 my $doy = '(?<doy>00[1-9]|0[1-9][0-9]|[1-2][0-9][0-9]|3[0-5][0-9]|36[0-6])';
1060 my $w = '(?<w>0[1-9]|[1-4][0-9]|5[0-3])';
1061 my $dow = '(?<dow>[1-7])';
1062 my $yod = '(?<yod>\d)';
1063 my $cc = '(?<c>\d\d)';
1064
1065 my $cdaterx =
1066 "${y4}${m}${d}|" . # CCYYMMDD
1067 "${y4}\\-${m}\\-${d}|" . # CCYY-MM-DD
1068 "\\-${y2}${m}${d}|" . # -YYMMDD
1069 "\\-${y2}\\-${m}\\-${d}|" . # -YY-MM-DD
1070 "\\-?${y2}${m}${d}|" . # YYMMDD
1071 "\\-?${y2}\\-${m}\\-${d}|" . # YY-MM-DD
1072 "\\-\\-${m}\\-?${d}|" . # --MM-DD --MMDD
1073 "\\-\\-\\-${d}|" . # ---DD
1074
1075 "${y4}\\-?${doy}|" . # CCYY-DoY CCYYDoY
1076 "\\-?${y2}\\-?${doy}|" . # YY-DoY -YY-DoY
1077 # YYDoY -YYDoY
1078 "\\-${doy}|" . # -DoY
1079
1080 "${y4}W${w}${dow}|" . # CCYYWwwD
1081 "${y4}\\-W${w}\\-${dow}|" . # CCYY-Www-D
1082 "\\-?${y2}W${w}${dow}|" . # YYWwwD -YYWwwD
1083 "\\-?${y2}\\-W${w}\\-${dow}|" . # YY-Www-D -YY-Www-D
1084
1085 "\\-?${yod}W${w}${dow}|" . # YWwwD -YWwwD
1086 "\\-?${yod}\\-W${w}\\-${dow}|" . # Y-Www-D -Y-Www-D
1087 "\\-W${w}\\-?${dow}|" . # -Www-D -WwwD
1088 "\\-W\\-${dow}|" . # -W-D
1089 "\\-\\-\\-${dow}"; # ---D
1090 $cdaterx = qr/(?:$cdaterx)/i;
1091
1092 my $tdaterx =
1093 "${y4}\\-${m}|" . # CCYY-MM
1094 "${y4}|" . # CCYY
1095 "\\-${y2}\\-?${m}|" . # -YY-MM -YYMM
1096 "\\-${y2}|" . # -YY
1097 "\\-\\-${m}|" . # --MM
1098
1099 "${y4}\\-?W${w}|" . # CCYYWww CCYY-Www
1100 "\\-?${y2}\\-?W${w}|" . # YY-Www YYWww
1101 # -YY-Www -YYWww
1102 "\\-?W${w}|" . # -Www Www
1103
1104 "${cc}"; # CC
1105 $tdaterx = qr/(?:$tdaterx)/i;
1106
1107 $$dmb{'data'}{'rx'}{'iso'}{'cdate'} = $cdaterx;
1108 $$dmb{'data'}{'rx'}{'iso'}{'tdate'} = $tdaterx;
1109
1110 } elsif ($rx eq 'ctime' || $rx eq 'ttime') {
1111
1112 my $hh = '(?<h>[0-1][0-9]|2[0-3])';
1113 my $mn = '(?<mn>[0-5][0-9])';
1114 my $ss = '(?<s>[0-5][0-9])';
1115 my $h24a = '(?<h24>24(?::00){0,2})';
1116 my $h24b = '(?<h24>24(?:00){0,2})';
1117 my $h = '(?<h>[0-9])';
1118
1119 my $fh = '(?:[\.,](?<fh>\d*))'; # fractional hours (keep)
1120 my $fm = '(?:[\.,](?<fm>\d*))'; # fractional seconds (keep)
1121 my $fs = '(?:[\.,]\d*)'; # fractional hours (discard)
1122
1123 my $zrx = $dmt->_zrx();
1124
1125 my $ctimerx =
1126 "${hh}${mn}${ss}${fs}?|" . # HHMNSS[,S+]
1127 "${hh}:${mn}:${ss}${fs}?|" . # HH:MN:SS[,S+]
1128 "${hh}:?${mn}${fm}|" . # HH:MN,M+ HHMN,M+
1129 "${hh}${fh}|" . # HH,H+
1130 "\\-${mn}:?${ss}${fs}?|" . # -MN:SS[,S+] -MNSS[,S+]
1131 "\\-${mn}${fm}|" . # -MN,M+
1132 "\\-\\-${ss}${fs}?|" . # --SS[,S+]
1133 "${hh}:?${mn}|" . # HH:MN HHMN
1134 "${h24a}|" . # 24:00:00 24:00 24
1135 "${h24b}|" . # 240000 2400
1136 "${h}:${mn}:${ss}${fs}?|" . # H:MN:SS[,S+]
1137 "${h}:${mn}${fm}"; # H:MN,M+
1138 $ctimerx = qr/(?:$ctimerx)(?:\s*$zrx)?/;
1139
1140 my $ttimerx =
1141 "${hh}|" . # HH
1142 "\\-${mn}"; # -MN
1143 $ttimerx = qr/(?:$ttimerx)/;
1144
1145 $$dmb{'data'}{'rx'}{'iso'}{'ctime'} = $ctimerx;
1146 $$dmb{'data'}{'rx'}{'iso'}{'ttime'} = $ttimerx;
1147
1148 } elsif ($rx eq 'date') {
1149
1150 my $cdaterx = $self->_iso8601_rx('cdate');
1151 my $tdaterx = $self->_iso8601_rx('tdate');
1152 $$dmb{'data'}{'rx'}{'iso'}{'date'} = qr/(?:$cdaterx|$tdaterx)/;
1153
1154 } elsif ($rx eq 'time') {
1155
1156 my $ctimerx = $self->_iso8601_rx('ctime');
1157 my $ttimerx = $self->_iso8601_rx('ttime');
1158 $$dmb{'data'}{'rx'}{'iso'}{'time'} = qr/(?:$ctimerx|$ttimerx)/;
1159
1160 } elsif ($rx eq 'fulldate') {
1161
1162 # A parseable string contains:
1163 # a complete date and complete time
1164 # a complete date and truncated time
1165 # a truncated date
1166 # a complete time
1167 # a truncated time
1168
1169 # If the string contains both a time and date, they may be adjacent
1170 # or separated by:
1171 # whitespace
1172 # T (which must be followed by a number)
1173 # a dash
1174
1175 my $cdaterx = $self->_iso8601_rx('cdate');
1176 my $tdaterx = $self->_iso8601_rx('tdate');
1177 my $ctimerx = $self->_iso8601_rx('ctime');
1178 my $ttimerx = $self->_iso8601_rx('ttime');
1179
1180 my $sep = qr/(?:T|\-|\s*)/i;
1181
1182 my $daterx = qr/^\s*(?: $cdaterx(?:$sep(?:$ctimerx|$ttimerx))? |
1183 $tdaterx |
1184 $ctimerx |
1185 $ttimerx
1186 )\s*$/x;
1187
1188 $$dmb{'data'}{'rx'}{'iso'}{'fulldate'} = $daterx;
1189 }
1190
1191 return $$dmb{'data'}{'rx'}{'iso'}{$rx};
1192}
1193
1194sub _parse_datetime_iso8601 {
1195 my($self,$string,$noupdate) = @_;
1196 my $dmt = $$self{'tz'};
1197 my $dmb = $$dmt{'base'};
1198 my $daterx = $self->_iso8601_rx('fulldate');
1199
1200 my($y,$m,$d,$h,$mn,$s,$tzstring,$zone,$abb,$off);
1201 my($doy,$dow,$yod,$c,$w,$fh,$fm,$h24);
1202
1203 if ($string =~ $daterx) {
1204 ($y,$m,$d,$h,$mn,$s,$doy,$dow,$yod,$c,$w,$fh,$fm,$h24,
1205 $tzstring,$zone,$abb,$off) =
1206 @+{qw(y m d h mn s doy dow yod c w fh fm h24 tzstring zone abb off)};
1207
1208 if (defined $w || defined $dow) {
1209 ($y,$m,$d) = $self->_def_date_dow($y,$w,$dow,$noupdate);
1210 } elsif (defined $doy) {
1211 ($y,$m,$d) = $self->_def_date_doy($y,$doy,$noupdate);
1212 } else {
1213 $y = $c . '00' if (defined $c);
1214 ($y,$m,$d) = $self->_def_date($y,$m,$d,$noupdate);
1215 }
1216
1217 ($h,$mn,$s) = $self->_time($h,$mn,$s,$fh,$fm,$h24,undef,$noupdate);
1218 } else {
1219 return (0);
1220 }
1221
1222 return (1,$y,$m,$d,$h,$mn,$s,$tzstring,$zone,$abb,$off);
1223}
1224
1225sub _parse_date_iso8601 {
1226 my($self,$string,$noupdate) = @_;
1227 my $dmt = $$self{'tz'};
1228 my $dmb = $$dmt{'base'};
1229 my $daterx = $self->_iso8601_rx('date');
1230
1231 my($y,$m,$d);
1232 my($doy,$dow,$yod,$c,$w);
1233
1234 if ($string =~ /^$daterx$/) {
1235 ($y,$m,$d,$doy,$dow,$yod,$c,$w) =
1236 @+{qw(y m d doy dow yod c w)};
1237
1238 if (defined $w || defined $dow) {
1239 ($y,$m,$d) = $self->_def_date_dow($y,$w,$dow,$noupdate);
1240 } elsif (defined $doy) {
1241 ($y,$m,$d) = $self->_def_date_doy($y,$doy,$noupdate);
1242 } else {
1243 $y = $c . '00' if (defined $c);
1244 ($y,$m,$d) = $self->_def_date($y,$m,$d,$noupdate);
1245 }
1246 } else {
1247 return (0);
1248 }
1249
1250 return (1,$y,$m,$d);
1251}
1252
1253# Handle all of the time fields.
1254#
12552165µs217µs
# spent 15µs (13+2) within Date::Manip::Date::BEGIN@1255 which was called: # once (13µs+2µs) by Date::Manip::DM6::BEGIN@62 at line 1255
no integer;
# spent 15µs making 1 call to Date::Manip::Date::BEGIN@1255 # spent 2µs making 1 call to integer::unimport
1256sub _time {
1257 my($self,$h,$mn,$s,$fh,$fm,$h24,$ampm,$noupdate) = @_;
1258
1259 if (defined($ampm) && $ampm) {
1260 my $dmt = $$self{'tz'};
1261 my $dmb = $$dmt{'base'};
1262 if ($$dmb{'data'}{'wordmatch'}{'ampm'}{lc($ampm)} == 2) {
1263 # pm times
1264 $h+=12 unless ($h==12);
1265 } else {
1266 # am times
1267 $h=0 if ($h==12);
1268 }
1269 }
1270
1271 if (defined $h24) {
1272 return(24,0,0);
1273 } elsif (defined $fh && $fh ne "") {
1274 $fh = "0.$fh";
1275 $s = int($fh * 3600);
1276 $mn = int($s/60);
1277 $s -= $mn*60;
1278 } elsif (defined $fm && $fm ne "") {
1279 $fm = "0.$fm";
1280 $s = int($fm*60);
1281 }
1282 ($h,$mn,$s) = $self->_def_time($h,$mn,$s,$noupdate);
1283 return($h,$mn,$s);
1284}
128525.80ms211µs
# spent 9µs (7+2) within Date::Manip::Date::BEGIN@1285 which was called: # once (7µs+2µs) by Date::Manip::DM6::BEGIN@62 at line 1285
use integer;
# spent 9µs making 1 call to Date::Manip::Date::BEGIN@1285 # spent 2µs making 1 call to integer::import
1286
1287# Set up the regular expressions for other date and time formats. Returns the
1288# requested regexp.
1289#
1290sub _other_rx {
1291 my($self,$rx) = @_;
1292 my $dmt = $$self{'tz'};
1293 my $dmb = $$dmt{'base'};
1294 $rx = '_' if (! defined $rx);
1295
1296 if ($rx eq 'time') {
1297
1298 my $h24 = '(?<h>2[0-3]|1[0-9]|0?[0-9])'; # 0-23 00-23
1299 my $h12 = '(?<h>1[0-2]|0?[1-9])'; # 1-12 01-12
1300 my $mn = '(?<mn>[0-5][0-9])'; # 00-59
1301 my $ss = '(?<s>[0-5][0-9])'; # 00-59
1302
1303 # how to express fractions
1304
1305 my($f1,$f2,$sepfr);
1306 if (exists $$dmb{'data'}{'rx'}{'sepfr'} &&
1307 $$dmb{'data'}{'rx'}{'sepfr'}) {
1308 $sepfr = $$dmb{'data'}{'rx'}{'sepfr'};
1309 } else {
1310 $sepfr = '';
1311 }
1312
1313 if ($sepfr) {
1314 $f1 = "(?:[.,]|$sepfr)";
1315 $f2 = "(?:[.,:]|$sepfr)";
1316 } else {
1317 $f1 = "[.,]";
1318 $f2 = "[.,:]";
1319 }
1320 my $fh = "(?:$f1(?<fh>\\d*))"; # fractional hours (keep)
1321 my $fm = "(?:$f1(?<fm>\\d*))"; # fractional minutes (keep)
1322 my $fs = "(?:$f2\\d*)"; # fractional seconds
1323
1324 # AM/PM
1325
1326 my($ampm);
1327 if (exists $$dmb{'data'}{'rx'}{'ampm'}) {
1328 $ampm = "(?:\\s*(?<ampm>$$dmb{data}{rx}{ampm}[0]))";
1329 }
1330
1331 # H:MN and MN:S separators
1332
1333 my @hm = ("\Q:\E");
1334 my @ms = ("\Q:\E");
1335 if ($dmb->_config('periodtimesep')) {
1336 push(@hm,"\Q.\E");
1337 push(@ms,"\Q.\E");
1338 }
1339 if (exists $$dmb{'data'}{'rx'}{'sephm'} &&
1340 defined $$dmb{'data'}{'rx'}{'sephm'} &&
1341 exists $$dmb{'data'}{'rx'}{'sepms'} &&
1342 defined $$dmb{'data'}{'rx'}{'sepms'}) {
1343 push(@hm,@{ $$dmb{'data'}{'rx'}{'sephm'} });
1344 push(@ms,@{ $$dmb{'data'}{'rx'}{'sepms'} });
1345 }
1346
1347 # How to express the time
1348 # matches = (H, FH, MN, FMN, S, AM, TZSTRING, ZONE, ABB, OFF, ABB)
1349
1350 my $timerx;
1351
1352 for (my $i=0; $i<=$#hm; $i++) {
1353 my $hm = $hm[$i];
1354 my $ms = $ms[$i];
1355 $timerx .= "${h12}$hm${mn}$ms${ss}${fs}?${ampm}?|" # H12:MN:SS[,S+] [AM]
1356 if ($ampm);
1357 $timerx .= "${h24}$hm${mn}$ms${ss}${fs}?|" . # H24:MN:SS[,S+]
1358 "(?<h>24)$hm(?<mn>00)$ms(?<s>00)|"; # 24:00:00
1359 }
1360 for (my $i=0; $i<=$#hm; $i++) {
1361 my $hm = $hm[$i];
1362 my $ms = $ms[$i];
1363 $timerx .= "${h12}$hm${mn}${fm}${ampm}?|" # H12:MN,M+ [AM]
1364 if ($ampm);
1365 $timerx .= "${h24}$hm${mn}${fm}|"; # H24:MN,M+
1366 }
1367 for (my $i=0; $i<=$#hm; $i++) {
1368 my $hm = $hm[$i];
1369 my $ms = $ms[$i];
1370 $timerx .= "${h12}$hm${mn}${ampm}?|" # H12:MN [AM]
1371 if ($ampm);
1372 $timerx .= "${h24}$hm${mn}|" . # H24:MN
1373 "(?<h>24)$hm(?<mn>00)|"; # 24:00
1374 }
1375 $timerx .= "${h12}${fh}${ampm}?|" # H12,H+ [AM]
1376 if ($ampm);
1377 $timerx .= "${h24}${fh}|"; # H24,H+
1378
1379 $timerx .= "${h12}${ampm}|" if ($ampm); # H12 AM
1380 chop($timerx); # remove trailing pipe
1381
1382 my $zrx = $dmt->_zrx();
1383 my $at = $$dmb{'data'}{'rx'}{'at'};
1384 my $atrx = qr/(?:^|\s+)(?:$at)\s+/;
1385 $timerx = qr/(?:$atrx|^|\s+)(?:$timerx)(?:\s*$zrx)?(?:\s+|$)/i;
1386
1387 $$dmb{'data'}{'rx'}{'other'}{$rx} = $timerx;
1388
1389 } elsif ($rx eq 'common_1') {
1390
1391 # These are of the format M/D/Y
1392
1393 # Do NOT replace <m> and <d> with a regular expression to
1394 # match 1-12 since the DateFormat config may reverse the two.
1395 my $y4 = '(?<y>\d\d\d\d)';
1396 my $y2 = '(?<y>\d\d)';
1397 my $m = '(?<m>\d\d?)';
1398 my $d = '(?<d>\d\d?)';
1399 my $sep = '(?<sep>[\s\.\/\-])';
1400
1401 my $daterx =
1402 "${m}${sep}${d}\\k<sep>$y4|" . # M/D/YYYY
1403 "${m}${sep}${d}\\k<sep>$y2|" . # M/D/YY
1404 "${m}${sep}${d}"; # M/D
1405
1406 $daterx = qr/^\s*(?:$daterx)\s*$/;
1407 $$dmb{'data'}{'rx'}{'other'}{$rx} = $daterx;
1408
1409 } elsif ($rx eq 'common_2') {
1410
1411 my $abb = $$dmb{'data'}{'rx'}{'month_abb'}[0];
1412 my $nam = $$dmb{'data'}{'rx'}{'month_name'}[0];
1413
1414 my $y4 = '(?<y>\d\d\d\d)';
1415 my $y2 = '(?<y>\d\d)';
1416 my $m = '(?<m>\d\d?)';
1417 my $d = '(?<d>\d\d?)';
1418 my $dd = '(?<d>\d\d)';
1419 my $mmm = "(?:(?<mmm>$abb)|(?<month>$nam))";
1420 my $sep = '(?<sep>[\s\.\/\-])';
1421
1422 my $daterx =
1423 "${y4}${sep}${m}\\k<sep>$d|" . # YYYY/M/D
1424
1425 "${mmm}\\s*${dd}\\s*${y4}|" . # mmmDDYYYY
1426 "${mmm}\\s*${dd}\\s*${y2}|" . # mmmDDYY
1427 "${mmm}\\s*${d}|" . # mmmD
1428 "${d}\\s*${mmm}\\s*${y4}|" . # DmmmYYYY
1429 "${d}\\s*${mmm}\\s*${y2}|" . # DmmmYY
1430 "${d}\\s*${mmm}|" . # Dmmm
1431 "${y4}\\s*${mmm}\\s*${d}|" . # YYYYmmmD
1432
1433 "${mmm}${sep}${d}\\k<sep>${y4}|" . # mmm/D/YYYY
1434 "${mmm}${sep}${d}\\k<sep>${y2}|" . # mmm/D/YY
1435 "${mmm}${sep}${d}|" . # mmm/D
1436 "${d}${sep}${mmm}\\k<sep>${y4}|" . # D/mmm/YYYY
1437 "${d}${sep}${mmm}\\k<sep>${y2}|" . # D/mmm/YY
1438 "${d}${sep}${mmm}|" . # D/mmm
1439 "${y4}${sep}${mmm}\\k<sep>${d}|" . # YYYY/mmm/D
1440
1441 "${mmm}${sep}?${d}\\s+${y2}|" . # mmmD YY mmm/D YY
1442 "${mmm}${sep}?${d}\\s+${y4}|" . # mmmD YYYY mmm/D YYYY
1443 "${d}${sep}?${mmm}\\s+${y2}|" . # Dmmm YY D/mmm YY
1444 "${d}${sep}?${mmm}\\s+${y4}|" . # Dmmm YYYY D/mmm YYYY
1445
1446 "${y2}\\s+${mmm}${sep}?${d}|" . # YY mmmD YY mmm/D
1447 "${y4}\\s+${mmm}${sep}?${d}|" . # YYYY mmmD YYYY mmm/D
1448 "${y2}\\s+${d}${sep}?${mmm}|" . # YY Dmmm YY D/mmm
1449 "${y4}\\s+${d}${sep}?${mmm}|" . # YYYY Dmmm YYYY D/mmm
1450
1451 "${y4}:${m}:${d}"; # YYYY:MM:DD
1452
1453 $daterx = qr/^\s*(?:$daterx)\s*$/i;
1454 $$dmb{'data'}{'rx'}{'other'}{$rx} = $daterx;
1455
1456 } elsif ($rx eq 'dow') {
1457
1458 my $day_abb = $$dmb{'data'}{'rx'}{'day_abb'}[0];
1459 my $day_name = $$dmb{'data'}{'rx'}{'day_name'}[0];
1460
1461 my $on = $$dmb{'data'}{'rx'}{'on'};
1462 my $onrx = qr/(?:^|\s+)(?:$on)\s+/;
1463 my $dowrx = qr/(?:$onrx|^|\s+)(?<dow>$day_name|$day_abb)($|\s+)/i;
1464
1465 $$dmb{'data'}{'rx'}{'other'}{$rx} = $dowrx;
1466
1467 } elsif ($rx eq 'ignore') {
1468
1469 my $of = $$dmb{'data'}{'rx'}{'of'};
1470
1471 my $ignrx = qr/(?:^|\s+)(?<of>$of)(\s+|$)/;
1472 $$dmb{'data'}{'rx'}{'other'}{$rx} = $ignrx;
1473
1474 } elsif ($rx eq 'miscdatetime') {
1475
1476 my $special = $$dmb{'data'}{'rx'}{'offset_time'}[0];
1477
1478 $special = "(?<special>$special)";
1479 my $secs = "(?<epoch>[-+]?\\d+)";
1480 my $abb = $$dmb{'data'}{'rx'}{'month_abb'}[0];
1481 my $mmm = "(?<mmm>$abb)";
1482 my $y4 = '(?<y>\d\d\d\d)';
1483 my $dd = '(?<d>\d\d)';
1484 my $h24 = '(?<h>2[0-3]|[01][0-9])'; # 00-23
1485 my $mn = '(?<mn>[0-5][0-9])'; # 00-59
1486 my $ss = '(?<s>[0-5][0-9])'; # 00-59
1487 my $offrx = $dmt->_offrx('simple');
1488
1489 my $daterx =
1490 "${special}|" . # now
1491
1492 "epoch\\s+$secs|" . # epoch SECS
1493
1494 "${dd}\\/${mmm}\\/${y4}:${h24}:${mn}:${ss}\\s*${offrx}";
1495 # Common log format: 10/Oct/2000:13:55:36 -0700
1496
1497 $daterx = qr/^\s*(?:$daterx)\s*$/i;
1498 $$dmb{'data'}{'rx'}{'other'}{$rx} = $daterx;
1499
1500 } elsif ($rx eq 'misc') {
1501
1502 my $abb = $$dmb{'data'}{'rx'}{'month_abb'}[0];
1503 my $nam = $$dmb{'data'}{'rx'}{'month_name'}[0];
1504 my $next = $$dmb{'data'}{'rx'}{'nextprev'}[0];
1505 my $last = $$dmb{'data'}{'rx'}{'last'};
1506 my $yf = $$dmb{data}{rx}{fields}[1];
1507 my $mf = $$dmb{data}{rx}{fields}[2];
1508 my $wf = $$dmb{data}{rx}{fields}[3];
1509 my $df = $$dmb{data}{rx}{fields}[4];
1510 my $nth = $$dmb{'data'}{'rx'}{'nth'}[0];
1511 my $nth_wom = $$dmb{'data'}{'rx'}{'nth_wom'}[0];
1512 my $special = $$dmb{'data'}{'rx'}{'offset_date'}[0];
1513
1514 my $y = '(?:(?<y>\d\d\d\d)|(?<y>\d\d))';
1515 my $mmm = "(?:(?<mmm>$abb)|(?<month>$nam))";
1516 $next = "(?<next>$next)";
1517 $last = "(?<last>$last)";
1518 $yf = "(?<field_y>$yf)";
1519 $mf = "(?<field_m>$mf)";
1520 $wf = "(?<field_w>$wf)";
1521 $df = "(?<field_d>$df)";
1522 my $fld = "(?:$yf|$mf|$wf)";
1523 $nth = "(?<nth>$nth)";
1524 $nth_wom = "(?<nth>$nth_wom)";
1525 $special = "(?<special>$special)";
1526
1527 my $daterx =
1528 "${mmm}\\s+${nth}\\s*$y?|" . # Dec 1st [1970]
1529 "${nth}\\s+${mmm}\\s*$y?|" . # 1st Dec [1970]
1530 "$y\\s+${mmm}\\s+${nth}|" . # 1970 Dec 1st
1531 "$y\\s+${nth}\\s+${mmm}|" . # 1970 1st Dec
1532
1533 "${next}\\s+${fld}|" . # next year, next month, next week
1534 "${next}|" . # next friday
1535
1536 "${last}\\s+${mmm}\\s*$y?|" . # last friday in october 95
1537 "${last}\\s+${df}\\s+${mmm}\\s*$y?|" .
1538 # last day in october 95
1539 "${last}\\s*$y?|" . # last friday in 95
1540
1541 "${nth_wom}\\s+${mmm}\\s*$y?|" .
1542 # nth DoW in MMM [YYYY]
1543 "${nth}\\s*$y?|" . # nth DoW in [YYYY]
1544
1545 "${nth}\\s+$df\\s+${mmm}\\s*$y?|" .
1546 # nth day in MMM [YYYY]
1547
1548 "${nth}\\s+${wf}\\s*$y?|" . # DoW Nth week [YYYY]
1549 "${wf}\\s+(?<n>\\d+)\\s*$y?|" . # DoW week N [YYYY]
1550
1551 "${special}|" . # today, tomorrow
1552 "${special}\\s+${wf}|" . # today week
1553 # British: same as 1 week from today
1554
1555 "${nth}|" . # nth
1556
1557 "${wf}"; # monday week
1558 # British: same as 'in 1 week on monday'
1559
1560 $daterx = qr/^\s*(?:$daterx)\s*$/i;
1561 $$dmb{'data'}{'rx'}{'other'}{$rx} = $daterx;
1562
1563 }
1564
1565 return $$dmb{'data'}{'rx'}{'other'}{$rx};
1566}
1567
1568sub _parse_time {
1569 my($self,$caller,$string,$noupdate,%opts) = @_;
1570 my $dmt = $$self{'tz'};
1571 my $dmb = $$dmt{'base'};
1572
1573 # Make time substitutions (i.e. noon => 12:00:00)
1574
1575 unless (exists $opts{'noother'}) {
1576 my @rx = @{ $$dmb{'data'}{'rx'}{'times'} };
1577 shift(@rx);
1578 foreach my $rx (@rx) {
1579 if ($string =~ $rx) {
1580 my $repl = $$dmb{'data'}{'wordmatch'}{'times'}{lc($1)};
1581 $string =~ s/$rx/$repl/g;
1582 }
1583 }
1584 }
1585
1586 # Check to see if there is a time in the string
1587
1588 my $timerx = (exists $$dmb{'data'}{'rx'}{'other'}{'time'} ?
1589 $$dmb{'data'}{'rx'}{'other'}{'time'} :
1590 $self->_other_rx('time'));
1591 my $got_time = 0;
1592
1593 my($h,$mn,$s,$fh,$fm,$h24,$ampm,$tzstring,$zone,$abb,$off);
1594
1595 if ($string =~ s/$timerx/ /) {
1596 ($h,$fh,$mn,$fm,$s,$ampm,$tzstring,$zone,$abb,$off) =
1597 @+{qw(h fh mn fm s ampm tzstring zone abb off)};
1598
1599 $h24 = 1 if ($h == 24 && $mn == 0 && $s == 0);
1600 $string =~ s/\s*$//;
1601 $got_time = 1;
1602 }
1603
1604 # If we called this from $date->parse()
1605 # returns the string and a list of time components
1606
1607 if ($caller eq 'parse') {
1608 if ($got_time) {
1609 ($h,$mn,$s) = $self->_time($h,$mn,$s,$fh,$fm,$h24,$ampm,$noupdate);
1610 return ($got_time,$string,$h,$mn,$s,$tzstring,$zone,$abb,$off);
1611 } else {
1612 return (0);
1613 }
1614 }
1615
1616 # If we called this from $date->parse_time()
1617
1618 if (! $got_time || $string) {
1619 $$self{'err'} = "[$caller] Invalid time string";
1620 return ();
1621 }
1622
1623 ($h,$mn,$s) = $self->_time($h,$mn,$s,$fh,$fm,$h24,$ampm,$noupdate);
1624 return ($h,$mn,$s,$tzstring,$zone,$abb,$off);
1625}
1626
1627# Parse common dates
1628sub _parse_date_common {
1629 my($self,$string,$noupdate) = @_;
1630 my $dmt = $$self{'tz'};
1631 my $dmb = $$dmt{'base'};
1632
1633 # Since we want whitespace to be used as a separator, turn all
1634 # whitespace into single spaces. This is necessary since the
1635 # regexps do backreferences to make sure that separators are
1636 # not mixed.
1637 $string =~ s/\s+/ /g;
1638
1639 my $daterx = (exists $$dmb{'data'}{'rx'}{'other'}{'common_1'} ?
1640 $$dmb{'data'}{'rx'}{'other'}{'common_1'} :
1641 $self->_other_rx('common_1'));
1642
1643 if ($string =~ $daterx) {
1644 my($y,$m,$d) = @+{qw(y m d)};
1645
1646 if ($dmb->_config('dateformat') ne 'US') {
1647 ($m,$d) = ($d,$m);
1648 }
1649
1650 ($y,$m,$d) = $self->_def_date($y,$m,$d,$noupdate);
1651 return($y,$m,$d);
1652 }
1653
1654 $daterx = (exists $$dmb{'data'}{'rx'}{'other'}{'common_2'} ?
1655 $$dmb{'data'}{'rx'}{'other'}{'common_2'} :
1656 $self->_other_rx('common_2'));
1657
1658 if ($string =~ $daterx) {
1659 my($y,$m,$d,$mmm,$month) = @+{qw(y m d mmm month)};
1660
1661 if ($mmm) {
1662 $m = $$dmb{'data'}{'wordmatch'}{'month_abb'}{lc($mmm)};
1663 } elsif ($month) {
1664 $m = $$dmb{'data'}{'wordmatch'}{'month_name'}{lc($month)};
1665 }
1666
1667 ($y,$m,$d) = $self->_def_date($y,$m,$d,$noupdate);
1668 return($y,$m,$d);
1669 }
1670
1671 return ();
1672}
1673
1674sub _parse_tz {
1675 my($self,$string,$noupdate) = @_;
1676 my $dmt = $$self{'tz'};
1677 my($tzstring,$zone,$abb,$off);
1678
1679 my $rx = $dmt->_zrx();
1680 if ($string =~ s/(?:^|\s)$rx(?:$|\s)/ /) {
1681 ($tzstring,$zone,$abb,$off) = @+{qw(tzstring zone abb off)};
1682 return($string,$tzstring,$zone,$abb,$off);
1683 }
1684 return($string);
1685}
1686
1687sub _parse_dow {
1688 my($self,$string,$noupdate) = @_;
1689 my $dmt = $$self{'tz'};
1690 my $dmb = $$dmt{'base'};
1691 my($y,$m,$d,$dow);
1692
1693 # Remove the day of week
1694
1695 my $rx = (exists $$dmb{'data'}{'rx'}{'other'}{'dow'} ?
1696 $$dmb{'data'}{'rx'}{'other'}{'dow'} :
1697 $self->_other_rx('dow'));
1698 if ($string =~ s/$rx/ /) {
1699 $dow = $+{'dow'};
1700 $dow = lc($dow);
1701
1702 $dow = $$dmb{'data'}{'wordmatch'}{'day_abb'}{$dow}
1703 if (exists $$dmb{'data'}{'wordmatch'}{'day_abb'}{$dow});
1704 $dow = $$dmb{'data'}{'wordmatch'}{'day_name'}{$dow}
1705 if (exists $$dmb{'data'}{'wordmatch'}{'day_name'}{$dow});
1706 } else {
1707 return (0);
1708 }
1709
1710 $string =~ s/\s*$//;
1711 $string =~ s/^\s*//;
1712
1713 return (0,$string,$dow) if ($string);
1714
1715 # Handle the simple DoW format
1716
1717 ($y,$m,$d) = $self->_def_date($y,$m,$d,$noupdate);
1718
1719 my($w,$dow1);
1720
1721 ($y,$w) = $dmb->week_of_year([$y,$m,$d]); # week of year
1722 ($y,$m,$d) = @{ $dmb->week_of_year($y,$w) }; # first day
1723 $dow1 = $dmb->day_of_week([$y,$m,$d]); # DoW of first day
1724 $dow1 -= 7 if ($dow1 > $dow);
1725 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],$dow-$dow1) };
1726
1727 return(1,$y,$m,$d);
1728}
1729
1730sub _parse_holidays {
1731 my($self,$string,$noupdate) = @_;
1732 my $dmt = $$self{'tz'};
1733 my $dmb = $$dmt{'base'};
1734 my($y,$m,$d);
1735
1736 if (! exists $$dmb{'data'}{'rx'}{'holidays'}) {
1737 return (0);
1738 }
1739
1740 $string =~ s/\s*$//;
1741 $string =~ s/^\s*//;
1742
1743 my $rx = $$dmb{'data'}{'rx'}{'holidays'};
1744 if ($string =~ $rx) {
1745 my $hol;
1746 ($y,$hol) = @+{qw(y holiday)};
1747 $y = $dmt->_now('y',$noupdate) if (! $y);
1748 $y += 0;
1749
1750 $self->_holidays($y,2);
1751 return (0) if (! exists $$dmb{'data'}{'holidays'}{'dates'}{$y});
1752 foreach my $m (keys %{ $$dmb{'data'}{'holidays'}{'dates'}{$y} }) {
1753 foreach my $d (keys %{ $$dmb{'data'}{'holidays'}{'dates'}{$y}{$m} }) {
1754 foreach my $nam (@{ $$dmb{'data'}{'holidays'}{'dates'}{$y}{$m}{$d} }) {
1755 if (lc($nam) eq lc($hol)) {
1756 return(1,$y,$m,$d);
1757 }
1758 }
1759 }
1760 }
1761 }
1762
1763 return (0);
1764}
1765
1766sub _parse_delta {
1767 my($self,$string,$dow,$got_time,$h,$mn,$s,$noupdate) = @_;
1768 my $dmt = $$self{'tz'};
1769 my $dmb = $$dmt{'base'};
1770 my($y,$m,$d);
1771
1772 my $delta = $self->new_delta();
1773 my $err = $delta->parse($string);
1774 my $tz = $dmt->_now('tz');
1775 my $isdst = $dmt->_now('isdst');
1776
1777 if (! $err) {
1778 my($dy,$dm,$dw,$dd,$dh,$dmn,$ds) = @{ $$delta{'data'}{'delta'} };
1779
1780 if ($got_time &&
1781 ($dh != 0 || $dmn != 0 || $ds != 0)) {
1782 $$self{'err'} = '[parse] Two times entered or implied';
1783 return (1);
1784 }
1785
1786 if ($got_time) {
1787 ($y,$m,$d) = $self->_def_date($y,$m,$d,$noupdate);
1788 } else {
1789 ($y,$m,$d,$h,$mn,$s) = $dmt->_now('now',$$noupdate);
1790 $$noupdate = 1;
1791 }
1792
1793 my $business = $$delta{'data'}{'business'};
1794
1795 my($date2,$offset,$abbrev);
1796 ($err,$date2,$offset,$isdst,$abbrev) =
1797 $self->__calc_date_delta([$y,$m,$d,$h,$mn,$s],
1798 [$dy,$dm,$dw,$dd,$dh,$dmn,$ds],
1799 0,$business,$tz,$isdst);
1800 ($y,$m,$d,$h,$mn,$s) = @$date2;
1801
1802 if ($dow) {
1803 if ($dd != 0 || $dh != 0 || $dmn != 0 || $ds != 0) {
1804 $$self{'err'} = '[parse] Day of week not allowed';
1805 return (1);
1806 }
1807
1808 my($w,$dow1);
1809
1810 ($y,$w) = $dmb->week_of_year([$y,$m,$d]); # week of year
1811 ($y,$m,$d) = @{ $dmb->week_of_year($y,$w) }; # first day
1812 $dow1 = $dmb->day_of_week([$y,$m,$d]); # DoW of first day
1813 $dow1 -= 7 if ($dow1 > $dow);
1814 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],$dow-$dow1) };
1815 }
1816
1817 return (1,$y,$m,$d,$h,$mn,$s);
1818 }
1819
1820 return (0);
1821}
1822
1823sub _parse_datetime_other {
1824 my($self,$string,$noupdate) = @_;
1825 my $dmt = $$self{'tz'};
1826 my $dmb = $$dmt{'base'};
1827
1828 my $rx = (exists $$dmb{'data'}{'rx'}{'other'}{'miscdatetime'} ?
1829 $$dmb{'data'}{'rx'}{'other'}{'miscdatetime'} :
1830 $self->_other_rx('miscdatetime'));
1831
1832 if ($string =~ $rx) {
1833 my ($special,$epoch,$y,$mmm,$d,$h,$mn,$s,$tzstring,$off) =
1834 @+{qw(special epoch y mmm d h mn s tzstring off)};
1835
1836 if (defined($special)) {
1837 my $delta = $$dmb{'data'}{'wordmatch'}{'offset_time'}{lc($special)};
1838 my @delta = @{ $dmb->split('delta',$delta) };
1839 my @date = $dmt->_now('now',$$noupdate);
1840 my $tz = $dmt->_now('tz');
1841 my $isdst = $dmt->_now('isdst');
1842 $$noupdate = 1;
1843
1844 my($err,$date2,$offset,$abbrev);
1845 ($err,$date2,$offset,$isdst,$abbrev) =
1846 $self->__calc_date_delta([@date],[@delta],0,0,$tz,$isdst);
1847 @date = @$date2;
1848
1849 return (1,@date);
1850
1851 } elsif (defined($epoch)) {
1852 my $date = [1970,1,1,0,0,0];
1853 my @delta = (0,0,$epoch);
1854 $date = $dmb->calc_date_time($date,\@delta);
1855 my($err);
1856 ($err,$date) = $dmt->convert_from_gmt($date);
1857 return (1,@$date);
1858
1859 } elsif (defined($y)) {
1860 my $m = $$dmb{'data'}{'wordmatch'}{'month_abb'}{lc($mmm)};
1861 return (1,$y,$m,$d,$h,$mn,$s,$tzstring,undef,undef,$off);
1862 }
1863 }
1864
1865 return (0);
1866}
1867
1868sub _parse_date_other {
1869 my($self,$string,$dow,$of,$noupdate) = @_;
1870 my $dmt = $$self{'tz'};
1871 my $dmb = $$dmt{'base'};
1872 my($y,$m,$d,$h,$mn,$s);
1873
1874 my $rx = (exists $$dmb{'data'}{'rx'}{'other'}{'misc'} ?
1875 $$dmb{'data'}{'rx'}{'other'}{'misc'} :
1876 $self->_other_rx('misc'));
1877
1878 my($mmm,$month,$nextprev,$last,$field_y,$field_m,$field_w,$field_d,$nth);
1879 my($special,$got_m,$n,$got_y);
1880
1881 if ($string =~ $rx) {
1882 ($y,$mmm,$month,$nextprev,$last,$field_y,$field_m,$field_w,$field_d,$nth,
1883 $special,$n) =
1884 @+{qw(y mmm month next last field_y field_m field_w field_d
1885 nth special n)};
1886
1887 if (defined($y)) {
1888 $y = $dmt->_fix_year($y);
1889 $got_y = 1;
1890 return () if (! $y);
1891 } else {
1892 $y = $dmt->_now('y',$$noupdate);
1893 $$noupdate = 1;
1894 $got_y = 0;
1895 $$self{'data'}{'def'}[0] = '';
1896 }
1897
1898 if (defined($mmm)) {
1899 $m = $$dmb{'data'}{'wordmatch'}{'month_abb'}{lc($mmm)};
1900 $got_m = 1;
1901 } elsif ($month) {
1902 $m = $$dmb{'data'}{'wordmatch'}{'month_name'}{lc($month)};
1903 $got_m = 1;
1904 }
1905
1906 if ($nth) {
1907 $nth = $$dmb{'data'}{'wordmatch'}{'nth'}{lc($nth)};
1908 }
1909
1910 if ($got_m && $nth && ! $dow) {
1911 # Dec 1st 1970
1912 # 1st Dec 1970
1913 # 1970 Dec 1st
1914 # 1970 1st Dec
1915
1916 $d = $nth;
1917
1918 } elsif ($nextprev) {
1919
1920 my $next = 0;
1921 my $sign = -1;
1922 if ($$dmb{'data'}{'wordmatch'}{'nextprev'}{lc($nextprev)} == 1) {
1923 $next = 1;
1924 $sign = 1;
1925 }
1926
1927 if ($field_y || $field_m || $field_w) {
1928 # next/prev year/month/week
1929
1930 my(@delta);
1931 if ($field_y) {
1932 @delta = ($sign*1,0,0,0,0,0,0);
1933 } elsif ($field_m) {
1934 @delta = (0,$sign*1,0,0,0,0,0);
1935 } else {
1936 @delta = (0,0,$sign*1,0,0,0,0);
1937 }
1938
1939 my @now = $dmt->_now('now',$$noupdate);
1940 my $tz = $dmt->_now('tz');
1941 my $isdst = $dmt->_now('isdst');
1942 $$noupdate = 1;
1943
1944 my($err,$offset,$abbrev,$date2);
1945 ($err,$date2,$offset,$isdst,$abbrev) =
1946 $self->__calc_date_delta([@now],[@delta],0,0,$tz,$isdst);
1947 ($y,$m,$d,$h,$mn,$s) = @$date2;
1948
1949 } elsif ($dow) {
1950 # next/prev friday
1951
1952 my @now = $dmt->_now('now',$$noupdate);
1953 $$noupdate = 1;
1954 ($y,$m,$d,$h,$mn,$s) = @{ $self->__next_prev(\@now,$next,$dow,0) };
1955 $dow = 0;
1956
1957 } else {
1958 return ();
1959 }
1960
1961 } elsif ($last) {
1962
1963 if ($field_d && $got_m) {
1964 # last day in october 95
1965
1966 $d = $dmb->days_in_month($y,$m);
1967
1968 } elsif ($dow && $got_m) {
1969 # last friday in october 95
1970
1971 $d = $dmb->days_in_month($y,$m);
1972 ($y,$m,$d,$h,$mn,$s) =
1973 @{ $self->__next_prev([$y,$m,$d,0,0,0],0,$dow,1) };
1974 $dow = 0;
1975
1976 } elsif ($dow) {
1977 # last friday in 95
1978
1979 ($y,$m,$d,$h,$mn,$s) =
1980 @{ $self->__next_prev([$y,12,31,0,0,0],0,$dow,0) };
1981
1982 } else {
1983 return ();
1984 }
1985
1986 } elsif ($nth && $dow && ! $field_w) {
1987
1988 if ($got_m) {
1989 if ($of) {
1990 # nth DoW of MMM [YYYY]
1991 return () if ($nth > 5);
1992
1993 $d = 1;
1994 ($y,$m,$d,$h,$mn,$s) =
1995 @{ $self->__next_prev([$y,$m,1,0,0,0],1,$dow,1) };
1996 my $m2 = $m;
1997 ($y,$m2,$d) = @{ $dmb->calc_date_days([$y,$m,$d],7*($nth-1)) }
1998 if ($nth > 1);
1999 return () if (! $m2 || $m2 != $m);
2000
2001 } else {
2002 # DoW, nth MMM [YYYY] (i.e. Sunday, 9th Dec 2008)
2003 $d = $nth;
2004 }
2005
2006 } else {
2007 # nth DoW [in YYYY]
2008
2009 ($y,$m,$d,$h,$mn,$s) = @{ $self->__next_prev([$y,1,1,0,0,0],1,$dow,1) };
2010 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],7*($nth-1)) }
2011 if ($nth > 1);
2012 }
2013
2014 } elsif ($field_w && $dow) {
2015
2016 if (defined($n) || $nth) {
2017 # sunday week 22 in 1996
2018 # sunday 22nd week in 1996
2019
2020 $n = $nth if ($nth);
2021 return () if (! $n);
2022 ($y,$m,$d) = @{ $dmb->week_of_year($y,$n) };
2023 ($y,$m,$d) = @{ $self->__next_prev([$y,$m,$d,0,0,0],1,$dow,1) };
2024
2025 } else {
2026 # DoW week
2027
2028 ($y,$m,$d) = $dmt->_now('now',$$noupdate);
2029 $$noupdate = 1;
2030 my $tmp = $dmb->_config('firstday');
2031 ($y,$m,$d) = @{ $self->__next_prev([$y,$m,$d,0,0,0],1,$tmp,0) };
2032 ($y,$m,$d) = @{ $self->__next_prev([$y,$m,$d,0,0,0],1,$dow,1) };
2033 }
2034
2035 } elsif ($nth && ! $got_y) {
2036 # 'in one week' makes it here too so return nothing in that case so it
2037 # drops through to the deltas.
2038 return () if ($field_d || $field_w || $field_m || $field_y);
2039 ($y,$m,$d) = $dmt->_now('now',$$noupdate);
2040 $$noupdate = 1;
2041 $d = $nth;
2042
2043 } elsif ($special) {
2044
2045 my $delta = $$dmb{'data'}{'wordmatch'}{'offset_date'}{lc($special)};
2046 my @delta = @{ $dmb->split('delta',$delta) };
2047 ($y,$m,$d) = $dmt->_now('now',$$noupdate);
2048 my $tz = $dmt->_now('tz');
2049 my $isdst = $dmt->_now('isdst');
2050 $$noupdate = 1;
2051 my($err,$offset,$abbrev,$date2);
2052 ($err,$date2,$offset,$isdst,$abbrev) =
2053 $self->__calc_date_delta([$y,$m,$d,0,0,0],[@delta],0,0,$tz,$isdst);
2054 ($y,$m,$d) = @$date2;
2055
2056 if ($field_w) {
2057 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],7) };
2058 }
2059 }
2060
2061 } else {
2062 return ();
2063 }
2064
2065 return($y,$m,$d,$dow);
2066}
2067
2068# Supply defaults for missing values (Y/M/D)
2069sub _def_date {
2070 my($self,$y,$m,$d,$noupdate) = @_;
2071 $y = '' if (! defined $y);
2072 $m = '' if (! defined $m);
2073 $d = '' if (! defined $d);
2074 my $defined = 0;
2075 my $dmt = $$self{'tz'};
2076 my $dmb = $$dmt{'base'};
2077
2078 # If year was not specified, defaults to current year.
2079 #
2080 # We'll also fix the year (turn 2-digit into 4-digit).
2081
2082 if ($y eq '') {
2083 $y = $dmt->_now('y',$$noupdate);
2084 $$noupdate = 1;
2085 $$self{'data'}{'def'}[0] = '';
2086 } else {
2087 $y = $dmt->_fix_year($y);
2088 $defined = 1;
2089 }
2090
2091 # If the month was not specifed, but the year was, a default of
2092 # 01 is supplied (this is a truncated date).
2093 #
2094 # If neither was specified, month defaults to the current month.
2095
2096 if ($m ne '') {
2097 $defined = 1;
2098 } elsif ($defined) {
2099 $m = 1;
2100 $$self{'data'}{'def'}[1] = 1;
2101 } else {
2102 $m = $dmt->_now('m',$$noupdate);
2103 $$noupdate = 1;
2104 $$self{'data'}{'def'}[1] = '';
2105 }
2106
2107 # If the day was not specified, but the year or month was, a default
2108 # of 01 is supplied (this is a truncated date).
2109 #
2110 # If none were specified, it default to the current day.
2111
2112 if ($d ne '') {
2113 $defined = 1;
2114 } elsif ($defined) {
2115 $d = 1;
2116 $$self{'data'}{'def'}[2] = 1;
2117 } else {
2118 $d = $dmt->_now('d',$$noupdate);
2119 $$noupdate = 1;
2120 $$self{'data'}{'def'}[2] = '';
2121 }
2122
2123 return($y,$m,$d);
2124}
2125
2126# Supply defaults for missing values (Y/DoY)
2127sub _def_date_doy {
2128 my($self,$y,$doy,$noupdate) = @_;
2129 $y = '' if (! defined $y);
2130 my $dmt = $$self{'tz'};
2131 my $dmb = $$dmt{'base'};
2132
2133 # If year was not specified, defaults to current year.
2134 #
2135 # We'll also fix the year (turn 2-digit into 4-digit).
2136
2137 if ($y eq '') {
2138 $y = $dmt->_now('y',$$noupdate);
2139 $$noupdate = 1;
2140 $$self{'data'}{'def'}[0] = '';
2141 } else {
2142 $y = $dmt->_fix_year($y);
2143 }
2144
2145 # DoY must be specified.
2146
2147 my($m,$d);
2148 my $ymd = $dmb->day_of_year($y,$doy);
2149
2150 return @$ymd;
2151}
2152
2153# Supply defaults for missing values (YY/Www/D) and (Y/Www/D)
2154sub _def_date_dow {
2155 my($self,$y,$w,$dow,$noupdate) = @_;
2156 $y = '' if (! defined $y);
2157 $w = '' if (! defined $w);
2158 $dow = '' if (! defined $dow);
2159 my $dmt = $$self{'tz'};
2160 my $dmb = $$dmt{'base'};
2161
2162 # If year was not specified, defaults to current year.
2163 #
2164 # If it was specified and is a single digit, it is the
2165 # year in the current decade.
2166 #
2167 # We'll also fix the year (turn 2-digit into 4-digit).
2168
2169 if ($y ne '') {
2170 if (length($y) == 1) {
2171 my $tmp = $dmt->_now('y',$$noupdate);
2172 $tmp =~ s/.$/$y/;
2173 $y = $tmp;
2174 $$noupdate = 1;
2175
2176 } else {
2177 $y = $dmt->_fix_year($y);
2178
2179 }
2180
2181 } else {
2182 $y = $dmt->_now('y',$$noupdate);
2183 $$noupdate = 1;
2184 $$self{'data'}{'def'}[0] = '';
2185 }
2186
2187 # If week was not specified, it defaults to the current
2188 # week. Get the first day of the week.
2189
2190 my($m,$d);
2191 if ($w ne '') {
2192 ($y,$m,$d) = @{ $dmb->week_of_year($y,$w) };
2193 } else {
2194 my($nowy,$nowm,$nowd) = $dmt->_now('now',$$noupdate);
2195 $$noupdate = 1;
2196 my $noww;
2197 ($nowy,$noww) = $dmb->week_of_year([$nowy,$nowm,$nowd]);
2198 ($y,$m,$d) = @{ $dmb->week_of_year($nowy,$noww) };
2199 }
2200
2201 # Handle the DoW
2202
2203 if ($dow eq '') {
2204 $dow = 1;
2205 }
2206 my $n = $dmb->days_in_month($y,$m);
2207 $d += ($dow-1);
2208 if ($d > $n) {
2209 $m++;
2210 if ($m==13) {
2211 $y++;
2212 $m = 1;
2213 }
2214 $d = $d-$n;
2215 }
2216
2217 return($y,$m,$d);
2218}
2219
2220# Supply defaults for missing values (HH:MN:SS)
2221sub _def_time {
2222 my($self,$h,$m,$s,$noupdate) = @_;
2223 $h = '' if (! defined $h);
2224 $m = '' if (! defined $m);
2225 $s = '' if (! defined $s);
2226 my $defined = 0;
2227 my $dmt = $$self{'tz'};
2228 my $dmb = $$dmt{'base'};
2229
2230 # If no time was specified, defaults to 00:00:00.
2231
2232 if ($h eq '' &&
2233 $m eq '' &&
2234 $s eq '') {
2235 $$self{'data'}{'def'}[3] = 1;
2236 $$self{'data'}{'def'}[4] = 1;
2237 $$self{'data'}{'def'}[5] = 1;
2238 return(0,0,0);
2239 }
2240
2241 # If hour was not specified, defaults to current hour.
2242
2243 if ($h ne '') {
2244 $defined = 1;
2245 } else {
2246 $h = $dmt->_now('h',$$noupdate);
2247 $$noupdate = 1;
2248 $$self{'data'}{'def'}[3] = '';
2249 }
2250
2251 # If the minute was not specifed, but the hour was, a default of
2252 # 00 is supplied (this is a truncated time).
2253 #
2254 # If neither was specified, minute defaults to the current minute.
2255
2256 if ($m ne '') {
2257 $defined = 1;
2258 } elsif ($defined) {
2259 $m = 0;
2260 $$self{'data'}{'def'}[4] = 1;
2261 } else {
2262 $m = $dmt->_now('mn',$$noupdate);
2263 $$noupdate = 1;
2264 $$self{'data'}{'def'}[4] = '';
2265 }
2266
2267 # If the second was not specified (either the hour or the minute were),
2268 # a default of 00 is supplied (this is a truncated time).
2269
2270 if ($s eq '') {
2271 $s = 0;
2272 $$self{'data'}{'def'}[5] = 1;
2273 }
2274
2275 return($h,$m,$s);
2276}
2277
2278########################################################################
2279# OTHER DATE METHODS
2280########################################################################
2281
2282# Gets the date in the parsed timezone (if $type = ''), local timezone
2283# (if $type = 'local') or GMT timezone (if $type = 'gmt').
2284#
2285# Gets the string value in scalar context, the split value in list
2286# context.
2287#
2288sub value {
2289 my($self,$type) = @_;
2290 my $dmt = $$self{'tz'};
2291 my $dmb = $$dmt{'base'};
2292 my $date;
2293
2294 while (1) {
2295 if (! $$self{'data'}{'set'}) {
2296 $$self{'err'} = '[value] Object does not contain a date';
2297 last;
2298 }
2299
2300 $type = '' if (! $type);
2301
2302 if ($type eq 'gmt') {
2303
2304 if (! @{ $$self{'data'}{'gmt'} }) {
2305 my $zone = $$self{'data'}{'tz'};
2306 my $date = $$self{'data'}{'date'};
2307
2308 if ($zone eq 'Etc/GMT') {
2309 $$self{'data'}{'gmt'} = $date;
2310
2311 } else {
2312 my $isdst = $$self{'data'}{'isdst'};
2313 my($err,$d) = $dmt->convert_to_gmt($date,$zone,$isdst);
2314 if ($err) {
2315 $$self{'err'} = '[value] Unable to convert date to GMT';
2316 last;
2317 }
2318 $$self{'data'}{'gmt'} = $d;
2319 }
2320 }
2321 $date = $$self{'data'}{'gmt'};
2322
2323 } elsif ($type eq 'local') {
2324
2325 if (! @{ $$self{'data'}{'loc'} }) {
2326 my $zone = $$self{'data'}{'tz'};
2327 $date = $$self{'data'}{'date'};
2328 my $local = $dmt->_now('tz',1);
2329
2330 if ($zone eq $local) {
2331 $$self{'data'}{'loc'} = $date;
2332
2333 } else {
2334 my $isdst = $$self{'data'}{'isdst'};
2335 my($err,$d) = $dmt->convert_to_local($date,$zone,$isdst);
2336 if ($err) {
2337 $$self{'err'} = '[value] Unable to convert date to localtime';
2338 last;
2339 }
2340 $$self{'data'}{'loc'} = $d;
2341 }
2342 }
2343 $date = $$self{'data'}{'loc'};
2344
2345 } else {
2346
2347 $date = $$self{'data'}{'date'};
2348
2349 }
2350
2351 last;
2352 }
2353
2354 if ($$self{'err'}) {
2355 if (wantarray) {
2356 return ();
2357 } else {
2358 return '';
2359 }
2360 }
2361
2362 if (wantarray) {
2363 return @$date;
2364 } else {
2365 return $dmb->join('date',$date);
2366 }
2367}
2368
2369sub cmp {
2370 my($self,$date) = @_;
2371 if ($$self{'err'} || ! $$self{'data'}{'set'}) {
2372 warn "WARNING: [cmp] Arguments must be valid dates: date1\n";
2373 return undef;
2374 }
2375
2376 if (! ref($date) eq 'Date::Manip::Date') {
2377 warn "WARNING: [cmp] Argument must be a Date::Manip::Date object\n";
2378 return undef;
2379 }
2380 if ($$date{'err'} || ! $$date{'data'}{'set'}) {
2381 warn "WARNING: [cmp] Arguments must be valid dates: date2\n";
2382 return undef;
2383 }
2384
2385 my($d1,$d2);
2386 if ($$self{'data'}{'tz'} eq $$date{'data'}{'tz'}) {
2387 $d1 = $self->value();
2388 $d2 = $date->value();
2389 } else {
2390 $d1 = $self->value('gmt');
2391 $d2 = $date->value('gmt');
2392 }
2393
2394 return ($d1 cmp $d2);
2395}
2396
2397
# spent 6µs within Date::Manip::Date::BEGIN@2397 which was called: # once (6µs+0s) by Date::Manip::DM6::BEGIN@62 at line 2616
BEGIN {
239817µs my %field = qw(y 0 m 1 d 2 h 3 mn 4 s 5);
2399
2400 sub set {
2401 my($self,$field,@val) = @_;
2402 $field = lc($field);
2403 my $dmt = $$self{'tz'};
2404 my $dmb = $$dmt{'base'};
2405
2406 # Make sure $self includes a valid date (unless the entire date is
2407 # being set, in which case it doesn't matter).
2408
2409 my($date,@def,$tz,$isdst);
2410
2411 if ($field eq 'zdate') {
2412 # If {data}{set} = 2, we want to preserve the defaults. Also, we've
2413 # already initialized.
2414 #
2415 # It is only set in the parse routines which means that this was
2416 # called via _parse_check.
2417
2418 $self->_init() if ($$self{'data'}{'set'} != 2);
2419 @def = @{ $$self{'data'}{'def'} };
2420
2421 } elsif ($field eq 'date') {
2422 if ($$self{'data'}{'set'} && ! $$self{'err'}) {
2423 $tz = $$self{'data'}{'tz'};
2424 } else {
2425 $tz = $dmt->_now('tz',1);
2426 }
2427 $self->_init();
2428 @def = @{ $$self{'data'}{'def'} };
2429
2430 } else {
2431 return 1 if ($$self{'err'} || ! $$self{'data'}{'set'});
2432 $date = $$self{'data'}{'date'};
2433 $tz = $$self{'data'}{'tz'};
2434 $isdst = $$self{'data'}{'isdst'};
2435 @def = @{ $$self{'data'}{'def'} };
2436 $self->_init();
2437 }
2438
2439 # Check the arguments
2440
2441 my($err,$new_tz,$new_date,$new_time);
2442
2443 if ($field eq 'date') {
2444
2445 if ($#val == 0) {
2446 # date,DATE
2447 $new_date = $val[0];
2448 } elsif ($#val == 1) {
2449 # date,DATE,ISDST
2450 ($new_date,$isdst) = @val;
2451 } else {
2452 $err = 1;
2453 }
2454 for (my $i=0; $i<=5; $i++) {
2455 $def[$i] = 0 if ($def[$i]);
2456 }
2457
2458 } elsif ($field eq 'time') {
2459
2460 if ($#val == 0) {
2461 # time,TIME
2462 $new_time = $val[0];
2463 } elsif ($#val == 1) {
2464 # time,TIME,ISDST
2465 ($new_time,$isdst) = @val;
2466 } else {
2467 $err = 1;
2468 }
2469 $def[3] = 0 if ($def[3]);
2470 $def[4] = 0 if ($def[4]);
2471 $def[5] = 0 if ($def[5]);
2472
2473 } elsif ($field eq 'zdate') {
2474
2475 if ($#val == 0) {
2476 # zdate,DATE
2477 $new_date = $val[0];
2478 } elsif ($#val == 1 && ($val[1] eq '0' || $val[1] eq '1')) {
2479 # zdate,DATE,ISDST
2480 ($new_date,$isdst) = @val;
2481 } elsif ($#val == 1) {
2482 # zdate,ZONE,DATE
2483 ($new_tz,$new_date) = @val;
2484 } elsif ($#val == 2) {
2485 # zdate,ZONE,DATE,ISDST
2486 ($new_tz,$new_date,$isdst) = @val;
2487 } else {
2488 $err = 1;
2489 }
2490 for (my $i=0; $i<=5; $i++) {
2491 $def[$i] = 0 if ($def[$i]);
2492 }
2493 $tz = $dmt->_now('tz',1) if (! $new_tz);
2494
2495 } elsif ($field eq 'zone') {
2496
2497 if ($#val == -1) {
2498 # zone
2499 } elsif ($#val == 0 && ($val[0] eq '0' || $val[0] eq '1')) {
2500 # zone,ISDST
2501 $isdst = $val[0];
2502 } elsif ($#val == 0) {
2503 # zone,ZONE
2504 $new_tz = $val[0];
2505 } elsif ($#val == 1) {
2506 # zone,ZONE,ISDST
2507 ($new_tz,$isdst) = @val;
2508 } else {
2509 $err = 1;
2510 }
2511 $tz = $dmt->_now('tz',1) if (! $new_tz);
2512
2513 } elsif (exists $field{$field}) {
2514
2515 my $i = $field{$field};
2516 my $val;
2517 if ($#val == 0) {
2518 $val = $val[0];
2519 } elsif ($#val == 1) {
2520 ($val,$isdst) = @val;
2521 } else {
2522 $err = 1;
2523 }
2524
2525 $$date[$i] = $val;
2526 $def[$i] = 0 if ($def[$i]);
2527
2528 } else {
2529
2530 $err = 2;
2531
2532 }
2533
2534 if ($err) {
2535 if ($err == 1) {
2536 $$self{'err'} = '[set] Invalid arguments';
2537 } else {
2538 $$self{'err'} = '[set] Invalid field';
2539 }
2540 return 1;
2541 }
2542
2543 # Handle the arguments
2544
2545 if ($new_tz) {
2546 my $tmp = $dmt->_zone($new_tz);
2547 if ($tmp) {
2548 # A zone/alias
2549 $tz = $tmp;
2550
2551 } else {
2552 # An offset
2553 my ($err,@args);
2554 push(@args,$date) if ($date);
2555 push(@args,$new_tz);
2556 push(@args,($isdst ? 'dstonly' : 'stdonly')) if (defined $isdst);
2557 $tz = $dmb->zone(@args);
2558
2559 if (! $tz) {
2560 $$self{'err'} = "[set] Invalid timezone argument: $new_tz";
2561 return 1;
2562 }
2563 }
2564 }
2565
2566 if ($new_date) {
2567 if ($dmb->check($new_date)) {
2568 $date = $new_date;
2569 } else {
2570 $$self{'err'} = '[set] Invalid date argument';
2571 return 1;
2572 }
2573 }
2574
2575 if ($new_time) {
2576 if ($dmb->check_time($new_time)) {
2577 $$date[3] = $$new_time[0];
2578 $$date[4] = $$new_time[1];
2579 $$date[5] = $$new_time[2];
2580 } else {
2581 $$self{'err'} = '[set] Invalid time argument';
2582 return 1;
2583 }
2584 }
2585
2586 # Check the date/timezone combination
2587
2588 my($abb,$off);
2589 if ($tz eq 'etc/gmt') {
2590 $abb = 'GMT';
2591 $off = [0,0,0];
2592 $isdst = 0;
2593 } else {
2594 my $per = $dmt->date_period($date,$tz,1,$isdst);
2595 if (! $per) {
2596 $$self{'err'} = '[set] Invalid date/timezone';
2597 return 1;
2598 }
2599 $isdst = $$per[5];
2600 $abb = $$per[4];
2601 $off = $$per[3];
2602 }
2603
2604 # Set the information
2605
2606 $$self{'data'}{'set'} = 1;
2607 $$self{'data'}{'date'} = $date;
2608 $$self{'data'}{'tz'} = $tz;
2609 $$self{'data'}{'isdst'} = $isdst;
2610 $$self{'data'}{'offset'}= $off;
2611 $$self{'data'}{'abb'} = $abb;
2612 $$self{'data'}{'def'} = [ @def ];
2613
2614 return 0;
2615 }
261611.49ms16µs}
# spent 6µs making 1 call to Date::Manip::Date::BEGIN@2397
2617
2618########################################################################
2619# NEXT/PREV METHODS
2620
2621sub prev {
2622 my($self,@args) = @_;
2623 return 1 if ($$self{'err'} || ! $$self{'data'}{'set'});
2624 my $date = $$self{'data'}{'date'};
2625
2626 $date = $self->__next_prev($date,0,@args);
2627
2628 return 1 if (! defined($date));
2629 $self->set('date',$date);
2630 return 0;
2631}
2632
2633sub next {
2634 my($self,@args) = @_;
2635 return 1 if ($$self{'err'} || ! $$self{'data'}{'set'});
2636 my $date = $$self{'data'}{'date'};
2637
2638 $date = $self->__next_prev($date,1,@args);
2639
2640 return 1 if (! defined($date));
2641 $self->set('date',$date);
2642 return 0;
2643}
2644
2645sub __next_prev {
2646 my($self,$date,$next,$dow,$curr,$time) = @_;
2647
2648 my ($caller,$sign,$prev);
2649 if ($next) {
2650 $caller = 'next';
2651 $sign = 1;
2652 $prev = 0;
2653 } else {
2654 $caller = 'prev';
2655 $sign = -1;
2656 $prev = 1;
2657 }
2658
2659 my $dmt = $$self{'tz'};
2660 my $dmb = $$dmt{'base'};
2661 my $orig = [ @$date ];
2662
2663 # Check the time (if any)
2664
2665 if (defined($time)) {
2666 if ($dow) {
2667 # $time will refer to a full [H,MN,S]
2668 my($err,$h,$mn,$s) = $dmb->_hms_fields({ 'out' => 'list' },$time);
2669 if ($err) {
2670 $$self{'err'} = "[$caller] invalid time argument";
2671 return undef;
2672 }
2673 $time = [$h,$mn,$s];
2674 } else {
2675 # $time may have leading undefs
2676 my @tmp = @$time;
2677 if ($#tmp != 2) {
2678 $$self{'err'} = "[$caller] invalid time argument";
2679 return undef;
2680 }
2681 my($h,$mn,$s) = @$time;
2682 if (defined($h)) {
2683 $mn = 0 if (! defined($mn));
2684 $s = 0 if (! defined($s));
2685 } elsif (defined($mn)) {
2686 $s = 0 if (! defined($s));
2687 } else {
2688 $s = 0 if (! defined($s));
2689 }
2690 $time = [$h,$mn,$s];
2691 }
2692 }
2693
2694 # Find the next DoW
2695
2696 if ($dow) {
2697
2698 if (! $dmb->_is_int($dow,1,7)) {
2699 $$self{'err'} = "[$caller] Invalid DOW: $dow";
2700 return undef;
2701 }
2702
2703 # Find the next/previous occurrence of DoW
2704
2705 my $curr_dow = $dmb->day_of_week($date);
2706 my $adjust = 0;
2707
2708 if ($dow == $curr_dow) {
2709 $adjust = 1 if ($curr == 0);
2710
2711 } else {
2712 my $num;
2713 if ($next) {
2714 # force $dow to be more than $curr_dow
2715 $dow += 7 if ($dow<$curr_dow);
2716 $num = $dow - $curr_dow;
2717 } else {
2718 # force $dow to be less than $curr_dow
2719 $dow -= 7 if ($dow>$curr_dow);
2720 $num = $curr_dow - $dow;
2721 $num *= -1;
2722 }
2723
2724 # Add/subtract $num days
2725 $date = $dmb->calc_date_days($date,$num);
2726 }
2727
2728 if (defined($time)) {
2729 my ($y,$m,$d,$h,$mn,$s) = @$date;
2730 ($h,$mn,$s) = @$time;
2731 $date = [$y,$m,$d,$h,$mn,$s];
2732 }
2733
2734 my $cmp = $dmb->cmp($orig,$date);
2735 $adjust = 1 if ($curr == 2 && $cmp != -1*$sign);
2736
2737 if ($adjust) {
2738 # Add/subtract 1 week
2739 $date = $dmb->calc_date_days($date,$sign*7);
2740 }
2741
2742 return $date;
2743 }
2744
2745 # Find the next Time
2746
2747 if (defined($time)) {
2748
2749 my ($h,$mn,$s) = @$time;
2750 my $orig = [ @$date ];
2751
2752 my $cmp;
2753 if (defined $h) {
2754 # Find next/prev HH:MN:SS
2755
2756 @$date[3..5] = @$time;
2757 $cmp = $dmb->cmp($orig,$date);
2758 if ($cmp == -1) {
2759 if ($prev) {
2760 $date = $dmb->calc_date_days($date,-1);
2761 }
2762 } elsif ($cmp == 1) {
2763 if ($next) {
2764 $date = $dmb->calc_date_days($date,1);
2765 }
2766 } else {
2767 if (! $curr) {
2768 $date = $dmb->calc_date_days($date,$sign);
2769 }
2770 }
2771
2772 } elsif (defined $mn) {
2773 # Find next/prev MN:SS
2774
2775 @$date[4..5] = @$time[1..2];
2776
2777 $cmp = $dmb->cmp($orig,$date);
2778 if ($cmp == -1) {
2779 if ($prev) {
2780 $date = $dmb->calc_date_time($date,[-1,0,0]);
2781 }
2782 } elsif ($cmp == 1) {
2783 if ($next) {
2784 $date = $dmb->calc_date_time($date,[1,0,0]);
2785 }
2786 } else {
2787 if (! $curr) {
2788 $date = $dmb->calc_date_time($date,[$sign,0,0]);
2789 }
2790 }
2791
2792 } else {
2793 # Find next/prev SS
2794
2795 $$date[5] = $$time[2];
2796
2797 $cmp = $dmb->cmp($orig,$date);
2798 if ($cmp == -1) {
2799 if ($prev) {
2800 $date = $dmb->calc_date_time($date,[0,-1,0]);
2801 }
2802 } elsif ($cmp == 1) {
2803 if ($next) {
2804 $date = $dmb->calc_date_time($date,[0,1,0]);
2805 }
2806 } else {
2807 if (! $curr) {
2808 $date = $dmb->calc_date_time($date,[0,$sign,0]);
2809 }
2810 }
2811 }
2812
2813 return $date;
2814 }
2815
2816 $$self{'err'} = "[$caller] Either DoW or time (or both) required";
2817 return undef;
2818}
2819
2820########################################################################
2821# CALC METHOD
2822
2823sub calc {
2824 my($self,$obj,@args) = @_;
2825
2826 if (ref($obj) eq 'Date::Manip::Date') {
2827 return $self->_calc_date_date($obj,@args);
2828
2829 } elsif (ref($obj) eq 'Date::Manip::Delta') {
2830 return $self->_calc_date_delta($obj,@args);
2831
2832 } else {
2833 return undef;
2834 }
2835}
2836
2837sub _calc_date_date {
2838 my($self,$date,@args) = @_;
2839 my $ret = $self->new_delta();
2840
2841 if ($$self{'err'} || ! $$self{'data'}{'set'}) {
2842 $$ret{'err'} = '[calc] First object invalid (date)';
2843 return $ret;
2844 }
2845
2846 if ($$date{'err'} || ! $$date{'data'}{'set'}) {
2847 $$ret{'err'} = '[calc] Second object invalid (date)';
2848 return $ret;
2849 }
2850
2851 # Handle subtract/mode arguments
2852
2853 my($subtract,$mode);
2854
2855 if ($#args == -1) {
2856 ($subtract,$mode) = (0,'');
2857 } elsif ($#args == 0) {
2858 if ($args[0] eq '0' || $args[0] eq '1') {
2859 ($subtract,$mode) = ($args[0],'');
2860 } else {
2861 ($subtract,$mode) = (0,$args[0]);
2862 }
2863
2864 } elsif ($#args == 1) {
2865 ($subtract,$mode) = @args;
2866 } else {
2867 $$ret{'err'} = '[calc] Invalid arguments';
2868 return $ret;
2869 }
2870 $mode = 'exact' if (! $mode);
2871
2872 if ($mode !~ /^(business|bsemi|bapprox|approx|semi|exact)$/i) {
2873 $$ret{'err'} = '[calc] Invalid mode argument';
2874 return $ret;
2875 }
2876
2877 # if business mode
2878 # dates must be in the same timezone
2879 # use dates in that zone
2880 #
2881 # otherwise if both dates are in the same timezone && approx/semi mode
2882 # use the dates in that zone
2883 #
2884 # otherwise
2885 # convert to gmt
2886 # use those dates
2887
2888 my($date1,$date2,$tz1,$isdst1,$tz2,$isdst2);
2889 if ($mode eq 'business' || $mode eq 'bapprox' || $mode eq 'bsemi') {
2890 if ($$self{'data'}{'tz'} eq $$date{'data'}{'tz'}) {
2891 $date1 = [ $self->value() ];
2892 $date2 = [ $date->value() ];
2893 $tz1 = $$self{'data'}{'tz'};
2894 $tz2 = $tz1;
2895 $isdst1 = $$self{'data'}{'isdst'};
2896 $isdst2 = $$date{'data'}{'isdst'};
2897 } else {
2898 $$ret{'err'} = '[calc] Dates must be in the same timezone for ' .
2899 'business mode calculations';
2900 return $ret;
2901 }
2902
2903 } elsif (($mode eq 'approx' || $mode eq 'semi') &&
2904 $$self{'data'}{'tz'} eq $$date{'data'}{'tz'}) {
2905 $date1 = [ $self->value() ];
2906 $date2 = [ $date->value() ];
2907 $tz1 = $$self{'data'}{'tz'};
2908 $tz2 = $tz1;
2909 $isdst1 = $$self{'data'}{'isdst'};
2910 $isdst2 = $$date{'data'}{'isdst'};
2911
2912 } else {
2913 $date1 = [ $self->value('gmt') ];
2914 $date2 = [ $date->value('gmt') ];
2915 $tz1 = 'GMT';
2916 $tz2 = $tz1;
2917 $isdst1 = 0;
2918 $isdst2 = 0;
2919 }
2920
2921 # Do the calculation
2922
2923 my(@delta);
2924 if ($subtract) {
2925 if ($mode eq 'business' || $mode eq 'exact' || $subtract == 2) {
2926 @delta = @{ $self->__calc_date_date($mode,$date2,$tz2,$isdst2,
2927 $date1,$tz1,$isdst1) };
2928 } else {
2929 @delta = @{ $self->__calc_date_date($mode,$date1,$tz1,$isdst1,
2930 $date2,$tz2,$isdst2) };
2931 @delta = map { -1*$_ } @delta;
2932 }
2933 } else {
2934 @delta = @{ $self->__calc_date_date($mode,$date1,$tz1,$isdst1,
2935 $date2,$tz2,$isdst2) };
2936 }
2937
2938 # Save the delta
2939
2940 if ($mode eq 'business' || $mode eq 'bapprox' || $mode eq 'bsemi') {
2941 $ret->set('business',\@delta);
2942 } else {
2943 $ret->set('delta',\@delta);
2944 }
2945 return $ret;
2946}
2947
2948sub __calc_date_date {
2949 my($self,$mode,$date1,$tz1,$isdst1,$date2,$tz2,$isdst2) = @_;
2950 my $dmt = $$self{'tz'};
2951 my $dmb = $$dmt{'base'};
2952
2953 my($dy,$dm,$dw,$dd,$dh,$dmn,$ds) = (0,0,0,0,0,0,0);
2954
2955 if ($mode eq 'approx' || $mode eq 'bapprox') {
2956 my($y1,$m1,$d1,$h1,$mn1,$s1) = @$date1;
2957 my($y2,$m2,$d2,$h2,$mn2,$s2) = @$date2;
2958 $dy = $y2-$y1;
2959 $dm = $m2-$m1;
2960
2961 if ($dy || $dm) {
2962 # If $d1 is greater than the number of days allowed in the
2963 # month $y2/$m2, set it equal to the number of days. In other
2964 # words:
2965 # Jan 31 2006 to Feb 28 2008 = 2 years 1 month
2966 #
2967 my $dim = $dmb->days_in_month($y2,$m2);
2968 $d1 = $dim if ($d1 > $dim);
2969
2970 $date1 = [$y2,$m2,$d1,$h1,$mn1,$s1];
2971 }
2972 }
2973
2974 if ($mode eq 'semi' || $mode eq 'approx') {
2975
2976 # Calculate the number of weeks/days apart (temporarily ignoring
2977 # DST effects).
2978
2979 $dd = $dmb->days_since_1BC($date2) -
2980 $dmb->days_since_1BC($date1);
2981 $dw = int($dd/7);
2982 $dd -= $dw*7;
2983
2984 # Adding $dd to $date1 gives: ($y2,$m2,$d2, $h1,$mn1,$s1)
2985 # Make sure this is valid (taking into account DST effects).
2986 # If it isn't, make it valid.
2987
2988 if ($dw || $dd) {
2989 my($y1,$m1,$d1,$h1,$mn1,$s1) = @$date1;
2990 my($y2,$m2,$d2,$h2,$mn2,$s2) = @$date2;
2991 $date1 = [$y2,$m2,$d2,$h1,$mn1,$s1];
2992 }
2993 if ($dy || $dm || $dw || $dd) {
2994 my $force = ( ($dw > 0 || $dd > 0) ? 1 : -1 );
2995 my($off,$isdst,$abb);
2996 ($date1,$off,$isdst,$abb) =
2997 $self->_calc_date_check_dst($date1,$tz2,$isdst2,$force);
2998 }
2999 }
3000
3001 if ($mode eq 'bsemi' || $mode eq 'bapprox') {
3002 # Calculate the number of weeks. Ignore the days
3003 # part. Also, since there are no DST effects, we don't
3004 # have to check for validity.
3005
3006 $dd = $dmb->days_since_1BC($date2) -
3007 $dmb->days_since_1BC($date1);
3008 $dw = int($dd/7);
3009 $dd = 0;
3010 $date1 = $dmb->calc_date_days($date1,$dw*7);
3011 }
3012
3013 if ($mode eq 'exact' || $mode eq 'semi' || $mode eq 'approx') {
3014 my $sec1 = $dmb->secs_since_1970($date1);
3015 my $sec2 = $dmb->secs_since_1970($date2);
3016 $ds = $sec2 - $sec1;
3017
3018 {
301921.28ms216µs
# spent 14µs (11+3) within Date::Manip::Date::BEGIN@3019 which was called: # once (11µs+3µs) by Date::Manip::DM6::BEGIN@62 at line 3019
no integer;
# spent 14µs making 1 call to Date::Manip::Date::BEGIN@3019 # spent 3µs making 1 call to integer::unimport
3020 $dh = int($ds/3600);
3021 $ds -= $dh*3600;
3022 }
3023 $dmn = int($ds/60);
3024 $ds -= $dmn*60;
3025 }
3026
3027 if ($mode eq 'business' || $mode eq 'bsemi' || $mode eq 'bapprox') {
3028
3029 # Make sure both are work days
3030
3031 $date1 = $self->__nextprev_business_day(0,0,1,$date1);
3032 $date2 = $self->__nextprev_business_day(0,0,1,$date2);
3033
3034 my($y1,$m1,$d1,$h1,$mn1,$s1) = @$date1;
3035 my($y2,$m2,$d2,$h2,$mn2,$s2) = @$date2;
3036
3037 # Find out which direction we need to move $date1 to get to $date2
3038
3039 my $dir = 0;
3040 if ($y1 < $y2) {
3041 $dir = 1;
3042 } elsif ($y1 > $y2) {
3043 $dir = -1;
3044 } elsif ($m1 < $m2) {
3045 $dir = 1;
3046 } elsif ($m1 > $m2) {
3047 $dir = -1;
3048 } elsif ($d1 < $d2) {
3049 $dir = 1;
3050 } elsif ($d1 > $d2) {
3051 $dir = -1;
3052 }
3053
3054 # Now do the day part (to get to the same day)
3055
3056 $dd = 0;
3057 while ($dir) {
3058 ($y1,$m1,$d1) = @{ $dmb->calc_date_days([$y1,$m1,$d1],$dir) };
3059 $dd += $dir if ($self->__is_business_day([$y1,$m1,$d1,0,0,0],0));
3060 $dir = 0 if ($y1 == $y2 && $m1 == $m2 && $d1 == $d2);
3061 }
3062
3063 # Both dates are now on a business day, and during business
3064 # hours, so do the hr/min/sec part trivially
3065
3066 $dh = $h2-$h1;
3067 $dmn = $mn2-$mn1;
3068 $ds = $s2-$s1;
3069 }
3070
3071 return [ $dy,$dm,$dw,$dd,$dh,$dmn,$ds ];
3072}
3073
3074sub _calc_date_delta {
3075 my($self,$delta,$subtract) = @_;
3076 my $ret = $self->new_date();
3077
3078 if ($$self{'err'} || ! $$self{'data'}{'set'}) {
3079 $$ret{'err'} = '[calc] Date object invalid';
3080 return $ret;
3081 }
3082
3083 if ($$delta{'err'}) {
3084 $$ret{'err'} = '[calc] Delta object invalid';
3085 return $ret;
3086 }
3087
3088 # Get the date/delta fields
3089
3090 $subtract = 0 if (! $subtract);
3091 my @delta = @{ $$delta{'data'}{'delta'} };
3092 my @date = @{ $$self{'data'}{'date'} };
3093 my $business = $$delta{'data'}{'business'};
3094 my $tz = $$self{'data'}{'tz'};
3095 my $isdst = $$self{'data'}{'isdst'};
3096
3097 my($err,$date2,$offset,$abbrev);
3098 ($err,$date2,$offset,$isdst,$abbrev) =
3099 $self->__calc_date_delta([@date],[@delta],$subtract,$business,$tz,$isdst);
3100
3101 if ($err) {
3102 $$ret{'err'} = '[calc] Unable to perform calculation';
3103 } else {
3104 $$ret{'data'}{'set'} = 1;
3105 $$ret{'data'}{'date'} = $date2;
3106 $$ret{'data'}{'tz'} = $tz;
3107 $$ret{'data'}{'isdst'} = $isdst;
3108 $$ret{'data'}{'offset'}= $offset;
3109 $$ret{'data'}{'abb'} = $abbrev;
3110 }
3111 return $ret;
3112}
3113
3114sub __calc_date_delta {
3115 my($self,$date,$delta,$subtract,$business,$tz,$isdst) = @_;
3116
3117 my ($dy,$dm,$dw,$dd,$dh,$dmn,$ds) = @$delta;
3118 my @date = @$date;
3119
3120 my ($err,$date2,$offset,$abbrev);
3121
3122 # In business mode, daylight saving time is ignored, so days are
3123 # of a constant, known length, so they'll be done in the exact
3124 # function. Otherwise, they'll be done in the approximate function.
3125 #
3126 # Also in business mode, if $subtract = 2, then the starting date
3127 # must be a business date or an error occurs.
3128
3129 my($dd_exact,$dd_approx);
3130 if ($business) {
3131 $dd_exact = $dd;
3132 $dd_approx = 0;
3133
3134 if ($subtract == 2 && ! $self->__is_business_day($date,1)) {
3135 return (1);
3136 }
3137
3138 } else {
3139 $dd_exact = 0;
3140 $dd_approx = $dd;
3141 }
3142
3143 if ($subtract == 2 && ($dy || $dm || $dw || $dd_approx)) {
3144 # For subtract=2:
3145 # DATE = RET + DELTA
3146 #
3147 # The delta consisists of an approximate part (which is added first)
3148 # and an exact part (added second):
3149 # DATE = RET + DELTA(approx) + DELTA(exact)
3150 # DATE = RET' + DELTA(exact)
3151 # where RET' = RET + DELTA(approx)
3152 #
3153 # For an exact delta, subtract==2 and subtract==1 are equivalent,
3154 # so this can be written:
3155 # DATE - DELTA(exact) = RET'
3156 #
3157 # So the inverse subtract only needs include the approximate
3158 # portion of the delta.
3159
3160 ($err,$date2,$offset,$isdst,$abbrev) =
3161 $self->__calc_date_delta_exact([@date],[-1*$dd_exact,-1*$dh,-1*$dmn,-1*$ds],
3162 $business,$tz,$isdst);
3163
3164 ($err,$date2,$offset,$isdst,$abbrev) =
3165 $self->__calc_date_delta_inverse($date2,[$dy,$dm,$dw,$dd_approx],
3166 $business,$tz,$isdst)
3167 if (! $err);
3168
3169 } else {
3170 # We'll add the approximate part, followed by the exact part.
3171 # After the approximate part, we need to make sure we're on
3172 # a valid business day in business mode.
3173
3174 ($dy,$dm,$dw,$dd_exact,$dd_approx,$dh,$dmn,$ds) =
3175 map { -1*$_ } ($dy,$dm,$dw,$dd_exact,$dd_approx,$dh,$dmn,$ds)
3176 if ($subtract);
3177 @$date2 = @date;
3178
3179 if ($dy || $dm || $dw || $dd) {
3180 ($err,$date2,$offset,$isdst,$abbrev) =
3181 $self->__calc_date_delta_approx($date2,[$dy,$dm,$dw,$dd_approx],
3182 $business,$tz,$isdst);
3183 } elsif ($business) {
3184 $date2 = $self->__nextprev_business_day(0,0,1,$date2);
3185 }
3186
3187 ($err,$date2,$offset,$isdst,$abbrev) =
3188 $self->__calc_date_delta_exact($date2,[$dd_exact,$dh,$dmn,$ds],
3189 $business,$tz,$isdst)
3190 if (! $err && ($dd_exact || $dh || $dmn || $ds));
3191 }
3192
3193 return($err,$date2,$offset,$isdst,$abbrev);
3194}
3195
3196# Do the inverse part of a calculation.
3197#
3198# $delta = [$dy,$dm,$dw,$dd]
3199#
3200sub __calc_date_delta_inverse {
3201 my($self,$date,$delta,$business,$tz,$isdst) = @_;
3202 my $dmt = $$self{'tz'};
3203 my $dmb = $$dmt{'base'};
3204 my @date2;
3205
3206 # Given: DATE1, DELTA
3207 # Find: DATE2
3208 # where DATE2 + DELTA = DATE1
3209 #
3210 # Start with:
3211 # DATE2 = DATE1 - DELTA
3212 #
3213 # if (DATE2+DELTA < DATE1)
3214 # while (1)
3215 # DATE2 = DATE2 + 1 day
3216 # if DATE2+DELTA < DATE1
3217 # next
3218 # elsif DATE2+DELTA > DATE1
3219 # return ERROR
3220 # else
3221 # return DATE2
3222 # done
3223 #
3224 # elsif (DATE2+DELTA > DATE1)
3225 # while (1)
3226 # DATE2 = DATE2 - 1 day
3227 # if DATE2+DELTA > DATE1
3228 # next
3229 # elsif DATE2+DELTA < DATE1
3230 # return ERROR
3231 # else
3232 # return DATE2
3233 # done
3234 #
3235 # else
3236 # return DATE2
3237
3238 if ($business) {
3239
3240 my $date1 = $date;
3241 my ($err,$date2,$off,$isd,$abb,@del,$tmp,$cmp);
3242 @del = map { $_*-1 } @$delta;
3243
3244 ($err,$date2,$off,$isd,$abb) =
3245 $self->__calc_date_delta_approx($date,[@del],$business,$tz,$isdst);
3246
3247 ($err,$tmp,$off,$isd,$abb) =
3248 $self->__calc_date_delta_approx($date2,$delta,$business,$tz,$isdst);
3249
3250 $cmp = $self->_cmp_date($tmp,$date1);
3251
3252 if ($cmp < 0) {
3253 while (1) {
3254 $date2 = $self->__nextprev_business_day(0,1,0,$date2);
3255 ($err,$tmp,$off,$isd,$abb) =
3256 $self->__calc_date_delta_approx($date2,$delta,$business,$tz,$isdst);
3257 $cmp = $self->_cmp_date($tmp,$date1);
3258 if ($cmp < 0) {
3259 next;
3260 } elsif ($cmp > 0) {
3261 return (1);
3262 } else {
3263 last;
3264 }
3265 }
3266
3267 } elsif ($cmp > 0) {
3268 while (1) {
3269 $date2 = $self->__nextprev_business_day(1,1,0,$date2);
3270 ($err,$tmp,$off,$isd,$abb) =
3271 $self->__calc_date_delta_approx($date2,$delta,$business,$tz,$isdst);
3272 $cmp = $self->_cmp_date($tmp,$date1);
3273 if ($cmp > 0) {
3274 next;
3275 } elsif ($cmp < 0) {
3276 return (1);
3277 } else {
3278 last;
3279 }
3280 }
3281 }
3282
3283 @date2 = @$date2;
3284
3285 } else {
3286
3287 my @tmp = @$date[0..2]; # [y,m,d]
3288 my @hms = @$date[3..5]; # [h,m,s]
3289 my $date1 = [@tmp];
3290
3291 my $date2 = $dmb->_calc_date_ymwd($date1,$delta,1);
3292 my $tmp = $dmb->_calc_date_ymwd($date2,$delta);
3293 my $cmp = $self->_cmp_date($tmp,$date1);
3294
3295 if ($cmp < 0) {
3296 while (1) {
3297 $date2 = $dmb->calc_date_days($date2,1);
3298 $tmp = $dmb->_calc_date_ymwd($date2,$delta);
3299 $cmp = $self->_cmp_date($tmp,$date1);
3300 if ($cmp < 0) {
3301 next;
3302 } elsif ($cmp > 0) {
3303 return (1);
3304 } else {
3305 last;
3306 }
3307 }
3308
3309 } elsif ($cmp > 0) {
3310 while (1) {
3311 $date2 = $dmb->calc_date_days($date2,-1);
3312 $tmp = $dmb->_calc_date_ymwd($date2,$delta);
3313 $cmp = $self->_cmp_date($tmp,$date1);
3314 if ($cmp > 0) {
3315 next;
3316 } elsif ($cmp < 0) {
3317 return (1);
3318 } else {
3319 last;
3320 }
3321 }
3322 }
3323
3324 @date2 = (@$date2,@hms);
3325 }
3326
3327 # Make sure DATE2 is valid (within DST constraints) and
3328 # return it.
3329
3330 my($date2,$abb,$off,$err);
3331 ($date2,$off,$isdst,$abb) = $self->_calc_date_check_dst([@date2],$tz,$isdst,0);
3332
3333 return (1) if (! defined($date2));
3334 return (0,$date2,$off,$isdst,$abb);
3335}
3336
3337sub _cmp_date {
3338 my($self,$date0,$date1) = @_;
3339 return ($$date0[0] <=> $$date1[0] ||
3340 $$date0[1] <=> $$date1[1] ||
3341 $$date0[2] <=> $$date1[2]);
3342}
3343
3344# Do the approximate part of a calculation.
3345#
3346sub __calc_date_delta_approx {
3347 my($self,$date,$delta,$business,$tz,$isdst) = @_;
3348
3349 my $dmt = $$self{'tz'};
3350 my $dmb = $$dmt{'base'};
3351 my($y,$m,$d,$h,$mn,$s) = @$date;
3352 my($dy,$dm,$dw,$dd) = @$delta;
3353
3354 #
3355 # Do the year/month part.
3356 #
3357 # If we are past the last day of a month, move the date back to
3358 # the last day of the month. i.e. Jan 31 + 1 month = Feb 28.
3359 #
3360
3361 $y += $dy if ($dy);
3362 $dmb->_mod_add(-12,$dm,\$m,\$y) # -12 means 1-12 instead of 0-11
3363 if ($dm);
3364
3365 my $dim = $dmb->days_in_month($y,$m);
3366 $d = $dim if ($d > $dim);
3367
3368 #
3369 # Do the week part.
3370 #
3371 # The week is treated as 7 days for both business and non-business
3372 # calculations.
3373 #
3374 # In a business calculation, make sure we're on a business date.
3375 #
3376
3377 if ($business) {
3378 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],$dw*7) } if ($dw);
3379 ($y,$m,$d,$h,$mn,$s) =
3380 @{ $self->__nextprev_business_day(0,0,1,[$y,$m,$d,$h,$mn,$s]) };
3381 } else {
3382 $dd += $dw*7;
3383 }
3384
3385 #
3386 # Now do the day part. $dd is always 0 in business calculations.
3387 #
3388
3389 if ($dd) {
3390 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],$dd) };
3391 }
3392
3393 #
3394 # At this point, we need to make sure that we're a valid date
3395 # (within the constraints of DST).
3396 #
3397 # If it is not valid in this offset, try the other one. If neither
3398 # works, then we want the the date to be 24 hours later than the
3399 # previous day at this time (if $dd > 0) or 24 hours earlier than
3400 # the next day at this time (if $dd < 0). We'll use the 24 hour
3401 # definition even for business days, but then we'll double check
3402 # that the resulting date is a business date.
3403 #
3404
3405 my $force = ( ($dd > 0 || $dw > 0 || $dm > 0 || $dy > 0) ? 1 : -1 );
3406 my($off,$abb);
3407 ($date,$off,$isdst,$abb) =
3408 $self->_calc_date_check_dst([$y,$m,$d,$h,$mn,$s],$tz,$isdst,$force);
3409 return (0,$date,$off,$isdst,$abb);
3410}
3411
3412# Do the exact part of a calculation.
3413#
3414sub __calc_date_delta_exact {
3415 my($self,$date,$delta,$business,$tz,$isdst) = @_;
3416 my $dmt = $$self{'tz'};
3417 my $dmb = $$dmt{'base'};
3418
3419 if ($business) {
3420
3421 # Simplify hours/minutes/seconds where the day length is defined
3422 # by the start/end of the business day.
3423
3424 my ($dd,$dh,$dmn,$ds) = @$delta;
3425 my ($y,$m,$d,$h,$mn,$s)= @$date;
3426 my ($hbeg,$mbeg,$sbeg) = @{ $$dmb{'data'}{'calc'}{'workdaybeg'} };
3427 my ($hend,$mend,$send) = @{ $$dmb{'data'}{'calc'}{'workdayend'} };
3428 my $bdlen = $$dmb{'data'}{'len'}{'bdlength'};
3429
3430252µs212µs
# spent 10µs (9+2) within Date::Manip::Date::BEGIN@3430 which was called: # once (9µs+2µs) by Date::Manip::DM6::BEGIN@62 at line 3430
no integer;
# spent 10µs making 1 call to Date::Manip::Date::BEGIN@3430 # spent 2µs making 1 call to integer::unimport
3431 my $tmp;
3432 $ds += $dh*3600 + $dmn*60;
3433 $tmp = int($ds/$bdlen);
3434 $dd += $tmp;
3435 $ds -= $tmp*$bdlen;
3436 $dh = int($ds/3600);
3437 $ds -= $dh*3600;
3438 $dmn = int($ds/60);
3439 $ds -= $dmn*60;
344023.91ms211µs
# spent 8µs (6+2) within Date::Manip::Date::BEGIN@3440 which was called: # once (6µs+2µs) by Date::Manip::DM6::BEGIN@62 at line 3440
use integer;
# spent 8µs making 1 call to Date::Manip::Date::BEGIN@3440 # spent 2µs making 1 call to integer::import
3441
3442 if ($dd) {
3443 my $prev = 0;
3444 if ($dd < 1) {
3445 $prev = 1;
3446 $dd *= -1;
3447 }
3448
3449 ($y,$m,$d,$h,$mn,$s) =
3450 @{ $self->__nextprev_business_day($prev,$dd,0,[$y,$m,$d,$h,$mn,$s]) };
3451 }
3452
3453 # At this point, we're adding less than a day for the
3454 # hours/minutes/seconds part AND we know that the current
3455 # day is during business hours.
3456 #
3457 # We'll add them (without affecting days... we'll need to
3458 # test things by hand to make sure we should or shouldn't
3459 # do that.
3460
3461 $dmb->_mod_add(60,$ds,\$s,\$mn);
3462 $dmb->_mod_add(60,$dmn,\$mn,\$h);
3463 $h += $dh;
3464 # Note: it's possible that $h > 23 at this point or $h < 0
3465
3466 if ($h > $hend ||
3467 ($h == $hend && $mn > $mend) ||
3468 ($h == $hend && $mn == $mend && $s > $send) ||
3469 ($h == $hend && $mn == $mend && $s == $send)) {
3470
3471 # We've gone past the end of the business day.
3472
3473 my $t2 = $dmb->calc_time_time([$h,$mn,$s],[$hend,$mend,$send],1);
3474
3475 while (1) {
3476 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],1) };
3477 last if ($self->__is_business_day([$y,$m,$d,$h,$mn,$s]));
3478 }
3479
3480 ($h,$mn,$s) = @{ $dmb->calc_time_time([$hbeg,$mbeg,$sbeg],$t2) };
3481
3482 } elsif ($h < $hbeg ||
3483 ($h == $hbeg && $mn < $mbeg) ||
3484 ($h == $hbeg && $mn == $mbeg && $s < $sbeg)) {
3485
3486 # We've gone back past the start of the business day.
3487
3488 my $t2 = $dmb->calc_time_time([$hbeg,$mbeg,$sbeg],[$h,$mn,$s],1);
3489
3490 while (1) {
3491 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],-1) };
3492 last if ($self->__is_business_day([$y,$m,$d,$h,$mn,$s]));
3493 }
3494
3495 ($h,$mn,$s) = @{ $dmb->calc_time_time([$hend,$mend,$send],$t2,1) };
3496 }
3497
3498 # Now make sure that the date is valid within DST constraints.
3499
3500 my $force = ( ($dd > 0 || $dh > 0 || $dmn > 0 || $ds > 0) ? 1 : -1 );
3501 my($off,$abb);
3502 ($date,$off,$isdst,$abb) =
3503 $self->_calc_date_check_dst([$y,$m,$d,$h,$mn,$s],$tz,$isdst,$force);
3504 return (0,$date,$off,$isdst,$abb);
3505
3506 } else {
3507
3508 # Convert to GTM
3509 # Do the calculation
3510 # Convert back
3511
3512 my ($dd,$dh,$dm,$ds) = @$delta; # $dd is always 0
3513 my $del = [$dh,$dm,$ds];
3514 my ($err,$offset,$abbrev);
3515
3516 ($err,$date,$offset,$isdst,$abbrev) =
3517 $dmt->_convert('__calc_date_delta_exact',$date,$tz,'GMT',$isdst);
3518
3519 $date = $dmb->calc_date_time($date,$del,0);
3520
3521 ($err,$date,$offset,$isdst,$abbrev) =
3522 $dmt->_convert('__calc_date_delta_exact',$date,'GMT',$tz,$isdst);
3523
3524 return($err,$date,$offset,$isdst,$abbrev);
3525 }
3526}
3527
3528# This checks to see which time (STD or DST) a date is in. It checks
3529# $isdst first, and the other value (1-$isdst) second.
3530#
3531# If the date is found in either time, it is returned.
3532#
3533# If the date is NOT found, then we got here by adding/subtracting 1 day
3534# from a different value, and we've obtained an invalid value. In this
3535# case, if $force = 0, then return nothing.
3536#
3537# If $force = 1, then go to the previous day and add 24 hours. If force
3538# is -1, then go to the next day and subtract 24 hours.
3539#
3540# Returns:
3541# ($date,$off,$isdst,$abb)
3542# or
3543# (undef)
3544#
3545sub _calc_date_check_dst {
3546 my($self,$date,$tz,$isdst,$force) = @_;
3547 my $dmt = $$self{'tz'};
3548 my $dmb = $$dmt{'base'};
3549 my($abb,$off,$err);
3550
3551 # Try the date as is in both ISDST and 1-ISDST times
3552
3553 my $per = $dmt->date_period($date,$tz,1,$isdst);
3554 if ($per) {
3555 $abb = $$per[4];
3556 $off = $$per[3];
3557 return($date,$off,$isdst,$abb);
3558 }
3559
3560 $per = $dmt->date_period($date,$tz,1,1-$isdst);
3561 if ($per) {
3562 $isdst = 1-$isdst;
3563 $abb = $$per[4];
3564 $off = $$per[3];
3565 return($date,$off,$isdst,$abb);
3566 }
3567
3568 # If we made it here, the date is invalid in this timezone.
3569 # Either return undef, or add/subtract a day from the date
3570 # and find out what time period we're in (all we care about
3571 # is the ISDST value).
3572
3573 if (! $force) {
3574 return(undef);
3575 }
3576
3577 my($dd);
3578 if ($force > 0) {
3579 $date = $dmb->calc_date_days($date,-1);
3580 $dd = 1;
3581 } else {
3582 $date = $dmb->calc_date_days($date,+1);
3583 $dd = -1;
3584 }
3585
3586 $per = $dmt->date_period($date,$tz,1,$isdst);
3587 $isdst = (1-$isdst) if (! $per);
3588
3589 # Now, convert it to GMT, add/subtract 24 hours, and convert
3590 # it back.
3591
3592 ($err,$date,$off,$isdst,$abb) = $dmt->convert_to_gmt($date,$tz,$isdst);
3593 $date = $dmb->calc_date_days($date,$dd);
3594 ($err,$date,$off,$isdst,$abb) = $dmt->convert_from_gmt($date,$tz);
3595
3596 return($date,$off,$isdst,$abb);
3597}
3598
3599########################################################################
3600# MISC METHODS
3601
3602sub secs_since_1970_GMT {
3603 my($self,$secs) = @_;
3604
3605 my $dmt = $$self{'tz'};
3606 my $dmb = $$dmt{'base'};
3607
3608 if (defined $secs) {
3609 my $date = $dmb->secs_since_1970($secs);
3610 my $err;
3611 ($err,$date) = $dmt->convert_from_gmt($date);
3612 return 1 if ($err);
3613 $self->set('date',$date);
3614 return 0;
3615 }
3616
3617 my @date = $self->value('gmt');
3618 $secs = $dmb->secs_since_1970(\@date);
3619 return $secs;
3620}
3621
3622sub week_of_year {
3623 my($self,$first) = @_;
3624 if ($$self{'err'} || ! $$self{'data'}{'set'}) {
3625 warn "WARNING: [week_of_year] Object must contain a valid date\n";
3626 return undef;
3627 }
3628
3629 my $dmt = $$self{'tz'};
3630 my $dmb = $$dmt{'base'};
3631 my $date = $$self{'data'}{'date'};
3632 my $y = $$date[0];
3633
3634 my($day,$dow,$doy,$f);
3635 $doy = $dmb->day_of_year($date);
3636
3637 # The date in January which must belong to the first week, and
3638 # it's DayOfWeek.
3639 if ($dmb->_config('jan1week1')) {
3640 $day=1;
3641 } else {
3642 $day=4;
3643 }
3644 $dow = $dmb->day_of_week([$y,1,$day]);
3645
3646 # The start DayOfWeek. If $first is passed in, use it. Otherwise,
3647 # use FirstDay.
3648
3649 if (! $first) {
3650 $first = $dmb->_config('firstday');
3651 }
3652
3653 # Find the pseudo-date of the first day of the first week (it may
3654 # be negative meaning it occurs last year).
3655
3656 $first -= 7 if ($first > $dow);
3657 $day -= ($dow-$first);
3658
3659 return 0 if ($day>$doy); # Day is in last week of previous year
3660 return (($doy-$day)/7 + 1);
3661}
3662
3663sub complete {
3664 my($self,$field) = @_;
3665 if ($$self{'err'} || ! $$self{'data'}{'set'}) {
3666 warn "WARNING: [complete] Object must contain a valid date\n";
3667 return undef;
3668 }
3669
3670 if (! $field) {
3671 return 1 if (! $$self{'data'}{'def'}[1] &&
3672 ! $$self{'data'}{'def'}[2] &&
3673 ! $$self{'data'}{'def'}[3] &&
3674 ! $$self{'data'}{'def'}[4] &&
3675 ! $$self{'data'}{'def'}[5]);
3676 return 0;
3677 }
3678
3679 if ($field eq 'm') {
3680 return 1 if (! $$self{'data'}{'def'}[1]);
3681 }
3682
3683 if ($field eq 'd') {
3684 return 1 if (! $$self{'data'}{'def'}[2]);
3685 }
3686
3687 if ($field eq 'h') {
3688 return 1 if (! $$self{'data'}{'def'}[3]);
3689 }
3690
3691 if ($field eq 'mn') {
3692 return 1 if (! $$self{'data'}{'def'}[4]);
3693 }
3694
3695 if ($field eq 's') {
3696 return 1 if (! $$self{'data'}{'def'}[5]);
3697 }
3698 return 0;
3699}
3700
3701sub convert {
3702 my($self,$zone) = @_;
3703 if ($$self{'err'} || ! $$self{'data'}{'set'}) {
3704 warn "WARNING: [convert] Object must contain a valid date\n";
3705 return 1;
3706 }
3707 my $dmt = $$self{'tz'};
3708 my $dmb = $$dmt{'base'};
3709
3710 my $zonename = $dmt->_zone($zone);
3711
3712 if (! $zonename) {
3713 $$self{'err'} = "[convert] Unable to determine timezone: $zone";
3714 return 1;
3715 }
3716
3717 my $date0 = $$self{'data'}{'date'};
3718 my $zone0 = $$self{'data'}{'tz'};
3719 my $isdst0 = $$self{'data'}{'isdst'};
3720
3721 my($err,$date,$off,$isdst,$abb) = $dmt->convert($date0,$zone0,$zonename,$isdst0);
3722
3723 if ($err) {
3724 $$self{'err'} = '[convert] Unable to convert date to new timezone';
3725 return 1;
3726 }
3727
3728 $self->_init();
3729 $$self{'data'}{'date'} = $date;
3730 $$self{'data'}{'tz'} = $zonename;
3731 $$self{'data'}{'isdst'} = $isdst;
3732 $$self{'data'}{'offset'} = $off;
3733 $$self{'data'}{'abb'} = $abb;
3734 $$self{'data'}{'set'} = 1;
3735
3736 return 0;
3737}
3738
3739########################################################################
3740# BUSINESS DAY METHODS
3741
3742sub is_business_day {
3743 my($self,$checktime) = @_;
3744 if ($$self{'err'} || ! $$self{'data'}{'set'}) {
3745 warn "WARNING: [is_business_day] Object must contain a valid date\n";
3746 return undef;
3747 }
3748 my $date = $$self{'data'}{'date'};
3749 return $self->__is_business_day($date,$checktime);
3750}
3751
3752sub __is_business_day {
3753 my($self,$date,$checktime) = @_;
3754 my($y,$m,$d,$h,$mn,$s) = @$date;
3755
3756 my $dmt = $$self{'tz'};
3757 my $dmb = $$dmt{'base'};
3758
3759 # Return 0 if it's a weekend.
3760
3761 my $dow = $dmb->day_of_week([$y,$m,$d]);
3762 return 0 if ($dow < $dmb->_config('workweekbeg') ||
3763 $dow > $dmb->_config('workweekend'));
3764
3765 # Return 0 if it's not during work hours (and we're checking
3766 # for that).
3767
3768 if ($checktime &&
3769 ! $dmb->_config('workday24hr')) {
3770 my $t = $dmb->join('hms',[$h,$mn,$s]);
3771 my $t0 = $dmb->join('hms',$$dmb{'data'}{'calc'}{'workdaybeg'});
3772 my $t1 = $dmb->join('hms',$$dmb{'data'}{'calc'}{'workdayend'});
3773 return 0 if ($t lt $t0 || $t gt $t1);
3774 }
3775
3776 # Check for holidays
3777
3778 $self->_holidays($y,2) unless ($$dmb{'data'}{'init_holidays'});
3779
3780 return 0 if (exists $$dmb{'data'}{'holidays'}{'dates'} &&
3781 exists $$dmb{'data'}{'holidays'}{'dates'}{$y+0} &&
3782 exists $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m+0} &&
3783 exists $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m+0}{$d+0});
3784
3785 return 1;
3786}
3787
3788sub list_holidays {
3789 my($self,$y) = @_;
3790 my $dmt = $$self{'tz'};
3791 my $dmb = $$dmt{'base'};
3792
3793 $y = $dmt->_now('y',1) if (! $y);
3794 $self->_holidays($y,2);
3795
3796 my @ret;
3797 my @m = sort { $a <=> $b } keys %{ $$dmb{'data'}{'holidays'}{'dates'}{$y+0} };
3798 foreach my $m (@m) {
3799 my @d = sort { $a <=> $b } keys %{ $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m} };
3800 foreach my $d (@d) {
3801 my $hol = $self->new_date();
3802 $hol->set('date',[$y,$m,$d,0,0,0]);
3803 push(@ret,$hol);
3804 }
3805 }
3806
3807 return @ret;
3808}
3809
3810sub holiday {
3811 my($self) = @_;
3812 if ($$self{'err'} || ! $$self{'data'}{'set'}) {
3813 warn "WARNING: [holiday] Object must contain a valid date\n";
3814 return undef;
3815 }
3816 my $dmt = $$self{'tz'};
3817 my $dmb = $$dmt{'base'};
3818
3819 my($y,$m,$d) = @{ $$self{'data'}{'date'} };
3820 $self->_holidays($y,2);
3821
3822 if (exists $$dmb{'data'}{'holidays'}{'dates'}{$y+0} &&
3823 exists $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m+0} &&
3824 exists $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m+0}{$d+0}) {
3825 my @tmp = @{ $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m+0}{$d+0} };
3826 if (wantarray) {
3827 return () if (! @tmp);
3828 return @tmp;
3829 } else {
3830 return '' if (! @tmp);
3831 return $tmp[0];
3832 }
3833 }
3834 return undef;
3835}
3836
3837sub next_business_day {
3838 my($self,$off,$checktime) = @_;
3839 if ($$self{'err'} || ! $$self{'data'}{'set'}) {
3840 warn "WARNING: [next_business_day] Object must contain a valid date\n";
3841 return undef;
3842 }
3843 my $date = $$self{'data'}{'date'};
3844
3845 $date = $self->__nextprev_business_day(0,$off,$checktime,$date);
3846 $self->set('date',$date);
3847}
3848
3849sub prev_business_day {
3850 my($self,$off,$checktime) = @_;
3851 if ($$self{'err'} || ! $$self{'data'}{'set'}) {
3852 warn "WARNING: [prev_business_day] Object must contain a valid date\n";
3853 return undef;
3854 }
3855 my $date = $$self{'data'}{'date'};
3856
3857 $date = $self->__nextprev_business_day(1,$off,$checktime,$date);
3858 $self->set('date',$date);
3859}
3860
3861sub __nextprev_business_day {
3862 my($self,$prev,$off,$checktime,$date) = @_;
3863 my($y,$m,$d,$h,$mn,$s) = @$date;
3864
3865 my $dmt = $$self{'tz'};
3866 my $dmb = $$dmt{'base'};
3867
3868 # Get day 0
3869
3870 while (! $self->__is_business_day([$y,$m,$d,$h,$mn,$s],$checktime)) {
3871 if ($checktime) {
3872 ($y,$m,$d,$h,$mn,$s) =
3873 @{ $self->__next_prev([$y,$m,$d,$h,$mn,$s],1,undef,0,
3874 $$dmb{'data'}{'calc'}{'workdaybeg'}) };
3875 } else {
3876 # Move forward 1 day
3877 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],1) };
3878 }
3879 }
3880
3881 # Move $off days into the future/past
3882
3883 while ($off > 0) {
3884 while (1) {
3885 if ($prev) {
3886 # Move backward 1 day
3887 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],-1) };
3888 } else {
3889 # Move forward 1 day
3890 ($y,$m,$d) = @{ $dmb->calc_date_days([$y,$m,$d],1) };
3891 }
3892 last if ($self->__is_business_day([$y,$m,$d,$h,$mn,$s]));
3893 }
3894 $off--;
3895 }
3896
3897 return [$y,$m,$d,$h,$mn,$s];
3898}
3899
3900sub nearest_business_day {
3901 my($self,$tomorrow) = @_;
3902 if ($$self{'err'} || ! $$self{'data'}{'set'}) {
3903 warn "WARNING: [nearest_business_day] Object must contain a valid date\n";
3904 return undef;
3905 }
3906
3907 my $date = $$self{'data'}{'date'};
3908 $date = $self->__nearest_business_day($tomorrow,$date);
3909
3910 # If @date is empty, the date is a business day and doesn't need
3911 # to be changed.
3912
3913 return if (! defined($date));
3914
3915 $self->set('date',$date);
3916}
3917
3918sub __nearest_business_day {
3919 my($self,$tomorrow,$date) = @_;
3920
3921 # We're done if this is a business day
3922 return undef if ($self->__is_business_day($date,0));
3923
3924 my $dmt = $$self{'tz'};
3925 my $dmb = $$dmt{'base'};
3926
3927 $tomorrow = $dmb->_config('tomorrowfirst') if (! defined $tomorrow);
3928
3929 my($a1,$a2);
3930 if ($tomorrow) {
3931 ($a1,$a2) = (1,-1);
3932 } else {
3933 ($a1,$a2) = (-1,1);
3934 }
3935
3936 my ($y,$m,$d,$h,$mn,$s) = @$date;
3937 my ($y1,$m1,$d1) = ($y,$m,$d);
3938 my ($y2,$m2,$d2) = ($y,$m,$d);
3939
3940 while (1) {
3941 ($y1,$m1,$d1) = @{ $dmb->calc_date_days([$y1,$m1,$d1],$a1) };
3942 if ($self->__is_business_day([$y1,$m1,$d1,$h,$mn,$s],0)) {
3943 ($y,$m,$d) = ($y1,$m1,$d1);
3944 last;
3945 }
3946 ($y2,$m2,$d2) = @{ $dmb->calc_date_days([$y2,$m2,$d2],$a2) };
3947 if ($self->__is_business_day([$y2,$m2,$d2,$h,$mn,$s],0)) {
3948 ($y,$m,$d) = ($y2,$m2,$d2);
3949 last;
3950 }
3951 }
3952
3953 return [$y,$m,$d,$h,$mn,$s];
3954}
3955
3956# We need to create all the objects which will be used to determine holidays.
3957# By doing this once only, a lot of time is saved.
3958#
3959sub _holiday_objs {
3960 my($self) = @_;
3961 my $dmt = $$self{'tz'};
3962 my $dmb = $$dmt{'base'};
3963
3964 $$dmb{'data'}{'holidays'}{'init'} = 1;
3965
3966 # Go through all of the strings from the config file.
3967 #
3968 my (@str) = @{ $$dmb{'data'}{'sections'}{'holidays'} };
3969 $$dmb{'data'}{'holidays'}{'hols'} = [];
3970
3971 while (@str) {
3972 my($string) = shift(@str);
3973 my($name) = shift(@str);
3974
3975 # If $string is a parse_date string AND it contains a year, we'll
3976 # store the date as a holiday, but not store the holiday description
3977 # so it never needs to be re-parsed.
3978
3979 my $date = $self->new_date();
3980 my $err = $date->parse_date($string);
3981 if (! $err) {
3982 if ($$date{'data'}{'def'}[0] eq '') {
3983 push(@{ $$dmb{'data'}{'holidays'}{'hols'} },$string,$name);
3984 } else {
3985 my($y,$m,$d) = @{ $$date{'data'}{'date'} };
3986 if (exists $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m+0}{$d+0}) {
3987 push @{ $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m+0}{$d+0} },$name;
3988 } else {
3989 $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m+0}{$d+0} = [ $name ];
3990 }
3991 }
3992
3993 next;
3994 }
3995 $date->err(1);
3996
3997 # If $string is a recurrence, we'll create a Recur object (which we
3998 # only have to do once) and store it.
3999
4000 my $recur = $self->new_recur();
4001 $recur->_holiday();
4002 $err = $recur->parse($string);
4003 if (! $err) {
4004 push(@{ $$dmb{'data'}{'holidays'}{'hols'} },$recur,$name);
4005 next;
4006 }
4007 $recur->err(1);
4008
4009 warn "WARNING: invalid holiday description: $string\n";
4010 }
4011}
4012
4013# Make sure that holidays are set for a given year.
4014#
4015# $$dmb{'data'}{'holidays'}{'years'}{$year} = 0 nothing done
4016# 1 this year done
4017# 2 both adjacent years done
4018#
4019sub _holidays {
4020 my($self,$year,$level) = @_;
4021
4022 my $dmt = $$self{'tz'};
4023 my $dmb = $$dmt{'base'};
4024 $self->_holiday_objs($year) if (! $$dmb{'data'}{'holidays'}{'init'});
4025
4026 $$dmb{'data'}{'holidays'}{'years'}{$year} = 0
4027 if (! exists $$dmb{'data'}{'holidays'}{'years'}{$year});
4028
4029 my $curr_level = $$dmb{'data'}{'holidays'}{'years'}{$year};
4030 return if ($curr_level >= $level);
4031 $$dmb{'data'}{'holidays'}{'years'}{$year} = $level;
4032
4033 # Parse the year
4034
4035 if ($curr_level == 0) {
4036 $self->_holidays_year($year);
4037
4038 return if ($level == 1);
4039 }
4040
4041 # Parse the years around it.
4042
4043 $self->_holidays($year-1,1);
4044 $self->_holidays($year+1,1);
4045}
4046
4047sub _holidays_year {
4048 my($self,$y) = @_;
4049
4050 my $dmt = $$self{'tz'};
4051 my $dmb = $$dmt{'base'};
4052
4053 # Get the objects and set them to use the new year. Also, get the
4054 # range for recurrences.
4055
4056 my @hol = @{ $$dmb{'data'}{'holidays'}{'hols'} };
4057
4058 my $beg = $self->new_date();
4059 $beg->set('date',[$y-1,12,1,0,0,0]);
4060 my $end = $self->new_date();
4061 $end->set('date',[$y+1,2,1,0,0,0]);
4062
4063 # Get the date for each holiday.
4064
4065 $$dmb{'data'}{'init_holidays'} = 1;
4066
4067 while (@hol) {
4068
4069 my($obj) = shift(@hol);
4070 my($name) = shift(@hol);
4071
4072 $$dmb{'data'}{'tmpnow'} = [$y,1,1,0,0,0];
4073 if (ref($obj)) {
4074 # It's a recurrence
4075
4076 # If the recurrence has a date range built in, we won't override it.
4077 # Otherwise, we'll only look for dates in this year.
4078
4079 if ($obj->start() && $obj->end()) {
4080 $obj->dates();
4081 } else {
4082 $obj->dates($beg,$end);
4083 }
4084
4085 foreach my $i (keys %{ $$obj{'data'}{'dates'} }) {
4086 next if ($$obj{'data'}{'saved'}{$i});
4087 my $date = $$obj{'data'}{'dates'}{$i};
4088 my($y,$m,$d) = @{ $$date{'data'}{'date'} };
4089 if (exists $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m+0}{$d+0}) {
4090 push @{ $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m+0}{$d+0} },$name;
4091 } else {
4092 $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m+0}{$d+0} = [$name];
4093 }
4094 $$obj{'data'}{'saved'}{$i} = 1;
4095 }
4096
4097 } else {
4098 my $date = $self->new_date();
4099 $date->parse_date($obj);
4100 my($y,$m,$d) = @{ $$date{'data'}{'date'} };
4101 if (exists $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m+0}{$d+0}) {
4102 push @{ $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m+0}{$d+0} },$name;
4103 } else {
4104 $$dmb{'data'}{'holidays'}{'dates'}{$y+0}{$m+0}{$d+0} = [$name];
4105 }
4106 }
4107 $$dmb{'data'}{'tmpnow'} = [];
4108 }
4109
4110 $$dmb{'data'}{'init_holidays'} = 0;
4111}
4112
4113########################################################################
4114# PRINTF METHOD
4115
4116
# spent 22µs within Date::Manip::Date::BEGIN@4116 which was called: # once (22µs+0s) by Date::Manip::DM6::BEGIN@62 at line 4433
BEGIN {
411716µs my %pad_0 = map { $_,1 } qw ( Y m d H M S I j G W L U );
411812µs my %pad_sp = map { $_,1 } qw ( y f e k i );
411911µs my %hr = map { $_,1 } qw ( H k I i );
412012µs my %dow = map { $_,1 } qw ( v a A w );
4121112µs my %num = map { $_,1 } qw ( Y m d H M S y f e k I i j G W L U );
4122
4123 sub printf {
4124 my($self,@in) = @_;
4125 if ($$self{'err'} || ! $$self{'data'}{'set'}) {
4126 warn "WARNING: [printf] Object must contain a valid date\n";
4127 return undef;
4128 }
4129
4130 my $dmt = $$self{'tz'};
4131 my $dmb = $$dmt{'base'};
4132
4133 my($y,$m,$d,$h,$mn,$s) = @{ $$self{'data'}{'date'} };
4134
4135 my(@out);
4136 foreach my $in (@in) {
4137 my $out = '';
4138 while ($in) {
4139 last if ($in eq '%');
4140
4141 # Everything up to the first '%'
4142
4143 if ($in =~ s/^([^%]+)//) {
4144 $out .= $1;
4145 next;
4146 }
4147
4148 # Extended formats: %<...>
4149
4150 if ($in =~ s/^%<([^>]+)>//) {
4151 my $f = $1;
4152 my $val;
4153
4154 if ($f =~ /^a=([1-7])$/) {
4155 $val = $$dmb{'data'}{'wordlist'}{'day_abb'}[$1-1];
4156
4157 } elsif ($f =~ /^v=([1-7])$/) {
4158 $val = $$dmb{'data'}{'wordlist'}{'day_char'}[$1-1];
4159
4160 } elsif ($f =~ /^A=([1-7])$/) {
4161 $val = $$dmb{'data'}{'wordlist'}{'day_name'}[$1-1];
4162
4163 } elsif ($f =~ /^p=([1-2])$/) {
4164 $val = $$dmb{'data'}{'wordlist'}{'ampm'}[$1-1];
4165
4166 } elsif ($f =~ /^b=(0?[1-9]|1[0-2])$/) {
4167 $val = $$dmb{'data'}{'wordlist'}{'month_abb'}[$1-1];
4168
4169 } elsif ($f =~ /^B=(0?[1-9]|1[0-2])$/) {
4170 $val = $$dmb{'data'}{'wordlist'}{'month_name'}[$1-1];
4171
4172 } elsif ($f =~ /^E=(0?[1-9]|[1-4][0-9]|5[0-3])$/) {
4173 $val = $$dmb{'data'}{'wordlist'}{'nth'}[$1-1];
4174
4175 } else {
4176 $val = '%<' . $1 . '>';
4177 }
4178 $out .= $val;
4179 next;
4180 }
4181
4182 # Normals one-character formats
4183
4184 $in =~ s/^%(.)//;
4185 my $f = $1;
4186
4187 if (exists $$self{'data'}{'f'}{$f}) {
4188 $out .= $$self{'data'}{'f'}{$f};
4189 next;
4190 }
4191
4192 my ($val,$pad,$len,$dow);
4193
4194 if (exists $pad_0{$f}) {
4195 $pad = '0';
4196 }
4197
4198 if (exists $pad_sp{$f}) {
4199 $pad = ' ';
4200 }
4201
4202 if ($f eq 'G' || $f eq 'W') {
4203 my($yy,$ww) = $dmb->_week_of_year(1,[$y,$m,$d]);
4204 if ($f eq 'G') {
4205 $val = $yy;
4206 $len = 4;
4207 } else {
4208 $val = $ww;
4209 $len = 2;
4210 }
4211 }
4212
4213 if ($f eq 'L' || $f eq 'U') {
4214 my($yy,$ww) = $dmb->_week_of_year(7,[$y,$m,$d]);
4215 if ($f eq 'L') {
4216 $val = $yy;
4217 $len = 4;
4218 } else {
4219 $val = $ww;
4220 $len = 2;
4221 }
4222 }
4223
4224 if ($f eq 'Y' || $f eq 'y') {
4225 $val = $y;
4226 $len = 4;
4227 }
4228
4229 if ($f eq 'm' || $f eq 'f') {
4230 $val = $m;
4231 $len = 2;
4232 }
4233
4234 if ($f eq 'd' || $f eq 'e') {
4235 $val = $d;
4236 $len = 2;
4237 }
4238
4239 if ($f eq 'j') {
4240 $val = $dmb->day_of_year([$y,$m,$d]);
4241 $len = 3;
4242 }
4243
4244
4245 if (exists $hr{$f}) {
4246 $val = $h;
4247 if ($f eq 'I' || $f eq 'i') {
4248 $val -= 12 if ($val > 12);
4249 $val = 12 if ($val == 0);
4250 }
4251 $len = 2;
4252 }
4253
4254 if ($f eq 'M') {
4255 $val = $mn;
4256 $len = 2;
4257 }
4258
4259 if ($f eq 'S') {
4260 $val = $s;
4261 $len = 2;
4262 }
4263
4264 if (exists $dow{$f}) {
4265 $dow = $dmb->day_of_week([$y,$m,$d]);
4266 }
4267
4268 ###
4269
4270 if (exists $num{$f}) {
4271 while (length($val) < $len) {
4272 $val = "$pad$val";
4273 }
4274
4275 $val = substr($val,2,2) if ($f eq 'y');
4276
4277 } elsif ($f eq 'b' || $f eq 'h') {
4278 $val = $$dmb{'data'}{'wordlist'}{'month_abb'}[$m-1];
4279
4280 } elsif ($f eq 'B') {
4281 $val = $$dmb{'data'}{'wordlist'}{'month_name'}[$m-1];
4282
4283 } elsif ($f eq 'v') {
4284 $val = $$dmb{'data'}{'wordlist'}{'day_char'}[$dow-1];
4285
4286 } elsif ($f eq 'a') {
4287 $val = $$dmb{'data'}{'wordlist'}{'day_abb'}[$dow-1];
4288
4289 } elsif ($f eq 'A') {
4290 $val = $$dmb{'data'}{'wordlist'}{'day_name'}[$dow-1];
4291
4292 } elsif ($f eq 'w') {
4293 $val = $dow;
4294
4295 } elsif ($f eq 'p') {
4296 my $i = ($h >= 12 ? 1 : 0);
4297 $val = $$dmb{'data'}{'wordlist'}{'ampm'}[$i];
4298
4299 } elsif ($f eq 'Z') {
4300 $val = $$self{'data'}{'abb'};
4301
4302 } elsif ($f eq 'N') {
4303 my $off = $$self{'data'}{'offset'};
4304 $val = $dmb->join('offset',$off);
4305
4306 } elsif ($f eq 'z') {
4307 my $off = $$self{'data'}{'offset'};
4308 $val = $dmb->join('offset',$off);
4309 $val =~ s/://g;
4310 $val =~ s/00$//;
4311
4312 } elsif ($f eq 'E') {
4313 $val = $$dmb{'data'}{'wordlist'}{'nth_dom'}[$d-1];
4314
4315 } elsif ($f eq 's') {
4316 $val = $self->secs_since_1970_GMT();
4317
4318 } elsif ($f eq 'o') {
4319 my $date2 = $self->new_date();
4320 $date2->parse('1970-01-01 00:00:00');
4321 my $delta = $date2->calc($self);
4322 $val = $delta->printf('%sys');
4323
4324 } elsif ($f eq 'l') {
4325 my $d0 = $self->new_date();
4326 my $d1 = $self->new_date();
4327 $d0->parse('-0:6:0:0:0:0:0'); # 6 months ago
4328 $d1->parse('+0:6:0:0:0:0:0'); # in 6 months
4329 $d0 = $d0->value();
4330 $d1 = $d1->value();
4331 my $date = $self->value();
4332 if ($date lt $d0 || $date ge $d1) {
4333 $in = '%b %e %Y' . $in;
4334 } else {
4335 $in = '%b %e %H:%M' . $in;
4336 }
4337 $val = '';
4338
4339 } elsif ($f eq 'c') {
4340 $in = '%a %b %e %H:%M:%S %Y' . $in;
4341 $val = '';
4342
4343 } elsif ($f eq 'C' || $f eq 'u') {
4344 $in = '%a %b %e %H:%M:%S %Z %Y' . $in;
4345 $val = '';
4346
4347 } elsif ($f eq 'g') {
4348 $in = '%a, %d %b %Y %H:%M:%S %Z' . $in;
4349 $val = '';
4350
4351 } elsif ($f eq 'D') {
4352 $in = '%m/%d/%y' . $in;
4353 $val = '';
4354
4355 } elsif ($f eq 'r') {
4356 $in = '%I:%M:%S %p' . $in;
4357 $val = '';
4358
4359 } elsif ($f eq 'R') {
4360 $in = '%H:%M' . $in;
4361 $val = '';
4362
4363 } elsif ($f eq 'T' || $f eq 'X') {
4364 $in = '%H:%M:%S' . $in;
4365 $val = '';
4366
4367 } elsif ($f eq 'V') {
4368 $in = '%m%d%H%M%y' . $in;
4369 $val = '';
4370
4371 } elsif ($f eq 'Q') {
4372 $in = '%Y%m%d' . $in;
4373 $val = '';
4374
4375 } elsif ($f eq 'q') {
4376 $in = '%Y%m%d%H%M%S' . $in;
4377 $val = '';
4378
4379 } elsif ($f eq 'P') {
4380 $in = '%Y%m%d%H:%M:%S' . $in;
4381 $val = '';
4382
4383 } elsif ($f eq 'O') {
4384 $in = '%Y-%m-%dT%H:%M:%S' . $in;
4385 $val = '';
4386
4387 } elsif ($f eq 'F') {
4388 $in = '%A, %B %e, %Y' . $in;
4389 $val = '';
4390
4391 } elsif ($f eq 'K') {
4392 $in = '%Y-%j' . $in;
4393 $val = '';
4394
4395 } elsif ($f eq 'x') {
4396 if ($dmb->_config('dateformat') eq 'US') {
4397 $in = '%m/%d/%y' . $in;
4398 } else {
4399 $in = '%d/%m/%y' . $in;
4400 }
4401 $val = '';
4402
4403 } elsif ($f eq 'J') {
4404 $in = '%G-W%W-%w' . $in;
4405 $val = '';
4406
4407 } elsif ($f eq 'n') {
4408 $val = "\n";
4409
4410 } elsif ($f eq 't') {
4411 $val = "\t";
4412
4413 } else {
4414 $val = $f;
4415 }
4416
4417 if ($val ne '') {
4418 $$self{'data'}{'f'}{$f} = $val;
4419 $out .= $val;
4420 }
4421 }
4422 push(@out,$out);
4423 }
4424
4425 if (wantarray) {
4426 return @out;
4427 } elsif (@out == 1) {
4428 return $out[0];
4429 }
4430
4431 return ''
4432 }
443311.78ms122µs}
# spent 22µs making 1 call to Date::Manip::Date::BEGIN@4116
4434
4435########################################################################
4436# EVENT METHODS
4437
4438sub list_events {
4439 my($self,@args) = @_;
4440 if ($$self{'err'} || ! $$self{'data'}{'set'}) {
4441 warn "WARNING: [list_events] Object must contain a valid date\n";
4442 return undef;
4443 }
4444 my $dmt = $$self{'tz'};
4445 my $dmb = $$dmt{'base'};
4446
4447 # Arguments
4448
4449 my($date,$day,$format);
4450 if (@args && $args[$#args] eq 'dates') {
4451 pop(@args);
4452 $format = 'dates';
4453 } else {
4454 $format = 'std';
4455 }
4456
4457 if (@args && $#args==0 && ref($args[0]) eq 'Date::Manip::Date') {
4458 $date = $args[0];
4459 } elsif (@args && $#args==0 && $args[0]==0) {
4460 $day = 1;
4461 } elsif (@args) {
4462 warn "ERROR: [list_events] unknown argument list\n";
4463 return [];
4464 }
4465
4466 # Get the beginning/end dates we're looking for events in
4467
4468 my($beg,$end);
4469 if ($date) {
4470 $beg = $self;
4471 $end = $date;
4472 } elsif ($day) {
4473 $beg = $self->new_date();
4474 $end = $self->new_date();
4475 my($y,$m,$d) = $self->value();
4476 $beg->set('date',[$y,$m,$d,0,0,0]);
4477 $end->set('date',[$y,$m,$d,23,59,59]);
4478 } else {
4479 $beg = $self;
4480 $end = $self;
4481 }
4482
4483 if ($beg->cmp($end) == 1) {
4484 my $tmp = $beg;
4485 $beg = $end;
4486 $end = $tmp;
4487 }
4488
4489 # We need to get a list of all events which may apply.
4490
4491 my($y0) = $beg->value();
4492 my($y1) = $end->value();
4493 foreach my $y ($y0..$y1) {
4494 $self->_events_year($y);
4495 }
4496
4497 my @events = ();
4498 foreach my $i (keys %{ $$dmb{'data'}{'events'} }) {
4499 my $event = $$dmb{'data'}{'events'}{$i};
4500 my $type = $$event{'type'};
4501 my $name = $$event{'name'};
4502
4503 if ($type eq 'specified') {
4504 my $d0 = $$dmb{'data'}{'events'}{$i}{'beg'};
4505 my $d1 = $$dmb{'data'}{'events'}{$i}{'end'};
4506 push @events,[$d0,$d1,$name];
4507
4508 } elsif ($type eq 'ym' || $type eq 'date') {
4509 foreach my $y ($y0..$y1) {
4510 if (exists $$dmb{'data'}{'events'}{$i}{$y}) {
4511 my($d0,$d1) = @{ $$dmb{'data'}{'events'}{$i}{$y} };
4512 push @events,[$d0,$d1,$name];
4513 }
4514 }
4515
4516 } elsif ($type eq 'recur') {
4517 my $rec = $$dmb{'data'}{'events'}{$i}{'recur'};
4518 my $del = $$dmb{'data'}{'events'}{$i}{'delta'};
4519 my @d = $rec->dates($beg,$end);
4520 foreach my $d0 (@d) {
4521 my $d1 = $d0->calc($del);
4522 push @events,[$d0,$d1,$name];
4523 }
4524 }
4525 }
4526
4527 # Next we need to see which ones apply.
4528
4529 my @tmp;
4530 foreach my $e (@events) {
4531 my($d0,$d1,$name) = @$e;
4532
4533 push(@tmp,$e) if ($beg->cmp($d1) != 1 &&
4534 $end->cmp($d0) != -1);
4535 }
4536
4537 # Now format them...
4538
4539 if ($format eq 'std') {
4540 @events = sort { $$a[0]->cmp($$b[0]) ||
4541 $$a[1]->cmp($$b[1]) ||
4542 $$a[2] cmp $$b[2] } @tmp;
4543
4544 } elsif ($format eq 'dates') {
4545 my $p1s = $self->new_delta();
4546 $p1s->parse('+0:0:0:0:0:0:1');
4547
4548 @events = ();
4549 my (@tmp2);
4550 foreach my $e (@tmp) {
4551 my $name = $$e[2];
4552 if ($$e[0]->cmp($beg) == -1) {
4553 # Event begins before the start
4554 push(@tmp2,[$beg,'+',$name]);
4555 } else {
4556 push(@tmp2,[$$e[0],'+',$name]);
4557 }
4558
4559 my $d1 = $$e[1]->calc($p1s);
4560
4561 if ($d1->cmp($end) == -1) {
4562 # Event ends before the end
4563 push(@tmp2,[$d1,'-',$name]);
4564 }
4565 }
4566
4567 return () if (! @tmp2);
4568 @tmp2 = sort { $$a[0]->cmp($$b[0]) ||
4569 $$a[1] cmp $$b[1] ||
4570 $$a[2] cmp $$b[2] } @tmp2;
4571
4572 # @tmp2 is now:
4573 # ( [ DATE1, OP1, NAME1 ], [ DATE2, OP2, NAME2 ], ... )
4574 # which is sorted by date.
4575
4576 my $d = $tmp2[0]->[0];
4577
4578 if ($beg->cmp($d) != 0) {
4579 push(@events,[$beg]);
4580 }
4581
4582 my %e;
4583 while (1) {
4584
4585 # If the first element is the same date as we're
4586 # currently working with, just perform the operation
4587 # and remove it from the list. If the list is not empty,
4588 # we'll proceed to the next element.
4589
4590 my $d0 = $tmp2[0]->[0];
4591 if ($d->cmp($d0) == 0) {
4592 my $e = shift(@tmp2);
4593 my $op = $$e[1];
4594 my $n = $$e[2];
4595 if ($op eq '+') {
4596 $e{$n} = 1;
4597 } else {
4598 delete $e{$n};
4599 }
4600
4601 next if (@tmp2);
4602 }
4603
4604 # We need to store the existing %e.
4605
4606 my @n = sort keys %e;
4607 push(@events,[$d,@n]);
4608
4609 # If the list is empty, we're done. Otherwise, we need to
4610 # reset the date and continue.
4611
4612 last if (! @tmp2);
4613 $d = $tmp2[0]->[0];
4614 }
4615 }
4616
4617 return @events;
4618}
4619
4620# The events of type date and ym are determined on a year-by-year basis
4621#
4622sub _events_year {
4623 my($self,$y) = @_;
4624 my $dmt = $$self{'tz'};
4625 my $dmb = $$dmt{'base'};
4626 my $tz = $dmt->_now('tz',1);
4627 return if (exists $$dmb{'data'}{'eventyears'}{$y});
4628 $self->_event_objs() if (! $$dmb{'data'}{'eventobjs'});
4629
4630 my $d = $self->new_date();
4631 $d->config('forcedate',"${y}-01-01-00:00:00,$tz");
4632
4633 my $hrM1 = $d->new_delta();
4634 $hrM1->set('delta',[0,0,0,0,0,59,59]);
4635
4636 my $dayM1 = $d->new_delta();
4637 $dayM1->set('delta',[0,0,0,0,23,59,59]);
4638
4639 foreach my $i (keys %{ $$dmb{'data'}{'events'} }) {
4640 my $event = $$dmb{'data'}{'events'}{$i};
4641 my $type = $$event{'type'};
4642
4643 if ($type eq 'ym') {
4644 my $beg = $$event{'beg'};
4645 my $end = $$event{'end'};
4646 my $d0 = $d->new_date();
4647 $d0->parse_date($beg);
4648 $d0->set('time',[0,0,0]);
4649
4650 my $d1;
4651 if ($end) {
4652 $d1 = $d0->new_date();
4653 $d1->parse_date($end);
4654 $d1->set('time',[23,59,59]);
4655 } else {
4656 $d1 = $d0->calc($dayM1);
4657 }
4658 $$dmb{'data'}{'events'}{$i}{$y} = [ $d0,$d1 ];
4659
4660 } elsif ($type eq 'date') {
4661 my $beg = $$event{'beg'};
4662 my $end = $$event{'end'};
4663 my $del = $$event{'delta'};
4664 my $d0 = $d->new_date();
4665 $d0->parse($beg);
4666
4667 my $d1;
4668 if ($end) {
4669 $d1 = $d0->new_date();
4670 $d1->parse($end);
4671 } elsif ($del) {
4672 $d1 = $d0->calc($del);
4673 } else {
4674 $d1 = $d0->calc($hrM1);
4675 }
4676 $$dmb{'data'}{'events'}{$i}{$y} = [ $d0,$d1 ];
4677 }
4678 }
4679}
4680
4681# This parses the raw event list. It only has to be done once.
4682#
4683sub _event_objs {
4684 my($self) = @_;
4685 my $dmt = $$self{'tz'};
4686 my $dmb = $$dmt{'base'};
4687 # Only parse once.
4688 $$dmb{'data'}{'eventobjs'} = 1;
4689
4690 my $hrM1 = $self->new_delta();
4691 $hrM1->set('delta',[0,0,0,0,0,59,59]);
4692
4693 my $M1 = $self->new_delta();
4694 $M1->set('delta',[0,0,0,0,0,0,-1]);
4695
4696 my @tmp = @{ $$dmb{'data'}{'sections'}{'events'} };
4697 my $i = 0;
4698 while (@tmp) {
4699 my $string = shift(@tmp);
4700 my $name = shift(@tmp);
4701 my @event = split(/\s*;\s*/,$string);
4702
4703 if ($#event == 0) {
4704
4705 # YMD/YM
4706
4707 my $d1 = $self->new_date();
4708 my $err = $d1->parse_date($event[0]);
4709 if (! $err) {
4710 if ($$d1{'data'}{'def'}[0] eq '') {
4711 # YM
4712 $$dmb{'data'}{'events'}{$i++} = { 'type' => 'ym',
4713 'name' => $name,
4714 'beg' => $event[0] };
4715 } else {
4716 # YMD
4717 my $d2 = $d1->new_date();
4718 my ($y,$m,$d) = $d1->value();
4719 $d1->set('time',[0,0,0]);
4720 $d2->set('date',[$y,$m,$d,23,59,59]);
4721 $$dmb{'data'}{'events'}{$i++} = { 'type' => 'specified',
4722 'name' => $name,
4723 'beg' => $d1,
4724 'end' => $d2 };
4725 }
4726 next;
4727 }
4728
4729 # Date
4730
4731 $err = $d1->parse($event[0]);
4732 if (! $err) {
4733 if ($$d1{'data'}{'def'}[0] eq '') {
4734 # Date (no year)
4735 $$dmb{'data'}{'events'}{$i++} = { 'type' => 'date',
4736 'name' => $name,
4737 'beg' => $event[0],
4738 'delta' => $hrM1
4739 };
4740 } else {
4741 # Date (year)
4742 my $d2 = $d1->calc($hrM1);
4743 $$dmb{'data'}{'events'}{$i++} = { 'type' => 'specified',
4744 'name' => $name,
4745 'beg' => $d1,
4746 'end' => $d2
4747 };
4748 }
4749 next;
4750 }
4751
4752 # Recur
4753
4754 my $r = $self->new_recur();
4755 $err = $r->parse($event[0]);
4756 if ($err) {
4757 warn "ERROR: invalid event definition (must be Date, YMD, YM, or Recur)\n"
4758 . " $string\n";
4759 next;
4760 }
4761
4762 my @d = $r->dates();
4763 if (@d) {
4764 foreach my $d (@d) {
4765 my $d2 = $d->calc($hrM1);
4766 $$dmb{'data'}{'events'}{$i++} = { 'type' => 'specified',
4767 'name' => $name,
4768 'beg' => $d1,
4769 'end' => $d2
4770 };
4771 }
4772 } else {
4773 $$dmb{'data'}{'events'}{$i++} = { 'type' => 'recur',
4774 'name' => $name,
4775 'recur' => $r,
4776 'delta' => $hrM1
4777 };
4778 }
4779
4780 } elsif ($#event == 1) {
4781 my($o1,$o2) = @event;
4782
4783 # YMD;YMD
4784 # YM;YM
4785
4786 my $d1 = $self->new_date();
4787 my $err = $d1->parse_date($o1);
4788 if (! $err) {
4789 my $d2 = $self->new_date();
4790 $err = $d2->parse_date($o2);
4791 if ($err) {
4792 warn "ERROR: invalid event definition (must be YMD;YMD or YM;YM)\n"
4793 . " $string\n";
4794 next;
4795 } elsif ($$d1{'data'}{'def'}[0] ne $$d2{'data'}{'def'}[0]) {
4796 warn "ERROR: invalid event definition (YMD;YM or YM;YMD not allowed)\n"
4797 . " $string\n";
4798 next;
4799 }
4800
4801 if ($$d1{'data'}{'def'}[0] eq '') {
4802 # YM;YM
4803 $$dmb{'data'}{'events'}{$i++} = { 'type' => 'ym',
4804 'name' => $name,
4805 'beg' => $o1,
4806 'end' => $o2
4807 };
4808 } else {
4809 # YMD;YMD
4810 $d1->set('time',[0,0,0]);
4811 $d2->set('time',[23,59,59]);
4812 $$dmb{'data'}{'events'}{$i++} = { 'type' => 'specified',
4813 'name' => $name,
4814 'beg' => $d1,
4815 'end' => $d2 };
4816 }
4817 next;
4818 }
4819
4820 # Date;Date
4821 # Date;Delta
4822
4823 $err = $d1->parse($o1);
4824 if (! $err) {
4825
4826 my $d2 = $self->new_date();
4827 $err = $d2->parse($o2,'nodelta');
4828
4829 if (! $err) {
4830 # Date;Date
4831 if ($$d1{'data'}{'def'}[0] ne $$d2{'data'}{'def'}[0]) {
4832 warn "ERROR: invalid event definition (year must be absent or\n"
4833 . " included in both dats in Date;Date)\n"
4834 . " $string\n";
4835 next;
4836 }
4837
4838 if ($$d1{'data'}{'def'}[0] eq '') {
4839 # Date (no year)
4840 $$dmb{'data'}{'events'}{$i++} = { 'type' => 'date',
4841 'name' => $name,
4842 'beg' => $o1,
4843 'end' => $o2
4844 };
4845 } else {
4846 # Date (year)
4847 $$dmb{'data'}{'events'}{$i++} = { 'type' => 'specified',
4848 'name' => $name,
4849 'beg' => $d1,
4850 'end' => $d2
4851 };
4852 }
4853 next;
4854 }
4855
4856 # Date;Delta
4857 my $del = $self->new_delta();
4858 $err = $del->parse($o2);
4859
4860 if ($err) {
4861 warn "ERROR: invalid event definition (must be Date;Date or\n"
4862 . " Date;Delta) $string\n";
4863 next;
4864 }
4865
4866 $del = $del->calc($M1);
4867 if ($$d1{'data'}{'def'}[0] eq '') {
4868 # Date (no year)
4869 $$dmb{'data'}{'events'}{$i++} = { 'type' => 'date',
4870 'name' => $name,
4871 'beg' => $o1,
4872 'delta' => $del
4873 };
4874 } else {
4875 # Date (year)
4876 $d2 = $d1->calc($del);
4877 $$dmb{'data'}{'events'}{$i++} = { 'type' => 'specified',
4878 'name' => $name,
4879 'beg' => $d1,
4880 'end' => $d2
4881 };
4882 }
4883 next;
4884 }
4885
4886 # Recur;Delta
4887
4888 my $r = $self->new_recur();
4889 $err = $r->parse($o1);
4890
4891 my $del = $self->new_delta();
4892 if (! $err) {
4893 $err = $del->parse($o2);
4894 }
4895
4896 if ($err) {
4897 warn "ERROR: invalid event definition (must be Date;Date, YMD;YMD, "
4898 . " YM;YM, Date;Delta, or Recur;Delta)\n"
4899 . " $string\n";
4900 next;
4901 }
4902
4903 $del = $del->calc($M1);
4904 my @d = $r->dates();
4905 if (@d) {
4906 foreach my $d1 (@d) {
4907 my $d2 = $d1->calc($del);
4908 $$dmb{'data'}{'events'}{$i++} = { 'type' => 'specified',
4909 'name' => $name,
4910 'beg' => $d1,
4911 'end' => $d2
4912 };
4913 }
4914 } else {
4915 $$dmb{'data'}{'events'}{$i++} = { 'type' => 'recur',
4916 'name' => $name,
4917 'recur' => $r,
4918 'delta' => $del
4919 };
4920 }
4921
4922 } else {
4923 warn "ERROR: invalid event definition\n"
4924 . " $string\n";
4925 next;
4926 }
4927 }
4928}
4929
493014µs1;
4931# Local Variables:
4932# mode: cperl
4933# indent-tabs-mode: nil
4934# cperl-indent-level: 3
4935# cperl-continued-statement-offset: 2
4936# cperl-continued-brace-offset: 0
4937# cperl-brace-offset: 0
4938# cperl-brace-imaginary-offset: 0
4939# cperl-label-offset: 0
4940# End:
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.