package DateTime::Format::Strptime;
use strict;
use warnings;
our $VERSION = '1.68';
use Carp qw( carp croak );
use DateTime 1.00;
use DateTime::Locale 0.45;
use DateTime::TimeZone 0.79;
use Params::Validate 1.20
qw( validate SCALAR BOOLEAN OBJECT CODEREF HASHREF );
use Try::Tiny;
use Exporter qw( import );
use Package::DeprecationManager 0.15 -deprecations => {
'accessor writers' => '1.58',
};
our @EXPORT_OK = qw( strftime strptime );
use constant PERL_58 => $] < 5.010;
{
my $spec = {
pattern => { type => SCALAR },
time_zone => {
type => SCALAR | OBJECT,
optional => 1,
},
zone_map => {
type => HASHREF,
default => {},
},
locale => {
type => SCALAR | OBJECT,
default => DateTime::Locale->load('en'),
},
on_error => {
type => SCALAR | CODEREF,
default => 'undef',
callbacks => {
'valid on_error' => sub {
return 1
if $_[0]
&& ( ref $_[0] eq 'CODE'
|| $_[0] =~ /\A(?:croak|undef)\z/ );
die
q{The value supplied to on_error must be either 'croak', 'undef' or a code reference.};
},
},
},
debug => {
type => BOOLEAN,
default => $ENV{DATETIME_FORMAT_STRPTIME_DEBUG},
},
};
sub new {
my $class = shift;
my %args = validate( @_, $spec );
if ( $args{locale} && !ref $args{locale} ) {
$args{locale} = DateTime::Locale->load( $args{locale} )
or croak "Could not create locale from $args{locale}";
}
if ( $args{time_zone} && !ref $args{time_zone} ) {
$args{time_zone}
= DateTime::TimeZone->new( name => $args{time_zone} )
or croak "Could not create time zone from $args{time_zone}";
}
my $self = bless {
%args,
zone_map => $class->_build_zone_map( $args{zone_map} ),
}, $class;
# Forces a check that the pattern is valid
$self->_parser;
binmode STDERR, ':encoding(UTF-8)'
if $self->{debug};
return $self;
}
}
{
my %zone_map = (
'A' => '+0100', 'ACDT' => '+1030', 'ACST' => '+0930',
'ADT' => undef, 'AEDT' => '+1100', 'AES' => '+1000',
'AEST' => '+1000', 'AFT' => '+0430', 'AHDT' => '-0900',
'AHST' => '-1000', 'AKDT' => '-0800', 'AKST' => '-0900',
'AMST' => '+0400', 'AMT' => '+0400', 'ANAST' => '+1300',
'ANAT' => '+1200', 'ART' => '-0300', 'AST' => undef,
'AT' => '-0100', 'AWST' => '+0800', 'AZOST' => '+0000',
'AZOT' => '-0100', 'AZST' => '+0500', 'AZT' => '+0400',
'B' => '+0200', 'BADT' => '+0400', 'BAT' => '+0600',
'BDST' => '+0200', 'BDT' => '+0600', 'BET' => '-1100',
'BNT' => '+0800', 'BORT' => '+0800', 'BOT' => '-0400',
'BRA' => '-0300', 'BST' => undef, 'BT' => undef,
'BTT' => '+0600', 'C' => '+0300', 'CAST' => '+0930',
'CAT' => undef, 'CCT' => undef, 'CDT' => undef,
'CEST' => '+0200', 'CET' => '+0100', 'CETDST' => '+0200',
'CHADT' => '+1345', 'CHAST' => '+1245', 'CKT' => '-1000',
'CLST' => '-0300', 'CLT' => '-0400', 'COT' => '-0500',
'CST' => undef, 'CSuT' => '+1030', 'CUT' => '+0000',
'CVT' => '-0100', 'CXT' => '+0700', 'ChST' => '+1000',
'D' => '+0400', 'DAVT' => '+0700', 'DDUT' => '+1000',
'DNT' => '+0100', 'DST' => '+0200', 'E' => '+0500',
'EASST' => '-0500', 'EAST' => undef, 'EAT' => '+0300',
'ECT' => undef, 'EDT' => undef, 'EEST' => '+0300',
'EET' => '+0200', 'EETDST' => '+0300', 'EGST' => '+0000',
'EGT' => '-0100', 'EMT' => '+0100', 'EST' => undef,
'ESuT' => '+1100', 'F' => '+0600', 'FDT' => undef,
'FJST' => '+1300', 'FJT' => '+1200', 'FKST' => '-0300',
'FKT' => '-0400', 'FST' => undef, 'FWT' => '+0100',
'G' => '+0700', 'GALT' => '-0600', 'GAMT' => '-0900',
'GEST' => '+0500', 'GET' => '+0400', 'GFT' => '-0300',
'GILT' => '+1200', 'GMT' => '+0000', 'GST' => undef,
'GT' => '+0000', 'GYT' => '-0400', 'GZ' => '+0000',
'H' => '+0800', 'HAA' => '-0300', 'HAC' => '-0500',
'HAE' => '-0400', 'HAP' => '-0700', 'HAR' => '-0600',
'HAT' => '-0230', 'HAY' => '-0800', 'HDT' => '-0930',
'HFE' => '+0200', 'HFH' => '+0100', 'HG' => '+0000',
'HKT' => '+0800', 'HL' => 'local', 'HNA' => '-0400',
'HNC' => '-0600', 'HNE' => '-0500', 'HNP' => '-0800',
'HNR' => '-0700', 'HNT' => '-0330', 'HNY' => '-0900',
'HOE' => '+0100', 'HST' => '-1000', 'I' => '+0900',
'ICT' => '+0700', 'IDLE' => '+1200', 'IDLW' => '-1200',
'IDT' => undef, 'IOT' => '+0500', 'IRDT' => '+0430',
'IRKST' => '+0900', 'IRKT' => '+0800', 'IRST' => '+0430',
'IRT' => '+0330', 'IST' => undef, 'IT' => '+0330',
'ITA' => '+0100', 'JAVT' => '+0700', 'JAYT' => '+0900',
'JST' => '+0900', 'JT' => '+0700', 'K' => '+1000',
'KDT' => '+1000', 'KGST' => '+0600', 'KGT' => '+0500',
'KOST' => '+1200', 'KRAST' => '+0800', 'KRAT' => '+0700',
'KST' => '+0900', 'L' => '+1100', 'LHDT' => '+1100',
'LHST' => '+1030', 'LIGT' => '+1000', 'LINT' => '+1400',
'LKT' => '+0600', 'LST' => 'local', 'LT' => 'local',
'M' => '+1200', 'MAGST' => '+1200', 'MAGT' => '+1100',
'MAL' => '+0800', 'MART' => '-0930', 'MAT' => '+0300',
'MAWT' => '+0600', 'MDT' => '-0600', 'MED' => '+0200',
'MEDST' => '+0200', 'MEST' => '+0200', 'MESZ' => '+0200',
'MET' => undef, 'MEWT' => '+0100', 'MEX' => '-0600',
'MEZ' => '+0100', 'MHT' => '+1200', 'MMT' => '+0630',
'MPT' => '+1000', 'MSD' => '+0400', 'MSK' => '+0300',
'MSKS' => '+0400', 'MST' => '-0700', 'MT' => '+0830',
'MUT' => '+0400', 'MVT' => '+0500', 'MYT' => '+0800',
'N' => '-0100', 'NCT' => '+1100', 'NDT' => '-0230',
'NFT' => undef, 'NOR' => '+0100', 'NOVST' => '+0700',
'NOVT' => '+0600', 'NPT' => '+0545', 'NRT' => '+1200',
'NST' => undef, 'NSUT' => '+0630', 'NT' => '-1100',
'NUT' => '-1100', 'NZDT' => '+1300', 'NZST' => '+1200',
'NZT' => '+1200', 'O' => '-0200', 'OESZ' => '+0300',
'OEZ' => '+0200', 'OMSST' => '+0700', 'OMST' => '+0600',
'OZ' => 'local', 'P' => '-0300', 'PDT' => '-0700',
'PET' => '-0500', 'PETST' => '+1300', 'PETT' => '+1200',
'PGT' => '+1000', 'PHOT' => '+1300', 'PHT' => '+0800',
'PKT' => '+0500', 'PMDT' => '-0200', 'PMT' => '-0300',
'PNT' => '-0830', 'PONT' => '+1100', 'PST' => undef,
'PWT' => '+0900', 'PYST' => '-0300', 'PYT' => '-0400',
'Q' => '-0400', 'R' => '-0500', 'R1T' => '+0200',
'R2T' => '+0300', 'RET' => '+0400', 'ROK' => '+0900',
'S' => '-0600', 'SADT' => '+1030', 'SAST' => undef,
'SBT' => '+1100', 'SCT' => '+0400', 'SET' => '+0100',
'SGT' => '+0800', 'SRT' => '-0300', 'SST' => undef,
'SWT' => '+0100', 'T' => '-0700', 'TFT' => '+0500',
'THA' => '+0700', 'THAT' => '-1000', 'TJT' => '+0500',
'TKT' => '-1000', 'TMT' => '+0500', 'TOT' => '+1300',
'TRUT' => '+1000', 'TST' => '+0300', 'TUC ' => '+0000',
'TVT' => '+1200', 'U' => '-0800', 'ULAST' => '+0900',
'ULAT' => '+0800', 'USZ1' => '+0200', 'USZ1S' => '+0300',
'USZ3' => '+0400', 'USZ3S' => '+0500', 'USZ4' => '+0500',
'USZ4S' => '+0600', 'USZ5' => '+0600', 'USZ5S' => '+0700',
'USZ6' => '+0700', 'USZ6S' => '+0800', 'USZ7' => '+0800',
'USZ7S' => '+0900', 'USZ8' => '+0900', 'USZ8S' => '+1000',
'USZ9' => '+1000', 'USZ9S' => '+1100', 'UTZ' => '-0300',
'UYT' => '-0300', 'UZ10' => '+1100', 'UZ10S' => '+1200',
'UZ11' => '+1200', 'UZ11S' => '+1300', 'UZ12' => '+1200',
'UZ12S' => '+1300', 'UZT' => '+0500', 'V' => '-0900',
'VET' => '-0400', 'VLAST' => '+1100', 'VLAT' => '+1000',
'VTZ' => '-0200', 'VUT' => '+1100', 'W' => '-1000',
'WAKT' => '+1200', 'WAST' => undef, 'WAT' => '+0100',
'WEST' => '+0100', 'WESZ' => '+0100', 'WET' => '+0000',
'WETDST' => '+0100', 'WEZ' => '+0000', 'WFT' => '+1200',
'WGST' => '-0200', 'WGT' => '-0300', 'WIB' => '+0700',
'WIT' => '+0900', 'WITA' => '+0800', 'WST' => undef,
'WTZ' => '-0100', 'WUT' => '+0100', 'X' => '-1100',
'Y' => '-1200', 'YAKST' => '+1000', 'YAKT' => '+0900',
'YAPT' => '+1000', 'YDT' => '-0800', 'YEKST' => '+0600',
'YEKT' => '+0500', 'YST' => '-0900', 'Z' => '+0000',
'UTC' => '+0000',
);
for my $i ( map { sprintf( '%02d', $_ ) } 1 .. 12 ) {
$zone_map{ '-' . $i } = '-' . $i . '00';
$zone_map{ '+' . $i } = '+' . $i . '00';
}
sub _build_zone_map {
return {
%zone_map,
%{ $_[1] },
};
}
}
sub parse_datetime {
my $self = shift;
my $string = shift;
my $parser = $self->_parser;
if ( $self->{debug} ) {
warn "Regex for $self->{pattern}: $parser->{regex}\n";
warn "Fields: @{$parser->{fields}}\n";
}
my @matches = ( $string =~ $parser->{regex} );
unless (@matches) {
my $msg = 'Your datetime does not match your pattern';
if ( $self->{debug} ) {
$msg .= qq{ - string = "$string" - regex = $parser->{regex}};
}
$msg .= q{.};
$self->_our_croak($msg);
return;
}
my %args;
my $i = 0;
for my $f ( @{ $parser->{fields} } ) {
unless ( defined $matches[$i] ) {
die
"Something horrible happened - the string matched $parser->{regex}"
. " but did not return the expected fields: [@{$parser->{fields}}]";
}
$args{$f} = $matches[ $i++ ];
}
# We need to copy the %args here because _munge_args will delete keys in
# order to turn this into something that can be passed to a DateTime
# constructor.
my ( $constructor, $args, $post_construct )
= $self->_munge_args( {%args} );
return unless $constructor && $args;
my $dt = try { DateTime->$constructor($args) };
$self->_our_croak('Parsed values did not produce a valid date')
unless $dt;
if ($post_construct) {
$post_construct->($dt);
}
return unless $dt && $self->_check_dt( $dt, \%args );
$dt->set_time_zone( $self->{time_zone} )
if $self->{time_zone};
return $dt;
}
sub _parser {
my $self = shift;
return $self->{parser} ||= $self->_build_parser;
}
sub _build_parser {
my $self = shift;
my (
$replacement_tokens_re,
$replacements,
$pattern_tokens_re,
$patterns,
) = $self->_parser_pieces;
my $pattern = $self->{pattern};
# When the first replacement is a glibc pattern, the first round of
# replacements may simply replace one replacement token (like %X) with
# another replacement token (like %I).
$pattern =~ s/%($replacement_tokens_re)/$replacements->{$1}/g for 1 .. 2;
if ( $self->{debug} && $pattern ne $self->{pattern} ) {
warn "Pattern after replacement substitution: $pattern\n";
}
my $regex;
my @fields;
while (
$pattern =~ /
\G
%($pattern_tokens_re)
|
%([1-9]?)(N)
|
(%[0-9]*[a-zA-Z])
|
([^%]+)
/xg
) {
# Using \G in the regex match fails for some reason on Perl 5.8, so we
# do this hack instead.
substr( $pattern, 0, pos $pattern, q{} )
if PERL_58;
if ($1) {
my $p = $patterns->{$1}
or croak
"Unidentified token in pattern: $1 in $self->{pattern}";
if ( $p->{field} ) {
$regex .= qr/($p->{regex})/;
push @fields, $p->{field};
}
else {
$regex .= qr/$p->{regex}/;
}
}
elsif ($3) {
$regex .= $2 ? qr/([0-9]{$2})/ : qr/([0-9]+)/;
push @fields, 'nanosecond';
}
elsif ($4) {
croak qq{Pattern contained an unrecognized strptime token, "$4"};
}
else {
$regex .= qr/\Q$5/;
}
}
return {
regex => qr/(?:\A\s|\b)*$regex/,
fields => \@fields,
};
}
{
my $d = qr/(?:[0-9])/;
my $one_or_two_digits = qr/[0-9 ]?$d/;
# These patterns are all locale-independent. There are a few that depend
# on the locale, and must be re-calculated for each new parser object.
my %universal_patterns = (
'%' => {
regex => qr/%/,
},
C => {
regex => $one_or_two_digits,
field => 'century',
},
d => {
regex => $one_or_two_digits,
field => 'day',
},
g => {
regex => $one_or_two_digits,
field => 'iso_week_year_100',
},
G => {
regex => qr/$d{4}/,
field => 'iso_week_year',
},
H => {
regex => $one_or_two_digits,
field => 'hour',
},
I => {
regex => $one_or_two_digits,
field => 'hour_12',
},
j => {
regex => qr/$d{1,3}/,
field => 'day_of_year',
},
m => {
regex => $one_or_two_digits,
field => 'month',
},
M => {
regex => $one_or_two_digits,
field => 'minute',
},
n => {
regex => qr/\s+/,
},
O => {
regex => qr{[a-zA-Z_]+(?:/[a-zA-Z_]+(?:/[a-zA-Z_]+)?)?},
field => 'time_zone_name',
},
s => {
regex => qr/$d+/,
field => 'epoch',
},
S => {
regex => $one_or_two_digits,
field => 'second',
},
U => {
regex => $one_or_two_digits,
field => 'week_sun_0',
},
u => {
regex => $one_or_two_digits,
field => 'day_of_week',
},
w => {
regex => $one_or_two_digits,
field => 'day_of_week_sun_0',
},
W => {
regex => $one_or_two_digits,
field => 'week_mon_1',
},
y => {
regex => $one_or_two_digits,
field => 'year_100',
},
Y => {
regex => qr/$d{4}/,
field => 'year',
},
z => {
regex => qr/[+-]$d{4}/,
field => 'time_zone_offset',
},
Z => {
regex => qr/[a-zA-Z]{1,6}|[\-\+][0-9]{2}/,
field => 'time_zone_abbreviation',
},
);
$universal_patterns{e} = $universal_patterns{d};
$universal_patterns{k} = $universal_patterns{H};
$universal_patterns{l} = $universal_patterns{I};
$universal_patterns{t} = $universal_patterns{n};
my %universal_replacements = (
D => '%m/%d/%y',
F => '%Y-%m-%d',
r => '%I:%M:%S %p',
R => '%H:%M',
T => '%H:%M:%S',
);
sub _parser_pieces {
my $self = shift;
my %replacements = %universal_replacements;
$replacements{c} = $self->{locale}->glibc_datetime_format;
$replacements{x} = $self->{locale}->glibc_date_format;
$replacements{X} = $self->{locale}->glibc_time_format;
my %patterns = %universal_patterns;
$patterns{a} = $patterns{A} = {
regex => do {
my $days = join '|', map {quotemeta}
sort { ( length $b <=> length $a ) or ( $a cmp $b ) }
keys %{ $self->_locale_days };
qr/$days/i;
},
field => 'day_name',
};
$patterns{b} = $patterns{B} = $patterns{h} = {
regex => do {
my $months = join '|', map {quotemeta}
sort { ( length $b <=> length $a ) or ( $a cmp $b ) }
keys %{ $self->_locale_months };
qr/$months/i;
},
field => 'month_name',
};
$patterns{p} = $patterns{P} = {
regex => do {
my $am_pm = join '|',
map {quotemeta}
sort { ( length $b <=> length $a ) or ( $a cmp $b ) }
@{ $self->{locale}->am_pm_abbreviated };
qr/$am_pm/i;
},
field => 'am_pm',
};
return (
$self->_token_re_for( keys %replacements ),
\%replacements,
$self->_token_re_for( keys %patterns ),
\%patterns,
);
}
}
sub _locale_days {
my $self = shift;
return $self->{locale_days} if $self->{locale_days};
my $wide = $self->{locale}->day_format_wide;
my $abbr = $self->{locale}->day_format_abbreviated;
my %locale_days;
for my $i ( 0 .. 6 ) {
$locale_days{ lc $wide->[$i] } = $i;
$locale_days{ lc $abbr->[$i] } = $i;
}
return $self->{locale_days} ||= \%locale_days;
}
sub _locale_months {
my $self = shift;
return $self->{locale_months} if $self->{locale_months};
my $wide = $self->{locale}->month_format_wide;
my $abbr = $self->{locale}->month_format_abbreviated;
my %locale_months;
for my $i ( 0 .. 11 ) {
$locale_months{ lc $wide->[$i] } = $i + 1;
$locale_months{ lc $abbr->[$i] } = $i + 1;
}
return $self->{locale_months} ||= \%locale_months;
}
sub _token_re_for {
shift;
my $t = join '|',
sort { ( length $b <=> length $a ) or ( $a cmp $b ) } @_;
return qr/$t/;
}
{
# These are fields we parse that cannot be passed to a DateTime
# constructor
my @non_dt_keys = qw(
am_pm
century
day_name
day_of_week
day_of_week_sun_0
hour_12
iso_week_year
iso_week_year_100
month_name
time_zone_abbreviation
time_zone_name
time_zone_offset
week_mon_1
week_sun_0
year_100
);
sub _munge_args {
my $self = shift;
my $args = shift;
if ( defined $args->{month_name} ) {
my $num = $self->_locale_months->{ lc $args->{month_name} }
or die "We somehow parsed a month name ($args->{month_name})"
. ' that does not correspond to any month in this locale!';
$args->{month} = $num;
}
if ( defined $args->{am_pm} && defined $args->{hour_12} ) {
my ( $am, $pm ) = @{ $self->{locale}->am_pm_abbreviated };
$args->{hour} = $args->{hour_12};
if ( lc $args->{am_pm} eq lc $am ) {
$args->{hour} = 0 if $args->{hour} == 12;
}
else {
$args->{hour} += 12 unless $args->{hour} == 12;
}
}
elsif ( defined $args->{hour_12} ) {
$self->_our_croak(
qq{Parsed a 12-hour based hour, "$args->{hour_12}",}
. ' but the pattern does not include an AM/PM specifier'
);
return;
}
if ( defined $args->{year_100} ) {
if ( defined $args->{century} ) {
$args->{year}
= $args->{year_100} + ( $args->{century} * 100 );
}
else {
$args->{year} = $args->{year_100} + (
$args->{year_100} >= 69
? 1900
: 2000
);
}
}
if ( $args->{time_zone_offset} ) {
$args->{time_zone} = DateTime::TimeZone->new(
name => $args->{time_zone_offset} );
}
if ( defined $args->{time_zone_abbreviation} ) {
my $abbr = $args->{time_zone_abbreviation};
unless ( exists $self->{zone_map}{$abbr} ) {
$self->_our_croak(
qq{Parsed an unrecognized time zone abbreviation, "$args->{time_zone_abbreviation}"}
);
return;
}
if ( !defined $self->{zone_map}{$abbr} ) {
$self->_our_croak(
qq{The time zone abbreviation that was parsed is ambiguous, "$args->{time_zone_abbreviation}"}
);
return;
}
$args->{time_zone}
= DateTime::TimeZone->new( name => $self->{zone_map}{$abbr} );
}
else {
$args->{time_zone} ||= 'floating';
}
if ( $args->{time_zone_name} ) {
my $name = $args->{time_zone_name};
my $tz;
unless ( $tz = try { DateTime::TimeZone->new( name => $name ) } )
{
$name = lc $name;
$name =~ s{(^|[/_])(.)}{$1\U$2}g;
}
$tz = try { DateTime::TimeZone->new( name => $name ) };
unless ($tz) {
$self->_our_croak(
qq{The Olson time zone name that was parsed does not appear to be valid, "$args->{time_zone_name}"}
);
return;
}
$args->{time_zone} = $tz
if $tz;
}
delete @{$args}{@non_dt_keys};
$args->{locale} = $self->{locale};
for my $k ( grep { defined $args->{$_} }
qw( month day hour minute second nanosecond ) ) {
$args->{$k} =~ s/^\s+//;
}
if ( defined $args->{nanosecond} ) {
# If we parsed "12345" we treat it as "123450000" but if we parsed
# "000123456" we treat it as 123,456 nanoseconds. This is all a bit
# weird and confusing but it matches how this module has always
# worked.
$args->{nanosecond} *= 10**( 9 - length $args->{nanosecond} )
if length $args->{nanosecond} != 9;
# If we parsed 000000123 we want to turn this into a number.
$args->{nanosecond} += 0;
}
for my $k (qw( year month day )) {
$args->{$k} = 1 unless defined $args->{$k};
}
if ( defined $args->{epoch} ) {
# We don't want to pass a non-integer epoch value since that gets
# truncated as of DateTime 1.22. Instead, we'll set the nanosecond
# to parsed value after constructing the object. This is a hack,
# but it's the best I can come up with.
my $post_construct;
if ( my $nano = $args->{nanosecond} ) {
$post_construct = sub { $_[0]->set( nanosecond => $nano ) };
}
delete @{$args}{
qw( day_of_year year month day hour minute second nanosecond )
};
return ( 'from_epoch', $args, $post_construct );
}
elsif ( $args->{day_of_year} ) {
delete @{$args}{qw( epoch month day )};
return ( 'from_day_of_year', $args );
}
return ( 'new', $args );
}
}
sub _check_dt {
my $self = shift;
my $dt = shift;
my $args = shift;
my $is_am = defined $args->{am_pm}
&& lc $args->{am_pm} eq lc $self->{locale}->am_pm_abbreviated->[0];
if ( defined $args->{hour} && defined $args->{hour_12} ) {
unless ( ( $args->{hour} % 12 ) == $args->{hour_12} ) {
$self->_our_croak(
'Parsed an input with 24-hour and 12-hour time values that do not match'
. qq{ - "$args->{hour}" versus "$args->{hour_12}"} );
return;
}
}
if ( defined $args->{hour} && defined $args->{am_pm} ) {
if ( ( $is_am && $args->{hour} >= 12 )
|| ( !$is_am && $args->{hour} < 12 ) ) {
$self->_our_croak(
'Parsed an input with 24-hour and AM/PM values that do not match'
. qq{ - "$args->{hour}" versus "$args->{am_pm}"} );
return;
}
}
if ( defined $args->{year} && defined $args->{century} ) {
unless ( int( $args->{year} / 100 ) == $args->{century} ) {
$self->_our_croak(
'Parsed an input with year and century values that do not match'
. qq{ - "$args->{year}" versus "$args->{century}"} );
return;
}
}
if ( defined $args->{year} && defined $args->{year_100} ) {
unless ( ( $args->{year} % 100 ) == $args->{year_100} ) {
$self->_our_croak(
'Parsed an input with year and year-within-century values that do not match'
. qq{ - "$args->{year}" versus "$args->{year_100}"} );
return;
}
}
if ( defined $args->{time_zone_abbreviation}
&& defined $args->{time_zone_offset} ) {
unless ( $self->{zone_map}{ $args->{time_zone_abbreviation} }
&& $self->{zone_map}{ $args->{time_zone_abbreviation} } eq
$args->{time_zone_offset} ) {
$self->_our_croak(
'Parsed an input with time zone abbreviation and time zone offset values that do not match'
. qq{ - "$args->{time_zone_abbreviation}" versus "$args->{time_zone_offset}"}
);
return;
}
}
if ( defined $args->{epoch} ) {
for my $key (
qw( year month day minute hour second hour_12 day_of_year )) {
if ( defined $args->{$key} && $dt->$key != $args->{$key} ) {
my $print_key
= $key eq 'hour_12' ? 'hour (1-12)'
: $key eq 'day_of_year' ? 'day of year'
: $key;
$self->_our_croak(
"Parsed an input with epoch and $print_key values that do not match"
. qq{ - "$args->{epoch}" versus "$args->{$key}"} );
return;
}
}
}
if ( defined $args->{month} && defined $args->{day_of_year} ) {
unless ( $dt->month == $args->{month} ) {
$self->_our_croak(
'Parsed an input with month and day of year values that do not match'
. qq{ - "$args->{month}" versus "$args->{day_of_year}"} );
return;
}
}
if ( defined $args->{day_name} ) {
my $dow = $self->_locale_days->{ lc $args->{day_name} };
defined $dow
or die "We somehow parsed a day name ($args->{day_name})"
. ' that does not correspond to any day in this locale!';
unless ( $dt->day_of_week_0 == $dow ) {
$self->_our_croak(
'Parsed an input where the day name does not match the date'
. qq{ - "$args->{day_name}" versus "}
. $dt->ymd
. q{"} );
return;
}
}
if ( defined $args->{day_of_week} ) {
unless ( $dt->day_of_week == $args->{day_of_week} ) {
$self->_our_croak(
'Parsed an input where the day of week does not match the date'
. qq{ - "$args->{day_of_week}" versus "}
. $dt->ymd
. q{"} );
return;
}
}
if ( defined $args->{day_of_week_sun_0} ) {
unless ( ( $dt->day_of_week % 7 ) == $args->{day_of_week_sun_0} ) {
$self->_our_croak(
'Parsed an input where the day of week (Sunday as 0) does not match the date'
. qq{ - "$args->{day_of_week_sun_0}" versus "}
. $dt->ymd
. q{"} );
return;
}
}
if ( defined $args->{iso_week_year} ) {
unless ( $dt->week_year == $args->{iso_week_year} ) {
$self->_our_croak(
'Parsed an input where the ISO week year does not match the date'
. qq{ - "$args->{iso_week_year}" versus "}
. $dt->ymd
. q{"} );
return;
}
}
if ( defined $args->{iso_week_year_100} ) {
unless ( ( 0 + substr( $dt->week_year, -2 ) )
== $args->{iso_week_year_100} ) {
$self->_our_croak(
'Parsed an input where the ISO week year (without century) does not match the date'
. qq{ - "$args->{iso_week_year_100}" versus "}
. $dt->ymd
. q{"} );
return;
}
}
if ( defined $args->{week_mon_1} ) {
unless ( ( 0 + $dt->strftime('%W') ) == $args->{week_mon_1} ) {
$self->_our_croak(
'Parsed an input where the ISO week number (Monday starts week) does not match the date'
. qq{ - "$args->{week_mon_1}" versus "}
. $dt->ymd
. q{"} );
return;
}
}
if ( defined $args->{week_sun_0} ) {
unless ( ( 0 + $dt->strftime('%U') ) == $args->{week_sun_0} ) {
$self->_our_croak(
'Parsed an input where the ISO week number (Sunday starts week) does not match the date'
. qq{ - "$args->{week_sun_0}" versus "}
. $dt->ymd
. q{"} );
return;
}
}
return 1;
}
sub pattern {
my $self = shift;
if (@_) {
my $pattern = shift;
deprecated(
feature => 'accessor writers',
message => 'Calling pattern() as a writer is deprecated.',
);
my $new;
try {
$new = $self->_clone_with( pattern => $pattern );
}
catch {
$self->_our_carp($_);
}
return unless $new;
%{$self} = %{$new};
}
return $self->{pattern};
}
sub locale {
my $self = shift;
if (@_) {
my $locale = shift;
deprecated(
feature => 'accessor writers',
message => 'Calling locale() as a writer is deprecated.',
);
my $new;
try {
$new = $self->_clone_with( locale => $locale );
}
catch {
$self->_our_carp($_);
}
return unless $new;
%{$self} = %{$new};
}
return $self->{locale}->can('code')
? $self->{locale}->code
: $self->{locale}->id;
}
sub time_zone {
my $self = shift;
if (@_) {
my $time_zone = shift;
deprecated(
feature => 'accessor writers',
message => 'Calling time_zone() as a writer is deprecated.',
);
my $new;
try {
$new = $self->_clone_with( time_zone => $time_zone );
}
catch {
$self->_our_carp($_);
}
return unless $new;
%{$self} = %{$new};
}
return $self->{time_zone}->name;
}
# Only used for deprecated accessors-as-writers feature
sub _clone_with {
my $self = shift;
return ( ref $self )->new(
pattern => $self->{pattern},
locale => $self->{locale},
(
$self->{time_zone}
? ( time_zone => $self->{time_zone} )
: ()
),
on_error => $self->{on_error},
debug => $self->{debug},
@_,
);
}
sub parse_duration {
croak q{DateTime::Format::Strptime doesn't do durations.};
}
sub format_datetime {
my $self = shift;
my $dt = shift;
my $pattern = $self->pattern;
$pattern =~ s/%O/$dt->time_zone->name/eg;
return $dt->clone->set_locale( $self->locale )->strftime($pattern);
}
sub format_duration {
croak q{DateTime::Format::Strptime doesn't do durations.};
}
sub _our_croak {
my $self = shift;
my $error = shift;
return $self->{on_error}->( $self, $error ) if ref $self->{on_error};
croak $error if $self->{on_error} eq 'croak';
$self->{errmsg} = $error;
return;
}
sub _our_carp {
my $self = shift;
my $error = shift;
return $self->{on_error}->( $self, $error ) if ref $self->{on_error};
carp $error if $self->{on_error} eq 'croak';
$self->{errmsg} = $error;
return;
}
sub errmsg {
$_[0]->{errmsg};
}
# Exportable functions:
sub strftime {
my ( $pattern, $dt ) = @_;
return DateTime::Format::Strptime->new(
pattern => $pattern,
on_error => 'croak'
)->format_datetime($dt);
}
sub strptime {
my ( $pattern, $time_string ) = @_;
return DateTime::Format::Strptime->new(
pattern => $pattern,
on_error => 'croak'
)->parse_datetime($time_string);
}
1;
# ABSTRACT: Parse and format strp and strf time patterns
__END__
=pod
=encoding UTF-8
=head1 NAME
DateTime::Format::Strptime - Parse and format strp and strf time patterns
=head1 VERSION
version 1.68
=head1 SYNOPSIS
use DateTime::Format::Strptime;
my $strp = DateTime::Format::Strptime->new(
pattern => '%T',
locale => 'en_AU',
time_zone => 'Australia/Melbourne',
);
my $dt = $strp->parse_datetime('23:16:42');
$strp->format_datetime($dt);
# 23:16:42
# Croak when things go wrong:
my $strp = DateTime::Format::Strptime->new(
pattern => '%T',
locale => 'en_AU',
time_zone => 'Australia/Melbourne',
on_error => 'croak',
);
# Do something else when things go wrong:
my $strp = DateTime::Format::Strptime->new(
pattern => '%T',
locale => 'en_AU',
time_zone => 'Australia/Melbourne',
on_error => \&phone_police,
);
=head1 DESCRIPTION
This module implements most of C<strptime(3)>, the POSIX function that is the
reverse of C<strftime(3)>, for C<DateTime>. While C<strftime> takes a
C<DateTime> and a pattern and returns a string, C<strptime> takes a string and
a pattern and returns the C<DateTime> object associated.
=for Pod::Coverage parse_duration format_duration
=head1 METHODS
This class offers the following methods.
=head2 DateTime::Format::Strptime->new(%args)
This methods creates a new object. It accepts the following arguments:
=over 4
=item * pattern
This is the pattern to use for parsing. This is required.
=item * time_zone
The default time zone to use for objects returned from parsing.
=item * zone_map
Some time zone abbreviations are ambiguous (e.g. PST, EST, EDT). By default,
the parser will die when it parses an ambiguous abbreviation. You may specify
a C<zone_map> parameter as a hashref to map zone abbreviations however you like:
zone_map => { PST => '-0800', EST => '-0600' }
Note that you can also override non-ambiguous mappings if you want to as well.
=item * locale
The locale to use for objects returned from parsing.
=item * on_error
This can be one of C<'undef'> (the string, not an C<undef>), 'croak', or a
subroutine reference.
=over 8
=item * 'undef'
This is the default behavior. The module will return C<undef> on errors. The
error can be accessed using the C<< $object->errmsg >> method. This is the
ideal behaviour for interactive use where a user might provide an illegal
pattern or a date that doesn't match the pattern.
=item * 'croak'
The module will croak with an error message on errors.
=item * sub{...} or \&subname
When given a code ref, the module will call that sub on errors. The sub
receives two parameters: the object and the error message.
If your sub does not die, then the formatter will continue on as if
C<on_error> was C<'undef'>.
=back
=back
=head2 $strptime->parse_datetime($string)
Given a string in the pattern specified in the constructor, this method
will return a new C<DateTime> object.
If given a string that doesn't match the pattern, the formatter will croak or
return undef, depending on the setting of C<on_error> in the constructor.
=head2 $strptime->format_datetime($datetime)
Given a C<DateTime> object, this methods returns a string formatted in the
object's format. This method is synonymous with C<DateTime>'s strftime method.
=head2 $strptime->locale
This method returns the locale passed to the object's constructor.
=head2 $strptime->pattern
This method returns the pattern passed to the object's constructor.
=head2 $strptime->time_zone
This method returns the time zone passed to the object's constructor.
=head2 $strptime->errmsg
If the on_error behavior of the object is 'undef', you can retrieve error
messages with this method so you can work out why things went wrong.
=head1 EXPORTS
These subs are available as optional exports.
=head2 strptime( $strptime_pattern, $string )
Given a pattern and a string this function will return a new C<DateTime>
object.
=head2 strftime( $strftime_pattern, $datetime )
Given a pattern and a C<DateTime> object this function will return a
formatted string.
=head1 STRPTIME PATTERN TOKENS
The following tokens are allowed in the pattern string for strptime
(parse_datetime):
=over 4
=item * %%
The % character.
=item * %a or %A
The weekday name according to the current locale, in abbreviated form or
the full name.
=item * %b or %B or %h
The month name according to the current locale, in abbreviated form or
the full name.
=item * %C
The century number (0-99).
=item * %d or %e
The day of month (01-31). This will parse single digit numbers as well.
=item * %D
Equivalent to %m/%d/%y. (This is the American style date, very confusing
to non-Americans, especially since %d/%m/%y is widely used in Europe.
The ISO 8601 standard pattern is %F.)
=item * %F
Equivalent to %Y-%m-%d. (This is the ISO style date)
=item * %g
The year corresponding to the ISO week number, but without the century
(0-99).
=item * %G
The 4-digit year corresponding to the ISO week number.
=item * %H
The hour (00-23). This will parse single digit numbers as well.
=item * %I
The hour on a 12-hour clock (1-12).
=item * %j
The day number in the year (1-366).
=item * %m
The month number (01-12). This will parse single digit numbers as well.
=item * %M
The minute (00-59). This will parse single digit numbers as well.
=item * %n
Arbitrary whitespace.
=item * %N
Nanoseconds. For other sub-second values use C<%[number]N>.
=item * %p
The equivalent of AM or PM according to the locale in use. (See
L<DateTime::Locale>)
=item * %r
Equivalent to %I:%M:%S %p.
=item * %R
Equivalent to %H:%M.
=item * %s
Number of seconds since the Epoch.
=item * %S
The second (0-60; 60 may occur for leap seconds. See
L<DateTime::LeapSecond>).
=item * %t
Arbitrary whitespace.
=item * %T
Equivalent to %H:%M:%S.
=item * %U
The week number with Sunday the first day of the week (0-53). The first
Sunday of January is the first day of week 1.
=item * %u
The weekday number (1-7) with Monday = 1. This is the C<DateTime> standard.
=item * %w
The weekday number (0-6) with Sunday = 0.
=item * %W
The week number with Monday the first day of the week (0-53). The first
Monday of January is the first day of week 1.
=item * %y
The year within century (0-99). When a century is not otherwise specified
(with a value for %C), values in the range 69-99 refer to years in the
twentieth century (1969-1999); values in the range 00-68 refer to years in the
twenty-first century (2000-2068).
=item * %Y
A 4-digit year, including century (for example, 1991).
=item * %z
An RFC-822/ISO 8601 standard time zone specification. (For example
+1100) [See note below]
=item * %Z
The timezone name. (For example EST -- which is ambiguous) [See note
below]
=item * %O
This extended token allows the use of Olson Time Zone names to appear
in parsed strings. B<NOTE>: This pattern cannot be passed to C<DateTime>'s
C<strftime()> method, but can be passed to C<format_datetime()>.
=back
=head1 AUTHOR EMERITUS
This module was created by Rick Measham.
=head1 SEE ALSO
C<datetime@perl.org> mailing list.
http://datetime.perl.org/
L<perl>, L<DateTime>, L<DateTime::TimeZone>, L<DateTime::Locale>
=head1 BUGS
Please report any bugs or feature requests to
C<bug-datetime-format-strptime@rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org>. I will be notified, and then you'll automatically be
notified of progress on your bug as I make changes.
Bugs may be submitted through L<the RT bug tracker|http://rt.cpan.org/Public/Dist/Display.html?Name=DateTime-Format-Strptime>
(or L<bug-datetime-format-strptime@rt.cpan.org|mailto:bug-datetime-format-strptime@rt.cpan.org>).
There is a mailing list available for users of this distribution,
L<mailto:datetime@perl.org>.
I am also usually active on IRC as 'drolsky' on C<irc://irc.perl.org>.
=head1 DONATIONS
If you'd like to thank me for the work I've done on this module, please
consider making a "donation" to me via PayPal. I spend a lot of free time
creating free software, and would appreciate any support you'd care to offer.
Please note that B<I am not suggesting that you must do this> in order for me
to continue working on this particular software. I will continue to do so,
inasmuch as I have in the past, for as long as it interests me.
Similarly, a donation made in this way will probably not make me work on this
software much more, unless I get so many donations that I can consider working
on free software full time (let's all have a chuckle at that together).
To donate, log into PayPal and send money to autarch@urth.org, or use the
button at L<http://www.urth.org/~autarch/fs-donation.html>.
=head1 AUTHORS
=over 4
=item *
Dave Rolsky <autarch@urth.org>
=item *
Rick Measham <rickm@cpan.org>
=back
=head1 CONTRIBUTORS
=for stopwords D. Ilmari Mannsåker key-amb
=over 4
=item *
D. Ilmari Mannsåker <ilmari.mannsaker@net-a-porter.com>
=item *
key-amb <yasutake.kiyoshi@gmail.com>
=back
=head1 COPYRIGHT AND LICENCE
This software is Copyright (c) 2015 - 2016 by Dave Rolsky.
This is free software, licensed under:
The Artistic License 2.0 (GPL Compatible)
=cut