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