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

Filename/usr/share/perl5/Date/Manip/Delta.pm
StatementsExecuted 35 statements in 5.03ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11131µs36µsDate::Manip::Delta::::BEGIN@14Date::Manip::Delta::BEGIN@14
11123µs126µsDate::Manip::Delta::::BEGIN@17Date::Manip::Delta::BEGIN@17
11123µs270µsDate::Manip::Delta::::BEGIN@20Date::Manip::Delta::BEGIN@20
11121µs35µsDate::Manip::Delta::::BEGIN@21Date::Manip::Delta::BEGIN@21
11118µs18µsDate::Manip::Delta::::_initDate::Manip::Delta::_init
11117µs41µsDate::Manip::Delta::::BEGIN@18Date::Manip::Delta::BEGIN@18
11114µs20µsDate::Manip::Delta::::BEGIN@19Date::Manip::Delta::BEGIN@19
11113µs47µsDate::Manip::Delta::::BEGIN@24Date::Manip::Delta::BEGIN@24
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::::configDate::Manip::Delta::config
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
01126µsProfile data that couldn't be associated with a specific line:
# spent 126µs making 1 call to Date::Manip::Delta::BEGIN@17
1111µspackage Date::Manip::Delta;
2# Copyright (c) 1995-2010 Sullivan Beck. All rights reserved.
3# This program is free software; you can redistribute it and/or modify it
4# under the same terms as Perl itself.
5
6########################################################################
7# Any routine that starts with an underscore (_) is NOT intended for
8# public use. They are for internal use in the the Date::Manip
9# modules and are subject to change without warning or notice.
10#
11# ABSOLUTELY NO USER SUPPORT IS OFFERED FOR THESE ROUTINES!
12########################################################################
13
14369µs242µs
# spent 36µs (31+5) within Date::Manip::Delta::BEGIN@14 which was called: # once (31µs+5µs) by Date::Manip::Obj::new_delta at line 14
use Date::Manip::Obj;
# spent 36µs making 1 call to Date::Manip::Delta::BEGIN@14 # spent 5µs making 1 call to UNIVERSAL::import
15122µs@ISA = ('Date::Manip::Obj');
16
17499µs1103µs
# spent 126µs (23+103) within Date::Manip::Delta::BEGIN@17 which was called: # once (23µs+103µs) by Date::Manip::Obj::new_delta at line 0
require 5.010000;
# spent 103µs making 1 call to feature::import
18335µs266µs
# spent 41µs (17+24) within Date::Manip::Delta::BEGIN@18 which was called: # once (17µs+24µs) by Date::Manip::Obj::new_delta at line 18
use warnings;
# spent 41µs making 1 call to Date::Manip::Delta::BEGIN@18 # spent 24µs making 1 call to warnings::import
19330µs226µs
# spent 20µs (14+6) within Date::Manip::Delta::BEGIN@19 which was called: # once (14µs+6µs) by Date::Manip::Obj::new_delta at line 19
use strict;
# spent 20µs making 1 call to Date::Manip::Delta::BEGIN@19 # spent 6µs making 1 call to strict::import
20354µs2517µs
# spent 270µs (23+247) within Date::Manip::Delta::BEGIN@20 which was called: # once (23µs+247µs) by Date::Manip::Obj::new_delta at line 20
use IO::File;
# spent 270µs making 1 call to Date::Manip::Delta::BEGIN@20 # spent 247µs making 1 call to Exporter::import
21339µs249µs
# spent 35µs (21+14) within Date::Manip::Delta::BEGIN@21 which was called: # once (21µs+14µs) by Date::Manip::Obj::new_delta at line 21
use feature 'switch';
# spent 35µs making 1 call to Date::Manip::Delta::BEGIN@21 # spent 14µs making 1 call to feature::import
22#use re 'debug';
23
2434.64ms280µs
# spent 47µs (13+33) within Date::Manip::Delta::BEGIN@24 which was called: # once (13µs+33µs) by Date::Manip::Obj::new_delta at line 24
use vars qw($VERSION);
# spent 47µs making 1 call to Date::Manip::Delta::BEGIN@24 # spent 33µs making 1 call to vars::import
2511µs$VERSION='6.11';
26
27########################################################################
28# BASE METHODS
29########################################################################
30
31sub is_delta {
32 return 1;
33}
34
35sub config {
36 my($self,@args) = @_;
37 $self->SUPER::config(@args);
38
39 # A new config can change the value of the format fields, so clear them.
40 $$self{'data'}{'f'} = {};
41 $$self{'data'}{'flen'} = {};
42}
43
44# Call this every time a new delta is put in to make sure everything is
45# correctly initialized.
46#
47
# spent 18µs within Date::Manip::Delta::_init which was called: # once (18µs+0s) by Date::Manip::Obj::new at line 152 of Date/Manip/Obj.pm
sub _init {
4811µs my($self) = @_;
49
5011µs my $def = [0,0,0,0,0,0,0];
5111µs my $dmb = $$self{'objs'}{'base'};
52
5311µs $$self{'err'} = '';
5412µs $$self{'data'}{'delta'} = $def; # the delta
5511µs $$self{'data'}{'business'} = 0; # 1 for a business delta
5612µs $$self{'data'}{'gotmode'} = 0; # if exact/business set explicitly
5711µs $$self{'data'}{'in'} = ''; # the string that was parsed (if any)
5812µs $$self{'data'}{'f'} = {}; # format fields
5919µs $$self{'data'}{'flen'} = {}; # field lengths
60}
61
62sub _init_args {
63 my($self) = @_;
64
65 my @args = @{ $$self{'args'} };
66 if (@args) {
67 if ($#args == 0) {
68 $self->parse($args[0]);
69 } else {
70 warn "WARNING: [new] invalid arguments: @args\n";
71 }
72 }
73}
74
75sub value {
76 my($self) = @_;
77 my $dmb = $$self{'objs'}{'base'};
78
79 return undef if ($$self{'err'});
80 if (wantarray) {
81 return @{ $$self{'data'}{'delta'} };
82 } elsif ($$self{'data'}{'business'}) {
83 return $dmb->join('business',$$self{'data'}{'delta'});
84 } else {
85 return $dmb->join('delta',$$self{'data'}{'delta'});
86 }
87}
88
89########################################################################
90# DELTA METHODS
91########################################################################
92
93sub set {
94 my($self,$field,$val) = @_;
95
96 $field = lc($field);
97 my $business = 0;
98 my $dmb = $$self{'objs'}{'base'};
99 my $dmt = $$self{'objs'}{'tz'};
100 my $zone = $$self{'data'}{'tz'};
101 my $gotmode = $$self{'data'}{'gotmode'};
102 my (@delta,$err);
103
104 given ($field) {
105
106 when (['delta','business','normal']) {
107 if ($field eq 'business') {
108 $business = 1;
109 $gotmode = 1;
110 } elsif ($field eq 'normal') {
111 $business = 0;
112 $gotmode = 1;
113 }
114 my $type = ($business ? 'business' : 'delta');
115 if ($business) {
116 ($err,@delta) = $dmb->_normalize_business('norm',@$val);
117 } else {
118 ($err,@delta) = $dmb->_normalize_delta('norm',@$val);
119 }
120 }
121
122 when (['y','M','w','d','h','m','s']) {
123 if ($$self{'err'}) {
124 $$self{'err'} = "[set] Invalid delta";
125 return 1;
126 }
127
128 @delta = @{ $$self{'data'}{'delta'} };
129 $business = $$self{'data'}{'business'};
130 my %f = qw(y 0 M 1 w 2 d 3 h 4 m 5 s 6);
131 $delta[$f{$field}] = $val;
132
133 if ($business) {
134 ($err,@delta) = $dmb->_normalize_business(0,@$val);
135 } else {
136 ($err,@delta) = $dmb->_normalize_delta(0,@$val);
137 }
138 }
139
140 when ('mode') {
141 @delta = @{ $$self{'data'}{'delta'} };
142 $val = lc($val);
143 if ($val eq "business" || $val eq "normal") {
144 $gotmode = 1;
145 $business = ($val eq "business" ? 1 : 0);
146
147 } else {
148 $$self{'err'} = "[set] Invalid mode: $val";
149 return 1;
150 }
151 }
152
153 default {
154 $$self{'err'} = "[set] Invalid field: $field";
155 return 1;
156 }
157 }
158
159 if ($err) {
160 $$self{'err'} = "[set] Invalid field value: $field";
161 return 1;
162 }
163
164 $self->_init();
165 $$self{'data'}{'delta'} = [ @delta ];
166 $$self{'data'}{'business'} = $business;
167 $$self{'data'}{'gotmode'} = $gotmode;
168 return 0;
169}
170
171sub _rx {
172 my($self,$rx) = @_;
173 my $dmb = $$self{'objs'}{'base'};
174
175 return $$dmb{'data'}{'rx'}{'delta'}{$rx}
176 if (exists $$dmb{'data'}{'rx'}{'delta'}{$rx});
177
178 if ($rx eq 'expanded') {
179 my $sign = '[-+]?\s*';
180 my $sep = '(?:,\s*|\s+|$)';
181
182 my $y = "(?:(?<y>$sign\\d+)\\s*(?:$$dmb{data}{rx}{fields}[1])$sep)";
183 my $m = "(?:(?<m>$sign\\d+)\\s*(?:$$dmb{data}{rx}{fields}[2])$sep)";
184 my $w = "(?:(?<w>$sign\\d+)\\s*(?:$$dmb{data}{rx}{fields}[3])$sep)";
185 my $d = "(?:(?<d>$sign\\d+)\\s*(?:$$dmb{data}{rx}{fields}[4])$sep)";
186 my $h = "(?:(?<h>$sign\\d+)\\s*(?:$$dmb{data}{rx}{fields}[5])$sep)";
187 my $mn = "(?:(?<mn>$sign\\d+)\\s*(?:$$dmb{data}{rx}{fields}[6])$sep)";
188 my $s = "(?:(?<s>$sign\\d+)\\s*(?:$$dmb{data}{rx}{fields}[7])?)";
189
190 my $exprx = qr/^\s*$y?$m?$w?$d?$h?$mn?$s?\s*$/i;
191 $$dmb{'data'}{'rx'}{'delta'}{$rx} = $exprx;
192
193 } elsif ($rx eq 'mode') {
194
195 my $mode = qr/\b($$dmb{'data'}{'rx'}{'mode'}[0])\b/;
196 $$dmb{'data'}{'rx'}{'delta'}{$rx} = $mode;
197
198 } elsif ($rx eq 'when') {
199
200 my $when = qr/\b($$dmb{'data'}{'rx'}{'when'}[0])\b/;
201 $$dmb{'data'}{'rx'}{'delta'}{$rx} = $when;
202
203 }
204
205 return $$dmb{'data'}{'rx'}{'delta'}{$rx};
206}
207
208sub parse {
209 my($self,$string,$business) = @_;
210 my $instring = $string;
211 my($dmb) = $$self{'objs'}{'base'};
212 my $gotmode = 0;
213 $self->_init();
214
215 # Get the mode
216
217 $gotmode = 1 if (defined($business));
218 $business = 0 if (! $business);
219 my $mode = $self->_rx('mode');
220 if ($string =~ s/$mode//) {
221 my $m = ($1);
222 if ($$dmb{'data'}{'wordmatch'}{'mode'}{lc($m)} == 1) {
223 $business = 0;
224 } else {
225 $business = 1;
226 }
227 $gotmode = 1;
228 }
229
230 my $type = 'delta';
231 $type = 'business' if ($business);
232
233 # Parse the delta
234
235 my(@delta);
236 PARSE: {
237
238 $string =~ s/^\s*//;
239 $string =~ s/\s*$//;
240
241 # Colon format
242
243 if ($string) {
244 my $tmp = $dmb->split($type,$string);
245 if (defined $tmp) {
246 @delta = @$tmp;
247 last;
248 }
249 }
250
251 # Expanded format
252
253 my $when = $self->_rx('when');
254 my $past = 0;
255 if ($string &&
256 $string =~ s/$when//) {
257 my $when = ($1);
258 if ($$dmb{'data'}{'wordmatch'}{'when'}{lc($when)} == 1) {
259 $past = 1;
260 }
261 }
262
263 my $rx = $self->_rx('expanded');
264 if ($string &&
265 $string =~ $rx) {
266 @delta = @+{qw(y m w d h mn s)};
267 foreach my $f (@delta) {
268 $f = 0 if (! defined $f);
269 $f =~ s/\s//g;
270 }
271 my $err;
272 if ($type eq 'business') {
273 ($err,@delta) = $dmb->_normalize_business('split',@delta);
274 } else {
275 ($err,@delta) = $dmb->_normalize_delta('split',@delta);
276 }
277
278 if ($err) {
279 $$self{'err'} = "[parse] Invalid delta string";
280 return 1;
281 }
282
283 # if $past, reverse the signs
284 if ($past) {
285 foreach my $v (@delta) {
286 if (defined $v) {
287 $v *= -1;
288 }
289 }
290 }
291
292 last;
293 }
294
295 $$self{'err'} = "[parse] Invalid delta string";
296 return 1;
297 }
298
299 $$self{'data'}{'in'} = $string;
300 $$self{'data'}{'delta'} = [@delta];
301 $$self{'data'}{'business'} = $business;
302 $$self{'data'}{'gotmode'} = $gotmode;
303 return 0;
304}
305
306sub printf {
307 my($self,@in) = @_;
308 if ($$self{'err'}) {
309 warn "WARNING: [printf] Object must contain a valid delta\n";
310 return undef;
311 }
312
313 my($y,$M,$w,$d,$h,$m,$s) = @{ $$self{'data'}{'delta'} };
314
315 my @out;
316 foreach my $in (@in) {
317 my $out = '';
318 while ($in) {
319 if ($in =~ s/^([^%]+)//) {
320 $out .= $1;
321
322 } elsif ($in =~ s/^%%//) {
323 $out .= "%";
324
325 } elsif ($in =~ s/^%
326 (\+)? # sign
327 ([<>0])? # pad
328 (\d+)? # width
329 ([yMwdhms]) # field
330 v # type
331 //ox) {
332 my($sign,$pad,$width,$field) = ($1,$2,$3,$4);
333 $out .= $self->_printf_field($sign,$pad,$width,0,$field);
334
335 } elsif ($in =~ s/^(%
336 (\+)? # sign
337 ([<>0])? # pad
338 (\d+)? # width
339 (?:\.(\d+))? # precision
340 ([yMwdhms]) # field
341 ([yMwdhms]) # field0
342 ([yMwdhms]) # field1
343 )//ox) {
344 my($match,$sign,$pad,$width,$precision,$field,$field0,$field1) =
345 ($1,$2,$3,$4,$5,$6,$7,$8);
346
347 # Get the list of fields we're expressing
348
349 my @field = qw(y M w d h m s);
350 while (@field && $field[0] ne $field0) {
351 shift(@field);
352 }
353 while (@field && $field[$#field] ne $field1) {
354 pop(@field);
355 }
356
357 if (! @field) {
358 $out .= $match;
359 } else {
360 $out .=
361 $self->_printf_field($sign,$pad,$width,$precision,$field,@field);
362 }
363
364 } elsif ($in =~ s/^%
365 (\+)? # sign
366 ([<>])? # pad
367 (\d+)? # width
368 Dt
369 //ox) {
370 my($sign,$pad,$width) = ($1,$2,$3);
371 $out .= $self->_printf_delta($sign,$pad,$width,'y','s');
372
373 } elsif ($in =~ s/^(%
374 (\+)? # sign
375 ([<>])? # pad
376 (\d+)? # width
377 D
378 ([yMwdhms]) # field0
379 ([yMwdhms]) # field1
380 )//ox) {
381 my($match,$sign,$pad,$width,$field0,$field1) = ($1,$2,$3,$4,$5,$6);
382
383 # Get the list of fields we're expressing
384
385 my @field = qw(y M w d h m s);
386 while (@field && $field[0] ne $field0) {
387 shift(@field);
388 }
389 while (@field && $field[$#field] ne $field1) {
390 pop(@field);
391 }
392
393 if (! @field) {
394 $out .= $match;
395 } else {
396 $out .= $self->_printf_delta($sign,$pad,$width,$field[0],$field[$#field]);
397 }
398
399 } else {
400 $in =~ s/^(%[^%]*)//;
401 $out .= $1;
402 }
403 }
404 push(@out,$out);
405 }
406
407 if (wantarray) {
408 return @out;
409 } elsif (@out == 1) {
410 return $out[0];
411 }
412
413 return ''
414}
415
416sub _printf_delta {
417 my($self,$sign,$pad,$width,$field0,$field1) = @_;
418 my($dmb) = $$self{'objs'}{'base'};
419 my @delta = @{ $$self{'data'}{'delta'} };
420 my $delta;
421 my %tmp = qw(y 0 M 1 w 2 d 3 h 4 m 5 s 6);
422
423 # Add a sign to each field
424
425 my $s = "+";
426 foreach my $f (@delta) {
427 if ($f < 0) {
428 $s = "-";
429 } elsif ($f > 0) {
430 $s = "+";
431 $f *= 1;
432 $f = "+$f";
433 } else {
434 $f = "$s$f";
435 }
436 }
437
438 # Split the delta into field sets containing only those fields to
439 # print.
440 #
441 # @set = ( [SETa] [SETb] ....)
442 # where [SETx] is a listref of fields from one set of fields
443
444 my @set;
445 my $business = $$self{'data'}{'business'};
446
447 my $f0 = $tmp{$field0};
448 my $f1 = $tmp{$field1};
449
450 if ($field0 eq $field1) {
451 @set = ( [ $delta[$f0] ] );
452
453 } elsif ($business) {
454
455 if ($f0 <= 1) {
456 # if (field0 = y or M)
457 # add [y,M]
458 # field0 = w OR done if field1 = M
459 push(@set, [ @delta[0..1] ]);
460 $f0 = ($f1 == 1 ? 7 : 2);
461 }
462
463 if ($f0 == 2) {
464 # if (field0 = w)
465 # add [w]
466 # field0 = d OR done if field1 = w
467 push(@set, [ $delta[2] ]);
468 $f0 = ($f1 == 2 ? 7 : 3);
469 }
470
471 if ($f0 <= 6) {
472 push(@set, [ @delta[$f0..$f1] ]);
473 }
474
475 } else {
476
477 if ($f0 <= 1) {
478 # if (field0 = y or M)
479 # add [y,M]
480 # field0 = w OR done if field1 = M
481 push(@set, [ @delta[0..1] ]);
482 $f0 = ($f1 == 1 ? 7 : 2);
483 }
484
485 if ($f0 <= 6) {
486 push(@set, [ @delta[$f0..$f1] ]);
487 }
488 }
489
490 # If we're not forcing signs, remove signs from all fields
491 # except the first in each set.
492
493 my @ret;
494
495 foreach my $set (@set) {
496 my @f = @$set;
497
498 if (defined($sign) && $sign eq "+") {
499 push(@ret,@f);
500 } else {
501 push(@ret,shift(@f));
502 foreach my $f (@f) {
503 $f =~ s/[-+]//;
504 push(@ret,$f);
505 }
506 }
507 }
508
509 # Width/pad
510
511 my $ret = join(':',@ret);
512 if ($width && length($ret) < $width) {
513 if (defined $pad && $pad eq ">") {
514 $ret .= ' 'x($width-length($ret));
515 } else {
516 $ret = ' 'x($width-length($ret)) . $ret;
517 }
518 }
519
520 return $ret;
521}
522
523sub _printf_field {
524 my($self,$sign,$pad,$width,$precision,$field,@field) = @_;
525
526 my $val = $self->_printf_field_val($field,@field);
527 $pad = "<" if (! defined($pad));
528
529 # Strip off the sign.
530
531 my $s = '';
532
533 if ($val < 0) {
534 $s = "-";
535 $val *= -1;
536 } elsif ($sign) {
537 $s = "+";
538 }
539
540 # Handle the precision.
541
542 if (defined($precision)) {
543 $val = sprintf("%.${precision}f",$val);
544
545 } elsif (defined($width)) {
546 my $i = $s . int($val) . '.';
547 if (length($i) < $width) {
548 $precision = $width-length($i);
549 $val = sprintf("%.${precision}f",$val);
550 }
551 }
552
553 # Handle padding.
554
555 if ($width) {
556 if ($pad eq ">") {
557 $val = "$s$val";
558 $val .= ' 'x($width-length($val));
559
560 } elsif ($pad eq "<") {
561 $val = "$s$val";
562 $val = ' 'x($width-length($val)) . $val;
563
564 } else {
565 $val = $s . '0'x($width-length($val)-length($s)) . $val;
566 }
567 } else {
568 $val = "$s$val";
569 }
570
571 return $val;
572}
573
574# $$self{'data'}{'f'}{X}{Y} is the value of field X expressed in terms of Y.
575#
576sub _printf_field_val {
577 my($self,$field,@field) = @_;
578
579 if (! exists $$self{'data'}{'f'}{'y'} &&
580 ! exists $$self{'data'}{'f'}{'y'}{'y'}) {
581
582 my($yv,$Mv,$wv,$dv,$hv,$mv,$sv) = map { $_*1 } @{ $$self{'data'}{'delta'} };
583 $$self{'data'}{'f'}{'y'}{'y'} = $yv;
584 $$self{'data'}{'f'}{'M'}{'M'} = $Mv;
585 $$self{'data'}{'f'}{'w'}{'w'} = $wv;
586 $$self{'data'}{'f'}{'d'}{'d'} = $dv;
587 $$self{'data'}{'f'}{'h'}{'h'} = $hv;
588 $$self{'data'}{'f'}{'m'}{'m'} = $mv;
589 $$self{'data'}{'f'}{'s'}{'s'} = $sv;
590 }
591
592 # A single field
593
594 if (! @field) {
595 return $$self{'data'}{'f'}{$field}{$field};
596 }
597
598 # Find the length of 1 unit of each field in terms of seconds.
599
600 if (! exists $$self{'data'}{'flen'}{'s'}) {
601 $$self{'data'}{'flen'}{'s'} = 1;
602 $$self{'data'}{'flen'}{'m'} = 60;
603 $$self{'data'}{'flen'}{'h'} = 3600;
604
605 # Find the length of day/week/year
606 #
607 # $daylen is the number of second in a day
608 # $weeklen is the number of days in a week
609 # $yrlen is the number of days in a year
610
611 my $business = $$self{'data'}{'business'};
612 my ($weeklen,$daylen,$yrlen);
613 if ($business) {
614 my $dmb = $$self{'objs'}{'base'};
615 $daylen = $$dmb{'data'}{'calc'}{'bdlength'};
616 $weeklen = $$dmb{'data'}{'calc'}{'workweek'};
617 # The approximate length of the business year in business days
618 $yrlen = 365.2425*$weeklen/7;
619 } else {
620 $weeklen = 7;
621 $daylen = 86400; # 24*60*60
622 $yrlen = 365.2425;
623 }
624
625 $$self{'data'}{'flen'}{'d'} = $daylen;
626 $$self{'data'}{'flen'}{'w'} = $weeklen*$daylen;
627 $$self{'data'}{'flen'}{'M'} = $yrlen*$daylen/12;
628 $$self{'data'}{'flen'}{'y'} = $yrlen*$daylen;
629 }
630
631 # Calculate the value for each field.
632
633 my $val = 0;
634 foreach my $f (@field) {
635
636 # We want the value of $f expressed in terms of $field
637
638 if (! exists $$self{'data'}{'f'}{$f}{$field}) {
639
640 # Get the value of $f expressed in seconds
641
642 if (! exists $$self{'data'}{'f'}{$f}{'s'}) {
643 $$self{'data'}{'f'}{$f}{'s'} =
644 $$self{'data'}{'f'}{$f}{$f} * $$self{'data'}{'flen'}{$f};
645 }
646
647 # Get the value of $f expressed in terms of $field
648
649 $$self{'data'}{'f'}{$f}{$field} =
650 $$self{'data'}{'f'}{$f}{'s'} / $$self{'data'}{'flen'}{$field};
651 }
652
653 $val += $$self{'data'}{'f'}{$f}{$field};
654 }
655
656 return $val;
657}
658
659sub type {
660 my($self,$op) = @_;
661
662 given ($op) {
663
664 when ('business') {
665 return $$self{'data'}{'business'};
666 }
667
668 when ('exact') {
669 my $exact = 1;
670 $exact = 0 if ($$self{'data'}{'delta'}[0] != 0 ||
671 $$self{'data'}{'delta'}[1] != 0 ||
672 ($$self{'data'}{'delta'}[2] != 0 &&
673 $$self{'data'}{'business'}));
674 return $exact;
675 }
676 }
677
678 return undef;
679}
680
681sub calc {
682 my($self,$obj,$subtract) = @_;
683 if ($$self{'err'}) {
684 $$self{'err'} = "[calc] First object invalid (delta)";
685 return undef;
686 }
687
688 if (ref($obj) eq 'Date::Manip::Date') {
689 if ($$obj{'err'}) {
690 $$self{'err'} = "[calc] Second object invalid (date)";
691 return undef;
692 }
693 return $obj->calc($self,$subtract);
694
695 } elsif (ref($obj) eq 'Date::Manip::Delta') {
696 if ($$obj{'err'}) {
697 $$self{'err'} = "[calc] Second object invalid (delta)";
698 return undef;
699 }
700 return $self->_calc_delta_delta($obj,$subtract);
701
702 } else {
703 $$self{'err'} = "[calc] Second object must be a Date/Delta object";
704 return undef;
705 }
706}
707
708sub _calc_delta_delta {
709 my($self,$delta,$subtract) = @_;
710 my $dmb = $$self{'objs'}{'base'};
711 my $ret = $self->new_delta;
712
713 if ($self->err()) {
714 $$ret{'err'} = "[calc] Invalid delta/delta calculation object: delta1";
715 return $ret;
716 } elsif ($delta->err()) {
717 $$ret{'err'} = "[calc] Invalid delta/delta calculation object: delta2";
718 return $ret;
719 }
720
721 my $business = 0;
722 if ($$self{'data'}{'business'} != $$delta{'data'}{'business'}) {
723 $$ret{'err'} = "[calc] Delta/delta calculation objects must be of " .
724 'the same type';
725 return $ret;
726 } else {
727 $business = $$self{'data'}{'business'};
728 }
729
730 my @delta;
731 for (my $i=0; $i<7; $i++) {
732 if ($subtract) {
733 $delta[$i] = $$self{'data'}{'delta'}[$i] - $$delta{'data'}{'delta'}[$i];
734 } else {
735 $delta[$i] = $$self{'data'}{'delta'}[$i] + $$delta{'data'}{'delta'}[$i];
736 }
737 $delta[$i] = "+" . $delta[$i] if ($delta[$i] > 0);
738 }
739
740 my $type = ($business ? 'business' : 'delta');
741 $ret->set($type,\@delta);
742
743 return $ret;
744}
745
74619µs1;
747# Local Variables:
748# mode: cperl
749# indent-tabs-mode: nil
750# cperl-indent-level: 3
751# cperl-continued-statement-offset: 2
752# cperl-continued-brace-offset: 0
753# cperl-brace-offset: 0
754# cperl-brace-imaginary-offset: 0
755# cperl-label-offset: -2
756# End:
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.