← 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:47 2015

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