← 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 11:58:52 2013
Reported on Tue Oct 15 12:01:04 2013

Filename/usr/share/perl5/Date/Manip.pm
StatementsExecuted 47 statements in 7.72ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
11124.1ms65.7msDate::Manip::::BEGIN@64Date::Manip::BEGIN@64
11121µs333µsDate::Manip::::BEGIN@54Date::Manip::BEGIN@54
11120µs98µsDate::Manip::::BEGIN@11Date::Manip::BEGIN@11
11116µs61µsDate::Manip::::BEGIN@9Date::Manip::BEGIN@9
11116µs74µsDate::Manip::::BEGIN@53Date::Manip::BEGIN@53
11115µs32µsDate::Manip::::BEGIN@55Date::Manip::BEGIN@55
11114µs31µsDate::Manip::::BEGIN@56Date::Manip::BEGIN@56
11114µs101µsDate::Manip::::BEGIN@63Date::Manip::BEGIN@63
11113µs17µsDate::Manip::::BEGIN@52Date::Manip::BEGIN@52
11110µs14µsDate::Manip::::BEGIN@51Date::Manip::BEGIN@51
11110µs35µsDate::Manip::::BEGIN@58Date::Manip::BEGIN@58
0000s0sDate::Manip::::DateCalcDate::Manip::DateCalc
0000s0sDate::Manip::::DateManipVersionDate::Manip::DateManipVersion
0000s0sDate::Manip::::Date_CmpDate::Manip::Date_Cmp
0000s0sDate::Manip::::Date_ConvTZDate::Manip::Date_ConvTZ
0000s0sDate::Manip::::Date_DayOfWeekDate::Manip::Date_DayOfWeek
0000s0sDate::Manip::::Date_DayOfYearDate::Manip::Date_DayOfYear
0000s0sDate::Manip::::Date_DaySuffixDate::Manip::Date_DaySuffix
0000s0sDate::Manip::::Date_DaysInMonthDate::Manip::Date_DaysInMonth
0000s0sDate::Manip::::Date_DaysInYearDate::Manip::Date_DaysInYear
0000s0sDate::Manip::::Date_DaysSince1BCDate::Manip::Date_DaysSince1BC
0000s0sDate::Manip::::Date_GetNextDate::Manip::Date_GetNext
0000s0sDate::Manip::::Date_GetPrevDate::Manip::Date_GetPrev
0000s0sDate::Manip::::Date_InitDate::Manip::Date_Init
0000s0sDate::Manip::::Date_IsHolidayDate::Manip::Date_IsHoliday
0000s0sDate::Manip::::Date_IsWorkDayDate::Manip::Date_IsWorkDay
0000s0sDate::Manip::::Date_LeapYearDate::Manip::Date_LeapYear
0000s0sDate::Manip::::Date_NearestWorkDayDate::Manip::Date_NearestWorkDay
0000s0sDate::Manip::::Date_NextWorkDayDate::Manip::Date_NextWorkDay
0000s0sDate::Manip::::Date_NthDayOfYearDate::Manip::Date_NthDayOfYear
0000s0sDate::Manip::::Date_PrevWorkDayDate::Manip::Date_PrevWorkDay
0000s0sDate::Manip::::Date_SecsSince1970Date::Manip::Date_SecsSince1970
0000s0sDate::Manip::::Date_SecsSince1970GMTDate::Manip::Date_SecsSince1970GMT
0000s0sDate::Manip::::Date_SetDateFieldDate::Manip::Date_SetDateField
0000s0sDate::Manip::::Date_SetTimeDate::Manip::Date_SetTime
0000s0sDate::Manip::::Date_TimeZoneDate::Manip::Date_TimeZone
0000s0sDate::Manip::::Date_WeekOfYearDate::Manip::Date_WeekOfYear
0000s0sDate::Manip::::Delta_FormatDate::Manip::Delta_Format
0000s0sDate::Manip::::Events_ListDate::Manip::Events_List
0000s0sDate::Manip::::ParseDateDate::Manip::ParseDate
0000s0sDate::Manip::::ParseDateDeltaDate::Manip::ParseDateDelta
0000s0sDate::Manip::::ParseDateStringDate::Manip::ParseDateString
0000s0sDate::Manip::::ParseRecurDate::Manip::ParseRecur
0000s0sDate::Manip::::UnixDateDate::Manip::UnixDate
0000s0sDate::Manip::::_Delta_Format_oldDate::Manip::_Delta_Format_old
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
0198µsProfile data that couldn't be associated with a specific line:
# spent 98µs making 1 call to Date::Manip::BEGIN@11
118µspackage Date::Manip;
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###########################################################################
8
9394µs2107µs
# spent 61µs (16+46) within Date::Manip::BEGIN@9 which was called: # once (16µs+46µs) by C4::Overdues::BEGIN@25 at line 9
use vars qw(@ISA @EXPORT);
# spent 61µs making 1 call to Date::Manip::BEGIN@9 # spent 46µs making 1 call to vars::import
10
11492µs178µs
# spent 98µs (20+78) within Date::Manip::BEGIN@11 which was called: # once (20µs+78µs) by C4::Overdues::BEGIN@25 at line 0
require 5.010000;
# spent 78µs making 1 call to feature::import
121800nsrequire Exporter;
13115µs@ISA = qw(Exporter);
1416µs@EXPORT = qw(
15 DateManipVersion
16 Date_Init
17 ParseDate
18 ParseDateString
19 ParseDateDelta
20 ParseRecur
21 Date_IsHoliday
22 Date_IsWorkDay
23 Date_Cmp
24 DateCalc
25 UnixDate
26 Delta_Format
27 Date_GetPrev
28 Date_GetNext
29 Date_SetTime
30 Date_SetDateField
31 Events_List
32 Date_NextWorkDay
33 Date_PrevWorkDay
34 Date_NearestWorkDay
35
36 Date_DayOfWeek
37 Date_SecsSince1970
38 Date_SecsSince1970GMT
39 Date_DaysSince1BC
40 Date_DayOfYear
41 Date_NthDayOfYear
42 Date_DaysInMonth
43 Date_DaysInYear
44 Date_WeekOfYear
45 Date_LeapYear
46 Date_DaySuffix
47 Date_ConvTZ
48 Date_TimeZone
49);
50
51326µs218µs
# spent 14µs (10+4) within Date::Manip::BEGIN@51 which was called: # once (10µs+4µs) by C4::Overdues::BEGIN@25 at line 51
use strict;
# spent 14µs making 1 call to Date::Manip::BEGIN@51 # spent 4µs making 1 call to strict::import
52349µs220µs
# spent 17µs (13+4) within Date::Manip::BEGIN@52 which was called: # once (13µs+4µs) by C4::Overdues::BEGIN@25 at line 52
use integer;
# spent 17µs making 1 call to Date::Manip::BEGIN@52 # spent 4µs making 1 call to integer::import
53335µs2131µs
# spent 74µs (16+58) within Date::Manip::BEGIN@53 which was called: # once (16µs+58µs) by C4::Overdues::BEGIN@25 at line 53
use Carp;
# spent 74µs making 1 call to Date::Manip::BEGIN@53 # spent 58µs making 1 call to Exporter::import
54345µs2645µs
# spent 333µs (21+312) within Date::Manip::BEGIN@54 which was called: # once (21µs+312µs) by C4::Overdues::BEGIN@25 at line 54
use IO::File;
# spent 333µs making 1 call to Date::Manip::BEGIN@54 # spent 312µs making 1 call to Exporter::import
55334µs248µs
# spent 32µs (15+16) within Date::Manip::BEGIN@55 which was called: # once (15µs+16µs) by C4::Overdues::BEGIN@25 at line 55
use feature 'switch';
# spent 32µs making 1 call to Date::Manip::BEGIN@55 # spent 16µs making 1 call to feature::import
56332µs248µs
# spent 31µs (14+17) within Date::Manip::BEGIN@56 which was called: # once (14µs+17µs) by C4::Overdues::BEGIN@25 at line 56
use warnings;
# spent 31µs making 1 call to Date::Manip::BEGIN@56 # spent 17µs making 1 call to warnings::import
57
58354µs259µs
# spent 35µs (10+25) within Date::Manip::BEGIN@58 which was called: # once (10µs+25µs) by C4::Overdues::BEGIN@25 at line 58
use vars qw($VERSION);
# spent 35µs making 1 call to Date::Manip::BEGIN@58 # spent 25µs making 1 call to vars::import
591700ns$VERSION='6.11';
60
61###########################################################################
62
63328µs2187µs
# spent 101µs (14+87) within Date::Manip::BEGIN@63 which was called: # once (14µs+87µs) by C4::Overdues::BEGIN@25 at line 63
use vars qw($dmb $dmt $date $delta $recur $date2 $dateUT);
# spent 101µs making 1 call to Date::Manip::BEGIN@63 # spent 87µs making 1 call to vars::import
6437.07ms165.7ms
# spent 65.7ms (24.1+41.6) within Date::Manip::BEGIN@64 which was called: # once (24.1ms+41.6ms) by C4::Overdues::BEGIN@25 at line 64
use Date::Manip::Date;
# spent 65.7ms making 1 call to Date::Manip::BEGIN@64
65
66112µs112.6ms$dateUT = new Date::Manip::Date;
# spent 12.6ms making 1 call to Date::Manip::Obj::new
67118µs11.62ms$dateUT->config("setdate","now,Etc/GMT");
# spent 1.62ms making 1 call to Date::Manip::Obj::config
68
69114µs16.63ms$date = new Date::Manip::Date;
# spent 6.63ms making 1 call to Date::Manip::Obj::new
70113µs169µs$date2 = $date->new_date();
# spent 69µs making 1 call to Date::Manip::Obj::new_date
71114µs16.07ms$delta = $date->new_delta();
# spent 6.07ms making 1 call to Date::Manip::Obj::new_delta
7219µs111.4ms$recur = $date->new_recur();
# spent 11.4ms making 1 call to Date::Manip::Obj::new_recur
73110µs16µs$dmb = $date->base();
# spent 6µs making 1 call to Date::Manip::Obj::base
7416µs16µs$dmt = $date->tz();
# spent 6µs making 1 call to Date::Manip::Obj::tz
75
76########################################################################
77########################################################################
78# THESE ARE THE MAIN ROUTINES
79########################################################################
80########################################################################
81
82sub DateManipVersion {
83 my($flag) = @_;
84 return $date->version($flag);
85}
86
87sub Date_Init {
88 my(@args) = @_;
89 my(@args2);
90
91 foreach my $arg (@args) {
92 if ($arg =~ /^(\S+)\s*=\s*(.*)$/) {
93 push(@args2,$1,$2);
94 } else {
95 warn "ERROR: invalid Date_Init argument: $arg\n";
96 }
97 }
98 $date->config(@args2);
99}
100
101sub ParseDateString {
102 my($string) = @_;
103 my $err = $date->parse($string);
104 return '' if ($err);
105 my $ret = $date->value('local');
106 return $ret;
107}
108
109sub ParseDate {
110 my(@a) = @_;
111
112 if ($#a!=0) {
113 print "ERROR: Invalid number of arguments to ParseDate.\n";
114 return '';
115 }
116 my @args;
117 my $args = $a[0];
118 my $ref = ref($args);
119 my $list = 0;
120
121 if (! $ref) {
122 @args = ($args);
123 } elsif ($ref eq 'ARRAY') {
124 @args = @$args;
125 $list = 1;
126 } elsif ($ref eq 'SCALAR') {
127 @args = ($$args);
128 } else {
129 print "ERROR: Invalid arguments to ParseDate.\n";
130 return '';
131 }
132
133 while (@args) {
134 my $string = join(' ',@args);
135 my $err = $date->parse($string);
136 if (! $err) {
137 splice(@$args,0,$#args+1) if ($list);
138 my $ret = $date->value('local');
139 return $ret;
140 }
141 pop(@args);
142 }
143
144 return '';
145}
146
147sub ParseDateDelta {
148 my(@a) = @_;
149
150 if ($#a!=0) {
151 print "ERROR: Invalid number of arguments to ParseDateDelta.\n";
152 return '';
153 }
154 my @args;
155 my $args = $a[0];
156 my $ref = ref($args);
157 my $list = 0;
158
159 if (! $ref) {
160 @args = ($args);
161 } elsif ($ref eq 'ARRAY') {
162 @args = @$args;
163 $list = 1;
164 } elsif ($ref eq 'SCALAR') {
165 @args = ($$args);
166 } else {
167 print "ERROR: Invalid arguments to ParseDateDelta.\n";
168 return '';
169 }
170
171 while (@args) {
172 my $string = join(' ',@args);
173 my $err = $delta->parse($string);
174 if (! $err) {
175 splice(@$args,0,$#args+1) if ($list);
176 my $ret = $delta->value('local');
177 return $ret;
178 }
179 pop(@args);
180 }
181
182 return '';
183}
184
185sub UnixDate {
186 my($string,@in) = @_;
187 my(@ret);
188
189 my $err = $date->parse($string);
190 return () if ($err);
191
192 foreach my $in (@in) {
193 push(@ret,$date->printf($in));
194 }
195
196 if (! wantarray) {
197 return join(" ",@ret);
198 }
199 return @ret;
200}
201
202sub Delta_Format {
203 my($string,@args) = @_;
204
205 my $err = $delta->parse($string);
206 return () if ($err);
207
208 my($mode,$dec,@in);
209 if (lc($args[0]) eq 'exact' ||
210 lc($args[0]) eq 'approx') {
211 ($mode,$dec,@in) = (@args);
212 $mode = lc($mode);
213
214 } elsif (! defined($args[0])) {
215 $mode = '';
216 @in = @args;
217 shift(@in);
218
219 } elsif ($args[0] =~ /^\d+$/) {
220 ($mode,$dec,@in) = ('exact',@args);
221
222 } else {
223 $mode = '';
224 @in = @args;
225 }
226
227 if ($mode) {
228 @in = _Delta_Format_old($mode,$dec,@in);
229 }
230
231 my @ret = ();
232 foreach my $in (@in) {
233 push(@ret,$delta->printf($in));
234 }
235
236 if (! wantarray) {
237 return join(" ",@ret);
238 }
239
240 return @ret;
241}
242
243sub _Delta_Format_old {
244 my($mode,$dec,@in) = @_;
245 my(@ret);
246 my $business = $delta->type('business');
247
248 foreach my $in (@in) {
249 my $out = '';
250
251 while ($in) {
252 if ($in =~ s/^([^%]+)//) {
253 $out .= $1;
254
255 } elsif ($in =~ s/^%([yMwdhms])([vdht])//) {
256 my($field,$scope) = ($1,$2);
257 $out .= '%';
258
259 given ($scope) {
260 when ('v') {
261 $out .= "${field}v";
262 }
263
264 when ('d') {
265 if ($mode eq 'approx') {
266 $out .= ".${dec}${field}${field}s";
267 } elsif ($field eq 'y' || $field eq 'M') {
268 $out .= ".${dec}${field}${field}M";
269 } elsif ($field eq 'w' && $business) {
270 $out .= ".${dec}wws";
271 } else {
272 $out .= ".${dec}${field}${field}s";
273 }
274 }
275
276 when ('h') {
277 if ($mode eq 'approx') {
278 $out .= ".${dec}${field}y${field}";
279 } elsif ($field eq 'y' || $field eq 'M') {
280 $out .= ".${dec}${field}y${field}";
281 } elsif ($business) {
282 if ($field eq 'w') {
283 $out .= 'wv';
284 } else {
285 $out .= ".${dec}${field}d${field}";
286 }
287 } else {
288 $out .= ".${dec}${field}w${field}";
289 }
290 }
291
292 when ('t') {
293 if ($mode eq 'approx') {
294 $out .= ".${dec}${field}ys";
295 } elsif ($field eq 'y' || $field eq 'M') {
296 $out .= ".${dec}${field}yM";
297 } elsif ($business) {
298 if ($field eq 'w') {
299 $out .= 'wv';
300 } else {
301 $out .= ".${dec}${field}ds";
302 }
303 } else {
304 $out .= ".${dec}${field}ws";
305 }
306 }
307 }
308
309 } else {
310 $in =~ s/^(%.?)//;
311 $out .= $1;
312 }
313 }
314
315 push(@ret,$out);
316 }
317
318 return @ret;
319}
320
321sub DateCalc {
322 my($d1,$d2,@args) = @_;
323
324 # Handle \$err arg
325
326 my($ref,$errref);
327
328 if (@args && ref($args[0])) {
329 $errref = shift(@args);
330 $ref = 1;
331 } else {
332 $ref = 0;
333 }
334
335 # Parse $d1 and $d2
336
337 my ($obj1,$obj2,$err,$usemode);
338 $usemode = 1;
339
340 $obj1 = $date->new_date();
341 $err = $obj1->parse($d1,'nodelta');
342 if ($err) {
343 $obj1 = $date->new_delta();
344 $err = $obj1->parse($d1);
345 if ($err) {
346 $$errref = 1 if ($ref);
347 return '';
348 }
349 $usemode = 0;
350 }
351
352 $obj2 = $date->new_date();
353 $err = $obj2->parse($d2,'nodelta');
354 if ($err) {
355 $obj2 = $date->new_delta();
356 $err = $obj2->parse($d2);
357 if ($err) {
358 $$errref = 2 if ($ref);
359 return '';
360 }
361 $usemode = 0;
362 }
363
364 # Handle $mode
365
366 my($mode);
367 if (@args) {
368 $mode = shift(@args);
369 }
370 if (@args) {
371 $$errref = 3 if ($ref);
372 return '';
373 }
374
375 # Apply the $mode to any deltas
376
377 if (defined($mode)) {
378 if (ref($obj1) eq 'Date::Manip::Delta') {
379 if ($$obj1{'data'}{'gotmode'}) {
380 if ($mode == 2 || $mode == 3) {
381 if (! $obj1->type('business')) {
382 $$errref = 3 if ($ref);
383 return '';
384 }
385 } else {
386 if ($obj1->type('business')) {
387 $$errref = 3 if ($ref);
388 return '';
389 }
390 }
391 } else {
392 if ($mode == 2 || $mode == 3) {
393 $obj1->set('mode','business');
394 } else {
395 $obj1->set('mode','normal');
396 }
397 }
398 }
399
400 if (ref($obj2) eq 'Date::Manip::Delta') {
401 if ($$obj2{'data'}{'gotmode'}) {
402 if ($mode == 2 || $mode == 3) {
403 if (! $obj2->type('business')) {
404 $$errref = 3 if ($ref);
405 return '';
406 }
407 } else {
408 if ($obj2->type('business')) {
409 $$errref = 3 if ($ref);
410 return '';
411 }
412 }
413 } else {
414 if ($mode ==2 || $mode == 3) {
415 $obj2->set('mode','business');
416 } else {
417 $obj2->set('mode','normal');
418 }
419 }
420 }
421 }
422
423 # Do the calculation
424
425 my $obj3;
426 if ($usemode) {
427 $mode = 0 if (! $mode);
428 if ($mode == 3) {
429 $mode = 'business';
430 } elsif ($mode == 2) {
431 $mode = 'bapprox';
432 } elsif ($mode) {
433 $mode = 'approx';
434 } else {
435 $mode = 'exact';
436 }
437 $obj3 = $obj1->calc($obj2,$mode);
438 } else {
439 $obj3 = $obj1->calc($obj2);
440 }
441
442 my $ret = $obj3->value();
443 return $ret;
444}
445
446sub Date_GetPrev {
447 my($string,$dow,$curr,@time) = @_;
448 my $err = $date->parse($string);
449 return '' if ($err);
450
451 if (defined($dow)) {
452 $dow = lc($dow);
453 if (exists $$dmb{'data'}{'wordmatch'}{'day_char'}{$dow}) {
454 $dow = $$dmb{'data'}{'wordmatch'}{'day_char'}{$dow};
455 } elsif (exists $$dmb{'data'}{'wordmatch'}{'day_abb'}{$dow}) {
456 $dow = $$dmb{'data'}{'wordmatch'}{'day_abb'}{$dow};
457 } elsif (exists $$dmb{'data'}{'wordmatch'}{'day_name'}{$dow}) {
458 $dow = $$dmb{'data'}{'wordmatch'}{'day_name'}{$dow};
459 }
460 }
461
462 if ($#time == 0) {
463 @time = @{ $dmb->split('hms',$time[0]) };
464 }
465
466 if (@time) {
467 while ($#time < 2) {
468 push(@time,0);
469 }
470 $date->prev($dow,$curr,\@time);
471 } else {
472 $date->prev($dow,$curr);
473 }
474 my $ret = $date->value();
475 return $ret;
476}
477
478sub Date_GetNext {
479 my($string,$dow,$curr,@time) = @_;
480 my $err = $date->parse($string);
481 return '' if ($err);
482
483 if (defined($dow)) {
484 $dow = lc($dow);
485 if (exists $$dmb{'data'}{'wordmatch'}{'day_char'}{$dow}) {
486 $dow = $$dmb{'data'}{'wordmatch'}{'day_char'}{$dow};
487 } elsif (exists $$dmb{'data'}{'wordmatch'}{'day_abb'}{$dow}) {
488 $dow = $$dmb{'data'}{'wordmatch'}{'day_abb'}{$dow};
489 } elsif (exists $$dmb{'data'}{'wordmatch'}{'day_name'}{$dow}) {
490 $dow = $$dmb{'data'}{'wordmatch'}{'day_name'}{$dow};
491 }
492 }
493
494 if ($#time == 0) {
495 @time = @{ $dmb->split('hms',$time[0]) };
496 }
497
498 if (@time) {
499 while ($#time < 2) {
500 push(@time,0);
501 }
502 $date->next($dow,$curr,\@time);
503 } else {
504 $date->next($dow,$curr);
505 }
506 my $ret = $date->value();
507 return $ret;
508}
509
510sub Date_SetTime {
511 my($string,@time) = @_;
512
513 my $err = $date->parse($string);
514 return '' if ($err);
515
516 if ($#time == 0) {
517 @time = @{ $dmb->split('hms',$time[0]) };
518 }
519
520 while ($#time < 2) {
521 push(@time,0);
522 }
523
524 $date->set('time',\@time);
525 my $val = $date->value();
526 return $val;
527}
528
529sub Date_SetDateField {
530 my($string,$field,$val) = @_;
531
532 my $err = $date->parse($string);
533 return '' if ($err);
534
535 $date->set($field,$val);
536 my $ret = $date->value();
537 return $ret;
538}
539
540sub Date_NextWorkDay {
541 my($string,$n,$checktime) = @_;
542 my $err = $date->parse($string);
543 return '' if ($err);
544 $date->next_business_day($n,$checktime);
545 my $val = $date->value();
546 return $val;
547}
548
549sub Date_PrevWorkDay {
550 my($string,$n,$checktime) = @_;
551 my $err = $date->parse($string);
552 return '' if ($err);
553 $date->prev_business_day($n,$checktime);
554 my $val = $date->value();
555 return $val;
556}
557
558sub Date_NearestWorkDay {
559 my($string,$tomorrowfirst) = @_;
560 my $err = $date->parse($string);
561 return '' if ($err);
562 $date->nearest_business_day($tomorrowfirst);
563 my $val = $date->value();
564 return $val;
565}
566
567sub ParseRecur {
568 my($string,@args) = @_;
569
570 if ($#args == 3) {
571 my($base,$d0,$d1,$flags) = @args;
572 @args = ();
573 push(@args,$flags) if ($flags);
574 push(@args,$base,$d0,$d1);
575 }
576
577 my $err = $recur->parse($string,@args);
578 return '' if ($err);
579
580 if (wantarray) {
581 my @dates = $recur->dates();
582 my @ret;
583 foreach my $d (@dates) {
584 my $val = $d->value();
585 push(@ret,$val);
586 }
587 return @ret;
588 }
589
590 my @int = @{ $$recur{'data'}{'interval'} };
591 my @rtime = @{ $$recur{'data'}{'rtime'} };
592 my @flags = @{ $$recur{'data'}{'flags'} };
593 my $start = $$recur{'data'}{'start'};
594 my $end = $$recur{'data'}{'end'};
595 my $base = $$recur{'data'}{'base'};
596
597 my $r;
598 if (@int) {
599 $r = join(':',@int);
600 }
601 if (@rtime) {
602 my @rt;
603 foreach my $rt (@rtime) {
604 push(@rt,join(",",@$rt));
605 }
606 $r .= '*' . join(':',@rt);
607 }
608
609 $r .= '*' . join(",",@flags);
610
611 my $val = (defined($base) ? $base->value() : '');
612 $r .= "*$val";
613
614 $val = (defined($start) ? $start->value() : '');
615 $r .= "*$val";
616
617 $val = (defined($end) ? $end->value() : '');
618 $r .= "*$val";
619
620 return $r;
621}
622
623sub Events_List {
624 my($datestr,@args) = @_;
625
626 # First argument is always a date
627
628 my $err = $date->parse($datestr);
629 return [] if ($err);
630
631 # Second argument is absent, a date, or 0.
632
633 my @list;
634 my $flag = 0;
635 my ($date0,$date1);
636
637 if (! @args) {
638 # absent
639 @list = $date->list_events('dates');
640
641 } else {
642 # a date or 0
643 my $arg = shift(@args);
644 $flag = shift(@args) if (@args);
645 if (@args) {
646 warn "ERROR: unknown argument list\n";
647 return [];
648 }
649
650 if (! $arg) {
651 my($y,$m,$d) = $date->value();
652 $date2->set('date',[$y,$m,$d,23,59,59]);
653 @list = $date->list_events(0, 'dates');
654
655 } else {
656 $err = $date2->parse($arg);
657 if ($err) {
658 warn "ERROR: invalid argument: $arg\n";
659 return [];
660 }
661 @list = $date->list_events($date2, 'dates');
662 }
663 }
664
665 # Handle the flag
666
667 if (! $flag) {
668 my @ret = ();
669 foreach my $e (@list) {
670 my($d,@n) = @$e;
671 my $v = $d->value();
672 push(@ret,$v,[@n]);
673 }
674 return \@ret;
675 }
676
677 push(@list,[$date2]);
678 my %ret;
679
680 if ($flag==1) {
681 while ($#list > 0) {
682 my($d0,@n) = @{ shift(@list) };
683 my $d1 = $list[0]->[0];
684 my $delta = $d0->calc($d1);
685
686 foreach $flag (@n) {
687 $flag = '' if (! defined($flag));
688 if (exists $ret{$flag}) {
689 $ret{$flag} = $ret{$flag}->calc($delta);
690 } else {
691 $ret{$flag} = $delta;
692 }
693 }
694 }
695
696 } elsif ($flag==2) {
697 while ($#list > 0) {
698 my($d0,@n) = @{ shift(@list) };
699 my $d1 = $list[0]->[0];
700 my $delta = $d0->calc($d1);
701 $flag = join("+",sort(@n));
702
703 if (exists $ret{$flag}) {
704 $ret{$flag} = $ret{$flag}->calc($delta);
705 } else {
706 $ret{$flag} = $delta;
707 }
708 }
709
710 } else {
711 warn "ERROR: Invalid flag $flag\n";
712 return [];
713 }
714
715 foreach my $flag (keys %ret) {
716 $ret{$flag} = $ret{$flag}->value();
717 }
718
719 return \%ret;
720}
721
722########################################################################
723# ADDITIONAL ROUTINES
724########################################################################
725
726sub Date_DayOfWeek {
727 my($m,$d,$y) = @_;
728 return $dmb->day_of_week([$y,$m,$d]);
729}
730
731sub Date_SecsSince1970 {
732 my($m,$d,$y,$h,$mn,$s) = @_;
733 return $dmb->secs_since_1970([$y,$m,$d,$h,$mn,$s]);
734}
735
736sub Date_SecsSince1970GMT {
737 my($m,$d,$y,$h,$mn,$s) = @_;
738 $date->set('date',[$y,$m,$d,$h,$mn,$s]);
739 return $date->secs_since_1970_GMT();
740}
741
742sub Date_DaysSince1BC {
743 my($m,$d,$y) = @_;
744 return $dmb->days_since_1BC([$y,$m,$d]);
745}
746
747sub Date_DayOfYear {
748 my($m,$d,$y) = @_;
749 return $dmb->day_of_year([$y,$m,$d]);
750}
751
752sub Date_NthDayOfYear {
753 my($y,$n) = @_;
754 my @ret = @{ $dmb->day_of_year($y,$n) };
755 push(@ret,0,0,0) if ($#ret == 2);
756 return @ret;
757}
758
759sub Date_DaysInMonth {
760 my($m,$y) = @_;
761 return $dmb->days_in_month($y,$m);
762}
763
764sub Date_DaysInYear {
765 my($y) = @_;
766 return $dmb->days_in_year($y);
767}
768
769sub Date_WeekOfYear {
770 my($m,$d,$y,$first) = @_;
771 my($yy,$ww) = $dmb->_week_of_year($first,[$y,$m,$d]);
772 return 0 if ($yy<$y);
773 return 53 if ($yy>$y);
774 return $ww;
775}
776
777sub Date_LeapYear {
778 my($y) = @_;
779 return $dmb->leapyear($y);
780}
781
782sub Date_DaySuffix {
783 my($d) = @_;
784 return $$dmb{'data'}{'wordlistL'}{'nth_dom'}[$d-1];
785}
786
787sub Date_TimeZone {
788 my($ret) = $dmb->_now('tz');
789 return $ret;
790}
791
792sub Date_ConvTZ {
793 my($str,$from,$to) = @_;
794 $from = $dmb->_now("tz") if (! $from);
795 $to = $dmb->_now("tz") if (! $to);
796
797 # Parse the date (ignoring timezone information):
798
799 my $err = $dateUT->parse($str);
800 return '' if ($err);
801 my $d = [ $dateUT->value() ];
802 return '' if (! $d);
803
804 # Get the timezone for $from. First, we'll assume that
805 # the date matches exactly (so if the timezone is passed
806 # in as an abbreviation, we'll try to get the timezone
807 # that fits the date/abbrev combination). If we can't,
808 # we'll just assume that the timezone is more generic
809 # and try it without the date.
810
811 my $tmp;
812 $tmp = $dmt->zone($from,$d);
813 if (! $tmp) {
814 $tmp = $dmt->zone($from);
815 return '' if (! $tmp);
816 }
817 $from = $tmp;
818
819 $tmp = $dmt->zone($to,$d);
820 if (! $tmp) {
821 $tmp = $dmt->zone($to);
822 return '' if (! $tmp);
823 }
824 $to = $tmp;
825
826 ($err,$d) = $dmt->convert($d,$from,$to);
827 return '' if ($err);
828 return $dmb->join('date',$d);
829}
830
831sub Date_IsWorkDay {
832 my($str,$checktime) = @_;
833 my $err = $date->parse($str);
834 return '' if ($err);
835 return $date->is_business_day($checktime);
836}
837
838sub Date_IsHoliday {
839 my($str) = @_;
840 my $err = $date->parse($str);
841 return undef if ($err);
842 return $date->holiday();
843}
844
845sub Date_Cmp {
846 my($str1,$str2) = @_;
847 my $err = $date->parse($str1);
848 return undef if ($err);
849 $err = $date2->parse($str2);
850 return undef if ($err);
851 return $date->cmp($date2);
852}
853
854134µs1;
855# Local Variables:
856# mode: cperl
857# indent-tabs-mode: nil
858# cperl-indent-level: 3
859# cperl-continued-statement-offset: 2
860# cperl-continued-brace-offset: 0
861# cperl-brace-offset: 0
862# cperl-brace-imaginary-offset: 0
863# cperl-label-offset: -2
864# End:
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.