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 5     5   43501 use Carp;
  5         12  
  5         373  
6 5     5   2203 use Time::Timezone;
  5         16  
  5         339  
7 5     5   2186 use Time::JulianDay;
  5         11  
  5         515  
8             require Exporter;
9             @ISA = qw(Exporter);
10             @EXPORT = qw(parsedate);
11             @EXPORT_OK = qw(pd_raw %mtable %umult %wdays);
12              
13 5     5   39 use strict;
  5         8  
  5         115  
14             #use diagnostics;
15              
16             # constants
17 5     5   20 use vars qw(%mtable %umult %wdays $VERSION);
  5         10  
  5         307  
18              
19             $VERSION = 2015.0925;
20              
21             # globals
22 5     5   23 use vars qw($debug);
  5         8  
  5         146  
23              
24             # dynamically-scoped
25 5     5   21 use vars qw($parse);
  5         8  
  5         23564  
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 293     293 0 713943 my ($t, %options) = @_;
72              
73 293         386 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 293 100       632 my $now = defined($options{NOW}) ? $options{NOW} : time;
83 293         325 my $passes = 0;
84 293 100       530 my $uk = defined($options{UK}) ? $options{UK} : 0;
85              
86 293         414 local $parse = ''; # will be dynamically scoped.
87              
88 293 100       2676 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     58 ($d, $m, $y, $H, $M, $S, $tzo) = ($1, $mtable{"\u\L$2"}, $3, $4, $5, $6, $7 ? &mkoff($7) : ($tzo || undef));
105 9 50       24 $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       14 $parse .= " ".__LINE__ if $debug;
113             } else {
114 283         401 while(1) {
115 842 100 66     3114 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 321 100       683 if (&parse_date_only(\$t, \$y, \$m, \$d, $uk)) {
120 201 50       357 $parse .= " ".__LINE__ if $debug;
121 201         261 next;
122             }
123             }
124 641 100 66     1584 if (! defined $H and ! defined $rs) {
125 328 100       901 if (&parse_time_only(\$t, \$H, \$M, \$S,
126             \$tz, %options))
127             {
128 161 50       270 $parse .= " ".__LINE__ if $debug;
129 161         235 next;
130             }
131             }
132 480 50 66     1120 next if $passes == 0 and $options{'TIMEFIRST'};
133 480 100       869 if (! defined $y) {
134 252 100       586 if (&parse_year_only(\$t, \$y, $now, %options)) {
135 37 50       84 $parse .= " ".__LINE__ if $debug;
136 37         45 next;
137             }
138             }
139 443 100 100     2808 if (! defined $tz and ! defined $tzo and ! defined $rs
      100        
      66        
140             and (defined $m or defined $H))
141             {
142 203 100       381 if (&parse_tz_only(\$t, \$tz, \$tzo)) {
143 63 50       110 $parse .= " ".__LINE__ if $debug;
144 63         76 next;
145             }
146             }
147 380 100 66     1038 if (! defined $H and ! defined $rs) {
148 167 100       387 if (&parse_time_offset(\$t, \$rs, %options)) {
149 38         42 $rel = 1;
150 38 50       67 $parse .= " ".__LINE__ if $debug;
151 38         54 next;
152             }
153             }
154 342 50 66     891 if (! defined $m and ! defined $rd and ! defined $y) {
      66        
155 82 100       220 if (&parse_date_offset(\$t, $now, \$y,
156             \$m, \$d, \$rd, \$rs, %options))
157             {
158 57         60 $rel = 1;
159 57 50       95 $parse .= " ".__LINE__ if $debug;
160 57         78 next;
161             }
162             }
163 285 100 100     824 if (defined $M or defined $rd) {
164 205 100       830 if ($t =~ s/^\s*(?:at|\@|\+)($break)//x) {
165 2         3 $rel = 1;
166 2 50       6 $parse .= " ".__LINE__ if $debug;
167 2         2 next;
168             }
169             }
170 283         329 last;
171             } continue {
172 559         640 $passes++;
173 559 50       1302 &debug_display($tz, $tzo, $H, $M, $S, $m, $d, $y, $rs, $rd, $rel, $passes, $parse, $t) if $debug;
174              
175             }
176              
177 283 100       562 if ($passes == 0) {
178 3 50       8 print "nothing matched\n" if $debug;
179 3 50       6 return (undef, "no match on time/date")
180             if wantarray();
181 3         9 return undef;
182             }
183             }
184              
185 290 50       565 &debug_display($tz, $tzo, $H, $M, $S, $m, $d, $y, $rs, $rd, $rel, $passes, $parse, $t) if $debug;
186              
187 290         330 $t =~ s/^\s+//;
188              
189 290 100       554 if ($t ne '') {
190             # we didn't manage to eat the string
191 15 50       29 print "NOT WHOLE\n" if $debug;
192 15 100       33 if ($options{WHOLE}) {
193 2 50       5 return (undef, "characters left over after parse")
194             if wantarray();
195             return undef
196 2         7 }
197             }
198              
199             # define a date if there isn't one already
200              
201 288 100 66     713 if (! defined $y and ! defined $m and ! defined $rd) {
      66        
202 22 50       40 print "no date defined, trying to find one." if $debug;
203 22 50 66     66 if (defined $rs or defined $H) {
204             # we do have a time.
205 22 50       47 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       45 if (defined $rs) {
211 17 50       38 print "simple offset: $rs\n" if $debug;
212 17         25 my $rv = $now + $rs;
213 17 50       38 return ($rv, $t) if wantarray();
214 17         69 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 271 50 66     623 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 271         293 my $secs;
234             my $jd;
235              
236 271 100       439 if (defined $rd) {
237 49 100 66     276 if (defined $rs || ! (defined($H) || defined($M) || defined($S))) {
      100        
238 42 50       77 print "fully relative\n" if $debug;
239 42         40 my ($j, $in, $it);
240 42 100       65 my $definedrs = defined($rs) ? $rs : 0;
241 42         40 my ($isdst_now, $isdst_then);
242 42         113 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         120 $isdst_now = (localtime($r))[8];
249 42         108 $isdst_then = (localtime($now))[8];
250 42 100 66     126 if (($isdst_now == $isdst_then) || $options{GMT})
251             {
252 28 50       54 return ($r, $t) if wantarray();
253 28         110 return $r
254             }
255            
256 14 50       31 print "localtime changed DST during time period!\n" if $debug;
257             }
258              
259 21 50       40 print "relative date\n" if $debug;
260             $jd = $options{GMT}
261 21 100       71 ? gm_julian_day($now)
262             : local_julian_day($now);
263 21 50       39 print "jd($now) = $jd\n" if $debug;
264 21         25 $jd += $rd;
265             } else {
266 222 100       414 unless (defined $y) {
267 19 100       49 if ($options{PREFER_PAST}) {
    100          
268 4         5 my ($day, $mon011);
269 4         9 ($day, $mon011, $y) = (&righttime($now))[3,4,5];
270              
271 4 50       44 print "calc year -past $day-$d $mon011-$m $y\n" if $debug;
272 4 100 100     25 $y -= 1 if ($mon011+1 < $m) ||
      66        
273             (($mon011+1 == $m) && ($day < $d));
274             } elsif ($options{PREFER_FUTURE}) {
275 3 50       9 print "calc year -future\n" if $debug;
276 3         6 my ($day, $mon011);
277 3         7 ($day, $mon011, $y) = (&righttime($now))[3,4,5];
278 3 100 33     25 $y += 1 if ($mon011 >= $m) ||
      66        
279             (($mon011+1 == $m) && ($day > $d));
280             } else {
281 12 50       25 print "calc year -this\n" if $debug;
282 12         39 $y = (localtime($now))[5];
283             }
284 19         30 $y += 1900;
285             }
286              
287 222 100       522 $y = expand_two_digit_year($y, $now, %options)
288             if $y < 100;
289              
290 222 100       446 if ($options{VALIDATE}) {
291 6         29 require Time::DaysInMonth;
292 6         15 my $dim = Time::DaysInMonth::days_in($y, $m);
293 6 100 33     87 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       6 return (undef, "illegal YMD: $y, $m, $d")
297             if wantarray();
298 2         7 return undef;
299             }
300             }
301 220         563 $jd = julian_day($y, $m, $d);
302 220 50       455 print "jd($y, $m, $d) = $jd\n" if $debug;
303             }
304              
305             # put time into HMS
306              
307 241 100       466 if (! defined($H)) {
308 72 100 100     270 if (defined($rd) || defined($rs)) {
309 28         61 ($S, $M, $H) = &righttime($now, %options);
310 28 50       76 print "HMS set to $H $M $S\n" if $debug;
311             }
312             }
313              
314 241         259 my $carry;
315              
316 241 0       502 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 241 100       459 $S = 0 unless $S; # -w
325 241 100       413 $M = 0 unless $M; # -w
326 241 100       434 $H = 0 unless $H; # -w
327              
328 241 100 100     480 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 239 100       421 $S += $rs if defined $rs;
336 239   100     700 $carry = int($S / 60) - ($S < 0 && $S % 60 && 1);
337 239         346 $S -= $carry * 60;
338 239         267 $M += $carry;
339 239   100     634 $carry = int($M / 60) - ($M < 0 && $M % 60 && 1);
340 239         266 $M %= 60;
341 239         249 $H += $carry;
342 239   50     529 $carry = int($H / 24) - ($H < 0 && $H % 24 && 1);
343 239         234 $H %= 24;
344 239         278 $jd += $carry;
345              
346 239 50       428 print "after rs $jd $H $M $S\n" if $debug;
347              
348 239         567 $secs = jd_secondsgm($jd, $H, $M, $S);
349 239 50       492 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 239         262 my $tzadj;
358 239 100       506 if ($tz) {
    100          
359 43         94 $tzadj = tz_offset($tz, $secs);
360 43 50       95 if (defined $tzadj) {
361 43 50       84 print "adjusting secs for $tz: $tzadj\n" if $debug;
362 43         105 $tzadj = tz_offset($tz, $secs-$tzadj);
363 43         70 $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       46 print "adjusting time for offset: $tzo\n" if $debug;
371 27         33 $secs -= $tzo;
372             } else {
373 169 100       380 unless ($options{GMT}) {
374 166 100       289 if ($options{ZONE}) {
375 38   100     104 $tzadj = tz_offset($options{ZONE}, $secs) || 0;
376 38         106 $tzadj = tz_offset($options{ZONE}, $secs-$tzadj);
377 38 50       79 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       64 print "adjusting secs for $options{ZONE}: $tzadj\n" if $debug;
383 38         56 $secs -= $tzadj;
384             } else {
385 128         332 $tzadj = tz_local_offset($secs);
386 128 50       266 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 128         351 $tzadj = tz_local_offset($secs-$tzadj);
392 128         216 $secs -= $tzadj;
393             }
394             }
395             }
396              
397 239 50       407 print "returning $secs.\n" if $debug;
398              
399 239 100       433 return ($secs, $t) if wantarray();
400 238         872 return $secs;
401             }
402              
403              
404             sub mkoff
405             {
406 28     28 0 35 my($offset) = @_;
407              
408 28 50 33     171 if (defined $offset and $offset =~ s#^([-+])(\d\d):?(\d\d)$##) {
409 28 100       121 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 203     203 0 1823 my($tr, $tz, $tzo) = @_;
419              
420 203         274 $$tr =~ s#^\s+##;
421 203         220 my $o;
422              
423 203 100       2549 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       10 printf "matched at %d.\n", __LINE__ if $debug;
440 4         12 return 1;
441             } elsif ($$tr =~ s#^GMT\s*([-+]\d{1,2})($break)##x) {
442 6         14 $o = $1;
443 6 50 33     30 if ($o < 24 and $o !~ /^0/) {
444             # probably hours.
445 6 50       12 printf "adjusted at %d. ($o 00)\n", __LINE__ if $debug;
446 6         16 $o = "${o}00";
447             }
448 6         27 $o =~ s/\b(\d\d\d)/0$1/;
449 6         13 $$tzo = &mkoff($o);
450 6 50       14 printf "matched at %d. ($$tzo, $o)\n", __LINE__ if $debug;
451 6         19 return 1;
452             } elsif ($$tr =~ s#^(?:GMT\s*)?([-+]\d\d:?\d\d)($break)##x) {
453 13         22 $o = $1;
454 13         23 $$tzo = &mkoff($o);
455 13 50       28 printf "matched at %d.\n", __LINE__ if $debug;
456 13         36 return 1;
457             } elsif ($$tr =~ s#^"?((?:[A-Z]{1,4}[TCW56])|IDLE)$break##x) { #"
458 40         92 $$tz = $1;
459 40 100 66     126 $$tz .= " DST"
460             if $$tz eq 'MET' && $$tr =~ s#^DST$break##x;
461 40 50       75 printf "matched at %d: '$$tz'.\n", __LINE__ if $debug;
462 40         123 return 1;
463             }
464 140         455 return 0;
465             }
466              
467             sub parse_date_only
468             {
469 321     321 0 470 my ($tr, $yr, $mr, $dr, $uk) = @_;
470              
471 321         603 $$tr =~ s#^\s+##;
472              
473 321 100       9058 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         172 ($$yr, $$mr, $$dr) = ($1, $3, $4);
477 39 50       106 printf "matched at %d.\n", __LINE__ if $debug;
478 39         123 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     67 if ($uk || $1>12) {
484 8         28 ($$yr, $$mr, $$dr) = ($4, $3, $1);
485             } else {
486 7         28 ($$yr, $$mr, $$dr) = ($4, $1, $3);
487             }
488 15 50       32 printf "matched at %d.\n", __LINE__ if $debug;
489 15         44 return 1;
490             } elsif ($$tr =~ s#^(\d\d\d\d)/(\d\d?)$break##x) {
491             # yyyy/mm
492              
493 1         5 ($$yr, $$mr, $$dr) = ($1, $2, 1);
494 1 50       4 printf "matched at %d.\n", __LINE__ if $debug;
495 1         4 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         111 ($$yr, $$mr, $$dr) = ($4, $mtable{"\u\L$3"}, $1);
514              
515 26 50       58 printf "%d: %s - %s - %s\n", __LINE__, $1, $2, $3 if $debug;
516 26 50 33     56 print "y undef\n" if ($debug && ! defined($$yr));
517 26         80 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 50         241 ($$yr, $$mr, $$dr) = ($5, $mtable{"\u\L$1"}, $4);
539 50 50       116 printf "%d: %s - %s - %s\n", __LINE__, $1, $2, $4 if $debug;
540 50 50 33     105 print "y undef\n" if ($debug && ! defined($$yr));
541 50         165 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     56 ($$yr, $$mr, $$dr) = ($3 || $4, $mtable{"\u\L$1"}, $2);
564 9 50       23 printf "%d: %s - %s - %s - %s\n", __LINE__, $1, $2, $3, $4 if $debug;
565 9 50 33     22 print "y undef\n" if ($debug && ! defined($$yr));
566 9 50       17 printf "matched at %d.\n", __LINE__ if $debug;
567 9         33 return 1;
568             } elsif ($$tr =~ s#^(\d\d?)([-/.])(\d\d?)\2(\d\d?)($break)##x) {
569 46 100 100     327 if ($1 > 31 || (!$uk && $1 > 12 && $4 < 32)) {
    100 66        
      66        
      100        
570             # yy/mm/dd
571 17         58 ($$yr, $$mr, $$dr) = ($1, $3, $4);
572             } elsif ($1 > 12 || $uk) {
573             # dd/mm/yy
574 4         17 ($$yr, $$mr, $$dr) = ($4, $3, $1);
575             } else {
576             # mm/dd/yy
577 25         92 ($$yr, $$mr, $$dr) = ($4, $1, $3);
578             }
579 46 50       95 printf "matched at %d.\n", __LINE__ if $debug;
580 46         156 return 1;
581             } elsif ($$tr =~ s#^(\d\d?)/(\d\d?)($break)##x) {
582 5 100 33     65 if ($1 > 31 || (!$uk && $1 > 12)) {
    100 66        
    50 33        
      66        
      33        
583             # yy/mm
584 1         4 ($$yr, $$mr, $$dr) = ($1, $2, 1);
585             } elsif ($2 > 31 || ($uk && $2 > 12)) {
586             # mm/yy
587 1         5 ($$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         11 ($$mr, $$dr) = ($1, $2);
594             }
595 5 50       12 printf "matched at %d.\n", __LINE__ if $debug;
596 5         18 return 1;
597             } elsif ($$tr =~ s#^(\d\d)(\d\d)(\d\d)($break)##x) {
598 8 100 33     38 if ($1 > 31 || (!$uk && $1 > 12)) {
    50 66        
      33        
599             # YYMMDD
600 7         25 ($$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       20 printf "matched at %d.\n", __LINE__ if $debug;
609 8         29 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         6 ($$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       10 printf "%d: %s - %s - %s - %s\n", __LINE__, $1, $2, $3, $4 if $debug;
646 1 50 33     6 print "y undef\n" if ($debug && ! defined($$yr));
647 1 50       4 printf "matched at %d.\n", __LINE__ if $debug;
648 1         4 return 1;
649             }
650 120         501 return 0;
651             }
652              
653             sub parse_time_only
654             {
655 328     328 0 702 my ($tr, $hr, $mr, $sr, $tzr, %options) = @_;
656              
657 328         562 $$tr =~ s#^\s+##;
658              
659 328 100       3157 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 157         162 my $ampm;
706 157   100     681 $$hr = $1 || $5 || $10 || 0; # 10 is undef, but 5 is defined..
707 157   100     626 $$mr = $2 || $6 || 0;
708 157   100     585 $$sr = $3 || $7 || 0;
709 157 50 66     365 if (defined($8) && exists($options{SUBSECOND}) && $options{SUBSECOND}) {
      66        
710 7         11 my($frac) = $8;
711 7         15 substr($frac,0,1) = '.';
712 7         18 $$sr += $frac;
713             }
714 157 50       286 print "S = $$sr\n" if $debug;
715 157   100     894 $ampm = $4 || $9 || $11 || '';
716 157         223 $$tzr = $12;
717 157 100 100     369 $$hr += 12 if $ampm and "\U$ampm" eq "PM" && $$hr != 12;
      66        
718 157 100 100     423 $$hr = 0 if $$hr == 12 && "\U$ampm" eq "AM";
719 157 50       274 printf "matched at %d, rem = %s.\n", __LINE__, $$tr if $debug;
720 157         533 return 1;
721             } elsif ($$tr =~ s#^noon$break##ix) {
722             # noon
723 2         5 ($$hr, $$mr, $$sr) = (12, 0, 0);
724 2 50       12 printf "matched at %d.\n", __LINE__ if $debug;
725 2         8 return 1;
726             } elsif ($$tr =~ s#^midnight$break##ix) {
727             # midnight
728 2         5 ($$hr, $$mr, $$sr) = (0, 0, 0);
729 2 50       7 printf "matched at %d.\n", __LINE__ if $debug;
730 2         7 return 1;
731             }
732 167         605 return 0;
733             }
734              
735             sub parse_time_offset
736             {
737 167     167 0 321 my ($tr, $rsr, %options) = @_;
738              
739 167         236 $$tr =~ s/^\s+//;
740              
741 167 50       324 return 0 if $options{NO_RELATIVE};
742              
743 167 100       1189 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       87 $$rsr = 0 unless defined $$rsr;
765 38 50 66     106 return 0 if defined($5) && $5 == 0;
766 38 100       108 my $num = defined($2)
767             ? $2
768             : $3 + $4/$5;
769 38 100       100 $num = -$num if $1;
770 38         112 $$rsr += $umult{"\L$6"} * $num;
771              
772 38 100 100     185 $$rsr = -$$rsr if $7 ||
773             $$tr =~ /\b(day|mon|month|year)s?\s*ago\b/;
774 38 50       74 printf "matched at %d.\n", __LINE__ if $debug;
775 38         140 return 1;
776             }
777 129         379 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 152 my ($yr, $now, %options) = @_;
797              
798 65 50       113 return $yr if $yr > 100;
799              
800 65         138 my ($y) = (&righttime($now, %options))[5];
801 65         116 $y += 1900;
802 65         112 my $century = int($y / 100) * 100;
803 65         72 my $within = $y % 100;
804              
805 65         74 my $r = $yr + $century;
806              
807 65 100       183 if ($options{PREFER_PAST}) {
    100          
    50          
808 3 100       8 if ($yr > $within) {
809 2         3 $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         3 $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     166 if ($within > 80 && $within - $yr > 60) {
824 1         2 $r = $yr + $century + 100;
825             }
826              
827 59 100 100     206 if ($within < 30 && $yr - $within > 59) {
828 35         48 $r = $yr + $century - 100;
829             }
830             }
831 65 50       138 print "two digit year '$yr' expanded into $r\n" if $debug;
832 65         140 return $r;
833             }
834              
835              
836             sub calc
837             {
838 33     33 0 90 my ($rsr, $yr, $mr, $dr, $rdr, $now, $units, $count, %options) = @_;
839              
840 33 50       94 confess unless $units;
841 33         43 $units = "\L$units";
842 33 50       60 print "calc based on $units\n" if $debug;
843              
844 33 100 66     130 if ($units eq 'day') {
    100          
    50          
    100          
    50          
845 17         24 $$rdr = $count;
846             } elsif ($units eq 'week') {
847 3         5 $$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       21 $$rsr = 0 unless $$rsr;
853             } elsif ($units eq 'year') {
854 6         14 ($$yr, $$mr, $$dr) = &monthoff($now, $count * 12, %options);
855 6 50       20 $$rsr = 0 unless $$rsr;
856             } else {
857 0         0 carp "interal error";
858             }
859 33 50       92 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 35 my ($now, $months, %options) = @_;
865              
866             # months are 0..11
867 13         28 my ($d, $m11, $y) = (&righttime($now, %options)) [ 3,4,5 ] ;
868              
869 13         25 $y += 1900;
870              
871 13 50       26 print "m11 = $m11 + $months, y = $y\n" if $debug;
872              
873 13         15 $m11 += $months;
874              
875 13 50       24 print "m11 = $m11, y = $y\n" if $debug;
876 13 100 100     52 if ($m11 > 11 || $m11 < 0) {
877 6 100 100     91 $y -= 1 if $m11 < 0 && ($m11 % 12 != 0);
878 6         10 $y += int($m11/12);
879              
880             # this is required to work around a bug in perl 5.003
881 5     5   38 no integer;
  5         9  
  5         30  
882 6         9 $m11 %= 12;
883             }
884 13 50       20 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     47 if ($d > 30 or ($d > 28 && $m11 == 1)) {
      66        
896 4         1124 require Time::DaysInMonth;
897 4         12 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         41 return ($y, $m11+1, $d);
902             }
903              
904             sub righttime
905             {
906 195     195 0 348 my ($time, %options) = @_;
907 195 100       343 if ($options{GMT}) {
908 3         11 return gmtime($time);
909             } else {
910 192         752 return localtime($time);
911             }
912             }
913              
914             sub parse_year_only
915             {
916 252     252 0 507 my ($tr, $yr, $now, %options) = @_;
917              
918 252         380 $$tr =~ s#^\s+##;
919              
920 252 100       1425 if ($$tr =~ s#^(\d\d\d\d)$break##) {
    50          
921 37         62 $$yr = $1;
922 37 50       72 printf "matched at %d.\n", __LINE__ if $debug;
923 37         106 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         614 return 0;
930             }
931              
932             sub parse_date_offset
933             {
934 82     82 0 194 my ($tr, $now, $yr, $mr, $dr, $rdr, $rsr, %options) = @_;
935              
936 82 50       156 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         195 my $wday = (&righttime($now, %options))[6];
947              
948 82         176 $$tr =~ s#^\s+##;
949              
950 82 100 66     3201 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         20 my $amt = $1 + 0;
962 10         16 my $units = $2;
963 10 100 100     52 $amt = -$amt if $3 ||
964             $$tr =~ m#\b(sec|second|min|minute|hour)s?\s*ago\b#;
965 10         25 &calc($rsr, $yr, $mr, $dr, $rdr, $now, $units,
966             $amt, %options);
967 10 50       21 printf "matched at %d.\n", __LINE__ if $debug;
968 10         32 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     49 my $one = $1 || '';
984 16   50     49 my $two = $2 || '';
985 16         32 my $amt = "$one$two"+0;
986 16         40 &calc($rsr, $yr, $mr, $dr, $rdr, $now, $3,
987             $amt, %options);
988 16 50       32 printf "matched at %d.\n", __LINE__ if $debug;
989 16         54 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       8 $$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       10 $$rdr = $wdays{"\L$1"} - $wday - ( $wdays{"\L$1"} < $wday ? 7 : 14);
1014 2 50       5 printf "matched at %d.\n", __LINE__ if $debug;
1015 2         8 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       18 + ( $wdays{"\L$1"} > $wday ? 0 : 7);
1025 4 50       8 printf "matched at %d.\n", __LINE__ if $debug;
1026 4         15 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         11 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       8 printf "c %d - %d + ( %d < %d ? 0 : -7 \n", $wdays{"\L$1"}, $wday, $wdays{"\L$1"}, $wday if $debug;
1043 3 100       14 $$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         13 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       14 + ( $wdays{"\L$1"} > $wday ? 0 : 7);
1054 3 50       6 printf "matched at %d.\n", __LINE__ if $debug;
1055 3         15 return 1;
1056             } elsif ($$tr =~ s#^today$break##xi) {
1057             # today
1058 1         3 $$rdr = 0;
1059 1 50       3 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       3 printf "matched at %d.\n", __LINE__ if $debug;
1064 1         5 return 1;
1065             } elsif ($$tr =~ s#^yesterday$break##xi) {
1066 1         2 $$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       9 printf "matched at %d.\n", __LINE__ if $debug;
1072 4         16 return 1;
1073             } elsif ($$tr =~ s#^next\s+(week|month|year)$break##xi) {
1074 3         10 &calc($rsr, $yr, $mr, $dr, $rdr, $now, $1, 1, %options);
1075 3 50       7 printf "matched at %d.\n", __LINE__ if $debug;
1076 3         11 return 1;
1077             } elsif ($$tr =~ s#^now $break##x) {
1078 5         9 $$rdr = 0;
1079 5         33 return 1;
1080             }
1081 25         125 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__