| Filename | /home/sulbeck/local/lib/perl5/5.20.1/Date/Manip/Delta.pm |
| Statements | Executed 514 statements in 4.51ms |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 39 | 6 | 1 | 1.61ms | 1.61ms | Date::Manip::Delta::CORE:regcomp (opcode) |
| 6 | 1 | 1 | 193µs | 2.16ms | Date::Manip::Delta::parse |
| 30 | 3 | 1 | 134µs | 1.72ms | Date::Manip::Delta::_rx |
| 36 | 4 | 1 | 58µs | 58µs | Date::Manip::Delta::CORE:subst (opcode) |
| 12 | 2 | 2 | 38µs | 38µs | Date::Manip::Delta::_init |
| 12 | 1 | 1 | 33µs | 33µs | Date::Manip::Delta::CORE:match (opcode) |
| 1 | 1 | 1 | 11µs | 11µs | Date::Manip::Delta::BEGIN@114 |
| 1 | 1 | 1 | 9µs | 9µs | Date::Manip::Delta::BEGIN@14 |
| 1 | 1 | 1 | 8µs | 11µs | Date::Manip::Delta::BEGIN@902 |
| 1 | 1 | 1 | 7µs | 108µs | Date::Manip::Delta::BEGIN@21 |
| 1 | 1 | 1 | 7µs | 19µs | Date::Manip::Delta::BEGIN@19 |
| 1 | 1 | 1 | 6µs | 6µs | Date::Manip::Delta::BEGIN@971 |
| 1 | 1 | 1 | 5µs | 14µs | Date::Manip::Delta::BEGIN@18 |
| 1 | 1 | 1 | 5µs | 6µs | Date::Manip::Delta::BEGIN@979 |
| 1 | 1 | 1 | 5µs | 6µs | Date::Manip::Delta::BEGIN@20 |
| 1 | 1 | 1 | 5µs | 5µs | Date::Manip::Delta::BEGIN@24 |
| 1 | 1 | 1 | 3µs | 3µs | Date::Manip::Delta::BEGIN@25 |
| 1 | 1 | 1 | 2µs | 2µs | Date::Manip::Delta::END |
| 3 | 3 | 1 | 2µs | 2µs | Date::Manip::Delta::CORE:qr (opcode) |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::_calc_delta_delta |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::_init_args |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::_printf_delta |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::_printf_field |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::_printf_field_val |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::calc |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::cmp |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::config |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::convert |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::input |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::is_delta |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::printf |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::set |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::type |
| 0 | 0 | 0 | 0s | 0s | Date::Manip::Delta::value |
| Line | State ments |
Time on line |
Calls | Time in subs |
Code |
|---|---|---|---|---|---|
| 1 | package Date::Manip::Delta; | ||||
| 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 | 40µs | 1 | 9µs | # spent 9µs within Date::Manip::Delta::BEGIN@14 which was called:
# once (9µs+0s) by Date::Manip::Obj::new_delta at line 14 # spent 9µs making 1 call to Date::Manip::Delta::BEGIN@14 |
| 15 | 1 | 6µs | @ISA = ('Date::Manip::Obj'); | ||
| 16 | |||||
| 17 | 1 | 8µs | require 5.010000; | ||
| 18 | 2 | 13µs | 2 | 22µs | # spent 14µs (5+8) within Date::Manip::Delta::BEGIN@18 which was called:
# once (5µs+8µs) by Date::Manip::Obj::new_delta at line 18 # spent 14µs making 1 call to Date::Manip::Delta::BEGIN@18
# spent 8µs making 1 call to warnings::import |
| 19 | 2 | 12µs | 2 | 31µs | # spent 19µs (7+12) within Date::Manip::Delta::BEGIN@19 which was called:
# once (7µs+12µs) by Date::Manip::Obj::new_delta at line 19 # spent 19µs making 1 call to Date::Manip::Delta::BEGIN@19
# spent 12µs making 1 call to strict::import |
| 20 | 2 | 11µs | 2 | 8µs | # spent 6µs (5+2) within Date::Manip::Delta::BEGIN@20 which was called:
# once (5µs+2µs) by Date::Manip::Obj::new_delta at line 20 # spent 6µs making 1 call to Date::Manip::Delta::BEGIN@20
# spent 2µs making 1 call to utf8::import |
| 21 | 2 | 19µs | 2 | 210µs | # spent 108µs (7+101) within Date::Manip::Delta::BEGIN@21 which was called:
# once (7µs+101µs) by Date::Manip::Obj::new_delta at line 21 # spent 108µs making 1 call to Date::Manip::Delta::BEGIN@21
# spent 101µs making 1 call to Exporter::import |
| 22 | #use re 'debug'; | ||||
| 23 | |||||
| 24 | 2 | 12µs | 1 | 5µs | # spent 5µs within Date::Manip::Delta::BEGIN@24 which was called:
# once (5µs+0s) by Date::Manip::Obj::new_delta at line 24 # spent 5µs making 1 call to Date::Manip::Delta::BEGIN@24 |
| 25 | 2 | 408µs | 1 | 3µs | # spent 3µs within Date::Manip::Delta::BEGIN@25 which was called:
# once (3µs+0s) by Date::Manip::Obj::new_delta at line 25 # spent 3µs making 1 call to Date::Manip::Delta::BEGIN@25 |
| 26 | |||||
| 27 | 1 | 100ns | our $VERSION; | ||
| 28 | 1 | 200ns | $VERSION='6.49'; | ||
| 29 | 1 | 3µs | # spent 2µs within Date::Manip::Delta::END which was called:
# once (2µs+0s) by main::RUNTIME at line 0 of ../dm5dm6_ex3 | ||
| 30 | |||||
| 31 | ######################################################################## | ||||
| 32 | # BASE METHODS | ||||
| 33 | ######################################################################## | ||||
| 34 | |||||
| 35 | sub is_delta { | ||||
| 36 | return 1; | ||||
| 37 | } | ||||
| 38 | |||||
| 39 | sub config { | ||||
| 40 | my($self,@args) = @_; | ||||
| 41 | $self->SUPER::config(@args); | ||||
| 42 | |||||
| 43 | # A new config can change the value of the format fields, so clear them. | ||||
| 44 | $$self{'data'}{'f'} = {}; | ||||
| 45 | $$self{'data'}{'flen'} = {}; | ||||
| 46 | } | ||||
| 47 | |||||
| 48 | # Call this every time a new delta is put in to make sure everything is | ||||
| 49 | # correctly initialized. | ||||
| 50 | # | ||||
| 51 | # spent 38µs within Date::Manip::Delta::_init which was called 12 times, avg 3µs/call:
# 6 times (26µs+0s) by Date::Manip::Obj::new at line 162 of Date/Manip/Obj.pm, avg 4µs/call
# 6 times (12µs+0s) by Date::Manip::Delta::parse at line 305, avg 2µs/call | ||||
| 52 | 12 | 2µs | my($self) = @_; | ||
| 53 | |||||
| 54 | 12 | 6µs | my $def = [0,0,0,0,0,0,0]; | ||
| 55 | 12 | 5µs | my $dmt = $$self{'tz'}; | ||
| 56 | 12 | 1µs | my $dmb = $$dmt{'base'}; | ||
| 57 | |||||
| 58 | 12 | 3µs | $$self{'err'} = ''; | ||
| 59 | 12 | 32µs | $$self{'data'} = { | ||
| 60 | 'delta' => $def, # the delta (all negative fields signed) | ||||
| 61 | 'in' => '', # the string that was parsed (if any) | ||||
| 62 | 'length' => 0, # length of delta (in seconds) | ||||
| 63 | |||||
| 64 | 'gotmode' => 0, # 1 if mode set explicitly | ||||
| 65 | 'business' => 0, # 1 for a business delta | ||||
| 66 | |||||
| 67 | 'f' => {}, # format fields | ||||
| 68 | 'flen' => {}, # field lengths | ||||
| 69 | } | ||||
| 70 | } | ||||
| 71 | |||||
| 72 | sub _init_args { | ||||
| 73 | my($self) = @_; | ||||
| 74 | |||||
| 75 | my @args = @{ $$self{'args'} }; | ||||
| 76 | if (@args) { | ||||
| 77 | if ($#args == 0) { | ||||
| 78 | $self->parse($args[0]); | ||||
| 79 | } else { | ||||
| 80 | warn "WARNING: [new] invalid arguments: @args\n"; | ||||
| 81 | } | ||||
| 82 | } | ||||
| 83 | } | ||||
| 84 | |||||
| 85 | sub value { | ||||
| 86 | my($self) = @_; | ||||
| 87 | my $dmt = $$self{'tz'}; | ||||
| 88 | my $dmb = $$dmt{'base'}; | ||||
| 89 | |||||
| 90 | return undef if ($$self{'err'}); | ||||
| 91 | if (wantarray) { | ||||
| 92 | return @{ $$self{'data'}{'delta'} }; | ||||
| 93 | } else { | ||||
| 94 | my @delta = @{ $$self{'data'}{'delta'} }; | ||||
| 95 | my $err; | ||||
| 96 | ($err,@delta) = $dmb->_delta_fields( { 'nonorm' => 1, | ||||
| 97 | 'source' => 'delta', | ||||
| 98 | 'sign' => 0 }, | ||||
| 99 | [@delta]); | ||||
| 100 | return undef if ($err); | ||||
| 101 | return join(':',@delta); | ||||
| 102 | } | ||||
| 103 | } | ||||
| 104 | |||||
| 105 | sub input { | ||||
| 106 | my($self) = @_; | ||||
| 107 | return $$self{'data'}{'in'}; | ||||
| 108 | } | ||||
| 109 | |||||
| 110 | ######################################################################## | ||||
| 111 | # DELTA METHODS | ||||
| 112 | ######################################################################## | ||||
| 113 | |||||
| 114 | # spent 11µs within Date::Manip::Delta::BEGIN@114 which was called:
# once (11µs+0s) by Date::Manip::Obj::new_delta at line 199 | ||||
| 115 | 1 | 3µs | my %ops = map { $_,1 } qw( delta business normal standard ); | ||
| 116 | 1 | 9µs | my %f = qw( y 0 M 1 w 2 d 3 h 4 m 5 s 6 ); | ||
| 117 | |||||
| 118 | sub set { | ||||
| 119 | my($self,$field,$val,$no_normalize) = @_; | ||||
| 120 | |||||
| 121 | my $dmt = $$self{'tz'}; | ||||
| 122 | my $dmb = $$dmt{'base'}; | ||||
| 123 | my $zone = $$self{'data'}{'tz'}; | ||||
| 124 | my $gotmode = $$self{'data'}{'gotmode'}; | ||||
| 125 | my $business = 0; | ||||
| 126 | |||||
| 127 | my (@delta,$err); | ||||
| 128 | |||||
| 129 | if (exists $ops{lc($field)}) { | ||||
| 130 | $field = lc($field); | ||||
| 131 | |||||
| 132 | if ($field eq 'business') { | ||||
| 133 | $business = 1; | ||||
| 134 | $gotmode = 1; | ||||
| 135 | } elsif ($field eq 'normal' || $field eq 'standard') { | ||||
| 136 | $business = 0; | ||||
| 137 | $gotmode = 1; | ||||
| 138 | } elsif ($field eq 'delta') { | ||||
| 139 | $business = $$self{'data'}{'business'}; | ||||
| 140 | $gotmode = $$self{'data'}{'gotmode'}; | ||||
| 141 | } | ||||
| 142 | |||||
| 143 | ($err,@delta) = $dmb->_delta_fields( { 'nonorm' => $no_normalize, | ||||
| 144 | 'business' => $business, | ||||
| 145 | 'source' => 'delta', | ||||
| 146 | 'sign' => -1 }, | ||||
| 147 | $val); | ||||
| 148 | |||||
| 149 | } elsif (exists $f{$field}) { | ||||
| 150 | |||||
| 151 | if ($$self{'err'}) { | ||||
| 152 | $$self{'err'} = "[set] Invalid delta"; | ||||
| 153 | return 1; | ||||
| 154 | } | ||||
| 155 | |||||
| 156 | @delta = @{ $$self{'data'}{'delta'} }; | ||||
| 157 | $business = $$self{'data'}{'business'}; | ||||
| 158 | $delta[$f{$field}] = $val; | ||||
| 159 | |||||
| 160 | ($err,@delta) = $dmb->_delta_fields( { 'nonorm' => $no_normalize, | ||||
| 161 | 'business' => $business, | ||||
| 162 | 'source' => 'delta', | ||||
| 163 | 'sign' => -1 }, | ||||
| 164 | [@delta]); | ||||
| 165 | |||||
| 166 | } elsif (lc($field) eq 'mode') { | ||||
| 167 | |||||
| 168 | @delta = @{ $$self{'data'}{'delta'} }; | ||||
| 169 | $val = lc($val); | ||||
| 170 | if ($val eq 'business' || $val eq 'normal' || $val eq 'standard') { | ||||
| 171 | $gotmode = 1; | ||||
| 172 | $business = ($val eq 'business' ? 1 : 0); | ||||
| 173 | |||||
| 174 | } else { | ||||
| 175 | $$self{'err'} = "[set] Invalid mode: $val"; | ||||
| 176 | return 1; | ||||
| 177 | } | ||||
| 178 | |||||
| 179 | } else { | ||||
| 180 | |||||
| 181 | $$self{'err'} = "[set] Invalid field: $field"; | ||||
| 182 | return 1; | ||||
| 183 | |||||
| 184 | } | ||||
| 185 | |||||
| 186 | if ($err) { | ||||
| 187 | $$self{'err'} = "[set] Invalid field value: $field"; | ||||
| 188 | return 1; | ||||
| 189 | } | ||||
| 190 | |||||
| 191 | $self->_init(); | ||||
| 192 | $$self{'data'}{'delta'} = [ @delta ]; | ||||
| 193 | $$self{'data'}{'business'} = $business; | ||||
| 194 | $$self{'data'}{'gotmode'} = $gotmode; | ||||
| 195 | $$self{'data'}{'length'} = 'unknown'; | ||||
| 196 | |||||
| 197 | return 0; | ||||
| 198 | } | ||||
| 199 | 1 | 1.59ms | 1 | 11µs | } # spent 11µs making 1 call to Date::Manip::Delta::BEGIN@114 |
| 200 | |||||
| 201 | # spent 1.72ms (134µs+1.59) within Date::Manip::Delta::_rx which was called 30 times, avg 57µs/call:
# 12 times (95µs+1.56ms) by Date::Manip::Delta::parse at line 378, avg 138µs/call
# 12 times (19µs+23µs) by Date::Manip::Delta::parse at line 369, avg 4µs/call
# 6 times (19µs+7µs) by Date::Manip::Delta::parse at line 332, avg 4µs/call | ||||
| 202 | 30 | 4µs | my($self,$rx) = @_; | ||
| 203 | 30 | 4µs | my $dmt = $$self{'tz'}; | ||
| 204 | 30 | 3µs | my $dmb = $$dmt{'base'}; | ||
| 205 | |||||
| 206 | 30 | 39µs | return $$dmb{'data'}{'rx'}{'delta'}{$rx} | ||
| 207 | if (exists $$dmb{'data'}{'rx'}{'delta'}{$rx}); | ||||
| 208 | |||||
| 209 | 3 | 1µs | if ($rx eq 'expanded') { | ||
| 210 | 1 | 100ns | my $sign = '[-+]?\s*'; | ||
| 211 | 1 | 100ns | my $sep = '(?:,\s*|\s+|$)'; | ||
| 212 | |||||
| 213 | 1 | 600ns | my $nth = $$dmb{'data'}{'rx'}{'nth'}[0]; | ||
| 214 | 1 | 400ns | my $yf = $$dmb{data}{rx}{fields}[1]; | ||
| 215 | 1 | 300ns | my $mf = $$dmb{data}{rx}{fields}[2]; | ||
| 216 | 1 | 300ns | my $wf = $$dmb{data}{rx}{fields}[3]; | ||
| 217 | 1 | 200ns | my $df = $$dmb{data}{rx}{fields}[4]; | ||
| 218 | 1 | 400ns | my $hf = $$dmb{data}{rx}{fields}[5]; | ||
| 219 | 1 | 600ns | my $mnf = $$dmb{data}{rx}{fields}[6]; | ||
| 220 | 1 | 400ns | my $sf = $$dmb{data}{rx}{fields}[7]; | ||
| 221 | 1 | 0s | my $num = '(?:\d+(?:\.\d*)?|\.\d+)'; | ||
| 222 | |||||
| 223 | 1 | 2µs | my $y = "(?:(?:(?<y>$sign$num)|(?<y>$nth))\\s*(?:$yf)$sep)"; | ||
| 224 | 1 | 1µs | my $m = "(?:(?:(?<m>$sign$num)|(?<m>$nth))\\s*(?:$mf)$sep)"; | ||
| 225 | 1 | 900ns | my $w = "(?:(?:(?<w>$sign$num)|(?<w>$nth))\\s*(?:$wf)$sep)"; | ||
| 226 | 1 | 1µs | my $d = "(?:(?:(?<d>$sign$num)|(?<d>$nth))\\s*(?:$df)$sep)"; | ||
| 227 | 1 | 900ns | my $h = "(?:(?:(?<h>$sign$num)|(?<h>$nth))\\s*(?:$hf)$sep)"; | ||
| 228 | 1 | 1µs | my $mn = "(?:(?:(?<mn>$sign$num)|(?<mn>$nth))\\s*(?:$mnf)$sep)"; | ||
| 229 | 1 | 800ns | my $s = "(?:(?:(?<s>$sign$num)|(?<s>$nth))\\s*(?:$sf)?)"; | ||
| 230 | |||||
| 231 | 1 | 1.63ms | 2 | 1.56ms | my $exprx = qr/^\s*$y?$m?$w?$d?$h?$mn?$s?\s*$/i; # spent 1.56ms making 1 call to Date::Manip::Delta::CORE:regcomp
# spent 800ns making 1 call to Date::Manip::Delta::CORE:qr |
| 232 | 1 | 2µs | $$dmb{'data'}{'rx'}{'delta'}{$rx} = $exprx; | ||
| 233 | |||||
| 234 | } elsif ($rx eq 'mode') { | ||||
| 235 | |||||
| 236 | 1 | 12µs | 2 | 7µs | my $mode = qr/\b($$dmb{'data'}{'rx'}{'mode'}[0])\b/i; # spent 6µs making 1 call to Date::Manip::Delta::CORE:regcomp
# spent 700ns making 1 call to Date::Manip::Delta::CORE:qr |
| 237 | 1 | 800ns | $$dmb{'data'}{'rx'}{'delta'}{$rx} = $mode; | ||
| 238 | |||||
| 239 | } elsif ($rx eq 'when') { | ||||
| 240 | |||||
| 241 | 1 | 26µs | 2 | 23µs | my $when = qr/\b($$dmb{'data'}{'rx'}{'when'}[0])\b/i; # spent 22µs making 1 call to Date::Manip::Delta::CORE:regcomp
# spent 600ns making 1 call to Date::Manip::Delta::CORE:qr |
| 242 | 1 | 700ns | $$dmb{'data'}{'rx'}{'delta'}{$rx} = $when; | ||
| 243 | |||||
| 244 | } | ||||
| 245 | |||||
| 246 | 3 | 6µs | return $$dmb{'data'}{'rx'}{'delta'}{$rx}; | ||
| 247 | } | ||||
| 248 | |||||
| 249 | # spent 2.16ms (193µs+1.97) within Date::Manip::Delta::parse which was called 6 times, avg 360µs/call:
# 6 times (193µs+1.97ms) by Date::Manip::Date::_parse_delta at line 1812 of Date/Manip/Date.pm, avg 360µs/call | ||||
| 250 | 6 | 2µs | my($self,$instring,@args) = @_; | ||
| 251 | 6 | 700ns | my($business,$no_normalize,$gotmode,$err,@delta); | ||
| 252 | |||||
| 253 | 6 | 4µs | if (@args == 2) { | ||
| 254 | ($business,$no_normalize) = (lc($args[0]),lc($args[1])); | ||||
| 255 | if ($business eq 'standard') { | ||||
| 256 | $business = 0; | ||||
| 257 | } elsif ($business eq 'business') { | ||||
| 258 | $business = 1; | ||||
| 259 | } elsif ($business) { | ||||
| 260 | $business = 1; | ||||
| 261 | } else { | ||||
| 262 | $business = 0; | ||||
| 263 | } | ||||
| 264 | if ($no_normalize) { | ||||
| 265 | $no_normalize = 1; | ||||
| 266 | } else { | ||||
| 267 | $no_normalize = 0; | ||||
| 268 | } | ||||
| 269 | $gotmode = 1; | ||||
| 270 | |||||
| 271 | } elsif (@args == 1) { | ||||
| 272 | my $arg = lc($args[0]); | ||||
| 273 | if ($arg eq 'standard') { | ||||
| 274 | $business = 0; | ||||
| 275 | $no_normalize = 0; | ||||
| 276 | $gotmode = 1; | ||||
| 277 | } elsif ($arg eq 'business') { | ||||
| 278 | $business = 1; | ||||
| 279 | $no_normalize = 0; | ||||
| 280 | $gotmode = 1; | ||||
| 281 | } elsif ($arg eq 'nonormalize') { | ||||
| 282 | $business = 0; | ||||
| 283 | $no_normalize = 1; | ||||
| 284 | $gotmode = 0; | ||||
| 285 | } elsif ($arg) { | ||||
| 286 | $business = 1; | ||||
| 287 | $no_normalize = 0; | ||||
| 288 | $gotmode = 1; | ||||
| 289 | } else { | ||||
| 290 | $business = 0; | ||||
| 291 | $no_normalize = 0; | ||||
| 292 | $gotmode = 0; | ||||
| 293 | } | ||||
| 294 | } elsif (@args == 0) { | ||||
| 295 | 6 | 1µs | $business = 0; | ||
| 296 | 6 | 600ns | $no_normalize = 0; | ||
| 297 | 6 | 800ns | $gotmode = 0; | ||
| 298 | } else { | ||||
| 299 | $$self{'err'} = "[parse] Unknown arguments"; | ||||
| 300 | return 1; | ||||
| 301 | } | ||||
| 302 | |||||
| 303 | 6 | 1µs | my $dmt = $$self{'tz'}; | ||
| 304 | 6 | 800ns | my $dmb = $$dmt{'base'}; | ||
| 305 | 6 | 6µs | 6 | 12µs | $self->_init(); # spent 12µs making 6 calls to Date::Manip::Delta::_init, avg 2µs/call |
| 306 | |||||
| 307 | 6 | 800ns | if (! $instring) { | ||
| 308 | $$self{'err'} = '[parse] Empty delta string'; | ||||
| 309 | return 1; | ||||
| 310 | } | ||||
| 311 | |||||
| 312 | # | ||||
| 313 | # Parse the string | ||||
| 314 | # | ||||
| 315 | |||||
| 316 | 6 | 1µs | $$self{'err'} = ''; | ||
| 317 | 6 | 20µs | 6 | 11µs | $instring =~ s/^\s*//; # spent 11µs making 6 calls to Date::Manip::Delta::CORE:subst, avg 2µs/call |
| 318 | 6 | 16µs | 6 | 10µs | $instring =~ s/\s*$//; # spent 10µs making 6 calls to Date::Manip::Delta::CORE:subst, avg 2µs/call |
| 319 | |||||
| 320 | 6 | 9µs | 6 | 60µs | PARSE: { # spent 60µs making 6 calls to Date::Manip::Base::_split_delta, avg 10µs/call |
| 321 | |||||
| 322 | # First, we'll try the standard format (without a mode string) | ||||
| 323 | |||||
| 324 | 6 | 2µs | ($err,@delta) = $dmb->_split_delta($instring); | ||
| 325 | 6 | 800ns | last PARSE if (! $err); | ||
| 326 | |||||
| 327 | # Next, we'll need to get a list of all the encodings and look | ||||
| 328 | # for (and remove) the mode string from each. We'll also recheck | ||||
| 329 | # the standard format for each. | ||||
| 330 | |||||
| 331 | 6 | 6µs | 6 | 58µs | my @strings = $dmb->_encoding($instring); # spent 58µs making 6 calls to Date::Manip::Base::_encoding, avg 10µs/call |
| 332 | 6 | 5µs | 6 | 26µs | my $moderx = $self->_rx('mode'); # spent 26µs making 6 calls to Date::Manip::Delta::_rx, avg 4µs/call |
| 333 | 6 | 2µs | my %mode = (); | ||
| 334 | |||||
| 335 | 6 | 2µs | foreach my $string (@strings) { | ||
| 336 | 12 | 60µs | 24 | 37µs | if ($string =~ s/\s*$moderx\s*//i) { # spent 24µs making 12 calls to Date::Manip::Delta::CORE:subst, avg 2µs/call
# spent 14µs making 12 calls to Date::Manip::Delta::CORE:regcomp, avg 1µs/call |
| 337 | my $b = $1; | ||||
| 338 | if ($$dmb{'data'}{'wordmatch'}{'mode'}{lc($b)} == 1) { | ||||
| 339 | $b = 0; | ||||
| 340 | } else { | ||||
| 341 | $b = 1; | ||||
| 342 | } | ||||
| 343 | |||||
| 344 | ($err,@delta) = $dmb->_split_delta($string); | ||||
| 345 | if (! $err) { | ||||
| 346 | $business = $b; | ||||
| 347 | $gotmode = 1; | ||||
| 348 | last PARSE; | ||||
| 349 | } | ||||
| 350 | |||||
| 351 | $mode{$string} = $b; | ||||
| 352 | } | ||||
| 353 | } | ||||
| 354 | |||||
| 355 | # Now we'll check each string for an expanded form delta. | ||||
| 356 | |||||
| 357 | 6 | 5µs | foreach my $string (@strings) { | ||
| 358 | 12 | 1µs | my($b,$g); | ||
| 359 | 12 | 3µs | if (exists $mode{$string}) { | ||
| 360 | $b = $mode{$string}; | ||||
| 361 | $g = 1; | ||||
| 362 | } else { | ||||
| 363 | 12 | 1µs | $b = $business; | ||
| 364 | 12 | 2µs | $g = 0; | ||
| 365 | } | ||||
| 366 | |||||
| 367 | 12 | 1µs | my $past = 0; | ||
| 368 | |||||
| 369 | 12 | 6µs | 12 | 42µs | my $whenrx = $self->_rx('when'); # spent 42µs making 12 calls to Date::Manip::Delta::_rx, avg 4µs/call |
| 370 | 12 | 38µs | 24 | 19µs | if ($string && # spent 14µs making 12 calls to Date::Manip::Delta::CORE:subst, avg 1µs/call
# spent 5µs making 12 calls to Date::Manip::Delta::CORE:regcomp, avg 417ns/call |
| 371 | $string =~ s/$whenrx//i) { | ||||
| 372 | my $when = $1; | ||||
| 373 | if ($$dmb{'data'}{'wordmatch'}{'when'}{lc($when)} == 1) { | ||||
| 374 | $past = 1; | ||||
| 375 | } | ||||
| 376 | } | ||||
| 377 | |||||
| 378 | 12 | 6µs | 12 | 1.65ms | my $rx = $self->_rx('expanded'); # spent 1.65ms making 12 calls to Date::Manip::Delta::_rx, avg 138µs/call |
| 379 | 12 | 71µs | 24 | 40µs | if ($string && # spent 33µs making 12 calls to Date::Manip::Delta::CORE:match, avg 3µs/call
# spent 7µs making 12 calls to Date::Manip::Delta::CORE:regcomp, avg 608ns/call |
| 380 | $string =~ $rx) { | ||||
| 381 | $business = $b; | ||||
| 382 | $gotmode = $g; | ||||
| 383 | @delta = @+{qw(y m w d h mn s)}; | ||||
| 384 | foreach my $f (@delta) { | ||||
| 385 | if (! defined $f) { | ||||
| 386 | $f = 0; | ||||
| 387 | } elsif (exists $$dmb{'data'}{'wordmatch'}{'nth'}{lc($f)}) { | ||||
| 388 | $f = $$dmb{'data'}{'wordmatch'}{'nth'}{lc($f)}; | ||||
| 389 | } else { | ||||
| 390 | $f =~ s/\s//g; | ||||
| 391 | } | ||||
| 392 | } | ||||
| 393 | |||||
| 394 | # if $past, reverse the signs | ||||
| 395 | if ($past) { | ||||
| 396 | foreach my $v (@delta) { | ||||
| 397 | $v *= -1; | ||||
| 398 | } | ||||
| 399 | } | ||||
| 400 | |||||
| 401 | last PARSE; | ||||
| 402 | } | ||||
| 403 | } | ||||
| 404 | } | ||||
| 405 | |||||
| 406 | 6 | 1µs | if (! @delta) { | ||
| 407 | 6 | 1µs | $$self{'err'} = "[parse] Invalid delta string"; | ||
| 408 | 6 | 9µs | return 1; | ||
| 409 | } | ||||
| 410 | |||||
| 411 | ($err,@delta) = $dmb->_delta_fields( { 'nonorm' => $no_normalize, | ||||
| 412 | 'business' => $business, | ||||
| 413 | 'source' => 'string', | ||||
| 414 | 'sign' => -1 }, | ||||
| 415 | [@delta]); | ||||
| 416 | |||||
| 417 | if ($err) { | ||||
| 418 | $$self{'err'} = "[parse] Invalid delta string"; | ||||
| 419 | return 1; | ||||
| 420 | } | ||||
| 421 | |||||
| 422 | $$self{'data'}{'in'} = $instring; | ||||
| 423 | $$self{'data'}{'delta'} = [@delta]; | ||||
| 424 | $$self{'data'}{'business'} = $business; | ||||
| 425 | $$self{'data'}{'gotmode'} = $gotmode; | ||||
| 426 | $$self{'data'}{'length'} = 'unknown'; | ||||
| 427 | return 0; | ||||
| 428 | } | ||||
| 429 | |||||
| 430 | sub printf { | ||||
| 431 | my($self,@in) = @_; | ||||
| 432 | if ($$self{'err'}) { | ||||
| 433 | warn "WARNING: [printf] Object must contain a valid delta\n"; | ||||
| 434 | return undef; | ||||
| 435 | } | ||||
| 436 | |||||
| 437 | my($y,$M,$w,$d,$h,$m,$s) = @{ $$self{'data'}{'delta'} }; | ||||
| 438 | |||||
| 439 | my @out; | ||||
| 440 | foreach my $in (@in) { | ||||
| 441 | my $out = ''; | ||||
| 442 | while ($in) { | ||||
| 443 | if ($in =~ s/^([^%]+)//) { | ||||
| 444 | $out .= $1; | ||||
| 445 | |||||
| 446 | } elsif ($in =~ s/^%%//) { | ||||
| 447 | $out .= "%"; | ||||
| 448 | |||||
| 449 | } elsif ($in =~ s/^% | ||||
| 450 | (\+)? # sign | ||||
| 451 | ([<>0])? # pad | ||||
| 452 | (\d+)? # width | ||||
| 453 | ([yMwdhms]) # field | ||||
| 454 | v # type | ||||
| 455 | //ox) { | ||||
| 456 | my($sign,$pad,$width,$field) = ($1,$2,$3,$4); | ||||
| 457 | $out .= $self->_printf_field($sign,$pad,$width,0,$field); | ||||
| 458 | |||||
| 459 | } elsif ($in =~ s/^(% | ||||
| 460 | (\+)? # sign | ||||
| 461 | ([<>0])? # pad | ||||
| 462 | (\d+)? # width | ||||
| 463 | (?:\.(\d+))? # precision | ||||
| 464 | ([yMwdhms]) # field | ||||
| 465 | ([yMwdhms]) # field0 | ||||
| 466 | ([yMwdhms]) # field1 | ||||
| 467 | )//ox) { | ||||
| 468 | my($match,$sign,$pad,$width,$precision,$field,$field0,$field1) = | ||||
| 469 | ($1,$2,$3,$4,$5,$6,$7,$8); | ||||
| 470 | |||||
| 471 | # Get the list of fields we're expressing | ||||
| 472 | |||||
| 473 | my @field = qw(y M w d h m s); | ||||
| 474 | while (@field && $field[0] ne $field0) { | ||||
| 475 | shift(@field); | ||||
| 476 | } | ||||
| 477 | while (@field && $field[$#field] ne $field1) { | ||||
| 478 | pop(@field); | ||||
| 479 | } | ||||
| 480 | |||||
| 481 | if (! @field) { | ||||
| 482 | $out .= $match; | ||||
| 483 | } else { | ||||
| 484 | $out .= | ||||
| 485 | $self->_printf_field($sign,$pad,$width,$precision,$field,@field); | ||||
| 486 | } | ||||
| 487 | |||||
| 488 | } elsif ($in =~ s/^% | ||||
| 489 | (\+)? # sign | ||||
| 490 | ([<>])? # pad | ||||
| 491 | (\d+)? # width | ||||
| 492 | Dt | ||||
| 493 | //ox) { | ||||
| 494 | my($sign,$pad,$width) = ($1,$2,$3); | ||||
| 495 | $out .= $self->_printf_delta($sign,$pad,$width,'y','s'); | ||||
| 496 | |||||
| 497 | } elsif ($in =~ s/^(% | ||||
| 498 | (\+)? # sign | ||||
| 499 | ([<>])? # pad | ||||
| 500 | (\d+)? # width | ||||
| 501 | D | ||||
| 502 | ([yMwdhms]) # field0 | ||||
| 503 | ([yMwdhms]) # field1 | ||||
| 504 | )//ox) { | ||||
| 505 | my($match,$sign,$pad,$width,$field0,$field1) = ($1,$2,$3,$4,$5,$6); | ||||
| 506 | |||||
| 507 | # Get the list of fields we're expressing | ||||
| 508 | |||||
| 509 | my @field = qw(y M w d h m s); | ||||
| 510 | while (@field && $field[0] ne $field0) { | ||||
| 511 | shift(@field); | ||||
| 512 | } | ||||
| 513 | while (@field && $field[$#field] ne $field1) { | ||||
| 514 | pop(@field); | ||||
| 515 | } | ||||
| 516 | |||||
| 517 | if (! @field) { | ||||
| 518 | $out .= $match; | ||||
| 519 | } else { | ||||
| 520 | $out .= $self->_printf_delta($sign,$pad,$width,$field[0], | ||||
| 521 | $field[$#field]); | ||||
| 522 | } | ||||
| 523 | |||||
| 524 | } else { | ||||
| 525 | $in =~ s/^(%[^%]*)//; | ||||
| 526 | $out .= $1; | ||||
| 527 | } | ||||
| 528 | } | ||||
| 529 | push(@out,$out); | ||||
| 530 | } | ||||
| 531 | |||||
| 532 | if (wantarray) { | ||||
| 533 | return @out; | ||||
| 534 | } elsif (@out == 1) { | ||||
| 535 | return $out[0]; | ||||
| 536 | } | ||||
| 537 | |||||
| 538 | return '' | ||||
| 539 | } | ||||
| 540 | |||||
| 541 | sub _printf_delta { | ||||
| 542 | my($self,$sign,$pad,$width,$field0,$field1) = @_; | ||||
| 543 | my $dmt = $$self{'tz'}; | ||||
| 544 | my $dmb = $$dmt{'base'}; | ||||
| 545 | my @delta = @{ $$self{'data'}{'delta'} }; | ||||
| 546 | my $delta; | ||||
| 547 | my %tmp = qw(y 0 M 1 w 2 d 3 h 4 m 5 s 6); | ||||
| 548 | |||||
| 549 | # Add a sign to each field | ||||
| 550 | |||||
| 551 | my $s = "+"; | ||||
| 552 | foreach my $f (@delta) { | ||||
| 553 | if ($f < 0) { | ||||
| 554 | $s = "-"; | ||||
| 555 | } elsif ($f > 0) { | ||||
| 556 | $s = "+"; | ||||
| 557 | $f *= 1; | ||||
| 558 | $f = "+$f"; | ||||
| 559 | } else { | ||||
| 560 | $f = "$s$f"; | ||||
| 561 | } | ||||
| 562 | } | ||||
| 563 | |||||
| 564 | # Split the delta into field sets containing only those fields to | ||||
| 565 | # print. | ||||
| 566 | # | ||||
| 567 | # @set = ( [SETa] [SETb] ....) | ||||
| 568 | # where [SETx] is a listref of fields from one set of fields | ||||
| 569 | |||||
| 570 | my @set; | ||||
| 571 | my $business = $$self{'data'}{'business'}; | ||||
| 572 | |||||
| 573 | my $f0 = $tmp{$field0}; | ||||
| 574 | my $f1 = $tmp{$field1}; | ||||
| 575 | |||||
| 576 | if ($field0 eq $field1) { | ||||
| 577 | @set = ( [ $delta[$f0] ] ); | ||||
| 578 | |||||
| 579 | } elsif ($business) { | ||||
| 580 | |||||
| 581 | if ($f0 <= 1) { | ||||
| 582 | # if (field0 = y or M) | ||||
| 583 | # add [y,M] | ||||
| 584 | # field0 = w OR done if field1 = M | ||||
| 585 | push(@set, [ @delta[0..1] ]); | ||||
| 586 | $f0 = ($f1 == 1 ? 7 : 2); | ||||
| 587 | } | ||||
| 588 | |||||
| 589 | if ($f0 == 2) { | ||||
| 590 | # if (field0 = w) | ||||
| 591 | # add [w] | ||||
| 592 | # field0 = d OR done if field1 = w | ||||
| 593 | push(@set, [ $delta[2] ]); | ||||
| 594 | $f0 = ($f1 == 2 ? 7 : 3); | ||||
| 595 | } | ||||
| 596 | |||||
| 597 | if ($f0 <= 6) { | ||||
| 598 | push(@set, [ @delta[$f0..$f1] ]); | ||||
| 599 | } | ||||
| 600 | |||||
| 601 | } else { | ||||
| 602 | |||||
| 603 | if ($f0 <= 1) { | ||||
| 604 | # if (field0 = y or M) | ||||
| 605 | # add [y,M] | ||||
| 606 | # field0 = w OR done if field1 = M | ||||
| 607 | push(@set, [ @delta[0..1] ]); | ||||
| 608 | $f0 = ($f1 == 1 ? 7 : 2); | ||||
| 609 | } | ||||
| 610 | |||||
| 611 | if ($f0 <= 6) { | ||||
| 612 | push(@set, [ @delta[$f0..$f1] ]); | ||||
| 613 | } | ||||
| 614 | } | ||||
| 615 | |||||
| 616 | # If we're not forcing signs, remove signs from all fields | ||||
| 617 | # except the first in each set. | ||||
| 618 | |||||
| 619 | my @ret; | ||||
| 620 | |||||
| 621 | foreach my $set (@set) { | ||||
| 622 | my @f = @$set; | ||||
| 623 | |||||
| 624 | if (defined($sign) && $sign eq "+") { | ||||
| 625 | push(@ret,@f); | ||||
| 626 | } else { | ||||
| 627 | push(@ret,shift(@f)); | ||||
| 628 | foreach my $f (@f) { | ||||
| 629 | $f =~ s/[-+]//; | ||||
| 630 | push(@ret,$f); | ||||
| 631 | } | ||||
| 632 | } | ||||
| 633 | } | ||||
| 634 | |||||
| 635 | # Width/pad | ||||
| 636 | |||||
| 637 | my $ret = join(':',@ret); | ||||
| 638 | if ($width && length($ret) < $width) { | ||||
| 639 | if (defined $pad && $pad eq ">") { | ||||
| 640 | $ret .= ' 'x($width-length($ret)); | ||||
| 641 | } else { | ||||
| 642 | $ret = ' 'x($width-length($ret)) . $ret; | ||||
| 643 | } | ||||
| 644 | } | ||||
| 645 | |||||
| 646 | return $ret; | ||||
| 647 | } | ||||
| 648 | |||||
| 649 | sub _printf_field { | ||||
| 650 | my($self,$sign,$pad,$width,$precision,$field,@field) = @_; | ||||
| 651 | |||||
| 652 | my $val = $self->_printf_field_val($field,@field); | ||||
| 653 | $pad = "<" if (! defined($pad)); | ||||
| 654 | |||||
| 655 | # Strip off the sign. | ||||
| 656 | |||||
| 657 | my $s = ''; | ||||
| 658 | |||||
| 659 | if ($val < 0) { | ||||
| 660 | $s = "-"; | ||||
| 661 | $val *= -1; | ||||
| 662 | } elsif ($sign) { | ||||
| 663 | $s = "+"; | ||||
| 664 | } | ||||
| 665 | |||||
| 666 | # Handle the precision. | ||||
| 667 | |||||
| 668 | if (defined($precision)) { | ||||
| 669 | $val = sprintf("%.${precision}f",$val); | ||||
| 670 | |||||
| 671 | } elsif (defined($width)) { | ||||
| 672 | my $i = $s . int($val) . '.'; | ||||
| 673 | if (length($i) < $width) { | ||||
| 674 | $precision = $width-length($i); | ||||
| 675 | $val = sprintf("%.${precision}f",$val); | ||||
| 676 | } | ||||
| 677 | } | ||||
| 678 | |||||
| 679 | # Handle padding. | ||||
| 680 | |||||
| 681 | if ($width) { | ||||
| 682 | if ($pad eq ">") { | ||||
| 683 | $val = "$s$val"; | ||||
| 684 | $val .= ' 'x($width-length($val)); | ||||
| 685 | |||||
| 686 | } elsif ($pad eq "<") { | ||||
| 687 | $val = "$s$val"; | ||||
| 688 | $val = ' 'x($width-length($val)) . $val; | ||||
| 689 | |||||
| 690 | } else { | ||||
| 691 | $val = $s . '0'x($width-length($val)-length($s)) . $val; | ||||
| 692 | } | ||||
| 693 | } else { | ||||
| 694 | $val = "$s$val"; | ||||
| 695 | } | ||||
| 696 | |||||
| 697 | return $val; | ||||
| 698 | } | ||||
| 699 | |||||
| 700 | # $$self{'data'}{'f'}{X}{Y} is the value of field X expressed in terms of Y. | ||||
| 701 | # | ||||
| 702 | sub _printf_field_val { | ||||
| 703 | my($self,$field,@field) = @_; | ||||
| 704 | |||||
| 705 | if (! exists $$self{'data'}{'f'}{'y'} && | ||||
| 706 | ! exists $$self{'data'}{'f'}{'y'}{'y'}) { | ||||
| 707 | |||||
| 708 | my($yv,$Mv,$wv,$dv,$hv,$mv,$sv) = map { $_*1 } @{ $$self{'data'}{'delta'} }; | ||||
| 709 | $$self{'data'}{'f'}{'y'}{'y'} = $yv; | ||||
| 710 | $$self{'data'}{'f'}{'M'}{'M'} = $Mv; | ||||
| 711 | $$self{'data'}{'f'}{'w'}{'w'} = $wv; | ||||
| 712 | $$self{'data'}{'f'}{'d'}{'d'} = $dv; | ||||
| 713 | $$self{'data'}{'f'}{'h'}{'h'} = $hv; | ||||
| 714 | $$self{'data'}{'f'}{'m'}{'m'} = $mv; | ||||
| 715 | $$self{'data'}{'f'}{'s'}{'s'} = $sv; | ||||
| 716 | } | ||||
| 717 | |||||
| 718 | # A single field | ||||
| 719 | |||||
| 720 | if (! @field) { | ||||
| 721 | return $$self{'data'}{'f'}{$field}{$field}; | ||||
| 722 | } | ||||
| 723 | |||||
| 724 | # Find the length of 1 unit of each field in terms of seconds. | ||||
| 725 | |||||
| 726 | if (! exists $$self{'data'}{'flen'}{'s'}) { | ||||
| 727 | my $business = $$self{'data'}{'business'}; | ||||
| 728 | my $dmb = $self->base(); | ||||
| 729 | $$self{'data'}{'flen'} = { 's' => 1, | ||||
| 730 | 'm' => 60, | ||||
| 731 | 'h' => 3600, | ||||
| 732 | 'd' => $$dmb{'data'}{'len'}{$business}{'dl'}, | ||||
| 733 | 'w' => $$dmb{'data'}{'len'}{$business}{'wl'}, | ||||
| 734 | 'M' => $$dmb{'data'}{'len'}{$business}{'ml'}, | ||||
| 735 | 'y' => $$dmb{'data'}{'len'}{$business}{'yl'}, | ||||
| 736 | }; | ||||
| 737 | } | ||||
| 738 | |||||
| 739 | # Calculate the value for each field. | ||||
| 740 | |||||
| 741 | my $val = 0; | ||||
| 742 | foreach my $f (@field) { | ||||
| 743 | |||||
| 744 | # We want the value of $f expressed in terms of $field | ||||
| 745 | |||||
| 746 | if (! exists $$self{'data'}{'f'}{$f}{$field}) { | ||||
| 747 | |||||
| 748 | # Get the value of $f expressed in seconds | ||||
| 749 | |||||
| 750 | if (! exists $$self{'data'}{'f'}{$f}{'s'}) { | ||||
| 751 | $$self{'data'}{'f'}{$f}{'s'} = | ||||
| 752 | $$self{'data'}{'f'}{$f}{$f} * $$self{'data'}{'flen'}{$f}; | ||||
| 753 | } | ||||
| 754 | |||||
| 755 | # Get the value of $f expressed in terms of $field | ||||
| 756 | |||||
| 757 | $$self{'data'}{'f'}{$f}{$field} = | ||||
| 758 | $$self{'data'}{'f'}{$f}{'s'} / $$self{'data'}{'flen'}{$field}; | ||||
| 759 | } | ||||
| 760 | |||||
| 761 | $val += $$self{'data'}{'f'}{$f}{$field}; | ||||
| 762 | } | ||||
| 763 | |||||
| 764 | return $val; | ||||
| 765 | } | ||||
| 766 | |||||
| 767 | sub type { | ||||
| 768 | my($self,$op) = @_; | ||||
| 769 | $op = lc($op); | ||||
| 770 | |||||
| 771 | if ($op eq 'business') { | ||||
| 772 | return $$self{'data'}{'business'}; | ||||
| 773 | } elsif ($op eq 'standard') { | ||||
| 774 | return 1-$$self{'data'}{'business'}; | ||||
| 775 | } | ||||
| 776 | |||||
| 777 | my($exact,$semi,$approx) = (0,0,0); | ||||
| 778 | my($y,$m,$w,$d,$h,$mn,$s) = @{ $$self{'data'}{'delta'} }; | ||||
| 779 | if ($y || $m) { | ||||
| 780 | $approx = 1; | ||||
| 781 | } elsif ($w || (! $$self{'data'}{'business'} && $d)) { | ||||
| 782 | $semi = 1; | ||||
| 783 | } else { | ||||
| 784 | $exact = 1; | ||||
| 785 | } | ||||
| 786 | |||||
| 787 | if ($op eq 'exact') { | ||||
| 788 | return $exact; | ||||
| 789 | } elsif ($op eq 'semi') { | ||||
| 790 | return $semi; | ||||
| 791 | } elsif ($op eq 'approx') { | ||||
| 792 | return $approx; | ||||
| 793 | } | ||||
| 794 | |||||
| 795 | return undef; | ||||
| 796 | } | ||||
| 797 | |||||
| 798 | sub calc { | ||||
| 799 | my($self,$obj,$subtract,$no_normalize) = @_; | ||||
| 800 | if ($$self{'err'}) { | ||||
| 801 | $$self{'err'} = "[calc] First object invalid (delta)"; | ||||
| 802 | return undef; | ||||
| 803 | } | ||||
| 804 | |||||
| 805 | if (ref($obj) eq 'Date::Manip::Date') { | ||||
| 806 | if ($$obj{'err'}) { | ||||
| 807 | $$self{'err'} = "[calc] Second object invalid (date)"; | ||||
| 808 | return undef; | ||||
| 809 | } | ||||
| 810 | return $obj->calc($self,$subtract); | ||||
| 811 | |||||
| 812 | } elsif (ref($obj) eq 'Date::Manip::Delta') { | ||||
| 813 | if ($$obj{'err'}) { | ||||
| 814 | $$self{'err'} = "[calc] Second object invalid (delta)"; | ||||
| 815 | return undef; | ||||
| 816 | } | ||||
| 817 | return $self->_calc_delta_delta($obj,$subtract,$no_normalize); | ||||
| 818 | |||||
| 819 | } else { | ||||
| 820 | $$self{'err'} = "[calc] Second object must be a Date/Delta object"; | ||||
| 821 | return undef; | ||||
| 822 | } | ||||
| 823 | } | ||||
| 824 | |||||
| 825 | sub _calc_delta_delta { | ||||
| 826 | my($self,$delta,@args) = @_; | ||||
| 827 | my $dmt = $$self{'tz'}; | ||||
| 828 | my $dmb = $$dmt{'base'}; | ||||
| 829 | my $ret = $self->new_delta; | ||||
| 830 | |||||
| 831 | if ($self->err()) { | ||||
| 832 | $$ret{'err'} = "[calc] First delta object invalid"; | ||||
| 833 | return $ret; | ||||
| 834 | } elsif ($delta->err()) { | ||||
| 835 | $$ret{'err'} = "[calc] Second delta object invalid"; | ||||
| 836 | return $ret; | ||||
| 837 | } | ||||
| 838 | |||||
| 839 | my($subtract,$no_normalize); | ||||
| 840 | if (@args == 2) { | ||||
| 841 | ($subtract,$no_normalize) = @args; | ||||
| 842 | } elsif ($args[0] eq 'nonormalize') { | ||||
| 843 | $subtract = 0; | ||||
| 844 | $no_normalize = 1; | ||||
| 845 | } else { | ||||
| 846 | $subtract = 0; | ||||
| 847 | $no_normalize = 0; | ||||
| 848 | } | ||||
| 849 | |||||
| 850 | my $business = 0; | ||||
| 851 | if ($$self{'data'}{'business'} != $$delta{'data'}{'business'}) { | ||||
| 852 | $$ret{'err'} = "[calc] Delta/delta calculation objects must be of " . | ||||
| 853 | 'the same type'; | ||||
| 854 | return $ret; | ||||
| 855 | } else { | ||||
| 856 | $business = $$self{'data'}{'business'}; | ||||
| 857 | } | ||||
| 858 | |||||
| 859 | my ($err,@delta); | ||||
| 860 | for (my $i=0; $i<7; $i++) { | ||||
| 861 | if ($subtract) { | ||||
| 862 | $delta[$i] = $$self{'data'}{'delta'}[$i] - $$delta{'data'}{'delta'}[$i]; | ||||
| 863 | } else { | ||||
| 864 | $delta[$i] = $$self{'data'}{'delta'}[$i] + $$delta{'data'}{'delta'}[$i]; | ||||
| 865 | } | ||||
| 866 | } | ||||
| 867 | |||||
| 868 | ($err,@delta) = $dmb->_delta_fields( { 'nonorm' => 0, | ||||
| 869 | 'source' => 'delta', | ||||
| 870 | 'sign' => -1 }, | ||||
| 871 | [@delta]) if (! $no_normalize); | ||||
| 872 | |||||
| 873 | $$ret{'data'}{'delta'} = [@delta]; | ||||
| 874 | $$ret{'data'}{'business'} = $business; | ||||
| 875 | $$self{'data'}{'length'} = 'unknown'; | ||||
| 876 | |||||
| 877 | return $ret; | ||||
| 878 | } | ||||
| 879 | |||||
| 880 | sub convert { | ||||
| 881 | my($self,$to) = @_; | ||||
| 882 | |||||
| 883 | # What mode are we currently in | ||||
| 884 | |||||
| 885 | my $from; | ||||
| 886 | my($y,$m,$w,$d,$h,$mn,$s) = @{ $$self{'data'}{'delta'} }; | ||||
| 887 | if ($y || $m) { | ||||
| 888 | $from = 'approx'; | ||||
| 889 | } elsif ($w || (! $$self{'data'}{'business'} && $d)) { | ||||
| 890 | $from = 'semi'; | ||||
| 891 | } else { | ||||
| 892 | $from = 'exact'; | ||||
| 893 | } | ||||
| 894 | |||||
| 895 | my $business = $$self{'data'}{'business'}; | ||||
| 896 | |||||
| 897 | # | ||||
| 898 | # Do the conversion | ||||
| 899 | # | ||||
| 900 | |||||
| 901 | { | ||||
| 902 | 2 | 184µs | 2 | 13µs | # spent 11µs (8+2) within Date::Manip::Delta::BEGIN@902 which was called:
# once (8µs+2µs) by Date::Manip::Obj::new_delta at line 902 # spent 11µs making 1 call to Date::Manip::Delta::BEGIN@902
# spent 2µs making 1 call to integer::unimport |
| 903 | |||||
| 904 | my $dmb = $self->base(); | ||||
| 905 | my $yl = $$dmb{'data'}{'len'}{$business}{'yl'}; | ||||
| 906 | my $ml = $$dmb{'data'}{'len'}{$business}{'ml'}; | ||||
| 907 | my $wl = $$dmb{'data'}{'len'}{$business}{'wl'}; | ||||
| 908 | my $dl = $$dmb{'data'}{'len'}{$business}{'dl'}; | ||||
| 909 | |||||
| 910 | # Convert it to seconds | ||||
| 911 | |||||
| 912 | $s += $y*$yl + $m*$ml + $w*$wl + $d*$dl + $h*3600 + $mn*60; | ||||
| 913 | ($y,$m,$w,$d,$h,$mn) = (0,0,0,0,0,0); | ||||
| 914 | |||||
| 915 | # Convert it to $to | ||||
| 916 | |||||
| 917 | if ($to eq 'approx') { | ||||
| 918 | # Figure out how many months there are | ||||
| 919 | $m = int($s/$ml); | ||||
| 920 | $s -= $m*$ml; | ||||
| 921 | } | ||||
| 922 | |||||
| 923 | if ($to eq 'approx' || $to eq 'semi') { | ||||
| 924 | if ($business) { | ||||
| 925 | $w = int($s/$wl); | ||||
| 926 | $s -= $w*$wl; | ||||
| 927 | } else { | ||||
| 928 | $d = int($s/$dl); | ||||
| 929 | $s -= $d*$dl; | ||||
| 930 | } | ||||
| 931 | } | ||||
| 932 | |||||
| 933 | $s = int($s); | ||||
| 934 | } | ||||
| 935 | |||||
| 936 | $self->set('delta',[$y,$m,$w,$d,$h,$mn,$s]); | ||||
| 937 | } | ||||
| 938 | |||||
| 939 | sub cmp { | ||||
| 940 | my($self,$delta) = @_; | ||||
| 941 | |||||
| 942 | if ($$self{'err'}) { | ||||
| 943 | warn "WARNING: [cmp] Arguments must be valid deltas: delta1\n"; | ||||
| 944 | return undef; | ||||
| 945 | } | ||||
| 946 | |||||
| 947 | if (! ref($delta) eq 'Date::Manip::Delta') { | ||||
| 948 | warn "WARNING: [cmp] Argument must be a Date::Manip::Delta object\n"; | ||||
| 949 | return undef; | ||||
| 950 | } | ||||
| 951 | if ($$delta{'err'}) { | ||||
| 952 | warn "WARNING: [cmp] Arguments must be valid deltas: delta2\n"; | ||||
| 953 | return undef; | ||||
| 954 | } | ||||
| 955 | |||||
| 956 | if ($$self{'data'}{'business'} != $$delta{'data'}{'business'}) { | ||||
| 957 | warn "WARNING: [cmp] Deltas must both be business or standard\n"; | ||||
| 958 | return undef; | ||||
| 959 | } | ||||
| 960 | |||||
| 961 | my $business = $$self{'data'}{'business'}; | ||||
| 962 | my $dmb = $self->base(); | ||||
| 963 | my $yl = $$dmb{'data'}{'len'}{$business}{'yl'}; | ||||
| 964 | my $ml = $$dmb{'data'}{'len'}{$business}{'ml'}; | ||||
| 965 | my $wl = $$dmb{'data'}{'len'}{$business}{'wl'}; | ||||
| 966 | my $dl = $$dmb{'data'}{'len'}{$business}{'dl'}; | ||||
| 967 | |||||
| 968 | if ($$self{'data'}{'length'} eq 'unknown') { | ||||
| 969 | my($y,$m,$w,$d,$h,$mn,$s) = @{ $$self{'data'}{'delta'} }; | ||||
| 970 | |||||
| 971 | 2 | 40µs | 2 | 7µs | # spent 6µs (6+800ns) within Date::Manip::Delta::BEGIN@971 which was called:
# once (6µs+800ns) by Date::Manip::Obj::new_delta at line 971 # spent 6µs making 1 call to Date::Manip::Delta::BEGIN@971
# spent 800ns making 1 call to integer::unimport |
| 972 | $$self{'data'}{'length'} = int($y*$yl + $m*$ml + $w*$wl + | ||||
| 973 | $d*$dl + $h*3600 + $mn*60 + $s); | ||||
| 974 | } | ||||
| 975 | |||||
| 976 | if ($$delta{'data'}{'length'} eq 'unknown') { | ||||
| 977 | my($y,$m,$w,$d,$h,$mn,$s) = @{ $$delta{'data'}{'delta'} }; | ||||
| 978 | |||||
| 979 | 2 | 72µs | 2 | 7µs | # spent 6µs (5+600ns) within Date::Manip::Delta::BEGIN@979 which was called:
# once (5µs+600ns) by Date::Manip::Obj::new_delta at line 979 # spent 6µs making 1 call to Date::Manip::Delta::BEGIN@979
# spent 600ns making 1 call to integer::unimport |
| 980 | $$delta{'data'}{'length'} = int($y*$yl + $m*$ml + $w*$wl + | ||||
| 981 | $d*$dl + $h*3600 + $mn*60 + $s); | ||||
| 982 | } | ||||
| 983 | |||||
| 984 | return ($$self{'data'}{'length'} cmp $$delta{'data'}{'length'}); | ||||
| 985 | } | ||||
| 986 | |||||
| 987 | 1 | 3µs | 1; | ||
| 988 | # Local Variables: | ||||
| 989 | # mode: cperl | ||||
| 990 | # indent-tabs-mode: nil | ||||
| 991 | # cperl-indent-level: 3 | ||||
| 992 | # cperl-continued-statement-offset: 2 | ||||
| 993 | # cperl-continued-brace-offset: 0 | ||||
| 994 | # cperl-brace-offset: 0 | ||||
| 995 | # cperl-brace-imaginary-offset: 0 | ||||
| 996 | # cperl-label-offset: 0 | ||||
| 997 | # End: | ||||
# spent 33µs within Date::Manip::Delta::CORE:match which was called 12 times, avg 3µs/call:
# 12 times (33µs+0s) by Date::Manip::Delta::parse at line 379, avg 3µs/call | |||||
sub Date::Manip::Delta::CORE:qr; # opcode | |||||
# spent 1.61ms within Date::Manip::Delta::CORE:regcomp which was called 39 times, avg 41µs/call:
# 12 times (14µs+0s) by Date::Manip::Delta::parse at line 336, avg 1µs/call
# 12 times (7µs+0s) by Date::Manip::Delta::parse at line 379, avg 608ns/call
# 12 times (5µs+0s) by Date::Manip::Delta::parse at line 370, avg 417ns/call
# once (1.56ms+0s) by Date::Manip::Delta::_rx at line 231
# once (22µs+0s) by Date::Manip::Delta::_rx at line 241
# once (6µs+0s) by Date::Manip::Delta::_rx at line 236 | |||||
# spent 58µs within Date::Manip::Delta::CORE:subst which was called 36 times, avg 2µs/call:
# 12 times (24µs+0s) by Date::Manip::Delta::parse at line 336, avg 2µs/call
# 12 times (14µs+0s) by Date::Manip::Delta::parse at line 370, avg 1µs/call
# 6 times (11µs+0s) by Date::Manip::Delta::parse at line 317, avg 2µs/call
# 6 times (10µs+0s) by Date::Manip::Delta::parse at line 318, avg 2µs/call |