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

Filename/usr/share/perl5/Date/Manip/Delta.pm
StatementsExecuted 34 statements in 4.26ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11112µs16µsDate::Manip::Delta::::BEGIN@902Date::Manip::Delta::BEGIN@902
11112µs20µsDate::Manip::Delta::::BEGIN@18Date::Manip::Delta::BEGIN@18
11112µs12µsDate::Manip::Delta::::BEGIN@14Date::Manip::Delta::BEGIN@14
11110µs11µsDate::Manip::Delta::::BEGIN@979Date::Manip::Delta::BEGIN@979
1119µs120µsDate::Manip::Delta::::BEGIN@21Date::Manip::Delta::BEGIN@21
1119µs9µsDate::Manip::Delta::::BEGIN@114Date::Manip::Delta::BEGIN@114
1119µs11µsDate::Manip::Delta::::BEGIN@20Date::Manip::Delta::BEGIN@20
1118µs10µsDate::Manip::Delta::::BEGIN@971Date::Manip::Delta::BEGIN@971
1117µs7µsDate::Manip::Delta::::_initDate::Manip::Delta::_init
1116µs18µsDate::Manip::Delta::::BEGIN@19Date::Manip::Delta::BEGIN@19
1115µs5µsDate::Manip::Delta::::BEGIN@24Date::Manip::Delta::BEGIN@24
1115µs5µsDate::Manip::Delta::::BEGIN@25Date::Manip::Delta::BEGIN@25
1113µs3µsDate::Manip::Delta::::ENDDate::Manip::Delta::END
0000s0sDate::Manip::Delta::::_calc_delta_deltaDate::Manip::Delta::_calc_delta_delta
0000s0sDate::Manip::Delta::::_init_argsDate::Manip::Delta::_init_args
0000s0sDate::Manip::Delta::::_printf_deltaDate::Manip::Delta::_printf_delta
0000s0sDate::Manip::Delta::::_printf_fieldDate::Manip::Delta::_printf_field
0000s0sDate::Manip::Delta::::_printf_field_valDate::Manip::Delta::_printf_field_val
0000s0sDate::Manip::Delta::::_rxDate::Manip::Delta::_rx
0000s0sDate::Manip::Delta::::calcDate::Manip::Delta::calc
0000s0sDate::Manip::Delta::::cmpDate::Manip::Delta::cmp
0000s0sDate::Manip::Delta::::configDate::Manip::Delta::config
0000s0sDate::Manip::Delta::::convertDate::Manip::Delta::convert
0000s0sDate::Manip::Delta::::inputDate::Manip::Delta::input
0000s0sDate::Manip::Delta::::is_deltaDate::Manip::Delta::is_delta
0000s0sDate::Manip::Delta::::parseDate::Manip::Delta::parse
0000s0sDate::Manip::Delta::::printfDate::Manip::Delta::printf
0000s0sDate::Manip::Delta::::setDate::Manip::Delta::set
0000s0sDate::Manip::Delta::::typeDate::Manip::Delta::type
0000s0sDate::Manip::Delta::::valueDate::Manip::Delta::value
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Date::Manip::Delta;
2# Copyright (c) 1995-2014 Sullivan Beck. All rights reserved.
3# This program is free software; you can redistribute it and/or modify it
4# under the same terms as Perl itself.
5
6########################################################################
7# Any routine that starts with an underscore (_) is NOT intended for
8# public use. They are for internal use in the the Date::Manip
9# modules and are subject to change without warning or notice.
10#
11# ABSOLUTELY NO USER SUPPORT IS OFFERED FOR THESE ROUTINES!
12########################################################################
13
14243µs112µs
# spent 12µs within Date::Manip::Delta::BEGIN@14 which was called: # once (12µs+0s) by Date::Manip::Obj::new_delta at line 14
use Date::Manip::Obj;
# spent 12µs making 1 call to Date::Manip::Delta::BEGIN@14
1519µs@ISA = ('Date::Manip::Obj');
16
1719µsrequire 5.010000;
18223µs227µs
# spent 20µs (12+7) within Date::Manip::Delta::BEGIN@18 which was called: # once (12µs+7µs) by Date::Manip::Obj::new_delta at line 18
use warnings;
# spent 20µs making 1 call to Date::Manip::Delta::BEGIN@18 # spent 7µs making 1 call to warnings::import
19221µs229µs
# spent 18µs (6+11) within Date::Manip::Delta::BEGIN@19 which was called: # once (6µs+11µs) by Date::Manip::Obj::new_delta at line 19
use strict;
# spent 18µs making 1 call to Date::Manip::Delta::BEGIN@19 # spent 11µs making 1 call to strict::import
20219µs213µs
# spent 11µs (9+2) within Date::Manip::Delta::BEGIN@20 which was called: # once (9µs+2µs) by Date::Manip::Obj::new_delta at line 20
use utf8;
# spent 11µs making 1 call to Date::Manip::Delta::BEGIN@20 # spent 2µs making 1 call to utf8::import
21226µs2232µs
# spent 120µs (9+111) within Date::Manip::Delta::BEGIN@21 which was called: # once (9µs+111µs) by Date::Manip::Obj::new_delta at line 21
use IO::File;
# spent 120µs making 1 call to Date::Manip::Delta::BEGIN@21 # spent 111µs making 1 call to Exporter::import
22#use re 'debug';
23
24220µs15µ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
use Date::Manip::Base;
# spent 5µs making 1 call to Date::Manip::Delta::BEGIN@24
252671µs15µs
# spent 5µs within Date::Manip::Delta::BEGIN@25 which was called: # once (5µs+0s) by Date::Manip::Obj::new_delta at line 25
use Date::Manip::TZ;
# spent 5µs making 1 call to Date::Manip::Delta::BEGIN@25
26
2710sour $VERSION;
281200ns$VERSION='6.47';
2914µs
# spent 3µs within Date::Manip::Delta::END which was called: # once (3µs+0s) by main::RUNTIME at line 131 of C4/Service.pm
END { undef $VERSION; }
30
31########################################################################
32# BASE METHODS
33########################################################################
34
35sub is_delta {
36 return 1;
37}
38
39sub 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 7µs within Date::Manip::Delta::_init which was called: # once (7µs+0s) by Date::Manip::Obj::new at line 162 of Date/Manip/Obj.pm
sub _init {
521300ns my($self) = @_;
53
541900ns my $def = [0,0,0,0,0,0,0];
5513µs my $dmt = $$self{'tz'};
561200ns my $dmb = $$dmt{'base'};
57
581300ns $$self{'err'} = '';
5915µ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
72sub _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
85sub 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
105sub input {
106 my($self) = @_;
107 return $$self{'data'}{'in'};
108}
109
110########################################################################
111# DELTA METHODS
112########################################################################
113
114
# spent 9µs within Date::Manip::Delta::BEGIN@114 which was called: # once (9µs+0s) by Date::Manip::Obj::new_delta at line 199
BEGIN {
11514µs my %ops = map { $_,1 } qw( delta business normal standard );
11615µ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 }
19912.95ms19µs}
# spent 9µs making 1 call to Date::Manip::Delta::BEGIN@114
200
201sub _rx {
202 my($self,$rx) = @_;
203 my $dmt = $$self{'tz'};
204 my $dmb = $$dmt{'base'};
205
206 return $$dmb{'data'}{'rx'}{'delta'}{$rx}
207 if (exists $$dmb{'data'}{'rx'}{'delta'}{$rx});
208
209 if ($rx eq 'expanded') {
210 my $sign = '[-+]?\s*';
211 my $sep = '(?:,\s*|\s+|$)';
212
213 my $nth = $$dmb{'data'}{'rx'}{'nth'}[0];
214 my $yf = $$dmb{data}{rx}{fields}[1];
215 my $mf = $$dmb{data}{rx}{fields}[2];
216 my $wf = $$dmb{data}{rx}{fields}[3];
217 my $df = $$dmb{data}{rx}{fields}[4];
218 my $hf = $$dmb{data}{rx}{fields}[5];
219 my $mnf = $$dmb{data}{rx}{fields}[6];
220 my $sf = $$dmb{data}{rx}{fields}[7];
221 my $num = '(?:\d+(?:\.\d*)?|\.\d+)';
222
223 my $y = "(?:(?:(?<y>$sign$num)|(?<y>$nth))\\s*(?:$yf)$sep)";
224 my $m = "(?:(?:(?<m>$sign$num)|(?<m>$nth))\\s*(?:$mf)$sep)";
225 my $w = "(?:(?:(?<w>$sign$num)|(?<w>$nth))\\s*(?:$wf)$sep)";
226 my $d = "(?:(?:(?<d>$sign$num)|(?<d>$nth))\\s*(?:$df)$sep)";
227 my $h = "(?:(?:(?<h>$sign$num)|(?<h>$nth))\\s*(?:$hf)$sep)";
228 my $mn = "(?:(?:(?<mn>$sign$num)|(?<mn>$nth))\\s*(?:$mnf)$sep)";
229 my $s = "(?:(?:(?<s>$sign$num)|(?<s>$nth))\\s*(?:$sf)?)";
230
231 my $exprx = qr/^\s*$y?$m?$w?$d?$h?$mn?$s?\s*$/i;
232 $$dmb{'data'}{'rx'}{'delta'}{$rx} = $exprx;
233
234 } elsif ($rx eq 'mode') {
235
236 my $mode = qr/\b($$dmb{'data'}{'rx'}{'mode'}[0])\b/i;
237 $$dmb{'data'}{'rx'}{'delta'}{$rx} = $mode;
238
239 } elsif ($rx eq 'when') {
240
241 my $when = qr/\b($$dmb{'data'}{'rx'}{'when'}[0])\b/i;
242 $$dmb{'data'}{'rx'}{'delta'}{$rx} = $when;
243
244 }
245
246 return $$dmb{'data'}{'rx'}{'delta'}{$rx};
247}
248
249sub parse {
250 my($self,$instring,@args) = @_;
251 my($business,$no_normalize,$gotmode,$err,@delta);
252
253 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 $business = 0;
296 $no_normalize = 0;
297 $gotmode = 0;
298 } else {
299 $$self{'err'} = "[parse] Unknown arguments";
300 return 1;
301 }
302
303 my $dmt = $$self{'tz'};
304 my $dmb = $$dmt{'base'};
305 $self->_init();
306
307 if (! $instring) {
308 $$self{'err'} = '[parse] Empty delta string';
309 return 1;
310 }
311
312 #
313 # Parse the string
314 #
315
316 $$self{'err'} = '';
317 $instring =~ s/^\s*//;
318 $instring =~ s/\s*$//;
319
320 PARSE: {
321
322 # First, we'll try the standard format (without a mode string)
323
324 ($err,@delta) = $dmb->_split_delta($instring);
325 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 my @strings = $dmb->_encoding($instring);
332 my $moderx = $self->_rx('mode');
333 my %mode = ();
334
335 foreach my $string (@strings) {
336 if ($string =~ s/\s*$moderx\s*//i) {
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 foreach my $string (@strings) {
358 my($b,$g);
359 if (exists $mode{$string}) {
360 $b = $mode{$string};
361 $g = 1;
362 } else {
363 $b = $business;
364 $g = 0;
365 }
366
367 my $past = 0;
368
369 my $whenrx = $self->_rx('when');
370 if ($string &&
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 my $rx = $self->_rx('expanded');
379 if ($string &&
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 if (! @delta) {
407 $$self{'err'} = "[parse] Invalid delta string";
408 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
430sub 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
541sub _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
649sub _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#
702sub _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
767sub 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
798sub 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
825sub _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
880sub 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 {
9022292µs219µs
# spent 16µs (12+3) within Date::Manip::Delta::BEGIN@902 which was called: # once (12µs+3µs) by Date::Manip::Obj::new_delta at line 902
no integer;
# spent 16µs making 1 call to Date::Manip::Delta::BEGIN@902 # spent 3µ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
939sub 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
971266µs212µs
# spent 10µs (8+2) within Date::Manip::Delta::BEGIN@971 which was called: # once (8µs+2µs) by Date::Manip::Obj::new_delta at line 971
no integer;
# spent 10µs making 1 call to Date::Manip::Delta::BEGIN@971 # spent 2µs 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
979283µs213µs
# spent 11µs (10+2) within Date::Manip::Delta::BEGIN@979 which was called: # once (10µs+2µs) by Date::Manip::Obj::new_delta at line 979
no integer;
# spent 11µs making 1 call to Date::Manip::Delta::BEGIN@979 # spent 2µs 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
98713µs1;
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:
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.