1package DateTime::Format::Strptime; 2 3use strict; 4use warnings; 5 6our $VERSION = '1.79'; 7 8use Carp qw( carp croak ); 9use DateTime 1.00; 10use DateTime::Locale 1.30; 11use DateTime::Format::Strptime::Types; 12use DateTime::TimeZone 2.09; 13use Exporter (); 14use Params::ValidationCompiler qw( validation_for ); 15use Try::Tiny; 16 17our @EXPORT_OK = qw( strftime strptime ); 18 19## no critic (ValuesAndExpressions::ProhibitConstantPragma) 20use constant PERL_58 => $] < 5.010; 21 22# We previously used Package::DeprecationManager which allowed passing of 23# "-api_version => X" on import. We don't want any such imports to blow up but 24# we no longer have anything to deprecate. 25sub import { 26 my $class = shift; 27 my @args; 28 ## no critic (ControlStructures::ProhibitCStyleForLoops) 29 for ( my $i = 0; $i < @_; $i++ ) { 30 if ( $_[$i] eq '-api_version' ) { 31 $i++; 32 } 33 else { 34 push @args, $_[$i]; 35 } 36 } 37 @_ = ( $class, @args ); 38 goto &Exporter::import; 39} 40 41{ 42 my $en_locale = DateTime::Locale->load('en'); 43 44 my $validator = validation_for( 45 params => { 46 pattern => { type => t('NonEmptyStr') }, 47 time_zone => { 48 type => t('TimeZone'), 49 optional => 1, 50 }, 51 zone_map => { 52 type => t('HashRef'), 53 default => sub { {} }, 54 }, 55 locale => { 56 type => t('Locale'), 57 default => sub {$en_locale}, 58 }, 59 on_error => { 60 type => t('OnError'), 61 default => 'undef', 62 }, 63 strict => { 64 type => t('Bool'), 65 default => 0, 66 }, 67 debug => { 68 type => t('Bool'), 69 default => $ENV{DATETIME_FORMAT_STRPTIME_DEBUG}, 70 }, 71 }, 72 ); 73 74 sub new { 75 my $class = shift; 76 my %args = $validator->(@_); 77 78 my $self = bless { 79 %args, 80 zone_map => $class->_build_zone_map( $args{zone_map} ), 81 }, $class; 82 83 # Forces a check that the pattern is valid 84 $self->_parser; 85 86 if ( $self->{debug} ) { 87 binmode STDERR, ':encoding(UTF-8)' or die $!; 88 } 89 90 return $self; 91 } 92} 93 94{ 95 my %zone_map = ( 96 'A' => '+0100', 'ACDT' => '+1030', 'ACST' => '+0930', 97 'ADT' => undef, 'AEDT' => '+1100', 'AES' => '+1000', 98 'AEST' => '+1000', 'AFT' => '+0430', 'AHDT' => '-0900', 99 'AHST' => '-1000', 'AKDT' => '-0800', 'AKST' => '-0900', 100 'AMST' => '+0400', 'AMT' => '+0400', 'ANAST' => '+1300', 101 'ANAT' => '+1200', 'ART' => '-0300', 'AST' => undef, 102 'AT' => '-0100', 'AWST' => '+0800', 'AZOST' => '+0000', 103 'AZOT' => '-0100', 'AZST' => '+0500', 'AZT' => '+0400', 104 'B' => '+0200', 'BADT' => '+0400', 'BAT' => '+0600', 105 'BDST' => '+0200', 'BDT' => '+0600', 'BET' => '-1100', 106 'BNT' => '+0800', 'BORT' => '+0800', 'BOT' => '-0400', 107 'BRA' => '-0300', 'BST' => undef, 'BT' => undef, 108 'BTT' => '+0600', 'C' => '+0300', 'CAST' => '+0930', 109 'CAT' => undef, 'CCT' => undef, 'CDT' => undef, 110 'CEST' => '+0200', 'CET' => '+0100', 'CETDST' => '+0200', 111 'CHADT' => '+1345', 'CHAST' => '+1245', 'CKT' => '-1000', 112 'CLST' => '-0300', 'CLT' => '-0400', 'COT' => '-0500', 113 'CST' => undef, 'CSuT' => '+1030', 'CUT' => '+0000', 114 'CVT' => '-0100', 'CXT' => '+0700', 'ChST' => '+1000', 115 'D' => '+0400', 'DAVT' => '+0700', 'DDUT' => '+1000', 116 'DNT' => '+0100', 'DST' => '+0200', 'E' => '+0500', 117 'EASST' => '-0500', 'EAST' => undef, 'EAT' => '+0300', 118 'ECT' => undef, 'EDT' => undef, 'EEST' => '+0300', 119 'EET' => '+0200', 'EETDST' => '+0300', 'EGST' => '+0000', 120 'EGT' => '-0100', 'EMT' => '+0100', 'EST' => undef, 121 'ESuT' => '+1100', 'F' => '+0600', 'FDT' => undef, 122 'FJST' => '+1300', 'FJT' => '+1200', 'FKST' => '-0300', 123 'FKT' => '-0400', 'FST' => undef, 'FWT' => '+0100', 124 'G' => '+0700', 'GALT' => '-0600', 'GAMT' => '-0900', 125 'GEST' => '+0500', 'GET' => '+0400', 'GFT' => '-0300', 126 'GILT' => '+1200', 'GMT' => '+0000', 'GST' => undef, 127 'GT' => '+0000', 'GYT' => '-0400', 'GZ' => '+0000', 128 'H' => '+0800', 'HAA' => '-0300', 'HAC' => '-0500', 129 'HAE' => '-0400', 'HAP' => '-0700', 'HAR' => '-0600', 130 'HAT' => '-0230', 'HAY' => '-0800', 'HDT' => '-0930', 131 'HFE' => '+0200', 'HFH' => '+0100', 'HG' => '+0000', 132 'HKT' => '+0800', 'HL' => 'local', 'HNA' => '-0400', 133 'HNC' => '-0600', 'HNE' => '-0500', 'HNP' => '-0800', 134 'HNR' => '-0700', 'HNT' => '-0330', 'HNY' => '-0900', 135 'HOE' => '+0100', 'HST' => '-1000', 'I' => '+0900', 136 'ICT' => '+0700', 'IDLE' => '+1200', 'IDLW' => '-1200', 137 'IDT' => undef, 'IOT' => '+0500', 'IRDT' => '+0430', 138 'IRKST' => '+0900', 'IRKT' => '+0800', 'IRST' => '+0430', 139 'IRT' => '+0330', 'IST' => undef, 'IT' => '+0330', 140 'ITA' => '+0100', 'JAVT' => '+0700', 'JAYT' => '+0900', 141 'JST' => '+0900', 'JT' => '+0700', 'K' => '+1000', 142 'KDT' => '+1000', 'KGST' => '+0600', 'KGT' => '+0500', 143 'KOST' => '+1200', 'KRAST' => '+0800', 'KRAT' => '+0700', 144 'KST' => '+0900', 'L' => '+1100', 'LHDT' => '+1100', 145 'LHST' => '+1030', 'LIGT' => '+1000', 'LINT' => '+1400', 146 'LKT' => '+0600', 'LST' => 'local', 'LT' => 'local', 147 'M' => '+1200', 'MAGST' => '+1200', 'MAGT' => '+1100', 148 'MAL' => '+0800', 'MART' => '-0930', 'MAT' => '+0300', 149 'MAWT' => '+0600', 'MDT' => '-0600', 'MED' => '+0200', 150 'MEDST' => '+0200', 'MEST' => '+0200', 'MESZ' => '+0200', 151 'MET' => undef, 'MEWT' => '+0100', 'MEX' => '-0600', 152 'MEZ' => '+0100', 'MHT' => '+1200', 'MMT' => '+0630', 153 'MPT' => '+1000', 'MSD' => '+0400', 'MSK' => '+0300', 154 'MSKS' => '+0400', 'MST' => '-0700', 'MT' => '+0830', 155 'MUT' => '+0400', 'MVT' => '+0500', 'MYT' => '+0800', 156 'N' => '-0100', 'NCT' => '+1100', 'NDT' => '-0230', 157 'NFT' => undef, 'NOR' => '+0100', 'NOVST' => '+0700', 158 'NOVT' => '+0600', 'NPT' => '+0545', 'NRT' => '+1200', 159 'NST' => undef, 'NSUT' => '+0630', 'NT' => '-1100', 160 'NUT' => '-1100', 'NZDT' => '+1300', 'NZST' => '+1200', 161 'NZT' => '+1200', 'O' => '-0200', 'OESZ' => '+0300', 162 'OEZ' => '+0200', 'OMSST' => '+0700', 'OMST' => '+0600', 163 'OZ' => 'local', 'P' => '-0300', 'PDT' => '-0700', 164 'PET' => '-0500', 'PETST' => '+1300', 'PETT' => '+1200', 165 'PGT' => '+1000', 'PHOT' => '+1300', 'PHT' => '+0800', 166 'PKT' => '+0500', 'PMDT' => '-0200', 'PMT' => '-0300', 167 'PNT' => '-0830', 'PONT' => '+1100', 'PST' => undef, 168 'PWT' => '+0900', 'PYST' => '-0300', 'PYT' => '-0400', 169 'Q' => '-0400', 'R' => '-0500', 'R1T' => '+0200', 170 'R2T' => '+0300', 'RET' => '+0400', 'ROK' => '+0900', 171 'S' => '-0600', 'SADT' => '+1030', 'SAST' => undef, 172 'SBT' => '+1100', 'SCT' => '+0400', 'SET' => '+0100', 173 'SGT' => '+0800', 'SRT' => '-0300', 'SST' => undef, 174 'SWT' => '+0100', 'T' => '-0700', 'TFT' => '+0500', 175 'THA' => '+0700', 'THAT' => '-1000', 'TJT' => '+0500', 176 'TKT' => '-1000', 'TMT' => '+0500', 'TOT' => '+1300', 177 'TRUT' => '+1000', 'TST' => '+0300', 'TUC ' => '+0000', 178 'TVT' => '+1200', 'U' => '-0800', 'ULAST' => '+0900', 179 'ULAT' => '+0800', 'USZ1' => '+0200', 'USZ1S' => '+0300', 180 'USZ3' => '+0400', 'USZ3S' => '+0500', 'USZ4' => '+0500', 181 'USZ4S' => '+0600', 'USZ5' => '+0600', 'USZ5S' => '+0700', 182 'USZ6' => '+0700', 'USZ6S' => '+0800', 'USZ7' => '+0800', 183 'USZ7S' => '+0900', 'USZ8' => '+0900', 'USZ8S' => '+1000', 184 'USZ9' => '+1000', 'USZ9S' => '+1100', 'UTZ' => '-0300', 185 'UYT' => '-0300', 'UZ10' => '+1100', 'UZ10S' => '+1200', 186 'UZ11' => '+1200', 'UZ11S' => '+1300', 'UZ12' => '+1200', 187 'UZ12S' => '+1300', 'UZT' => '+0500', 'V' => '-0900', 188 'VET' => '-0400', 'VLAST' => '+1100', 'VLAT' => '+1000', 189 'VTZ' => '-0200', 'VUT' => '+1100', 'W' => '-1000', 190 'WAKT' => '+1200', 'WAST' => undef, 'WAT' => '+0100', 191 'WEST' => '+0100', 'WESZ' => '+0100', 'WET' => '+0000', 192 'WETDST' => '+0100', 'WEZ' => '+0000', 'WFT' => '+1200', 193 'WGST' => '-0200', 'WGT' => '-0300', 'WIB' => '+0700', 194 'WIT' => '+0900', 'WITA' => '+0800', 'WST' => undef, 195 'WTZ' => '-0100', 'WUT' => '+0100', 'X' => '-1100', 196 'Y' => '-1200', 'YAKST' => '+1000', 'YAKT' => '+0900', 197 'YAPT' => '+1000', 'YDT' => '-0800', 'YEKST' => '+0600', 198 'YEKT' => '+0500', 'YST' => '-0900', 'Z' => '+0000', 199 'UTC' => '+0000', 200 ); 201 202 for my $i ( map { sprintf( '%02d', $_ ) } 1 .. 12 ) { 203 $zone_map{ '-' . $i } = '-' . $i . '00'; 204 $zone_map{ '+' . $i } = '+' . $i . '00'; 205 } 206 207 sub _build_zone_map { 208 return { 209 %zone_map, 210 %{ $_[1] }, 211 }; 212 } 213} 214 215sub parse_datetime { 216 my $self = shift; 217 my $string = shift; 218 219 my $parser = $self->_parser; 220 if ( $self->{debug} ) { 221 warn "Regex for $self->{pattern}: $parser->{regex}\n"; 222 warn "Fields: @{$parser->{fields}}\n"; 223 } 224 225 my @matches = ( $string =~ $parser->{regex} ); 226 unless (@matches) { 227 my $msg = 'Your datetime does not match your pattern'; 228 if ( $self->{debug} ) { 229 $msg .= qq{ - string = "$string" - regex = $parser->{regex}}; 230 } 231 $msg .= q{.}; 232 $self->_our_croak($msg); 233 return; 234 } 235 236 my %args; 237 my $i = 0; 238 for my $f ( @{ $parser->{fields} } ) { 239 unless ( defined $matches[$i] ) { 240 die 241 "Something horrible happened - the string matched $parser->{regex}" 242 . " but did not return the expected fields: [@{$parser->{fields}}]"; 243 } 244 $args{$f} = $matches[ $i++ ]; 245 } 246 247 # We need to copy the %args here because _munge_args will delete keys in 248 # order to turn this into something that can be passed to a DateTime 249 # constructor. 250 my ( $constructor, $args, $post_construct ) 251 = $self->_munge_args( {%args} ); 252 return unless $constructor && $args; 253 254 my $dt = try { DateTime->$constructor($args) }; 255 $self->_our_croak('Parsed values did not produce a valid date') 256 unless $dt; 257 if ($post_construct) { 258 $post_construct->($dt); 259 } 260 return unless $dt && $self->_check_dt( $dt, \%args ); 261 262 $dt->set_time_zone( $self->{time_zone} ) 263 if $self->{time_zone}; 264 265 return $dt; 266} 267 268sub _parser { 269 my $self = shift; 270 271 return $self->{parser} ||= $self->_build_parser; 272} 273 274sub _build_parser { 275 my $self = shift; 276 277 my ( 278 $replacement_tokens_re, 279 $replacements, 280 $pattern_tokens_re, 281 $patterns, 282 ) = $self->_parser_pieces; 283 284 my $pattern = $self->{pattern}; 285 286 # When the first replacement is a glibc pattern, the first round of 287 # replacements may simply replace one replacement token (like %X) with 288 # another replacement token (like %I). 289 $pattern =~ s/%($replacement_tokens_re)/$replacements->{$1}/g for 1 .. 2; 290 291 if ( $self->{debug} && $pattern ne $self->{pattern} ) { 292 warn "Pattern after replacement substitution: $pattern\n"; 293 } 294 295 my $regex = q{}; 296 my @fields; 297 298 while ( 299 $pattern =~ / 300 \G 301 %($pattern_tokens_re) 302 | 303 %([1-9]?)(N) 304 | 305 (%[0-9]*[a-zA-Z]) 306 | 307 ([^%]+) 308 /xg 309 ) { 310 # Using \G in the regex match fails for some reason on Perl 5.8, so we 311 # do this hack instead. 312 substr( $pattern, 0, pos $pattern, q{} ) 313 if PERL_58; 314 if ($1) { 315 my $p = $patterns->{$1} 316 or croak 317 "Unidentified token in pattern: $1 in $self->{pattern}"; 318 if ( $p->{field} ) { 319 $regex .= qr/($p->{regex})/; 320 push @fields, $p->{field}; 321 } 322 else { 323 $regex .= qr/$p->{regex}/; 324 } 325 } 326 elsif ($3) { 327 $regex .= $2 ? qr/([0-9]{$2})/ : qr/([0-9]+)/; 328 push @fields, 'nanosecond'; 329 } 330 elsif ($4) { 331 croak qq{Pattern contained an unrecognized strptime token, "$4"}; 332 } 333 else { 334 $regex .= qr/\Q$5/; 335 } 336 } 337 338 return { 339 regex => 340 ( $self->{strict} ? qr/(?:\A|\b)$regex(?:\b|\Z)/ : qr/$regex/ ), 341 fields => \@fields, 342 }; 343} 344 345{ 346 my $digit = qr/(?:[0-9])/; 347 my $one_or_two_digits = qr/[0-9 ]?$digit/; 348 349 # These patterns are all locale-independent. There are a few that depend 350 # on the locale, and must be re-calculated for each new parser object. 351 my %universal_patterns = ( 352 '%' => { 353 regex => qr/%/, 354 }, 355 C => { 356 regex => $one_or_two_digits, 357 field => 'century', 358 }, 359 d => { 360 regex => $one_or_two_digits, 361 field => 'day', 362 }, 363 g => { 364 regex => $one_or_two_digits, 365 field => 'iso_week_year_100', 366 }, 367 G => { 368 regex => qr/$digit{4}/, 369 field => 'iso_week_year', 370 }, 371 H => { 372 regex => $one_or_two_digits, 373 field => 'hour', 374 }, 375 I => { 376 regex => $one_or_two_digits, 377 field => 'hour_12', 378 }, 379 j => { 380 regex => qr/$digit{1,3}/, 381 field => 'day_of_year', 382 }, 383 m => { 384 regex => $one_or_two_digits, 385 field => 'month', 386 }, 387 M => { 388 regex => $one_or_two_digits, 389 field => 'minute', 390 }, 391 n => { 392 regex => qr/\s+/, 393 }, 394 O => { 395 regex => qr{[a-zA-Z_]+(?:/[a-zA-Z_]+(?:/[a-zA-Z_]+)?)?}, 396 field => 'time_zone_name', 397 }, 398 s => { 399 regex => qr/$digit+/, 400 field => 'epoch', 401 }, 402 S => { 403 regex => $one_or_two_digits, 404 field => 'second', 405 }, 406 U => { 407 regex => $one_or_two_digits, 408 field => 'week_sun_0', 409 }, 410 u => { 411 regex => $one_or_two_digits, 412 field => 'day_of_week', 413 }, 414 w => { 415 regex => $one_or_two_digits, 416 field => 'day_of_week_sun_0', 417 }, 418 W => { 419 regex => $one_or_two_digits, 420 field => 'week_mon_1', 421 }, 422 y => { 423 regex => $one_or_two_digits, 424 field => 'year_100', 425 }, 426 Y => { 427 regex => qr/$digit{4}/, 428 field => 'year', 429 }, 430 z => { 431 regex => qr/(?:Z|[+-]$digit{2}(?:[:]?$digit{2})?)/, 432 field => 'time_zone_offset', 433 }, 434 Z => { 435 regex => qr/[a-zA-Z]{1,6}|[\-\+]$digit{2}/, 436 field => 'time_zone_abbreviation', 437 }, 438 ); 439 440 $universal_patterns{e} = $universal_patterns{d}; 441 $universal_patterns{k} = $universal_patterns{H}; 442 $universal_patterns{l} = $universal_patterns{I}; 443 $universal_patterns{t} = $universal_patterns{n}; 444 445 my %universal_replacements = ( 446 D => '%m/%d/%y', 447 F => '%Y-%m-%d', 448 r => '%I:%M:%S %p', 449 R => '%H:%M', 450 T => '%H:%M:%S', 451 ); 452 453 sub _parser_pieces { 454 my $self = shift; 455 456 my %replacements = %universal_replacements; 457 $replacements{c} = $self->{locale}->glibc_datetime_format; 458 $replacements{x} = $self->{locale}->glibc_date_format; 459 $replacements{X} = $self->{locale}->glibc_time_format; 460 461 my %patterns = %universal_patterns; 462 $patterns{a} = $patterns{A} = { 463 regex => do { 464 my $days = join '|', map {quotemeta} 465 sort { ( length $b <=> length $a ) or ( $a cmp $b ) } 466 keys %{ $self->_locale_days }; 467 qr/$days/i; 468 }, 469 field => 'day_name', 470 }; 471 472 $patterns{b} = $patterns{B} = $patterns{h} = { 473 regex => do { 474 my $months = join '|', map {quotemeta} 475 sort { ( length $b <=> length $a ) or ( $a cmp $b ) } 476 keys %{ $self->_locale_months }; 477 qr/$months/i; 478 }, 479 field => 'month_name', 480 }; 481 482 $patterns{p} = $patterns{P} = { 483 regex => do { 484 my $am_pm = join '|', 485 map {quotemeta} 486 sort { ( length $b <=> length $a ) or ( $a cmp $b ) } 487 @{ $self->{locale}->am_pm_abbreviated }; 488 qr/$am_pm/i; 489 }, 490 field => 'am_pm', 491 }; 492 493 return ( 494 $self->_token_re_for( keys %replacements ), 495 \%replacements, 496 $self->_token_re_for( keys %patterns ), 497 \%patterns, 498 ); 499 } 500} 501 502sub _locale_days { 503 my $self = shift; 504 505 return $self->{locale_days} if $self->{locale_days}; 506 507 my $wide = $self->{locale}->day_format_wide; 508 my $abbr = $self->{locale}->day_format_abbreviated; 509 510 my %locale_days; 511 for my $i ( 0 .. 6 ) { 512 $locale_days{ lc $wide->[$i] } = $i; 513 $locale_days{ lc $abbr->[$i] } = $i; 514 } 515 516 return $self->{locale_days} ||= \%locale_days; 517} 518 519sub _locale_months { 520 my $self = shift; 521 522 return $self->{locale_months} if $self->{locale_months}; 523 524 my $wide = $self->{locale}->month_format_wide; 525 my $abbr = $self->{locale}->month_format_abbreviated; 526 527 my %locale_months; 528 for my $i ( 0 .. 11 ) { 529 $locale_months{ lc $wide->[$i] } = $i + 1; 530 $locale_months{ lc $abbr->[$i] } = $i + 1; 531 } 532 533 return $self->{locale_months} ||= \%locale_months; 534} 535 536sub _token_re_for { 537 shift; 538 my $t = join '|', 539 sort { ( length $b <=> length $a ) or ( $a cmp $b ) } @_; 540 541 return qr/$t/; 542} 543 544{ 545 # These are fields we parse that cannot be passed to a DateTime 546 # constructor 547 my @non_dt_keys = qw( 548 am_pm 549 century 550 day_name 551 day_of_week 552 day_of_week_sun_0 553 hour_12 554 iso_week_year 555 iso_week_year_100 556 month_name 557 time_zone_abbreviation 558 time_zone_name 559 time_zone_offset 560 week_mon_1 561 week_sun_0 562 year_100 563 ); 564 565 ## no critic (Subroutines::ProhibitExcessComplexity) 566 sub _munge_args { 567 my $self = shift; 568 my $args = shift; 569 570 if ( defined $args->{month_name} ) { 571 my $num = $self->_locale_months->{ lc $args->{month_name} } 572 or die "We somehow parsed a month name ($args->{month_name})" 573 . ' that does not correspond to any month in this locale!'; 574 575 $args->{month} = $num; 576 } 577 578 if ( defined $args->{am_pm} && defined $args->{hour_12} ) { 579 my ( $am, $pm ) = @{ $self->{locale}->am_pm_abbreviated }; 580 $args->{hour} = $args->{hour_12}; 581 582 if ( lc $args->{am_pm} eq lc $am ) { 583 $args->{hour} = 0 if $args->{hour} == 12; 584 } 585 else { 586 $args->{hour} += 12 unless $args->{hour} == 12; 587 } 588 } 589 elsif ( defined $args->{hour_12} ) { 590 $self->_our_croak( 591 qq{Parsed a 12-hour based hour, "$args->{hour_12}",} 592 . ' but the pattern does not include an AM/PM specifier' 593 ); 594 return; 595 } 596 597 if ( defined $args->{year_100} ) { 598 if ( defined $args->{century} ) { 599 $args->{year} 600 = $args->{year_100} + ( $args->{century} * 100 ); 601 } 602 else { 603 $args->{year} = $args->{year_100} + ( 604 $args->{year_100} >= 69 605 ? 1900 606 : 2000 607 ); 608 } 609 } 610 611 if ( $args->{time_zone_offset} ) { 612 my $offset = $args->{time_zone_offset}; 613 614 if ( $offset eq 'Z' ) { 615 $offset = '+0000'; 616 } 617 elsif ( $offset =~ /^[+-][0-9]{2}$/ ) { 618 $offset .= '00'; 619 } 620 621 my $tz = try { DateTime::TimeZone->new( name => $offset ) }; 622 unless ($tz) { 623 $self->_our_croak( 624 qq{The time zone name offset that was parsed does not appear to be valid, "$args->{time_zone_offset}"} 625 ); 626 return; 627 } 628 629 $args->{time_zone} = $tz; 630 } 631 632 if ( defined $args->{time_zone_abbreviation} ) { 633 my $abbr = $args->{time_zone_abbreviation}; 634 unless ( exists $self->{zone_map}{$abbr} ) { 635 $self->_our_croak( 636 qq{Parsed an unrecognized time zone abbreviation, "$args->{time_zone_abbreviation}"} 637 ); 638 return; 639 } 640 if ( !defined $self->{zone_map}{$abbr} ) { 641 $self->_our_croak( 642 qq{The time zone abbreviation that was parsed is ambiguous, "$args->{time_zone_abbreviation}"} 643 ); 644 return; 645 } 646 $args->{time_zone} 647 = DateTime::TimeZone->new( name => $self->{zone_map}{$abbr} ); 648 } 649 else { 650 $args->{time_zone} ||= 'floating'; 651 } 652 653 if ( $args->{time_zone_name} ) { 654 my $name = $args->{time_zone_name}; 655 my $tz; 656 unless ( $tz = try { DateTime::TimeZone->new( name => $name ) } ) 657 { 658 $name = lc $name; 659 $name =~ s{(^|[/_])(.)}{$1\U$2}g; 660 } 661 $tz = try { DateTime::TimeZone->new( name => $name ) }; 662 unless ($tz) { 663 $self->_our_croak( 664 qq{The Olson time zone name that was parsed does not appear to be valid, "$args->{time_zone_name}"} 665 ); 666 return; 667 } 668 $args->{time_zone} = $tz 669 if $tz; 670 } 671 672 delete @{$args}{@non_dt_keys}; 673 $args->{locale} = $self->{locale}; 674 675 for my $k ( grep { defined $args->{$_} } 676 qw( month day hour minute second nanosecond ) ) { 677 $args->{$k} =~ s/^\s+//; 678 } 679 680 if ( defined $args->{nanosecond} ) { 681 682 # If we parsed "12345" we treat it as "123450000" but if we parsed 683 # "000123456" we treat it as 123,456 nanoseconds. This is all a bit 684 # weird and confusing but it matches how this module has always 685 # worked. 686 $args->{nanosecond} *= 10**( 9 - length $args->{nanosecond} ) 687 if length $args->{nanosecond} != 9; 688 689 # If we parsed 000000123 we want to turn this into a number. 690 $args->{nanosecond} += 0; 691 } 692 693 for my $k (qw( year month day )) { 694 $args->{$k} = 1 unless defined $args->{$k}; 695 } 696 697 if ( defined $args->{epoch} ) { 698 699 # We don't want to pass a non-integer epoch value since that gets 700 # truncated as of DateTime 1.22. Instead, we'll set the nanosecond 701 # to parsed value after constructing the object. This is a hack, 702 # but it's the best I can come up with. 703 my $post_construct; 704 if ( my $nano = $args->{nanosecond} ) { 705 $post_construct = sub { $_[0]->set( nanosecond => $nano ) }; 706 } 707 708 delete @{$args}{ 709 qw( day_of_year year month day hour minute second nanosecond ) 710 }; 711 712 return ( 'from_epoch', $args, $post_construct ); 713 } 714 elsif ( $args->{day_of_year} ) { 715 delete @{$args}{qw( epoch month day )}; 716 return ( 'from_day_of_year', $args ); 717 } 718 719 return ( 'new', $args ); 720 } 721} 722 723## no critic (Subroutines::ProhibitExcessComplexity) 724sub _check_dt { 725 my $self = shift; 726 my $dt = shift; 727 my $args = shift; 728 729 my $is_am = defined $args->{am_pm} 730 && lc $args->{am_pm} eq lc $self->{locale}->am_pm_abbreviated->[0]; 731 if ( defined $args->{hour} && defined $args->{hour_12} ) { 732 unless ( ( $args->{hour} % 12 ) == $args->{hour_12} ) { 733 $self->_our_croak( 734 'Parsed an input with 24-hour and 12-hour time values that do not match' 735 . qq{ - "$args->{hour}" versus "$args->{hour_12}"} ); 736 return; 737 } 738 } 739 740 if ( defined $args->{hour} && defined $args->{am_pm} ) { 741 if ( ( $is_am && $args->{hour} >= 12 ) 742 || ( !$is_am && $args->{hour} < 12 ) ) { 743 $self->_our_croak( 744 'Parsed an input with 24-hour and AM/PM values that do not match' 745 . qq{ - "$args->{hour}" versus "$args->{am_pm}"} ); 746 return; 747 } 748 } 749 750 if ( defined $args->{year} && defined $args->{century} ) { 751 unless ( int( $args->{year} / 100 ) == $args->{century} ) { 752 $self->_our_croak( 753 'Parsed an input with year and century values that do not match' 754 . qq{ - "$args->{year}" versus "$args->{century}"} ); 755 return; 756 } 757 } 758 759 if ( defined $args->{year} && defined $args->{year_100} ) { 760 unless ( ( $args->{year} % 100 ) == $args->{year_100} ) { 761 $self->_our_croak( 762 'Parsed an input with year and year-within-century values that do not match' 763 . qq{ - "$args->{year}" versus "$args->{year_100}"} ); 764 return; 765 } 766 } 767 768 if ( defined $args->{time_zone_abbreviation} 769 && defined $args->{time_zone_offset} ) { 770 unless ( $self->{zone_map}{ $args->{time_zone_abbreviation} } 771 && $self->{zone_map}{ $args->{time_zone_abbreviation} } eq 772 $args->{time_zone_offset} ) { 773 774 $self->_our_croak( 775 'Parsed an input with time zone abbreviation and time zone offset values that do not match' 776 . qq{ - "$args->{time_zone_abbreviation}" versus "$args->{time_zone_offset}"} 777 ); 778 return; 779 } 780 } 781 782 if ( defined $args->{epoch} ) { 783 for my $key ( 784 qw( year month day minute hour second hour_12 day_of_year )) { 785 if ( defined $args->{$key} && $dt->$key != $args->{$key} ) { 786 my $print_key 787 = $key eq 'hour_12' ? 'hour (1-12)' 788 : $key eq 'day_of_year' ? 'day of year' 789 : $key; 790 $self->_our_croak( 791 "Parsed an input with epoch and $print_key values that do not match" 792 . qq{ - "$args->{epoch}" versus "$args->{$key}"} ); 793 return; 794 } 795 } 796 } 797 798 if ( defined $args->{month} && defined $args->{day_of_year} ) { 799 unless ( $dt->month == $args->{month} ) { 800 $self->_our_croak( 801 'Parsed an input with month and day of year values that do not match' 802 . qq{ - "$args->{month}" versus "$args->{day_of_year}"} ); 803 return; 804 } 805 } 806 807 if ( defined $args->{day_name} ) { 808 my $dow = $self->_locale_days->{ lc $args->{day_name} }; 809 defined $dow 810 or die "We somehow parsed a day name ($args->{day_name})" 811 . ' that does not correspond to any day in this locale!'; 812 813 unless ( $dt->day_of_week_0 == $dow ) { 814 $self->_our_croak( 815 'Parsed an input where the day name does not match the date' 816 . qq{ - "$args->{day_name}" versus "} 817 . $dt->ymd 818 . q{"} ); 819 return; 820 } 821 } 822 823 if ( defined $args->{day_of_week} ) { 824 unless ( $dt->day_of_week == $args->{day_of_week} ) { 825 $self->_our_croak( 826 'Parsed an input where the day of week does not match the date' 827 . qq{ - "$args->{day_of_week}" versus "} 828 . $dt->ymd 829 . q{"} ); 830 return; 831 } 832 } 833 834 if ( defined $args->{day_of_week_sun_0} ) { 835 unless ( ( $dt->day_of_week % 7 ) == $args->{day_of_week_sun_0} ) { 836 $self->_our_croak( 837 'Parsed an input where the day of week (Sunday as 0) does not match the date' 838 . qq{ - "$args->{day_of_week_sun_0}" versus "} 839 . $dt->ymd 840 . q{"} ); 841 return; 842 } 843 } 844 845 if ( defined $args->{iso_week_year} ) { 846 unless ( $dt->week_year == $args->{iso_week_year} ) { 847 $self->_our_croak( 848 'Parsed an input where the ISO week year does not match the date' 849 . qq{ - "$args->{iso_week_year}" versus "} 850 . $dt->ymd 851 . q{"} ); 852 return; 853 } 854 } 855 856 if ( defined $args->{iso_week_year_100} ) { 857 unless ( ( 0 + substr( $dt->week_year, -2 ) ) 858 == $args->{iso_week_year_100} ) { 859 $self->_our_croak( 860 'Parsed an input where the ISO week year (without century) does not match the date' 861 . qq{ - "$args->{iso_week_year_100}" versus "} 862 . $dt->ymd 863 . q{"} ); 864 return; 865 } 866 } 867 868 if ( defined $args->{week_mon_1} ) { 869 unless ( ( 0 + $dt->strftime('%W') ) == $args->{week_mon_1} ) { 870 $self->_our_croak( 871 'Parsed an input where the ISO week number (Monday starts week) does not match the date' 872 . qq{ - "$args->{week_mon_1}" versus "} 873 . $dt->ymd 874 . q{"} ); 875 return; 876 } 877 } 878 879 if ( defined $args->{week_sun_0} ) { 880 unless ( ( 0 + $dt->strftime('%U') ) == $args->{week_sun_0} ) { 881 $self->_our_croak( 882 'Parsed an input where the ISO week number (Sunday starts week) does not match the date' 883 . qq{ - "$args->{week_sun_0}" versus "} 884 . $dt->ymd 885 . q{"} ); 886 return; 887 } 888 } 889 890 return 1; 891} 892## use critic 893 894sub pattern { 895 my $self = shift; 896 return $self->{pattern}; 897} 898 899sub locale { 900 my $self = shift; 901 return $self->{locale}->can('code') 902 ? $self->{locale}->code 903 : $self->{locale}->id; 904} 905 906sub time_zone { 907 my $self = shift; 908 return $self->{time_zone}->name; 909} 910 911sub parse_duration { 912 croak q{DateTime::Format::Strptime doesn't do durations.}; 913} 914 915{ 916 my $validator = validation_for( params => [ { type => t('DateTime') } ] ); 917 918 sub format_datetime { 919 my $self = shift; 920 my ($dt) = $validator->(@_); 921 922 my $pattern = $self->pattern; 923 $pattern =~ s/%O/$dt->time_zone->name/eg; 924 return $dt->clone->set_locale( $self->locale )->strftime($pattern); 925 } 926 927} 928 929sub format_duration { 930 croak q{DateTime::Format::Strptime doesn't do durations.}; 931} 932 933sub _our_croak { 934 my $self = shift; 935 my $error = shift; 936 937 return $self->{on_error}->( $self, $error ) if ref $self->{on_error}; 938 croak $error if $self->{on_error} eq 'croak'; 939 $self->{errmsg} = $error; 940 return; 941} 942 943sub errmsg { 944 $_[0]->{errmsg}; 945} 946 947# Exportable functions: 948 949sub strftime { 950 my ( $pattern, $dt ) = @_; 951 return DateTime::Format::Strptime->new( 952 pattern => $pattern, 953 on_error => 'croak' 954 )->format_datetime($dt); 955} 956 957sub strptime { 958 my ( $pattern, $time_string ) = @_; 959 return DateTime::Format::Strptime->new( 960 pattern => $pattern, 961 on_error => 'croak' 962 )->parse_datetime($time_string); 963} 964 9651; 966 967# ABSTRACT: Parse and format strp and strf time patterns 968 969__END__ 970 971=pod 972 973=encoding UTF-8 974 975=head1 NAME 976 977DateTime::Format::Strptime - Parse and format strp and strf time patterns 978 979=head1 VERSION 980 981version 1.79 982 983=head1 SYNOPSIS 984 985 use DateTime::Format::Strptime; 986 987 my $strp = DateTime::Format::Strptime->new( 988 pattern => '%T', 989 locale => 'en_AU', 990 time_zone => 'Australia/Melbourne', 991 ); 992 993 my $dt = $strp->parse_datetime('23:16:42'); 994 995 $strp->format_datetime($dt); 996 997 # 23:16:42 998 999 # Croak when things go wrong: 1000 my $strp = DateTime::Format::Strptime->new( 1001 pattern => '%T', 1002 locale => 'en_AU', 1003 time_zone => 'Australia/Melbourne', 1004 on_error => 'croak', 1005 ); 1006 1007 # Do something else when things go wrong: 1008 my $strp = DateTime::Format::Strptime->new( 1009 pattern => '%T', 1010 locale => 'en_AU', 1011 time_zone => 'Australia/Melbourne', 1012 on_error => \&phone_police, 1013 ); 1014 1015=head1 DESCRIPTION 1016 1017This module implements most of C<strptime(3)>, the POSIX function that is the 1018reverse of C<strftime(3)>, for C<DateTime>. While C<strftime> takes a 1019C<DateTime> and a pattern and returns a string, C<strptime> takes a string and 1020a pattern and returns the C<DateTime> object associated. 1021 1022=for Pod::Coverage parse_duration format_duration 1023 1024=head1 METHODS 1025 1026This class offers the following methods. 1027 1028=head2 DateTime::Format::Strptime->new(%args) 1029 1030This methods creates a new object. It accepts the following arguments: 1031 1032=over 4 1033 1034=item * pattern 1035 1036This is the pattern to use for parsing. This is required. 1037 1038=item * strict 1039 1040This is a boolean which disables or enables strict matching mode. 1041 1042By default, this module turns your pattern into a regex that will match 1043anywhere in a string. So given the pattern C<%Y%m%d%H%M%S> it will match a 1044string like C<20161214233712>. However, this also means that a this pattern 1045will match B<any> string that contains 14 or more numbers! This behavior can be 1046very surprising. 1047 1048If you enable strict mode, then the generated regex is wrapped in boundary 1049checks of the form C</(?:\A|\b)...(?:\b|\z_/)>. These checks ensure that the 1050pattern will only match when at the beginning or end of a string, or when it is 1051separated by other text with a word boundary (C<\w> versus C<\W>). 1052 1053By default, strict mode is off. This is done for backwards compatibility. 1054Future releases may turn it on by default, as it produces less surprising 1055behavior in many cases. 1056 1057Because the default may change in the future, B<< you are strongly encouraged 1058to explicitly set this when constructing all C<DateTime::Format::Strptime> 1059objects >>. 1060 1061=item * time_zone 1062 1063The default time zone to use for objects returned from parsing. 1064 1065=item * zone_map 1066 1067Some time zone abbreviations are ambiguous (e.g. PST, EST, EDT). By default, 1068the parser will die when it parses an ambiguous abbreviation. You may specify a 1069C<zone_map> parameter as a hashref to map zone abbreviations however you like: 1070 1071 zone_map => { PST => '-0800', EST => '-0600' } 1072 1073Note that you can also override non-ambiguous mappings if you want to as well. 1074 1075=item * locale 1076 1077The locale to use for objects returned from parsing. 1078 1079=item * on_error 1080 1081This can be one of C<'undef'> (the string, not an C<undef>), 'croak', or a 1082subroutine reference. 1083 1084=over 8 1085 1086=item * 'undef' 1087 1088This is the default behavior. The module will return C<undef> on errors. The 1089error can be accessed using the C<< $object->errmsg >> method. This is the 1090ideal behaviour for interactive use where a user might provide an illegal 1091pattern or a date that doesn't match the pattern. 1092 1093=item * 'croak' 1094 1095The module will croak with an error message on errors. 1096 1097=item * sub{...} or \&subname 1098 1099When given a code ref, the module will call that sub on errors. The sub 1100receives two parameters: the object and the error message. 1101 1102If your sub does not die, then the formatter will continue on as if C<on_error> 1103was C<'undef'>. 1104 1105=back 1106 1107=back 1108 1109=head2 $strptime->parse_datetime($string) 1110 1111Given a string in the pattern specified in the constructor, this method will 1112return a new C<DateTime> object. 1113 1114If given a string that doesn't match the pattern, the formatter will croak or 1115return undef, depending on the setting of C<on_error> in the constructor. 1116 1117=head2 $strptime->format_datetime($datetime) 1118 1119Given a C<DateTime> object, this methods returns a string formatted in the 1120object's format. This method is synonymous with C<DateTime>'s strftime method. 1121 1122=head2 $strptime->locale 1123 1124This method returns the locale passed to the object's constructor. 1125 1126=head2 $strptime->pattern 1127 1128This method returns the pattern passed to the object's constructor. 1129 1130=head2 $strptime->time_zone 1131 1132This method returns the time zone passed to the object's constructor. 1133 1134=head2 $strptime->errmsg 1135 1136If the on_error behavior of the object is 'undef', you can retrieve error 1137messages with this method so you can work out why things went wrong. 1138 1139=head1 EXPORTS 1140 1141These subs are available as optional exports. 1142 1143=head2 strptime( $strptime_pattern, $string ) 1144 1145Given a pattern and a string this function will return a new C<DateTime> 1146object. 1147 1148=head2 strftime( $strftime_pattern, $datetime ) 1149 1150Given a pattern and a C<DateTime> object this function will return a formatted 1151string. 1152 1153=head1 STRPTIME PATTERN TOKENS 1154 1155The following tokens are allowed in the pattern string for strptime 1156(parse_datetime): 1157 1158=over 4 1159 1160=item * %% 1161 1162The % character. 1163 1164=item * %a or %A 1165 1166The weekday name according to the given locale, in abbreviated form or the full 1167name. 1168 1169=item * %b or %B or %h 1170 1171The month name according to the given locale, in abbreviated form or the full 1172name. 1173 1174=item * %c 1175 1176The datetime format according to the given locale. 1177 1178Note that this format can change without warning in new versions of 1179L<DateTime::Locale>. You should not use this pattern unless the string you are 1180parsing was generated by using this pattern with L<DateTime> B<and> you are 1181sure that this string was generated with the same version of 1182L<DateTime::Locale> that the parser is using. 1183 1184=item * %C 1185 1186The century number (0-99). 1187 1188=item * %d or %e 1189 1190The day of month (01-31). This will parse single digit numbers as well. 1191 1192=item * %D 1193 1194Equivalent to %m/%d/%y. (This is the American style date, very confusing to 1195non-Americans, especially since %d/%m/%y is widely used in Europe. The ISO 8601 1196standard pattern is %F.) 1197 1198=item * %F 1199 1200Equivalent to %Y-%m-%d. (This is the ISO style date) 1201 1202=item * %g 1203 1204The year corresponding to the ISO week number, but without the century (0-99). 1205 1206=item * %G 1207 1208The 4-digit year corresponding to the ISO week number. 1209 1210=item * %H 1211 1212The hour (00-23). This will parse single digit numbers as well. 1213 1214=item * %I 1215 1216The hour on a 12-hour clock (1-12). 1217 1218=item * %j 1219 1220The day number in the year (1-366). 1221 1222=item * %m 1223 1224The month number (01-12). This will parse single digit numbers as well. 1225 1226=item * %M 1227 1228The minute (00-59). This will parse single digit numbers as well. 1229 1230=item * %n 1231 1232Arbitrary whitespace. 1233 1234=item * %N 1235 1236Nanoseconds. For other sub-second values use C<%[number]N>. 1237 1238=item * %p or %P 1239 1240The equivalent of AM or PM according to the locale in use. See 1241L<DateTime::Locale>. 1242 1243=item * %r 1244 1245Equivalent to %I:%M:%S %p. 1246 1247=item * %R 1248 1249Equivalent to %H:%M. 1250 1251=item * %s 1252 1253Number of seconds since the Epoch. 1254 1255=item * %S 1256 1257The second (0-60; 60 may occur for leap seconds. See L<DateTime::LeapSecond>). 1258 1259=item * %t 1260 1261Arbitrary whitespace. 1262 1263=item * %T 1264 1265Equivalent to %H:%M:%S. 1266 1267=item * %U 1268 1269The week number with Sunday the first day of the week (0-53). The first Sunday 1270of January is the first day of week 1. 1271 1272=item * %u 1273 1274The weekday number (1-7) with Monday = 1. This is the C<DateTime> standard. 1275 1276=item * %w 1277 1278The weekday number (0-6) with Sunday = 0. 1279 1280=item * %W 1281 1282The week number with Monday the first day of the week (0-53). The first Monday 1283of January is the first day of week 1. 1284 1285=item * %x 1286 1287The date format according to the given locale. 1288 1289Note that this format can change without warning in new versions of 1290L<DateTime::Locale>. You should not use this pattern unless the string you are 1291parsing was generated by using this pattern with L<DateTime> B<and> you are 1292sure that this string was generated with the same version of 1293L<DateTime::Locale> that the parser is using. 1294 1295=item * %X 1296 1297The time format according to the given locale. 1298 1299Note that this format can change without warning in new versions of 1300L<DateTime::Locale>. You should not use this pattern unless the string you are 1301parsing was generated by using this pattern with L<DateTime> B<and> you are 1302sure that this string was generated with the same version of 1303L<DateTime::Locale> that the parser is using. 1304 1305=item * %y 1306 1307The year within century (0-99). When a century is not otherwise specified (with 1308a value for %C), values in the range 69-99 refer to years in the twentieth 1309century (1969-1999); values in the range 00-68 refer to years in the 1310twenty-first century (2000-2068). 1311 1312=item * %Y 1313 1314A 4-digit year, including century (for example, 1991). 1315 1316=item * %z 1317 1318An RFC-822/ISO 8601 standard time zone specification. (For example +1100) [See 1319note below] 1320 1321=item * %Z 1322 1323The timezone name. (For example EST -- which is ambiguous) [See note below] 1324 1325=item * %O 1326 1327This extended token allows the use of Olson Time Zone names to appear in parsed 1328strings. B<NOTE>: This pattern cannot be passed to C<DateTime>'s C<strftime()> 1329method, but can be passed to C<format_datetime()>. 1330 1331=back 1332 1333=head1 AUTHOR EMERITUS 1334 1335This module was created by Rick Measham. 1336 1337=head1 SEE ALSO 1338 1339C<datetime@perl.org> mailing list. 1340 1341http://datetime.perl.org/ 1342 1343L<perl>, L<DateTime>, L<DateTime::TimeZone>, L<DateTime::Locale> 1344 1345=head1 BUGS 1346 1347Please report any bugs or feature requests to 1348C<bug-datetime-format-strptime@rt.cpan.org>, or through the web interface at 1349L<http://rt.cpan.org>. I will be notified, and then you'll automatically be 1350notified of progress on your bug as I make changes. 1351 1352Bugs may be submitted at L<https://github.com/houseabsolute/DateTime-Format-Strptime/issues>. 1353 1354There is a mailing list available for users of this distribution, 1355L<mailto:datetime@perl.org>. 1356 1357I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>. 1358 1359=head1 SOURCE 1360 1361The source code repository for DateTime-Format-Strptime can be found at L<https://github.com/houseabsolute/DateTime-Format-Strptime>. 1362 1363=head1 DONATIONS 1364 1365If you'd like to thank me for the work I've done on this module, please 1366consider making a "donation" to me via PayPal. I spend a lot of free time 1367creating free software, and would appreciate any support you'd care to offer. 1368 1369Please note that B<I am not suggesting that you must do this> in order for me 1370to continue working on this particular software. I will continue to do so, 1371inasmuch as I have in the past, for as long as it interests me. 1372 1373Similarly, a donation made in this way will probably not make me work on this 1374software much more, unless I get so many donations that I can consider working 1375on free software full time (let's all have a chuckle at that together). 1376 1377To donate, log into PayPal and send money to autarch@urth.org, or use the 1378button at L<https://www.urth.org/fs-donation.html>. 1379 1380=head1 AUTHORS 1381 1382=over 4 1383 1384=item * 1385 1386Dave Rolsky <autarch@urth.org> 1387 1388=item * 1389 1390Rick Measham <rickm@cpan.org> 1391 1392=back 1393 1394=head1 CONTRIBUTORS 1395 1396=for stopwords Christian Hansen D. Ilmari Mannsåker gregor herrmann key-amb Mohammad S Anwar 1397 1398=over 4 1399 1400=item * 1401 1402Christian Hansen <chansen@cpan.org> 1403 1404=item * 1405 1406D. Ilmari Mannsåker <ilmari.mannsaker@net-a-porter.com> 1407 1408=item * 1409 1410gregor herrmann <gregoa@debian.org> 1411 1412=item * 1413 1414key-amb <yasutake.kiyoshi@gmail.com> 1415 1416=item * 1417 1418Mohammad S Anwar <mohammad.anwar@yahoo.com> 1419 1420=back 1421 1422=head1 COPYRIGHT AND LICENSE 1423 1424This software is Copyright (c) 2015 - 2021 by Dave Rolsky. 1425 1426This is free software, licensed under: 1427 1428 The Artistic License 2.0 (GPL Compatible) 1429 1430The full text of the license can be found in the 1431F<LICENSE> file included with this distribution. 1432 1433=cut 1434