package DateTime::Format::Strptime;
use strict;
use DateTime;
use DateTime::Locale;
use DateTime::TimeZone;
use Params::Validate qw( validate SCALAR BOOLEAN OBJECT CODEREF );
use Carp;
use Exporter;
use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK %ZONEMAP %FORMATS $CROAK $errmsg);
@ISA = 'Exporter';
$VERSION = '1.04';
@EXPORT_OK = qw( &strftime &strptime );
@EXPORT = ();
%ZONEMAP = (
'A' => '+0100', 'ACDT' => '+1030', 'ACST' => '+0930',
'ADT' => 'Ambiguous', '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' => 'Ambiguous',
'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' => 'Ambiguous', 'BT' => 'Ambiguous',
'BTT' => '+0600', 'C' => '+0300', 'CAST' => '+0930',
'CAT' => 'Ambiguous', 'CCT' => 'Ambiguous', 'CDT' => 'Ambiguous',
'CEST' => '+0200', 'CET' => '+0100', 'CETDST' => '+0200',
'CHADT' => '+1345', 'CHAST' => '+1245', 'CKT' => '-1000',
'CLST' => '-0300', 'CLT' => '-0400', 'COT' => '-0500',
'CST' => 'Ambiguous', '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' => 'Ambiguous', 'EAT' => '+0300',
'ECT' => 'Ambiguous', 'EDT' => 'Ambiguous', 'EEST' => '+0300',
'EET' => '+0200', 'EETDST' => '+0300', 'EGST' => '+0000',
'EGT' => '-0100', 'EMT' => '+0100', 'EST' => 'Ambiguous',
'ESuT' => '+1100', 'F' => '+0600', 'FDT' => 'Ambiguous',
'FJST' => '+1300', 'FJT' => '+1200', 'FKST' => '-0300',
'FKT' => '-0400', 'FST' => 'Ambiguous', 'FWT' => '+0100',
'G' => '+0700', 'GALT' => '-0600', 'GAMT' => '-0900',
'GEST' => '+0500', 'GET' => '+0400', 'GFT' => '-0300',
'GILT' => '+1200', 'GMT' => '+0000', 'GST' => 'Ambiguous',
'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' => 'Ambiguous', 'IOT' => '+0500', 'IRDT' => '+0430',
'IRKST' => '+0900', 'IRKT' => '+0800', 'IRST' => '+0430',
'IRT' => '+0330', 'IST' => 'Ambiguous', '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' => 'Ambiguous', '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' => 'Ambiguous', 'NOR' => '+0100', 'NOVST' => '+0700',
'NOVT' => '+0600', 'NPT' => '+0545', 'NRT' => '+1200',
'NST' => 'Ambiguous', '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' => 'Ambiguous',
'PWT' => '+0900', 'PYST' => '-0300', 'PYT' => '-0400',
'Q' => '-0400', 'R' => '-0500', 'R1T' => '+0200',
'R2T' => '+0300', 'RET' => '+0400', 'ROK' => '+0900',
'S' => '-0600', 'SADT' => '+1030', 'SAST' => 'Ambiguous',
'SBT' => '+1100', 'SCT' => '+0400', 'SET' => '+0100',
'SGT' => '+0800', 'SRT' => '-0300', 'SST' => 'Ambiguous',
'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' => 'Ambiguous', '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' => 'Ambiguous',
'WTZ' => '-0100', 'WUT' => '+0100', 'X' => '-1100',
'Y' => '-1200', 'YAKST' => '+1000', 'YAKT' => '+0900',
'YAPT' => '+1000', 'YDT' => '-0800', 'YEKST' => '+0600',
'YEKT' => '+0500', 'YST' => '-0900', 'Z' => '+0000',
);
sub new {
my $class = shift;
my %args = validate( @_, { pattern => { type => SCALAR },
time_zone => { type => SCALAR | OBJECT, optional => 1 },
language => { type => SCALAR | OBJECT, optional => 1 },
locale => { type => SCALAR | OBJECT, default => 'English' },
on_error => { type => SCALAR | CODEREF, default => 'undef' },
diagnostic => { type => SCALAR, default => 0 },
}
);
if ( exists $args{ language } ) {
CORE::warn("Use of the language parameter in the DateTime::Strptime constructor is deprecated. Please use locale instead.");
$args{ locale } ||= delete $args{ language };
}
croak("The value supplied to on_error must be either 'croak', 'undef' or a code reference.")
unless ref($args{on_error}) eq 'CODE'
or $args{on_error} eq 'croak'
or $args{on_error} eq 'undef';
unless (ref ($args{locale})) {
my $locale = DateTime::Locale->load( $args{locale} );
croak("Could not create locale from $args{locale}") unless $locale;
$args{_locale} = $locale;
} else {
$args{_locale} = $args{locale};
($args{locale}) = ref($args{_locale}) =~/::(\w+)[^:]+$/
}
if ($args{time_zone}) {
unless (ref ($args{time_zone})) {
$args{time_zone} = DateTime::TimeZone->new( name => $args{time_zone} );
croak("Could not create time zone from $args{time_zone}") unless $args{time_zone};
}
$args{set_time_zone} = $args{time_zone};
} else {
$args{time_zone} = DateTime::TimeZone->new( name => 'UTC' );
$args{set_time_zone} = '';
}
my $self = bless \%args, $class;
$self->{parser} = $self->_build_parser($self->{pattern});
if ($self->{parser}=~/(%[^\/])/) {
croak("Unidentified token in pattern: $1 in $self->{pattern}");
}
return $self;
}
sub pattern {
my $self = shift;
my $pattern = shift;
if ($pattern) {
my $possible_pattern = $self->_build_parser($pattern);
if ($possible_pattern=~/(%\{\w+\}|%\w)/) {
$self->local_carp("Unidentified token in pattern: $1 in $pattern. Leaving old pattern intact.") and return undef;
} else {
$self->{parser} = $possible_pattern;
$self->{pattern} = $pattern;
}
}
return $self->{pattern};
}
sub locale {
my $self = shift;
my $locale = shift;
if ($locale) {
my $possible_locale = DateTime::Locale->load( $locale );
unless ($possible_locale) {
$self->local_carp("Could not create locale from $locale. Leaving old locale intact.") and return undef;
} else {
$self->{locale} = $locale;
$self->{_locale} = $possible_locale;
$self->{parser} = $self->_build_parser($self->{pattern});
}
}
return $self->{locale};
}
sub language {
CORE::warn("Use of the language method in DateTime::Strptime is deprecated. Please use locale instead.");
return locale(@_);
}
sub time_zone {
my $self = shift;
my $time_zone = shift;
if ($time_zone) {
my $possible_time_zone = DateTime::TimeZone->new( name => $time_zone );
unless ($possible_time_zone) {
$self->local_carp("Could not create time zone from $time_zone. Leaving old time zone intact.") and return undef;
} else {
$self->{time_zone} = $possible_time_zone;
$self->{set_time_zone} = $self->{time_zone};
}
}
return $self->{time_zone}->name;
}
sub parse_datetime {
my ( $self, $time_string ) = @_;
local $^W = undef;
my ( $dow_name, $month_name, $century, $day,
$hour_24, $hour_12, $doy, $month,
$minute, $ampm, $second, $week_sun_0,
$dow_sun_0, $dow_mon_1, $week_mon_1, $year_100,
$year, $iso_week_year_100, $iso_week_year,
$epoch, $tz_offset, $timezone, $tz_olson,
$nanosecond, $ce_year,
$doy_dt, $epoch_dt, $use_timezone,
);
my ( $Year, $Month, $Day,
$Hour, $Minute, $Second, $Nanosecond,
) = ();
my $parser = $self->{parser};
eval($parser);
die $@ if $@;
if ($self->{diagnostic}) {
print qq|
Entered = $time_string
Parser = $parser
dow_name = $dow_name
month_name = $month_name
century = $century
day = $day
hour_24 = $hour_24
hour_12 = $hour_12
doy = $doy
month = $month
minute = $minute
ampm = $ampm
second = $second
nanosecond = $nanosecond
week_sun_0 = $week_sun_0
dow_sun_0 = $dow_sun_0
dow_mon_1 = $dow_mon_1
week_mon_1 = $week_mon_1
year_100 = $year_100
year = $year
ce_year = $ce_year
tz_offset = $tz_offset
tz_olson = $tz_olson
timezone = $timezone
epoch = $epoch
iso_week_year = $iso_week_year
iso_week_year_100 = $iso_week_year_100
|;
}
$self->local_croak("Your datetime does not match your pattern.") and return undef
if (
($self->{parser}=~/\$dow_name\b/ and $dow_name eq '') or
($self->{parser}=~/\$month_name\b/ and $month_name eq '') or
($self->{parser}=~/\$century\b/ and $century eq '') or
($self->{parser}=~/\$day\b/ and $day eq '') or
($self->{parser}=~/\$hour_24\b/ and $hour_24 eq '') or
($self->{parser}=~/\$hour_12\b/ and $hour_12 eq '') or
($self->{parser}=~/\$doy\b/ and $doy eq '') or
($self->{parser}=~/\$month\b/ and $month eq '') or
($self->{parser}=~/\$minute\b/ and $minute eq '') or
($self->{parser}=~/\$ampm\b/ and $ampm eq '') or
($self->{parser}=~/\$second\b/ and $second eq '') or
($self->{parser}=~/\$nanosecond\b/ and $nanosecond eq '') or
($self->{parser}=~/\$week_sun_0\b/ and $week_sun_0 eq '') or
($self->{parser}=~/\$dow_sun_0\b/ and $dow_sun_0 eq '') or
($self->{parser}=~/\$dow_mon_1\b/ and $dow_mon_1 eq '') or
($self->{parser}=~/\$week_mon_1\b/ and $week_mon_1 eq '') or
($self->{parser}=~/\$year_100\b/ and $year_100 eq '') or
($self->{parser}=~/\$year\b/ and $year eq '') or
($self->{parser}=~/\$ce_year\b/ and $ce_year eq '') or
($self->{parser}=~/\$tz_offset\b/ and $tz_offset eq '') or
($self->{parser}=~/\$tz_olson\b/ and $tz_olson eq '') or
($self->{parser}=~/\$timezone\b/ and $timezone eq '') or
($self->{parser}=~/\$epoch\b/ and $epoch eq '')
);
if ($tz_offset) {
$use_timezone = $tz_offset;
}
if ($timezone) {
$self->local_croak("I don't recognise the timezone $timezone.") and return undef unless $ZONEMAP{$timezone};
$self->local_croak("The timezone '$timezone' is ambiguous.") and return undef if $ZONEMAP{$timezone} eq 'Ambiguous' and not ($tz_offset or $tz_olson);
$self->local_croak("Your timezones ('$tz_offset' and '$timezone') do not match.") and return undef if $tz_offset and $ZONEMAP{$timezone} ne 'Ambiguous' and $ZONEMAP{$timezone} != $tz_offset;
$use_timezone = $ZONEMAP{$timezone} if $ZONEMAP{$timezone} ne 'Ambiguous';
}
if ($tz_olson) {
$tz_olson = ucfirst lc $tz_olson;
$tz_olson =~ s|/(\w)|/\U$1|;
my $tz = DateTime::TimeZone->new( name => $tz_olson );
$self->local_croak("I don't recognise the time zone '$tz_olson'.") and return undef unless $tz;
$use_timezone = $tz;
}
$use_timezone = $self->{time_zone} unless ($use_timezone);
print "Using timezone $use_timezone.\n" if $self->{diagnostic};
if ($epoch) {
$epoch_dt = DateTime->from_epoch( epoch => $epoch, time_zone => $use_timezone );
$Year = $epoch_dt->year;
$Month = $epoch_dt->month;
$Day = $epoch_dt->day;
$Hour = $epoch_dt->hour;
$Minute = $epoch_dt->minute;
$Second = $epoch_dt->second;
$Nanosecond= $epoch_dt->nanosecond;
print $epoch_dt->strftime("Epoch: %D %T.%N\n") if $self->{diagnostic};
}
if ($year_100) {
if ($century) {
$Year = (($century * 100) - 0) + $year_100;
} else {
print "No century, guessing for $year_100" if $self->{diagnostic};
if ($year_100 >= 69 and $year_100 <= 99) {
print "Guessed 1900s" if $self->{diagnostic};
$Year = 1900 + $year_100;
} else {
print "Guessed 2000s" if $self->{diagnostic};
$Year = 2000 + $year_100;
}
}
}
if ($year) {
$self->local_croak("Your two year values ($year_100 and $year) do not match.") and return undef if ($Year && ($year != $Year));
$Year = $year;
}
if ($ce_year) {
$self->local_croak("Your two year values ($ce_year and $year) do not match.") and return undef if ($Year && ($ce_year != $Year));
$Year = $ce_year;
}
$self->local_croak("Your year value does not match your epoch.") and return undef if $epoch_dt and $Year and $Year != $epoch_dt->year;
if ($month_name) {
$self->local_croak("There is no use providing a month name ($month_name) without providing a year.") and return undef unless $Year;
my $month_count = 0;
my $month_number = 0;
foreach my $month (@{$self->{_locale}->month_names}) {
$month_count++;
if (lc $month eq lc $month_name) {
$month_number = $month_count;
last;
}
}
unless ($month_number) {
my $month_count = 0;
foreach my $month (@{$self->{_locale}->month_abbreviations}) {
$month_count++;
if (lc $month eq lc $month_name) {
$month_number = $month_count;
last;
}
}
}
unless ($month_number) {
$self->local_croak("$month_name is not a recognised month in this locale.") and return undef;
}
$Month = $month_number;
}
if ($month) {
$self->local_croak("There is no use providing a month without providing a year.") and return undef unless $Year;
$self->local_croak("$month is too large to be a month of the year.") and return undef unless $month <= 12;
$self->local_croak("Your two month values ($month_name and $month) do not match.") and return undef if $Month and $month != $Month;
$Month = $month;
}
$self->local_croak("Your month value does not match your epoch.") and return undef if $epoch_dt and $Month and $Month != $epoch_dt->month;
if ($doy) {
$self->local_croak("There is no use providing a day of the year without providing a year.") and return undef unless $Year;
$doy_dt = ($DateTime::VERSION > 0.12)
? DateTime->from_day_of_year(year=>$Year, day_of_year=>$doy, time_zone => $use_timezone)
: DateTime->new(year=>$Year, day=>$doy, time_zone => $use_timezone);
my $month = $doy_dt->month;
$self->local_croak("Your day of the year ($doy - in ".$doy_dt->month_name.") is not in your month ($Month)") and return undef if $Month and $month != $Month;
$Month = $month;
}
$self->local_croak("Your day of the year does not match your epoch.") and return undef if $epoch_dt and $doy_dt and $doy_dt->doy != $epoch_dt->doy;
$self->local_croak("$day is too large to be a day of the month.") and return undef unless $day <= 31;
$self->local_croak("Your day of the month ($day) does not match your day of the year.") and return undef if $doy_dt and $day and $day != $doy_dt->day;
$Day = ($day)
? $day
: ($doy_dt)
? $doy_dt->day
: '';
if ($Day) {
$self->local_croak("There is no use providing a day without providing a month and year.") and return undef unless $Year and $Month;
my $dt = DateTime->new(year=>$Year, month=>$Month, day=>$Day, time_zone => $use_timezone);
$self->local_croak("There is no day $Day in $dt->month_name, $Year") and return undef
unless $dt->month == $Month;
}
$self->local_croak("Your day of the month does not match your epoch.") and return undef if $epoch_dt and $Day and $Day != $epoch_dt->day;
$self->local_croak("$hour_24 is too large to be an hour of the day.") and return undef unless $hour_24 <= 23; $self->local_croak("$hour_12 is too large to be an hour of the day.") and return undef unless $hour_12 <= 12;
$self->local_croak("You must specify am or pm for 12 hour clocks ($hour_12|$ampm).") and return undef if ($hour_12 && (! $ampm));
if ($ampm=~/p/i) {
if ($hour_12) {
$hour_12 += 12 if $hour_12 and $hour_12 != 12;
}
$self->local_croak("Your am/pm value ($ampm) does not match your hour ($hour_24)") and return undef if $hour_24 and $hour_24 < 12;
} elsif ($ampm=~/a/i) {
if ($hour_12) {
$hour_12 = 0 if $hour_12 == 12;
}
$self->local_croak("Your am/pm value ($ampm) does not match your hour ($hour_24)") and return undef if $hour_24 >= 12;
}
if ($hour_12 and $hour_24) {
$self->local_croak("You have specified mis-matching 12 and 24 hour clock information") and return undef unless $hour_12 == $hour_24;
$Hour = $hour_24;
} elsif ($hour_12) {
$Hour = $hour_12;
} elsif ($hour_24) {
$Hour = $hour_24;
}
$self->local_croak("Your hour does not match your epoch.") and return undef if $epoch_dt and $Hour and $Hour != $epoch_dt->hour;
print "Set hour to $Hour.\n" if $self->{diagnostic};
$self->local_croak("$minute is too large to be a minute.") and return undef unless $minute <= 59;
$Minute = $minute;
$self->local_croak("Your minute does not match your epoch.") and return undef if $epoch_dt and $Minute and $Minute != $epoch_dt->minute;
print "Set minute to $Minute.\n" if $self->{diagnostic};
$self->local_croak("$second is too large to be a second.") and return undef unless $second <= 59; $Second = $second;
$self->local_croak("Your second does not match your epoch.") and return undef if $epoch_dt and $Second and $Second != $epoch_dt->second;
print "Set second to $Second.\n" if $self->{diagnostic};
$self->local_croak("$nanosecond is too large to be a nanosecond.") and return undef unless length($nanosecond) <= 9;
$Nanosecond = $nanosecond;
$Nanosecond .= '0' while length($Nanosecond) < 9;
print "Set nanosecond to $Nanosecond.\n" if $self->{diagnostic};
my $potential_return = DateTime->new(
year => ($Year || 1),
month => ($Month || 1),
day => ($Day || 1),
hour => ($Hour || 0),
minute => ($Minute || 0),
second => ($Second || 0),
nanosecond => ($Nanosecond || 0),
locale => $self->{_locale},
time_zone => $use_timezone,
);
$self->local_croak("Your day of the week ($dow_mon_1) does not match the date supplied: ".$potential_return->ymd) and return undef if $dow_mon_1 and $potential_return->dow != $dow_mon_1;
$self->local_croak("Your day of the week ($dow_sun_0) does not match the date supplied: ".$potential_return->ymd) and return undef if $dow_sun_0 and ($potential_return->dow % 7) != $dow_sun_0;
if ($dow_name) {
my $dow_count = 0;
my $dow_number = 0;
foreach my $dow (@{$self->{_locale}->day_names}) {
$dow_count++;
if (lc $dow eq lc $dow_name) {
$dow_number = $dow_count;
last;
}
}
unless ($dow_number) {
my $dow_count = 0;
foreach my $dow (@{$self->{_locale}->day_abbreviations}) {
$dow_count++;
if (lc $dow eq lc $dow_name) {
$dow_number = $dow_count;
last;
}
}
}
unless ($dow_number) {
$self->local_croak("$dow_name is not a recognised day in this locale.") and return undef;
}
$self->local_croak("Your day of the week ($dow_name) does not match the date supplied: ".$potential_return->ymd) and return undef if $dow_number and $potential_return->dow != $dow_number;
}
$self->local_croak("Your week number ($week_sun_0) does not match the date supplied: ".$potential_return->ymd) and return undef if $week_sun_0 and $potential_return->strftime('%U') != $week_sun_0;
$self->local_croak("Your week number ($week_mon_1) does not match the date supplied: ".$potential_return->ymd) and return undef if $week_mon_1 and $potential_return->strftime('%W') != $week_mon_1;
$self->local_croak("Your ISO week year ($iso_week_year) does not match the date supplied: ".$potential_return->ymd) and return undef if $iso_week_year and $potential_return->strftime('%G') != $iso_week_year;
$self->local_croak("Your ISO week year ($iso_week_year_100) does not match the date supplied: ".$potential_return->ymd) and return undef if $iso_week_year_100 and $potential_return->strftime('%g') != $iso_week_year_100;
print "Potential Datetime: " . $potential_return->strftime("%F %T %z %Z") . "\n" if $self->{diagnostic};
print "Setting timezone: " . $self->{set_time_zone} . "\n" if $self->{diagnostic};
$potential_return->set_time_zone($self->{set_time_zone}) if $self->{set_time_zone};
print "Actual Datetime: " . $potential_return->strftime("%F %T %z %Z") . "\n" if $self->{diagnostic};
return $potential_return;
}
sub parse_duration {
croak "DateTime::Format::Strptime doesn't do durations.";
}
sub format_datetime {
my ( $self, $dt ) = @_;
return $dt->strftime($self->pattern);
}
sub format_duration {
croak "DateTime::Format::Strptime doesn't do durations.";
}
sub _build_parser {
my $self = shift;
my $regex = my $field_list = shift;
my @fields = $field_list =~ m/(%\{\w+\}|%\d*.)/g;
$field_list = join('',@fields);
my $tempdt = DateTime->now();
my $ampm_list = join('|', @{$self->{_locale}->am_pms});
$ampm_list .= '|' . lc $ampm_list;
my $default_date_format = $self->{_locale}->default_date_format;
my @locale_format = $default_date_format =~ m/(%\{\w+\}|%\d*.)/g;
$default_date_format = join('',@locale_format);
my $default_time_format = $self->{_locale}->default_time_format;
@locale_format = $default_time_format =~ m/(%\{\w+\}|%\d*.)/g;
$default_time_format = join('',@locale_format);
my $default_datetime_format = $self->{_locale}->default_datetime_format;
@locale_format = $default_datetime_format =~ m/(%\{\w+\}|%\d*.)/g;
$default_datetime_format = join('',@locale_format);
print "Date format: $default_date_format\nTime format: $default_time_format\nDatetime format: $default_datetime_format\n" if $self->{diagnostic};
$regex =~ s/%c/$self->{_locale}->default_datetime_format/eg;
$field_list =~ s/%c/$default_datetime_format/eg;
$regex =~ s/%x/$self->{_locale}->default_date_format/eg;
$field_list =~ s/%x/$default_date_format/eg;
$regex =~ s/%X/$self->{_locale}->default_time_format/eg;
$field_list =~ s/%X/$default_time_format/eg;
$regex=~s|([\/\.\-])|\\$1|g;
$regex =~ s/%T/%H:%M:%S/g;
$field_list =~ s/%T/%H%M%S/g;
$regex =~ s/%r/%I:%M:%S %p/g;
$field_list =~ s/%r/%I%M%S%p/g;
$regex =~ s/%R/%H:%M/g;
$field_list =~ s/%R/%H%M/g;
$regex =~ s|%D|%m\\/%d\\/%y|g;
$field_list =~ s|%D|%m%d%y|g;
$regex =~ s|%F|%Y\\-%m\\-%d|g;
$field_list =~ s|%F|%Y%m%d|g;
$regex =~ s/%a/(\\w+)/gi;
$field_list =~ s/%a/
$regex =~ s/%[bBh]/([^\\s]+)/g;
$field_list =~ s/%[bBh]/
$regex =~ s/%C/([\\d ]?\\d)/g;
$field_list =~ s/%C/
$regex =~ s/%[de]/([\\d ]?\\d)/g;
$field_list =~ s/%[de]/
$regex =~ s/%[Hk]/([\\d ]?\\d)/g;
$field_list =~ s/%[Hk]/
$regex =~ s/%g/([\\d ]?\\d)/g;
$field_list =~ s/%g/
$regex =~ s/%G/(\\d{4})/g;
$field_list =~ s/%G/
$regex =~ s/%[Il]/([\\d ]?\\d)/g;
$field_list =~ s/%[Il]/
$regex =~ s/%j/(\\d{1,3})/g;
$field_list =~ s/%j/
$regex =~ s/%m/([\\d ]?\\d)/g;
$field_list =~ s/%m/
$regex =~ s/%M/([\\d ]?\\d)/g;
$field_list =~ s/%M/
$regex =~ s/%[nt]/\\s+/g;
$field_list =~ s/%[nt]//g;
$regex =~ s/%p/($ampm_list)/gi;
$field_list =~ s/%p/
$regex =~ s/%s/(\\d+)/g;
$field_list =~ s/%s/
$regex =~ s/%S/([\\d ]?\\d)/g;
$field_list =~ s/%S/
$regex =~ s/%(\d*)N/($1) ? "(\\d{$1})" : "(\\d+)"/eg;
$field_list =~ s/%\d*N/
$regex =~ s/%U/([\\d ]?\\d)/g;
$field_list =~ s/%U/
$regex =~ s/%w/([0-6])/g;
$field_list =~ s/%w/
$regex =~ s/%u/([1-7])/g;
$field_list =~ s/%u/
$regex =~ s/%W/([\\d ]?\\d)/g;
$field_list =~ s/%W/
$regex =~ s/%y/([\\d ]?\\d)/g;
$field_list =~ s/%y/
$regex =~ s/%Y/(\\d{4})/g;
$field_list =~ s/%Y/
$regex =~ s|%z|([+-]\\d{4})|g;
$field_list =~ s/%z/
$regex =~ s|%Z|(\\w+)|g;
$field_list =~ s/%Z/
$regex =~ s|%{(\w+)}|($tempdt->can($1)) ? "(.+)" : ".+"|eg;
$field_list =~ s|(%{(\w+)})|($tempdt->can($2)) ? "#$2#" : $1 |eg;
$regex =~ s/%%/%/g;
$field_list =~ s/%%//g;
$field_list=~s/ $field_list=~s/,\s*$//;
return qq|($field_list) = \$time_string =~ /$regex/|;
}
sub local_croak {
my $self = $_[0];
return &{$self->{on_error}}(@_) if ref($self->{on_error});
croak($_[1]) if $self->{on_error} eq 'croak';
$self->{errmsg} = $_[1];
return ($self->{on_error} eq 'undef');
}
sub local_carp {
my $self = $_[0];
return &{$self->{on_error}}(@_) if ref($self->{on_error});
carp($_[1]) if $self->{on_error} eq 'croak';
$self->{errmsg} = $_[1];
return ($self->{on_error} eq 'undef');
}
sub errmsg {
$_[0]->{errmsg};
}
sub strftime {
my ($pattern, $dt) = @_;
return $dt->strftime($pattern);
}
sub strptime {
my ($pattern, $time_string) = @_;
return DateTime::Format::Strptime->new( pattern => $pattern, on_error=>'croak' )->parse_datetime($time_string);
}
1;
__END__
=head1 NAME
DateTime::Format::Strptime - Parse and format strp and strf time patterns
=head1 SYNOPSIS
use DateTime::Format::Strptime;
my $Strp = new DateTime::Format::Strptime(
pattern => '%T',
locale => 'en_AU',
time_zone => 'Melbourne/Australia',
);
my $dt = $Strp->parse_datetime('23:16:42');
$Strp->format_datetime($dt);
# 23:16:42
# Stop croak so interactions work:
my $Strp = new DateTime::Format::Strptime(
pattern => '%T',
locale => 'en_AU',
time_zone => 'Melbourne/Australia',
on_error => 'undef',
);
$pattern = $CGI->param('user_pattern');
# This would normally croak with an invalid pattern:
$newpattern = $Strp->pattern($pattern);
unless $newpattern {
do_something_with($Strp->errmsg);
}
=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.
=head1 CONSTRUCTOR
=over 4
=item * new( pattern=>$strptime_pattern )
Creates the format object. You must specify a pattern, you can also
specify a C<time_zone> and a C<locale>. If you specify a time zone
then any resulting C<DateTime> object will be in that time zone. If you
do not specify a C<time_zone> parameter, but there is a time zone in the
string you pass to C<parse_datetime>, then the resulting C<DateTime> will
use that time zone.
You can optionally use an on_error parameter. This parameter has three
valid options:
=over 4
=item * 'undef'
(not undef, 'undef', it's a string not an undefined value)
This is the default behavior. The module will return undef whenever it
gets upset. The error can be accessed using the $object->errstr 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'
(not croak, 'croak', it's a string, not a function)
This used to be the default behaviour. The module will croak with an
error message whenever it gets upset.
=item * sub{...} or \&subname
When given a code ref, the module will call that sub when it gets upset.
The sub receives two parameters: the object and the error message. Using
these two it is possible to emulate the 'undef' behavior. (Returning a
true value causes the method to return undef. Returning a false value
causes the method to bravely continue):
sub{$_[0]->{errmsg} = $_[1]; 1},
=back
=back
=head1 METHODS
This class offers the following methods.
=over 4
=item * 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 on_error in the constructor.
=item * 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
strptime method.
=item * locale($locale)
=item * language($locale)
When given a locale, this method sets its locale appropriately. If
the locale is not understood, the method will croak or return undef
(depending on the setting of on_error in the constructor)
If successful this method returns the current locale. (After
processing as above).
For backwards compatability the language() method still exists. The
method is deprecated and you are advised to update. Using the language
method will result in a CORE::warn being generated.
=item * pattern($strptime_pattern)
When given a pattern, this method sets the object's pattern. If the
pattern is invalid, the method will croak or return undef (depending on
the value of $DateTime::Format::Strptime::CROAK)
If successful this method returns the current pattern. (After processing
as above)
=item * time_zone($time_zone)
When given a name, offset or C<DateTime::TimeZone> object, this method
sets the object's time zone. This effects the C<DateTime> object
returned by parse_datetime
If the time zone is invalid, the method will croak or return undef
(depending on the value of $DateTime::Format::Strptime::CROAK)
If successful this method returns the current pattern. (After processing
as above)
=item * errmsg
If the on_error behavior of the object is 'undef', error messages with
this method so you can work out why things went wrong.
This code emulates $DateTime::Format::Strptime::CROAK being true:
C<$Strp->pattern($pattern) or die $DateTime::Format::Strptime::errmsg>
=back
=head1 EXPORTS
There are no methods exported by default, however the following are
available:
=over 4
=item * strptime($strptime_pattern, $string)
Given a pattern and a string this function will return a new C<DateTime>
object.
=item * strftime($strftime_pattern, $datetime)
Given a pattern and a C<DateTime> object this function will return a
formatted string.
=back
=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 (1-31).
=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 %Y-%m-%d.)
=item * %g
The year corresponding to the ISO week number, but without the century
(0-99).
=item * %G
The year corresponding to the ISO week number.
=item * %H
The hour (0-23).
=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 (1-12).
=item * %M
The minute (0-59).
=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, values in the range 69-99 refer to years in the twen- tieth
century (1969-1999); values in the range 00-68 refer to years in the
twenty-first century (2000-2068).
=item * %Y
The 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]
=back
=head1 NOTES
=over 4
=item * on_error
Default behavior of this module is now to return undef on erroring.
=back
=head1 SUPPORT
Support for this module is provided via the datetime@perl.org email
list. See http://lists.perl.org/ for more details.
Alternatively, log them via the CPAN RT system via the web or email:
bug-datetime-format-strptime@rt.cpan.org
This makes it much easier for me to track things and thus means your
problem is less likely to be neglected.
=head1 LICENSE AND COPYRIGHT
Copyright E<169> Rick Measham, 2003. All rights reserved.
This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.
The full text of the licenses can be found in the F<LICENCE> file
included with this module.
=head1 AUTHOR
Rick Measham <rickm@cpan.org>
=head1 SEE ALSO
C<datetime@perl.org> mailing list.
http://datetime.perl.org/
L<perl>, L<DateTime>, L<DateTime::TimeZone>
=cut