← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 17:10:45 2013
Reported on Tue Oct 15 17:12:33 2013

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