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.0800';
@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 },
locale => { type => SCALAR | OBJECT, default => 'English' },
on_error => { type => SCALAR | CODEREF, default => 'undef' },
diagnostic => { type => SCALAR, default => 0 },
}
);
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';
# Deal with locale
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 => 'floating' );
$args{set_time_zone} = '';
}
my $self = bless \%args, $class;
# Deal with the parser
$self->{parser} = $self->_build_parser($args{pattern});
if ($self->{parser}=~/(%\{\w+\}|%\w)/ and $args{pattern} !~ /\%$1/) {
croak("Unidentified token in pattern: $1 in $self->{pattern}");
}
return $self;
}
sub pattern {
my $self = shift;
my $pattern = shift;
if ($pattern) {
my $possible_parser = $self->_build_parser($pattern);
if ($possible_parser=~/(%\{\w+\}|%\w)/ and $pattern !~ /\%$1/) {
$self->local_carp("Unidentified token in pattern: $1 in $pattern. Leaving old pattern intact.") and return undef;
} else {
$self->{parser} = $possible_parser;
$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;
# When the locale changes we need to rebuild the parser
$self->{parser} = $self->_build_parser($self->{pattern});
}
}
return $self->{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;
# Variables from the parser
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, $set_time_zone,
);
# Variables for DateTime
my ( $Year, $Month, $Day,
$Hour, $Minute, $Second, $Nanosecond,
$Am, $Pm
) = ();
# Run the parser
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 '')
);
# Create a timezone to work with
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)|$1\U$2|;
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 = $set_time_zone = $tz;
}
$use_timezone = $self->{time_zone} unless ($use_timezone);
print "Using timezone $use_timezone.\n" if $self->{diagnostic};
# If there's an epoch, we're done. Just need to check all the others
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};
}
# Work out the year we're working with:
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;
# Work out which month we want
# Month names
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++;
# use bytes;
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++;
# use bytes;
# When abbreviating, sometimes there's a period, sometimes not.
$month =~ s/\.$//; $month_name =~ s/\.$//;
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 = eval {
DateTime->from_day_of_year(year=>$Year, day_of_year=>$doy, time_zone => $use_timezone);
};
$self->local_croak("Day of year $Year-$doy is not valid") and return undef if $@;
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;
# Day of the month
$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 = eval {
DateTime->new(year=>$Year, month=>$Month, day=>$Day, hour=>12, time_zone => $use_timezone);
};
$self->local_croak("Datetime $Year-$Month-$Day is not a valid date") and return undef if $@;
$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;
# Hour of the day
$self->local_croak("$hour_24 is too large to be an hour of the day.") and return undef unless $hour_24 <= 23; #OK so leap seconds will break!
$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));
($Am, $Pm) = @{$self->{_locale}->am_pms};
if (lc $ampm eq lc $Pm) {
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 (lc $ampm eq lc $Am) {
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};
# Minutes
$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};
# Seconds
$self->local_croak("$second is too large to be a second.") and return undef unless $second <= 59; #OK so leap seconds will break!
$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};
# Nanoeconds
$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;
# Epoch doesn't return nanoseconds
# croak "Your nanosecond does not match your epoch." if $epoch_dt and $Nanosecond and $Nanosecond != $epoch_dt->nanosecond;
print "Set nanosecond to $Nanosecond.\n" if $self->{diagnostic};
my $potential_return = eval {
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("Datetime is not a valid date") and return undef if $@;
$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++;
use bytes;
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++;
use bytes;
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;
# Move into the timezone in the object - if there is one
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};
if ($self->{set_time_zone}) {
$potential_return->set_time_zone($self->{set_time_zone});
} elsif ($set_time_zone) {
$potential_return->set_time_zone($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 ) = @_;
my $pattern = $self->pattern;
$pattern =~ s/%O/$dt->time_zone->name/eg;
return $dt->strftime($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(); # Created just so we can do $tempdt->can(..)
# Locale-ize the parser
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/%%/ovnksdjhvniurnvkjsdhfbngkjsdbnhuyw678rhiuwf/g;
$field_list =~ s/%%/ovnksdjhvniurnvkjsdhfbngkjsdbnhuyw678rhiuwf/g;
$regex =~ s/%c/$self->{_locale}->default_datetime_format/eg;
$field_list =~ s/%c/$default_datetime_format/eg;
# %c is the locale's default datetime format.
$regex =~ s/%x/$self->{_locale}->default_date_format/eg;
$field_list =~ s/%x/$default_date_format/eg;
# %x id the locale's default date format.
$regex =~ s/%X/$self->{_locale}->default_time_format/eg;
$field_list =~ s/%X/$default_time_format/eg;
# %x id the locale's default time format.
# I'm absolutely certain there's a better way to do this:
#$regex=~s|([\/\.\-])|\\$1|g;
$regex = quotemeta( $regex );
$regex =~ s/(?<!\\)\\%/%/g;
$regex =~ s/%\\\{([^\}]+)\\\}/%{$1}/g;
$regex =~ s/%T/%H:%M:%S/g;
$field_list =~ s/%T/%H%M%S/g;
# %T is the time as %H:%M:%S.
$regex =~ s/%r/%I:%M:%S %p/g;
$field_list =~ s/%r/%I%M%S%p/g;
#is the time as %I:%M:%S %p.
$regex =~ s/%R/%H:%M/g;
$field_list =~ s/%R/%H%M/g;
#is the time as %H:%M.
$regex =~ s|%D|%m\\/%d\\/%y|g;
$field_list =~ s|%D|%m%d%y|g;
#is the same as %m/%d/%y.
$regex =~ s|%F|%Y\\-%m\\-%d|g;
$field_list =~ s|%F|%Y%m%d|g;
#is the same as %Y-%m-%d - the ISO date format.
my $day_re = join('|',
map { quotemeta $_ }
sort { length $b <=> length $a }
grep(/\W/, @{$self->{_locale}->day_names}, @{$self->{_locale}->day_abbreviations})
);
$day_re .= '|' if $day_re;
$regex =~ s/%a/($day_re\\w+)/gi;
$field_list =~ s/%a/#dow_name#/gi;
# %a is the day of the week, using the locale's weekday names; either the abbreviated or full name may be specified.
# %A is the same as %a.
my $month_re = join('|',
map { quotemeta $_ }
sort { length $b <=> length $a }
grep(/\s/, @{$self->{_locale}->month_names}, @{$self->{_locale}->month_abbreviations})
);
$month_re .= '|' if $month_re;
$regex =~ s/%[bBh]/($month_re\\S+)/g;
$field_list =~ s/%[bBh]/#month_name#/g;
#is the month, using the locale's month names; either the abbreviated or full name may be specified.
# %B is the same as %b.
# %h is the same as %b.
#s/%c//g;
#is replaced by the locale's appropriate date and time representation.
$regex =~ s/%C/([\\d ]?\\d)/g;
$field_list =~ s/%C/#century#/g;
#is the century number [0,99]; leading zeros are permitted by not required.
$regex =~ s/%[de]/([\\d ]?\\d)/g;
$field_list =~ s/%[de]/#day#/g;
#is the day of the month [1,31]; leading zeros are permitted but not required.
#%e is the same as %d.
$regex =~ s/%[Hk]/([\\d ]?\\d)/g;
$field_list =~ s/%[Hk]/#hour_24#/g;
#is the hour (24-hour clock) [0,23]; leading zeros are permitted but not required.
# %k is the same as %H
$regex =~ s/%g/([\\d ]?\\d)/g;
$field_list =~ s/%g/#iso_week_year_100#/g;
# The year corresponding to the ISO week number, but without the century (0-99).
$regex =~ s/%G/(\\d{4})/g;
$field_list =~ s/%G/#iso_week_year#/g;
# The year corresponding to the ISO week number.
$regex =~ s/%[Il]/([\\d ]?\\d)/g;
$field_list =~ s/%[Il]/#hour_12#/g;
#is the hour (12-hour clock) [1-12]; leading zeros are permitted but not required.
# %l is the same as %I.
$regex =~ s/%j/(\\d{1,3})/g;
$field_list =~ s/%j/#doy#/g;
#is the day of the year [1,366]; leading zeros are permitted but not required.
$regex =~ s/%m/([\\d ]?\\d)/g;
$field_list =~ s/%m/#month#/g;
#is the month number [1-12]; leading zeros are permitted but not required.
$regex =~ s/%M/([\\d ]?\\d)/g;
$field_list =~ s/%M/#minute#/g;
#is the minute [0-59]; leading zeros are permitted but not required.
$regex =~ s/%[nt]/\\s+/g;
$field_list =~ s/%[nt]//g;
# %n is any white space.
# %t is any white space.
$regex =~ s/%p/($ampm_list)/gi;
$field_list =~ s/%p/#ampm#/gi;
# %p is the locale's equivalent of either A.M./P.M. indicator for 12-hour clock.
$regex =~ s/%s/(\\d+)/g;
$field_list =~ s/%s/#epoch#/g;
# %s is the seconds since the epoch
$regex =~ s/%S/([\\d ]?\\d)/g;
$field_list =~ s/%S/#second#/g;
# %S is the seconds [0-61]; leading zeros are permitted but not required.
$regex =~ s/%(\d*)N/($1) ? "(\\d{$1})" : "(\\d+)"/eg;
$field_list =~ s/%\d*N/#nanosecond#/g;
# %N is the nanoseconds (or sub seconds really)
$regex =~ s/%U/([\\d ]?\\d)/g;
$field_list =~ s/%U/#week_sun_0#/g;
# %U is the week number of the year (Sunday as the first day of the week) as a decimal number [0-53]; leading zeros are permitted but not required.
$regex =~ s/%w/([0-6])/g;
$field_list =~ s/%w/#dow_sun_0#/g;
# is the weekday as a decimal number [0-6], with 0 representing Sunday.
$regex =~ s/%u/([1-7])/g;
$field_list =~ s/%u/#dow_mon_1#/g;
# is the weekday as a decimal number [1-7], with 1 representing Monday - a la DateTime.
$regex =~ s/%W/([\\d ]?\\d)/g;
$field_list =~ s/%W/#week_mon_1#/g;
#is the week number of the year (Monday as the first day of the week) as a decimal number [0,53]; leading zeros are permitted but not required.
$regex =~ s/%y/([\\d ]?\\d)/g;
$field_list =~ s/%y/#year_100#/g;
# is the year within the century. When a century is not otherwise specified, values in the range 69-99 refer to years in the twentieth century (1969 to 1999 inclusive); values in the range 0-68 refer to years in the twenty-first century (2000-2068 inclusive). Leading zeros are permitted but not required.
$regex =~ s/%Y/(\\d{4})/g;
$field_list =~ s/%Y/#year#/g;
# is the year including the century (for example, 1998).
$regex =~ s|%z|([+-]\\d{4})|g;
$field_list =~ s/%z/#tz_offset#/g;
# Timezone Offset.
$regex =~ s|%Z|(\\w+)|g;
$field_list =~ s/%Z/#timezone#/g;
# The short timezone name.
$regex =~ s|%O|(\\w+\\/\\w+)|g;
$field_list =~ s/%O/#tz_olson#/g;
# The Olson timezone name.
$regex =~ s|%{(\w+)}|($tempdt->can($1)) ? "(.+)" : ".+"|eg;
$field_list =~ s|(%{(\w+)})|($tempdt->can($2)) ? "#$2#" : $1 |eg;
# Any function in DateTime.
$regex =~ s/ovnksdjhvniurnvkjsdhfbngkjsdbnhuyw678rhiuwf/\\%/g;
$field_list =~ s/ovnksdjhvniurnvkjsdhfbngkjsdbnhuyw678rhiuwf//g;
# is replaced by %.
#print $regex;
$field_list=~s/#([a-z0-9_]+)#/\$$1, /gi;
$field_list=~s/,\s*$//;
return qq|($field_list) = \$time_string =~ /$regex/|;
}
# Utility functions
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};
}
# Exportable functions:
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 => 'Australia/Melbourne',
);
my $dt = $Strp->parse_datetime('23:16:42');
$Strp->format_datetime($dt);
# 23:16:42
# Croak when things go wrong:
my $Strp = new DateTime::Format::Strptime(
pattern => '%T',
locale => 'en_AU',
time_zone => 'Australia/Melbourne',
on_error => 'croak',
);
$newpattern = $Strp->pattern('%Q');
# Unidentified token in pattern: %Q in %Q at line 34 of script.pl
# Do something else when things go wrong:
my $Strp = new DateTime::Format::Strptime(
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.
=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
strftime method.
=item * locale($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).
=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 the C<on_error> parameter)
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 the C<on_error> parameter)
If successful this method returns the current time zone. (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 a C<$DateTime::Format::Strptime> with
the C<on_error> parameter equal to C<'croak'>:
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 %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 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]
=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 RESOURCES
=over 4
=item * Mailing List
Support for this module is primarily provided via the DateTime
Mailing List: C<datetime@perl.org>
http://lists.cpan.org/showlist.cgi?name=datetime
=item * Bugtracker
For bug tracking and reporting, please use the google-code tracker
rather than the RT interface linked at search.cpan.org
http://code.google.com/p/datetime-format-strptime/issues/list
=item * Homepage
http://datetime-format-strptime.googlecode.com/
=item * Subversion Repository
The latest version is always available via subversion:
http://datetime-format-strptime.googlecode.com/svn/trunk/
=back
=head1 LICENSE AND COPYRIGHT
Copyright E<169> Rick Measham, 2003-2007. 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