File Coverage

blib/lib/Time/ParseDate.pm
Criterion Covered Total %
statement 413 459 89.9
branch 344 494 69.6
condition 163 238 68.4
subroutine 20 21 95.2
pod 0 13 0.0
total 940 1225 76.7


line stmt bran cond sub pod time code
1             package Time::ParseDate;
2              
3             require 5.000;
4              
5 4     4   43570 use Carp;
  4         7  
  4         295  
6 4     4   1713 use Time::Timezone;
  4         13  
  4         308  
7 4     4   1553 use Time::JulianDay;
  4         9  
  4         445  
8             require Exporter;
9             @ISA = qw(Exporter);
10             @EXPORT = qw(parsedate);
11             @EXPORT_OK = qw(pd_raw %mtable %umult %wdays);
12              
13 4     4   36 use strict;
  4         7  
  4         99  
14             #use diagnostics;
15              
16             # constants
17 4     4   16 use vars qw(%mtable %umult %wdays $VERSION);
  4         6  
  4         257  
18              
19             $VERSION = 2015.1030;
20              
21             # globals
22 4     4   17 use vars qw($debug);
  4         7  
  4         123  
23              
24             # dynamically-scoped
25 4     4   19 use vars qw($parse);
  4         7  
  4         20549  
26              
27             my %mtable;
28             my %umult;
29             my %wdays;
30             my $y2k;
31              
32             CONFIG: {
33              
34             %mtable = qw(
35             Jan 1 Jan. 1 January 1
36             Feb 2 Feb. 2 February 2
37             Mar 3 Mar. 3 March 3
38             Apr 4 Apr. 4 April 4
39             May 5
40             Jun 6 Jun. 6 June 6
41             Jul 7 Jul. 7 July 7
42             Aug 8 Aug. 8 August 8
43             Sep 9 Sep. 9 September 9 Sept 9
44             Oct 10 Oct. 10 October 10
45             Nov 11 Nov. 11 November 11
46             Dec 12 Dec. 12 December 12 );
47             %umult = qw(
48             sec 1 second 1
49             min 60 minute 60
50             hour 3600
51             day 86400
52             week 604800
53             fortnight 1209600);
54             %wdays = qw(
55             sun 0 sunday 0
56             mon 1 monday 1
57             tue 2 tuesday 2
58             wed 3 wednesday 3
59             thu 4 thursday 4
60             fri 5 friday 5
61             sat 6 saturday 6
62             );
63              
64             $y2k = 946684800; # turn of the century
65             }
66              
67             my $break = qr{(?:\s+|\Z|\b(?![-:.,/]\d))};
68              
69             sub parsedate
70             {
71 287     287 0 256969 my ($t, %options) = @_;
72              
73 287         373 my ($y, $m, $d); # year, month - 1..12, day
74 0         0 my ($H, $M, $S); # hour, minute, second
75 0         0 my $tz; # timezone
76 0         0 my $tzo; # timezone offset
77 0         0 my ($rd, $rs); # relative days, relative seconds
78              
79 0         0 my $rel; # time&|date is relative
80              
81 0         0 my $isspec;
82 287 100       710 my $now = defined($options{NOW}) ? $options{NOW} : time;
83 287         371 my $passes = 0;
84 287 100       554 my $uk = defined($options{UK}) ? $options{UK} : 0;
85              
86 287         452 local $parse = ''; # will be dynamically scoped.
87              
88 287 100       3020 if ($t =~ s#^ ([ \d]\d)
    100          
89             / (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)
90             / (\d\d\d\d)
91             : (\d\d)
92             : (\d\d)
93             : (\d\d)
94             (?:
95             [ ]
96             ([-+] \d\d\d\d)
97             (?: \("?(?:(?:[A-Z]{1,4}[TCW56])|IDLE)\))?
98             )?
99             $break
100             ##xi) { #"emacs
101             # [ \d]/Mon/yyyy:hh:mm:ss [-+]\d\d\d\d
102             # This is the format for www server logging.
103              
104 9 100 50     62 ($d, $m, $y, $H, $M, $S, $tzo) = ($1, $mtable{"\u\L$2"}, $3, $4, $5, $6, $7 ? &mkoff($7) : ($tzo || undef));
105 9 50       27 $parse .= " ".__LINE__ if $debug;
106             } elsif ($t =~ s#^(\d\d)/(\d\d)/(\d\d)\.(\d\d)\:(\d\d)($break)##) {
107             # yy/mm/dd.hh:mm
108             # I support this format because it's used by wbak/rbak
109             # on Apollo Domain OS. Silly, but historical.
110              
111 1         4 ($y, $m, $d, $H, $M, $S) = ($1, $2, $3, $4, $5, 0);
112 1 50       20 $parse .= " ".__LINE__ if $debug;
113             } else {
114 277         351 while(1) {
115 818 100 66     3522 if (! defined $m and ! defined $rd and ! defined $y
      66        
      66        
      33        
116             and ! ($passes == 0 and $options{'TIMEFIRST'}))
117             {
118             # no month defined.
119 315 100       864 if (&parse_date_only(\$t, \$y, \$m, \$d, $uk)) {
120 195 50       451 $parse .= " ".__LINE__ if $debug;
121 195         283 next;
122             }
123             }
124 623 100 66     1797 if (! defined $H and ! defined $rs) {
125 322 100       954 if (&parse_time_only(\$t, \$H, \$M, \$S,
126             \$tz, %options))
127             {
128 155 50       301 $parse .= " ".__LINE__ if $debug;
129 155         237 next;
130             }
131             }
132 468 50 66     1211 next if $passes == 0 and $options{'TIMEFIRST'};
133 468 100       996 if (! defined $y) {
134 246 100       685 if (&parse_year_only(\$t, \$y, $now, %options)) {
135 31 50       66 $parse .= " ".__LINE__ if $debug;
136 31         38 next;
137             }
138             }
139 437 100 100     3198 if (! defined $tz and ! defined $tzo and ! defined $rs
      100        
      66        
140             and (defined $m or defined $H))
141             {
142 197 100       424 if (&parse_tz_only(\$t, \$tz, \$tzo)) {
143 63 50       135 $parse .= " ".__LINE__ if $debug;
144 63         96 next;
145             }
146             }
147 374 100 66     1032 if (! defined $H and ! defined $rs) {
148 167 100       487 if (&parse_time_offset(\$t, \$rs, %options)) {
149 38         56 $rel = 1;
150 38 50       90 $parse .= " ".__LINE__ if $debug;
151 38         62 next;
152             }
153             }
154 336 50 66     1018 if (! defined $m and ! defined $rd and ! defined $y) {
      66        
155 82 100       248 if (&parse_date_offset(\$t, $now, \$y,
156             \$m, \$d, \$rd, \$rs, %options))
157             {
158 57         73 $rel = 1;
159 57 50       113 $parse .= " ".__LINE__ if $debug;
160 57         89 next;
161             }
162             }
163 279 100 100     977 if (defined $M or defined $rd) {
164 199 100       988 if ($t =~ s/^\s*(?:at|\@|\+)($break)//x) {
165 2         3 $rel = 1;
166 2 50       6 $parse .= " ".__LINE__ if $debug;
167 2         4 next;
168             }
169             }
170 277         440 last;
171             } continue {
172 541         662 $passes++;
173 541 50       1637 &debug_display($tz, $tzo, $H, $M, $S, $m, $d, $y, $rs, $rd, $rel, $passes, $parse, $t) if $debug;
174              
175             }
176              
177 277 100       620 if ($passes == 0) {
178 3 50       8 print "nothing matched\n" if $debug;
179 3 50       7 return (undef, "no match on time/date")
180             if wantarray();
181 3         11 return undef;
182             }
183             }
184              
185 284 50       636 &debug_display($tz, $tzo, $H, $M, $S, $m, $d, $y, $rs, $rd, $rel, $passes, $parse, $t) if $debug;
186              
187 284         358 $t =~ s/^\s+//;
188              
189 284 100       628 if ($t ne '') {
190             # we didn't manage to eat the string
191 15 50       34 print "NOT WHOLE\n" if $debug;
192 15 100       41 if ($options{WHOLE}) {
193 2 50       5 return (undef, "characters left over after parse")
194             if wantarray();
195             return undef
196 2         8 }
197             }
198              
199             # define a date if there isn't one already
200              
201 282 100 66     826 if (! defined $y and ! defined $m and ! defined $rd) {
      66        
202 22 50       47 print "no date defined, trying to find one." if $debug;
203 22 50 66     81 if (defined $rs or defined $H) {
204             # we do have a time.
205 22 50       61 if ($options{DATE_REQUIRED}) {
206 0 0       0 return (undef, "no date specified")
207             if wantarray();
208 0         0 return undef;
209             }
210 22 100       57 if (defined $rs) {
211 17 50       37 print "simple offset: $rs\n" if $debug;
212 17         35 my $rv = $now + $rs;
213 17 50       45 return ($rv, $t) if wantarray();
214 17         99 return $rv;
215             }
216 5         6 $rd = 0;
217             } else {
218 0 0       0 print "no time either!\n" if $debug;
219 0 0       0 return (undef, "no time specified")
220             if wantarray();
221 0         0 return undef;
222             }
223             }
224              
225 265 50 66     701 if ($options{TIME_REQUIRED} && ! defined($rs)
      66        
      33        
226             && ! defined($H) && ! defined($rd))
227             {
228 0 0       0 return (undef, "no time found")
229             if wantarray();
230 0         0 return undef;
231             }
232              
233 265         335 my $secs;
234             my $jd;
235              
236 265 100       483 if (defined $rd) {
237 49 100 66     315 if (defined $rs || ! (defined($H) || defined($M) || defined($S))) {
      100        
238 42 50       88 print "fully relative\n" if $debug;
239 42         45 my ($j, $in, $it);
240 42 100       81 my $definedrs = defined($rs) ? $rs : 0;
241 42         51 my ($isdst_now, $isdst_then);
242 42         72 my $r = $now + $rd * 86400 + $definedrs;
243             #
244             # It's possible that there was a timezone shift
245             # during the time specified. If so, keep the
246             # hours the "same".
247             #
248 42         160 $isdst_now = (localtime($r))[8];
249 42         131 $isdst_then = (localtime($now))[8];
250 42 100 66     159 if (($isdst_now == $isdst_then) || $options{GMT})
251             {
252 28 50       56 return ($r, $t) if wantarray();
253 28         141 return $r
254             }
255            
256 14 50       38 print "localtime changed DST during time period!\n" if $debug;
257             }
258              
259 21 50       42 print "relative date\n" if $debug;
260             $jd = $options{GMT}
261 21 100       88 ? gm_julian_day($now)
262             : local_julian_day($now);
263 21 50       51 print "jd($now) = $jd\n" if $debug;
264 21         33 $jd += $rd;
265             } else {
266 216 100       441 unless (defined $y) {
267 19 100       57 if ($options{PREFER_PAST}) {
    100          
268 4         7 my ($day, $mon011);
269 4         8 ($day, $mon011, $y) = (&righttime($now))[3,4,5];
270              
271 4 50       30 print "calc year -past $day-$d $mon011-$m $y\n" if $debug;
272 4 100 100     29 $y -= 1 if ($mon011+1 < $m) ||
      66        
273             (($mon011+1 == $m) && ($day < $d));
274             } elsif ($options{PREFER_FUTURE}) {
275 3 50       8 print "calc year -future\n" if $debug;
276 3         4 my ($day, $mon011);
277 3         8 ($day, $mon011, $y) = (&righttime($now))[3,4,5];
278 3 100 33     24 $y += 1 if ($mon011 >= $m) ||
      66        
279             (($mon011+1 == $m) && ($day > $d));
280             } else {
281 12 50       29 print "calc year -this\n" if $debug;
282 12         64 $y = (localtime($now))[5];
283             }
284 19         43 $y += 1900;
285             }
286              
287 216 100       606 $y = expand_two_digit_year($y, $now, %options)
288             if $y < 100;
289              
290 216 100       477 if ($options{VALIDATE}) {
291 6         33 require Time::DaysInMonth;
292 6         16 my $dim = Time::DaysInMonth::days_in($y, $m);
293 6 100 33     88 if ($y < 1000 or $m < 1 or $d < 1
      33        
      33        
      66        
      100        
294             or $y > 9999 or $m > 12 or $d > $dim)
295             {
296 2 50       7 return (undef, "illegal YMD: $y, $m, $d")
297             if wantarray();
298 2         8 return undef;
299             }
300             }
301 214         623 $jd = julian_day($y, $m, $d);
302 214 50       526 print "jd($y, $m, $d) = $jd\n" if $debug;
303             }
304              
305             # put time into HMS
306              
307 235 100       510 if (! defined($H)) {
308 72 100 100     289 if (defined($rd) || defined($rs)) {
309 28         72 ($S, $M, $H) = &righttime($now, %options);
310 28 50       93 print "HMS set to $H $M $S\n" if $debug;
311             }
312             }
313              
314 235         283 my $carry;
315              
316 235 0       463 print "before ", (defined($rs) ? "$rs" : ""),
    50          
317             " $jd $H $M $S\n"
318             if $debug;
319             #
320             # add in relative seconds. Do it this way because we want to
321             # preserve the localtime across DST changes.
322             #
323              
324 235 100       469 $S = 0 unless $S; # -w
325 235 100       495 $M = 0 unless $M; # -w
326 235 100       459 $H = 0 unless $H; # -w
327              
328 235 100 100     541 if ($options{VALIDATE} and
      66        
329             ($S < 0 or $M < 0 or $H < 0 or $S > 59 or $M > 59 or $H > 23))
330             {
331 2 50       6 return (undef, "illegal HMS: $H, $M, $S") if wantarray();
332 2         8 return undef;
333             }
334              
335 233 100       483 $S += $rs if defined $rs;
336 233   100     752 $carry = int($S / 60) - ($S < 0 && $S % 60 && 1);
337 233         317 $S -= $carry * 60;
338 233         340 $M += $carry;
339 233   100     675 $carry = int($M / 60) - ($M < 0 && $M % 60 && 1);
340 233         325 $M %= 60;
341 233         299 $H += $carry;
342 233   50     612 $carry = int($H / 24) - ($H < 0 && $H % 24 && 1);
343 233         310 $H %= 24;
344 233         298 $jd += $carry;
345              
346 233 50       513 print "after rs $jd $H $M $S\n" if $debug;
347              
348 233         694 $secs = jd_secondsgm($jd, $H, $M, $S);
349 233 50       551 print "jd_secondsgm($jd, $H, $M, $S) = $secs\n" if $debug;
350              
351             #
352             # If we see something link 3pm CST then and we want to end
353             # up with a GMT seconds, then we convert the 3pm to GMT and
354             # subtract in the offset for CST. We subtract because we
355             # are converting from CST to GMT.
356             #
357 233         262 my $tzadj;
358 233 100       550 if ($tz) {
    100          
359 43         125 $tzadj = tz_offset($tz, $secs);
360 43 50       105 if (defined $tzadj) {
361 43 50       132 print "adjusting secs for $tz: $tzadj\n" if $debug;
362 43         141 $tzadj = tz_offset($tz, $secs-$tzadj);
363 43         90 $secs -= $tzadj;
364             } else {
365 0 0       0 print "unknown timezone: $tz\n" if $debug;
366 0         0 undef $secs;
367 0         0 undef $t;
368             }
369             } elsif (defined $tzo) {
370 27 50       55 print "adjusting time for offset: $tzo\n" if $debug;
371 27         39 $secs -= $tzo;
372             } else {
373 163 100       390 unless ($options{GMT}) {
374 160 100       319 if ($options{ZONE}) {
375 38   100     125 $tzadj = tz_offset($options{ZONE}, $secs) || 0;
376 38         133 $tzadj = tz_offset($options{ZONE}, $secs-$tzadj);
377 38 50       97 unless (defined($tzadj)) {
378 0 0       0 return (undef, "could not convert '$options{ZONE}' to time offset")
379             if wantarray();
380 0         0 return undef;
381             }
382 38 50       86 print "adjusting secs for $options{ZONE}: $tzadj\n" if $debug;
383 38         61 $secs -= $tzadj;
384             } else {
385 122         308 $tzadj = tz_local_offset($secs);
386 122 50       367 print "adjusting secs for local offset: $tzadj\n" if $debug;
387             #
388             # Just in case we are very close to a time
389             # change...
390             #
391 122         358 $tzadj = tz_local_offset($secs-$tzadj);
392 122         219 $secs -= $tzadj;
393             }
394             }
395             }
396              
397 233 50       465 print "returning $secs.\n" if $debug;
398              
399 233 100       469 return ($secs, $t) if wantarray();
400 232         1060 return $secs;
401             }
402              
403              
404             sub mkoff
405             {
406 28     28 0 49 my($offset) = @_;
407              
408 28 50 33     197 if (defined $offset and $offset =~ s#^([-+])(\d\d):?(\d\d)$##) {
409 28 100       154 return ($1 eq '+' ?
410             3600 * $2 + 60 * $3
411             : -3600 * $2 + -60 * $3 );
412             }
413 0         0 return undef;
414             }
415              
416             sub parse_tz_only
417             {
418 197     197 0 350 my($tr, $tz, $tzo) = @_;
419              
420 197         332 $$tr =~ s#^\s+##;
421 197         232 my $o;
422              
423 197 100       2929 if ($$tr =~ s#^
    100          
    100          
    100          
424             ([-+]\d\d:?\d\d)
425             \s+
426             \(
427             "?
428             (?:
429             (?:
430             [A-Z]{1,4}[TCW56]
431             )
432             |
433             IDLE
434             )
435             \)
436             $break
437             ##x) { #"emacs
438 4         10 $$tzo = &mkoff($1);
439 4 50       13 printf "matched at %d.\n", __LINE__ if $debug;
440 4         15 return 1;
441             } elsif ($$tr =~ s#^GMT\s*([-+]\d{1,2})($break)##x) {
442 6         13 $o = $1;
443 6 50 33     33 if ($o < 24 and $o !~ /^0/) {
444             # probably hours.
445 6 50       10 printf "adjusted at %d. ($o 00)\n", __LINE__ if $debug;
446 6         24 $o = "${o}00";
447             }
448 6         29 $o =~ s/\b(\d\d\d)/0$1/;
449 6         15 $$tzo = &mkoff($o);
450 6 50       29 printf "matched at %d. ($$tzo, $o)\n", __LINE__ if $debug;
451 6         20 return 1;
452             } elsif ($$tr =~ s#^(?:GMT\s*)?([-+]\d\d:?\d\d)($break)##x) {
453 13         28 $o = $1;
454 13         28 $$tzo = &mkoff($o);
455 13 50       34 printf "matched at %d.\n", __LINE__ if $debug;
456 13         48 return 1;
457             } elsif ($$tr =~ s#^"?((?:[A-Z]{1,4}[TCW56])|IDLE)$break##x) { #"
458 40         84 $$tz = $1;
459 40 100 66     157 $$tz .= " DST"
460             if $$tz eq 'MET' && $$tr =~ s#^DST$break##x;
461 40 50       91 printf "matched at %d: '$$tz'.\n", __LINE__ if $debug;
462 40         163 return 1;
463             }
464 134         504 return 0;
465             }
466              
467             sub parse_date_only
468             {
469 315     315 0 555 my ($tr, $yr, $mr, $dr, $uk) = @_;
470              
471 315         699 $$tr =~ s#^\s+##;
472              
473 315 100       10081 if ($$tr =~ s#^(\d\d\d\d)([-./])(\d\d?)\2(\d\d?)(T|$break)##) {
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
474             # yyyy/mm/dd
475              
476 39         192 ($$yr, $$mr, $$dr) = ($1, $3, $4);
477 39 50       113 printf "matched at %d.\n", __LINE__ if $debug;
478 39         144 return 1;
479             } elsif ($$tr =~ s#^(\d\d?)([-./])(\d\d?)\2(\d\d\d\d?)($break)##) {
480             # mm/dd/yyyy - is this safe? No.
481             # -- or dd/mm/yyyy! If $1>12, then it's unambiguous.
482             # Otherwise check option UK for UK style date.
483 15 100 100     84 if ($uk || $1>12) {
484 8         32 ($$yr, $$mr, $$dr) = ($4, $3, $1);
485             } else {
486 7         33 ($$yr, $$mr, $$dr) = ($4, $1, $3);
487             }
488 15 50       39 printf "matched at %d.\n", __LINE__ if $debug;
489 15         57 return 1;
490             } elsif ($$tr =~ s#^(\d\d\d\d)/(\d\d?)$break##x) {
491             # yyyy/mm
492              
493 1         7 ($$yr, $$mr, $$dr) = ($1, $2, 1);
494 1 50       5 printf "matched at %d.\n", __LINE__ if $debug;
495 1         6 return 1;
496             } elsif ($$tr =~ s#^(?xi)
497             (?:
498             (?:Mon|Monday|Tue|Tuesday|Wed|Wednesday|
499             Thu|Thursday|Fri|Friday|
500             Sat|Saturday|Sun|Sunday),?
501             \s+
502             )?
503             (\d\d?)
504             (\s+ | - | \. | /)
505             (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)\.?
506             (?:
507             \2
508             (\d\d (?:\d\d)? )
509             )?
510             $break
511             ##) {
512             # [Dow,] dd Mon [yy[yy]]
513 26         152 ($$yr, $$mr, $$dr) = ($4, $mtable{"\u\L$3"}, $1);
514              
515 26 50       69 printf "%d: %s - %s - %s\n", __LINE__, $1, $2, $3 if $debug;
516 26 50 33     74 print "y undef\n" if ($debug && ! defined($$yr));
517 26         107 return 1;
518             } elsif ($$tr =~ s#^(?xi)
519             (?:
520             (?:Mon|Monday|Tue|Tuesday|Wed|Wednesday|
521             Thu|Thursday|Fri|Friday|
522             Sat|Saturday|Sun|Sunday),?
523             \s+
524             )?
525             (Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec)\.?
526             ((\s)+ | - | \. | /)
527            
528             (\d\d?)
529             ,?
530             (?:
531             (?: \2|\3+)
532             (\d\d (?: \d\d)?)
533             )?
534             $break
535             ##) {
536             # [Dow,] Mon dd [yyyy]
537             # [Dow,] Mon d, [yy]
538 44         232 ($$yr, $$mr, $$dr) = ($5, $mtable{"\u\L$1"}, $4);
539 44 50       111 printf "%d: %s - %s - %s\n", __LINE__, $1, $2, $4 if $debug;
540 44 50 33     114 print "y undef\n" if ($debug && ! defined($$yr));
541 44         172 return 1;
542             } elsif ($$tr =~ s#^(?xi)
543             (January|Jan\.?|February|Feb\.?|March|Mar\.?|April|Apr\.?|May|
544             June|Jun\.?|July|Jul\.?|August|Aug\.?|September|Sep\.?|
545             October|Oct\.?|November|Nov\.?|December|Dec\.?)
546             \s+
547             (\d+)
548             (?:st|nd|rd|th)?
549             \,?
550             (?:
551             \s+
552             (?:
553             (\d\d\d\d)
554             |(?:\' (\d\d))
555             )
556             )?
557             $break
558             ##) {
559             # Month day{st,nd,rd,th}, 'yy
560             # Month day{st,nd,rd,th}, year
561             # Month day, year
562             # Mon. day, year
563 9   66     67 ($$yr, $$mr, $$dr) = ($3 || $4, $mtable{"\u\L$1"}, $2);
564 9 50       26 printf "%d: %s - %s - %s - %s\n", __LINE__, $1, $2, $3, $4 if $debug;
565 9 50 33     26 print "y undef\n" if ($debug && ! defined($$yr));
566 9 50       21 printf "matched at %d.\n", __LINE__ if $debug;
567 9         39 return 1;
568             } elsif ($$tr =~ s#^(\d\d?)([-/.])(\d\d?)\2(\d\d?)($break)##x) {
569 46 100 100     391 if ($1 > 31 || (!$uk && $1 > 12 && $4 < 32)) {
    100 66        
      66        
      100        
570             # yy/mm/dd
571 17         74 ($$yr, $$mr, $$dr) = ($1, $3, $4);
572             } elsif ($1 > 12 || $uk) {
573             # dd/mm/yy
574 4         19 ($$yr, $$mr, $$dr) = ($4, $3, $1);
575             } else {
576             # mm/dd/yy
577 25         104 ($$yr, $$mr, $$dr) = ($4, $1, $3);
578             }
579 46 50       115 printf "matched at %d.\n", __LINE__ if $debug;
580 46         194 return 1;
581             } elsif ($$tr =~ s#^(\d\d?)/(\d\d?)($break)##x) {
582 5 100 33     75 if ($1 > 31 || (!$uk && $1 > 12)) {
    100 66        
    50 33        
      66        
      33        
583             # yy/mm
584 1         6 ($$yr, $$mr, $$dr) = ($1, $2, 1);
585             } elsif ($2 > 31 || ($uk && $2 > 12)) {
586             # mm/yy
587 1         7 ($$yr, $$mr, $$dr) = ($2, $1, 1);
588             } elsif ($1 > 12 || $uk) {
589             # dd/mm
590 0         0 ($$mr, $$dr) = ($2, $1);
591             } else {
592             # mm/dd
593 3         13 ($$mr, $$dr) = ($1, $2);
594             }
595 5 50       16 printf "matched at %d.\n", __LINE__ if $debug;
596 5         25 return 1;
597             } elsif ($$tr =~ s#^(\d\d)(\d\d)(\d\d)($break)##x) {
598 8 100 33     50 if ($1 > 31 || (!$uk && $1 > 12)) {
    50 66        
      33        
599             # YYMMDD
600 7         34 ($$yr, $$mr, $$dr) = ($1, $2, $3);
601             } elsif ($1 > 12 || $uk) {
602             # DDMMYY
603 0         0 ($$yr, $$mr, $$dr) = ($3, $2, $1);
604             } else {
605             # MMDDYY
606 1         5 ($$yr, $$mr, $$dr) = ($3, $1, $2);
607             }
608 8 50       21 printf "matched at %d.\n", __LINE__ if $debug;
609 8         42 return 1;
610             } elsif ($$tr =~ s#^(?xi)
611             (\d{1,2})
612             (\s+ | - | \. | /)
613             (January|Jan\.?|February|Feb\.?|March|Mar\.?|April|Apr\.?|May|
614             June|Jun\.?|July|Jul\.?|August|Aug\.?|September|Sep\.?|
615             October|Oct\.?|November|Nov\.?|December|Dec\.?)
616             (?:
617             \2
618             (
619             \d\d
620             (?:\d\d)?
621             )
622             )
623             $break
624             ##) {
625             # dd Month [yr]
626 1         7 ($$yr, $$mr, $$dr) = ($4, $mtable{"\u\L$3"}, $1);
627 1 50       4 printf "matched at %d.\n", __LINE__ if $debug;
628 1         4 return 1;
629             } elsif ($$tr =~ s#^(?xi)
630             (\d+)
631             (?:st|nd|rd|th)?
632             \s+
633             (January|Jan\.?|February|Feb\.?|March|Mar\.?|April|Apr\.?|May|
634             June|Jun\.?|July|Jul\.?|August|Aug\.?|September|Sep\.?|
635             October|Oct\.?|November|Nov\.?|December|Dec\.?)
636             (?:
637             \,?
638             \s+
639             (\d\d\d\d)
640             )?
641             $break
642             ##) {
643             # day{st,nd,rd,th}, Month year
644 1         7 ($$yr, $$mr, $$dr) = ($3, $mtable{"\u\L$2"}, $1);
645 1 50       11 printf "%d: %s - %s - %s - %s\n", __LINE__, $1, $2, $3, $4 if $debug;
646 1 50 33     5 print "y undef\n" if ($debug && ! defined($$yr));
647 1 50       4 printf "matched at %d.\n", __LINE__ if $debug;
648 1         5 return 1;
649             }
650 120         601 return 0;
651             }
652              
653             sub parse_time_only
654             {
655 322     322 0 870 my ($tr, $hr, $mr, $sr, $tzr, %options) = @_;
656              
657 322         655 $$tr =~ s#^\s+##;
658              
659 322 100       3582 if ($$tr =~ s!^(?x)
    100          
    100          
660             (?:
661             (?:
662             ([012]\d) (?# $1)
663             (?:
664             ([0-5]\d) (?# $2)
665             (?:
666             ([0-5]\d) (?# $3)
667             )?
668             )
669             \s*
670             ([apAP][mM])? (?# $4)
671             ) | (?:
672             (\d{1,2}) (?# $5)
673             (?:
674             \:
675             (\d\d) (?# $6)
676             (?:
677             \:
678             (\d\d) (?# $7)
679             (
680             (?# don't barf on database sub-second timings)
681             [:.,]
682             \d+
683             )? (?# $8)
684             )?
685             )
686             \s*
687             ([apAP][mM])? (?# $9)
688             ) | (?:
689             (\d{1,2}) (?# $10)
690             ([apAP][mM]) (?# ${11})
691             )
692             )
693             (?:
694             \s+
695             "?
696             ( (?# ${12})
697             (?: [A-Z]{1,4}[TCW56] )
698             |
699             IDLE
700             )
701             )?
702             $break
703             !!) { #"emacs
704             # HH[[:]MM[:SS]]meridian [zone]
705 151         182 my $ampm;
706 151   100     796 $$hr = $1 || $5 || $10 || 0; # 10 is undef, but 5 is defined..
707 151   100     677 $$mr = $2 || $6 || 0;
708 151   100     716 $$sr = $3 || $7 || 0;
709 151 50 66     423 if (defined($8) && exists($options{SUBSECOND}) && $options{SUBSECOND}) {
      66        
710 7         13 my($frac) = $8;
711 7         16 substr($frac,0,1) = '.';
712 7         21 $$sr += $frac;
713             }
714 151 50       320 print "S = $$sr\n" if $debug;
715 151   100     1108 $ampm = $4 || $9 || $11 || '';
716 151         264 $$tzr = $12;
717 151 100 100     440 $$hr += 12 if $ampm and "\U$ampm" eq "PM" && $$hr != 12;
      66        
718 151 100 100     480 $$hr = 0 if $$hr == 12 && "\U$ampm" eq "AM";
719 151 50       309 printf "matched at %d, rem = %s.\n", __LINE__, $$tr if $debug;
720 151         664 return 1;
721             } elsif ($$tr =~ s#^noon$break##ix) {
722             # noon
723 2         7 ($$hr, $$mr, $$sr) = (12, 0, 0);
724 2 50       18 printf "matched at %d.\n", __LINE__ if $debug;
725 2         13 return 1;
726             } elsif ($$tr =~ s#^midnight$break##ix) {
727             # midnight
728 2         5 ($$hr, $$mr, $$sr) = (0, 0, 0);
729 2 50       9 printf "matched at %d.\n", __LINE__ if $debug;
730 2         11 return 1;
731             }
732 167         762 return 0;
733             }
734              
735             sub parse_time_offset
736             {
737 167     167 0 397 my ($tr, $rsr, %options) = @_;
738              
739 167         293 $$tr =~ s/^\s+//;
740              
741 167 50       379 return 0 if $options{NO_RELATIVE};
742              
743 167 100       1477 if ($$tr =~ s{^(?xi)
744             (?:
745             (-) (?# 1)
746             |
747             [+]
748             )?
749             \s*
750             (?:
751             (\d+(?:\.\d+)?) (?# 2)
752             |
753             (?:(\d+)\s+(\d+)/(\d+)) (?# 3 4/5)
754             )
755             \s*
756             (sec|second|min|minute|hour)s? (?# 6)
757             (
758             \s+
759             ago (?# 7)
760             )?
761             $break
762             }{}) {
763             # count units
764 38 50       109 $$rsr = 0 unless defined $$rsr;
765 38 50 66     140 return 0 if defined($5) && $5 == 0;
766 38 100       121 my $num = defined($2)
767             ? $2
768             : $3 + $4/$5;
769 38 100       135 $num = -$num if $1;
770 38         221 $$rsr += $umult{"\L$6"} * $num;
771              
772 38 100 100     221 $$rsr = -$$rsr if $7 ||
773             $$tr =~ /\b(day|mon|month|year)s?\s*ago\b/;
774 38 50       91 printf "matched at %d.\n", __LINE__ if $debug;
775 38         177 return 1;
776             }
777 129         463 return 0;
778             }
779              
780             #
781             # What to you do with a date that has a two-digit year?
782             # There's not much that can be done except make a guess.
783             #
784             # Some example situations to handle:
785             #
786             # now year
787             #
788             # 1999 01
789             # 1999 71
790             # 2010 71
791             # 2110 09
792             #
793              
794             sub expand_two_digit_year
795             {
796 65     65 0 177 my ($yr, $now, %options) = @_;
797              
798 65 50       152 return $yr if $yr > 100;
799              
800 65         169 my ($y) = (&righttime($now, %options))[5];
801 65         233 $y += 1900;
802 65         134 my $century = int($y / 100) * 100;
803 65         91 my $within = $y % 100;
804              
805 65         95 my $r = $yr + $century;
806              
807 65 100       206 if ($options{PREFER_PAST}) {
    100          
    50          
808 3 100       9 if ($yr > $within) {
809 2         5 $r = $yr + $century - 100;
810             }
811             } elsif ($options{PREFER_FUTURE}) {
812             # being strict here would be silly
813 3 100       10 if ($yr < $within-20) {
814             # it's 2019 and the date is '08'
815 1         2 $r = $yr + $century + 100;
816             }
817             } elsif ($options{UNAMBIGUOUS}) {
818             # we really shouldn't guess
819 0         0 return undef;
820             } else {
821             # prefer the current century in most cases
822              
823 59 100 100     184 if ($within > 80 && $within - $yr > 60) {
824 1         2 $r = $yr + $century + 100;
825             }
826              
827 59 100 100     260 if ($within < 30 && $yr - $within > 59) {
828 35         58 $r = $yr + $century - 100;
829             }
830             }
831 65 50       143 print "two digit year '$yr' expanded into $r\n" if $debug;
832 65         163 return $r;
833             }
834              
835              
836             sub calc
837             {
838 33     33 0 107 my ($rsr, $yr, $mr, $dr, $rdr, $now, $units, $count, %options) = @_;
839              
840 33 50       74 confess unless $units;
841 33         49 $units = "\L$units";
842 33 50       76 print "calc based on $units\n" if $debug;
843              
844 33 100 66     137 if ($units eq 'day') {
    100          
    50          
    100          
    50          
845 17         29 $$rdr = $count;
846             } elsif ($units eq 'week') {
847 3         6 $$rdr = $count * 7;
848             } elsif ($umult{$units}) {
849 0         0 $$rsr = $count * $umult{$units};
850             } elsif ($units eq 'mon' || $units eq 'month') {
851 7         20 ($$yr, $$mr, $$dr) = &monthoff($now, $count, %options);
852 7 100       22 $$rsr = 0 unless $$rsr;
853             } elsif ($units eq 'year') {
854 6         17 ($$yr, $$mr, $$dr) = &monthoff($now, $count * 12, %options);
855 6 50       18 $$rsr = 0 unless $$rsr;
856             } else {
857 0         0 carp "interal error";
858             }
859 33 50       112 print "calced rsr $$rsr rdr $$rdr, yr $$yr mr $$mr dr $$dr.\n" if $debug;
860             }
861              
862             sub monthoff
863             {
864 13     13 0 34 my ($now, $months, %options) = @_;
865              
866             # months are 0..11
867 13         33 my ($d, $m11, $y) = (&righttime($now, %options)) [ 3,4,5 ] ;
868              
869 13         26 $y += 1900;
870              
871 13 50       29 print "m11 = $m11 + $months, y = $y\n" if $debug;
872              
873 13         14 $m11 += $months;
874              
875 13 50       27 print "m11 = $m11, y = $y\n" if $debug;
876 13 100 100     58 if ($m11 > 11 || $m11 < 0) {
877 6 100 100     28 $y -= 1 if $m11 < 0 && ($m11 % 12 != 0);
878 6         9 $y += int($m11/12);
879              
880             # this is required to work around a bug in perl 5.003
881 4     4   30 no integer;
  4         6  
  4         24  
882 6         10 $m11 %= 12;
883             }
884 13 50       25 print "m11 = $m11, y = $y\n" if $debug;
885              
886             #
887             # What is "1 month from January 31st?"
888             # I think the answer is February 28th most years.
889             #
890             # Similarly, what is one year from February 29th, 1980?
891             # I think it's February 28th, 1981.
892             #
893             # If you disagree, change the following code.
894             #
895 13 100 33     49 if ($d > 30 or ($d > 28 && $m11 == 1)) {
      66        
896 4         859 require Time::DaysInMonth;
897 4         14 my $dim = Time::DaysInMonth::days_in($y, $m11+1);
898 4 50       11 print "dim($y,$m11+1)= $dim\n" if $debug;
899 4 100       11 $d = $dim if $d > $dim;
900             }
901 13         46 return ($y, $m11+1, $d);
902             }
903              
904             sub righttime
905             {
906 195     195 0 427 my ($time, %options) = @_;
907 195 100       424 if ($options{GMT}) {
908 3         14 return gmtime($time);
909             } else {
910 192         950 return localtime($time);
911             }
912             }
913              
914             sub parse_year_only
915             {
916 246     246 0 603 my ($tr, $yr, $now, %options) = @_;
917              
918 246         436 $$tr =~ s#^\s+##;
919              
920 246 100       1705 if ($$tr =~ s#^(\d\d\d\d)$break##) {
    50          
921 31         61 $$yr = $1;
922 31 50       64 printf "matched at %d.\n", __LINE__ if $debug;
923 31         108 return 1;
924             } elsif ($$tr =~ s#\'(\d\d)$break##) {
925 0         0 $$yr = expand_two_digit_year($1, $now, %options);
926 0 0       0 printf "matched at %d.\n", __LINE__ if $debug;
927 0         0 return 1;
928             }
929 215         842 return 0;
930             }
931              
932             sub parse_date_offset
933             {
934 82     82 0 227 my ($tr, $now, $yr, $mr, $dr, $rdr, $rsr, %options) = @_;
935              
936 82 50       191 return 0 if $options{NO_RELATIVE};
937              
938             # now - current seconds_since_epoch
939             # yr - year return
940             # mr - month return
941             # dr - day return
942             # rdr - relative day return
943             # rsr - relative second return
944              
945 82         88 my $j;
946 82         213 my $wday = (&righttime($now, %options))[6];
947              
948 82         205 $$tr =~ s#^\s+##;
949              
950 82 100 66     3599 if ($$tr =~ s#^(?xi)
    100 66        
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
    100          
951             \s*
952             (\d+)
953             \s*
954             (day|week|month|year)s?
955             (
956             \s+
957             ago
958             )?
959             $break
960             ##) {
961 10         28 my $amt = $1 + 0;
962 10         19 my $units = $2;
963 10 100 100     59 $amt = -$amt if $3 ||
964             $$tr =~ m#\b(sec|second|min|minute|hour)s?\s*ago\b#;
965 10         32 &calc($rsr, $yr, $mr, $dr, $rdr, $now, $units,
966             $amt, %options);
967 10 50       27 printf "matched at %d.\n", __LINE__ if $debug;
968 10         38 return 1;
969             } elsif ($$tr =~ s#^(?xi)
970             (?:
971             (?:
972             now
973             \s+
974             )?
975             (\+ | \-)
976             \s*
977             )?
978             (\d+)
979             \s*
980             (day|week|month|year)s?
981             $break
982             ##) {
983 16   50     60 my $one = $1 || '';
984 16   50     42 my $two = $2 || '';
985 16         43 my $amt = "$one$two"+0;
986 16         49 &calc($rsr, $yr, $mr, $dr, $rdr, $now, $3,
987             $amt, %options);
988 16 50       42 printf "matched at %d.\n", __LINE__ if $debug;
989 16         73 return 1;
990             } elsif ($$tr =~ s#^(?xi)
991             (Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
992             |Wednesday|Thursday|Friday|Saturday|Sunday)
993             \s+
994             after
995             \s+
996             next
997             $break
998             ##) {
999             # Dow "after next"
1000 1 50       7 $$rdr = $wdays{"\L$1"} - $wday + ( $wdays{"\L$1"} > $wday ? 7 : 14);
1001 1 50       4 printf "matched at %d.\n", __LINE__ if $debug;
1002 1         5 return 1;
1003             } elsif ($$tr =~ s#^(?xi)
1004             (Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
1005             |Wednesday|Thursday|Friday|Saturday|Sunday)
1006             \s+
1007             before
1008             \s+
1009             last
1010             $break
1011             ##) {
1012             # Dow "before last"
1013 2 100       17 $$rdr = $wdays{"\L$1"} - $wday - ( $wdays{"\L$1"} < $wday ? 7 : 14);
1014 2 50       8 printf "matched at %d.\n", __LINE__ if $debug;
1015 2         12 return 1;
1016             } elsif ($$tr =~ s#^(?xi)
1017             next\s+
1018             (Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
1019             |Wednesday|Thursday|Friday|Saturday|Sunday)
1020             $break
1021             ##) {
1022             # "next" Dow
1023             $$rdr = $wdays{"\L$1"} - $wday
1024 4 100       21 + ( $wdays{"\L$1"} > $wday ? 0 : 7);
1025 4 50       8 printf "matched at %d.\n", __LINE__ if $debug;
1026 4         19 return 1;
1027             } elsif ($$tr =~ s#^(?xi)
1028             last\s+
1029             (Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
1030             |Wednesday|Thursday|Friday|Saturday|Sunday)
1031             $break##) {
1032             # "last" Dow
1033 3 50       9 printf "c %d - %d + ( %d < %d ? 0 : -7 \n", $wdays{"\L$1"}, $wday, $wdays{"\L$1"}, $wday if $debug;
1034 3 100       14 $$rdr = $wdays{"\L$1"} - $wday + ( $wdays{"\L$1"} < $wday ? 0 : -7);
1035 3 50       7 printf "matched at %d.\n", __LINE__ if $debug;
1036 3         14 return 1;
1037             } elsif ($options{PREFER_PAST} and $$tr =~ s#^(?xi)
1038             (Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
1039             |Wednesday|Thursday|Friday|Saturday|Sunday)
1040             $break##) {
1041             # Dow
1042 3 50       7 printf "c %d - %d + ( %d < %d ? 0 : -7 \n", $wdays{"\L$1"}, $wday, $wdays{"\L$1"}, $wday if $debug;
1043 3 100       15 $$rdr = $wdays{"\L$1"} - $wday + ( $wdays{"\L$1"} < $wday ? 0 : -7);
1044 3 50       7 printf "matched at %d.\n", __LINE__ if $debug;
1045 3         15 return 1;
1046             } elsif ($options{PREFER_FUTURE} and $$tr =~ s#^(?xi)
1047             (Mon|Tue|Wed|Thu|Fri|Sat|Sun|Monday|Tuesday
1048             |Wednesday|Thursday|Friday|Saturday|Sunday)
1049             $break
1050             ##) {
1051             # Dow
1052             $$rdr = $wdays{"\L$1"} - $wday
1053 3 100       12 + ( $wdays{"\L$1"} > $wday ? 0 : 7);
1054 3 50       9 printf "matched at %d.\n", __LINE__ if $debug;
1055 3         15 return 1;
1056             } elsif ($$tr =~ s#^today$break##xi) {
1057             # today
1058 1         2 $$rdr = 0;
1059 1 50       4 printf "matched at %d.\n", __LINE__ if $debug;
1060 1         5 return 1;
1061             } elsif ($$tr =~ s#^tomorrow$break##xi) {
1062 1         2 $$rdr = 1;
1063 1 50       4 printf "matched at %d.\n", __LINE__ if $debug;
1064 1         4 return 1;
1065             } elsif ($$tr =~ s#^yesterday$break##xi) {
1066 1         3 $$rdr = -1;
1067 1 50       3 printf "matched at %d.\n", __LINE__ if $debug;
1068 1         5 return 1;
1069             } elsif ($$tr =~ s#^last\s+(week|month|year)$break##xi) {
1070 4         13 &calc($rsr, $yr, $mr, $dr, $rdr, $now, $1, -1, %options);
1071 4 50       11 printf "matched at %d.\n", __LINE__ if $debug;
1072 4         17 return 1;
1073             } elsif ($$tr =~ s#^next\s+(week|month|year)$break##xi) {
1074 3         11 &calc($rsr, $yr, $mr, $dr, $rdr, $now, $1, 1, %options);
1075 3 50       8 printf "matched at %d.\n", __LINE__ if $debug;
1076 3         15 return 1;
1077             } elsif ($$tr =~ s#^now $break##x) {
1078 5         9 $$rdr = 0;
1079 5         39 return 1;
1080             }
1081 25         161 return 0;
1082             }
1083              
1084             sub debug_display
1085             {
1086 0     0 0   my ($tz, $tzo, $H, $M, $S, $m, $d, $y, $rs, $rd, $rel, $passes, $parse, $t) = @_;
1087 0           print "---------<<\n";
1088 0 0         print defined($tz) ? "tz: $tz.\n" : "no tz\n";
1089 0 0         print defined($tzo) ? "tzo: $tzo.\n" : "no tzo\n";
1090 0           print "HMS: ";
1091 0 0         print defined($H) ? "$H, " : "no H, ";
1092 0 0         print defined($M) ? "$M, " : "no M, ";
1093 0 0         print defined($S) ? "$S\n" : "no S.\n";
1094 0           print "mdy: ";
1095 0 0         print defined($m) ? "$m, " : "no m, ";
1096 0 0         print defined($d) ? "$d, " : "no d, ";
1097 0 0         print defined($y) ? "$y\n" : "no y.\n";
1098 0 0         print defined($rs) ? "rs: $rs.\n" : "no rs\n";
1099 0 0         print defined($rd) ? "rd: $rd.\n" : "no rd\n";
1100 0 0         print $rel ? "relative\n" : "not relative\n";
1101 0           print "passes: $passes\n";
1102 0           print "parse:$parse\n";
1103 0           print "t: $t.\n";
1104 0           print "--------->>\n";
1105             }
1106             1;
1107              
1108             __END__