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