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