package DateTime::Format::ISO8601;
use strict;
use warnings;
use vars qw( $VERSION );
$VERSION = '0.07';
use Carp qw( croak );
use DateTime;
use DateTime::Format::Builder;
use Params::Validate qw( validate validate_pos BOOLEAN OBJECT SCALAR );
{
my $default_legacy_year;
sub DefaultLegacyYear {
my $class = shift;
( $default_legacy_year ) = validate_pos( @_,
{
type => BOOLEAN,
callbacks => {
'is 0, 1, or undef' =>
sub { ! defined( $_[0] ) || $_[0] == 0 || $_[0] == 1 },
},
}
) if @_;
return $default_legacy_year;
}
}
__PACKAGE__->DefaultLegacyYear( 1 );
{
my $default_cut_off_year;
sub DefaultCutOffYear {
my $class = shift;
( $default_cut_off_year ) = validate_pos( @_,
{
type => SCALAR,
callbacks => {
'is between 0 and 99' =>
sub { $_[0] >= 0 && $_[0] <= 99 },
},
}
) if @_;
return $default_cut_off_year;
}
}
__PACKAGE__->DefaultCutOffYear( 49 );
sub new {
my( $class ) = shift;
my %args = validate( @_,
{
base_datetime => {
type => OBJECT,
can => 'utc_rd_values',
optional => 1,
},
legacy_year => {
type => BOOLEAN,
default => $class->DefaultLegacyYear,
callbacks => {
'is 0, 1, or undef' =>
sub { ! defined( $_[0] ) || $_[0] == 0 || $_[0] == 1 },
},
},
cut_off_year => {
type => SCALAR,
default => $class->DefaultCutOffYear,
callbacks => {
'is between 0 and 99' =>
sub { $_[0] >= 0 && $_[0] <= 99 },
},
},
}
);
$class = ref( $class ) || $class;
my $self = bless( \%args, $class );
if ( $args{ base_datetime } ) {
$self->set_base_datetime( object => $args{ base_datetime } );
}
return( $self );
}
sub clone { bless { %{ $_[0] } }, ref $_[0] }
sub base_datetime { $_[0]->{ base_datetime } }
sub set_base_datetime {
my $self = shift;
my %args = validate( @_,
{
object => {
type => OBJECT,
can => 'utc_rd_values',
},
}
);
my $dt = DateTime->from_object( object => $args{ object } );
my $lower_bound = DateTime->new( year => 0 );
my $upper_bound = DateTime->new( year => 10000 );
if ( $dt < $lower_bound ) {
croak "base_datetime must be greater then or equal to ",
$lower_bound->iso8601;
}
if ( $dt >= $upper_bound ) {
croak "base_datetime must be less then ", $upper_bound->iso8601;
}
$self->{ base_datetime } = $dt;
return $self;
}
sub legacy_year { $_[0]->{ legacy_year } }
sub set_legacy_year {
my $self = shift;
my @args = validate_pos( @_,
{
type => BOOLEAN,
callbacks => {
'is 0, 1, or undef' =>
sub { ! defined( $_[0] ) || $_[0] == 0 || $_[0] == 1 },
},
}
);
$self->{ legacy_year } = $args[0];
return $self;
}
sub cut_off_year { $_[0]->{ cut_off_year } }
sub set_cut_off_year {
my $self = shift;
my @args = validate_pos( @_,
{
type => SCALAR,
callbacks => {
'is between 0 and 99' =>
sub { $_[0] >= 0 && $_[0] <= 99 },
},
}
);
$self->{ cut_off_year } = $args[0];
return $self;
}
DateTime::Format::Builder->create_class(
parsers => {
parse_datetime => [
{
length => 8,
regex => qr/^ (\d{4}) (\d\d) (\d\d) $/x,
params => [ qw( year month day ) ],
},
{
length => 10,
regex => qr/^ (\d{4}) - (\d\d) - (\d\d) $/x,
params => [ qw( year month day ) ],
},
{
length => 7,
regex => qr/^ (\d{4}) - (\d\d) $/x,
params => [ qw( year month ) ],
},
{
length => 4,
regex => qr/^ (\d{4}) $/x,
params => [ qw( year ) ],
},
{
length => 2,
regex => qr/^ (\d\d) $/x,
params => [ qw( year ) ],
postprocess => \&_normalize_century,
},
{
length => [ qw( 6 8 ) ],
regex => qr/^ (\d\d) -?? (\d\d) -?? (\d\d) $/x,
params => [ qw( year month day ) ],
postprocess => \&_fix_2_digit_year,
},
{
length => [ qw( 5 6 ) ],
regex => qr/^ - (\d\d) -?? (\d\d) $/x,
params => [ qw( year month ) ],
postprocess => \&_fix_2_digit_year,
},
{
length => 3,
regex => qr/^ - (\d\d) $/x,
params => [ qw( year ) ],
postprocess => \&_fix_2_digit_year,
},
{
length => [ qw( 6 7 ) ],
regex => qr/^ -- (\d\d) -?? (\d\d) $/x,
params => [ qw( month day ) ],
postprocess => \&_add_year,
},
{
length => 4,
regex => qr/^ -- (\d\d) $/x,
params => [ qw( month ) ],
postprocess => \&_add_year,
},
{
length => 5,
regex => qr/^ --- (\d\d) $/x,
params => [ qw( day ) ],
postprocess => [ \&_add_year, \&_add_month ],
},
{
length => [ qw( 11 13 ) ],
regex => qr/^ \+ (\d{6}) -?? (\d\d) -?? (\d\d) $/x,
params => [ qw( year month day ) ],
},
{
length => 10,
regex => qr/^ \+ (\d{6}) - (\d\d) $/x,
params => [ qw( year month ) ],
},
{
length => 7,
regex => qr/^ \+ (\d{6}) $/x,
params => [ qw( year ) ],
},
{
length => 5,
regex => qr/^ \+ (\d{4}) $/x,
params => [ qw( year ) ],
postprocess => \&_normalize_century,
},
{
length => [ qw( 7 8 ) ],
regex => qr/^ (\d{4}) -?? (\d{3}) $/x,
params => [ qw( year day_of_year ) ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => [ qw( 5 6 ) ],
regex => qr/^ (\d\d) -?? (\d{3}) $/x,
params => [ qw( year day_of_year ) ],
postprocess => [ \&_fix_2_digit_year ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => 4,
regex => qr/^ - (\d{3}) $/x,
params => [ qw( day_of_year ) ],
postprocess => [ \&_add_year ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => [ qw( 10 11 ) ],
regex => qr/^ \+ (\d{6}) -?? (\d{3}) $/x,
params => [ qw( year day_of_year ) ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => [ qw( 8 10 ) ],
regex => qr/^ (\d{4}) -?? W (\d\d) -?? (\d) $/x,
params => [ qw( year week day_of_year ) ],
postprocess => [ \&_normalize_week ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => [ qw( 7 8 ) ],
regex => qr/^ (\d{4}) -?? W (\d\d) $/x,
params => [ qw( year week ) ],
postprocess => [ \&_normalize_week ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => [ qw( 6 8 ) ],
regex => qr/^ (\d\d) -?? W (\d\d) -?? (\d) $/x,
params => [ qw( year week day_of_year ) ],
postprocess => [ \&_fix_2_digit_year, \&_normalize_week ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => [ qw( 5 6 ) ],
regex => qr/^ (\d\d) -?? W (\d\d) $/x,
params => [ qw( year week ) ],
postprocess => [ \&_fix_2_digit_year, \&_normalize_week ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => [ qw( 6 8 ) ],
regex => qr/^ - (\d) -?? W (\d\d) -?? (\d) $/x,
params => [ qw( year week day_of_year ) ],
postprocess => [ \&_fix_1_digit_year, \&_normalize_week ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => [ qw( 5 6 ) ],
regex => qr/^ - (\d) -?? W (\d\d) $/x,
params => [ qw( year week ) ],
postprocess => [ \&_fix_1_digit_year, \&_normalize_week ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => [ qw( 5 6 ) ],
regex => qr/^ - W (\d\d) -?? (\d) $/x,
params => [ qw( week day_of_year ) ],
postprocess => [ \&_add_year, \&_normalize_week ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => 4,
regex => qr/^ - W (\d\d) $/x,
params => [ qw( week ) ],
postprocess => [ \&_add_year, \&_normalize_week ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => 4,
regex => qr/^ - W - (\d) $/x,
params => [ qw( day_of_year ) ],
postprocess => [
\&_add_year,
\&_add_week,
\&_normalize_week,
],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => [ qw( 11 13 ) ],
regex => qr/^ \+ (\d{6}) -?? W (\d\d) -?? (\d) $/x,
params => [ qw( year week day_of_year ) ],
postprocess => [ \&_normalize_week ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => [ qw( 10 11 ) ],
regex => qr/^ \+ (\d{6}) -?? W (\d\d) $/x,
params => [ qw( year week ) ],
postprocess => [ \&_normalize_week ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => [ qw( 8 9 ) ],
regex => qr/^ T?? (\d\d) : (\d\d) : (\d\d) $/x,
params => [ qw( hour minute second) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day
],
},
{
length => [ qw( 4 5 6 ) ],
regex => qr/^ T?? (\d\d) :?? (\d\d) $/x,
params => [ qw( hour minute ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day
],
},
{
regex => qr/^ T?? (\d\d) :?? (\d\d) :?? (\d\d) [\.,] (\d+) $/x,
params => [ qw( hour minute second nanosecond) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
\&_fractional_second
],
},
{
regex => qr/^ T?? (\d\d) :?? (\d\d) [\.,] (\d+) $/x,
params => [ qw( hour minute second ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
\&_fractional_minute
],
},
{
regex => qr/^ T?? (\d\d) [\.,] (\d+) $/x,
params => [ qw( hour minute ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
\&_fractional_hour
],
},
{
length => 6,
regex => qr/^ - (\d\d) : (\d\d) $/x,
params => [ qw( minute second ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
\&_add_hour
],
},
{
regex => qr/^ - (\d\d) :?? (\d\d) [\.,] (\d+) $/x,
params => [ qw( minute second nanosecond ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
\&_add_hour,
\&_fractional_second
],
},
{
regex => qr/^ - (\d\d) [\.,] (\d+) $/x,
params => [ qw( minute second ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
\&_add_hour,
\&_fractional_minute
],
},
{
regex => qr/^ -- (\d\d) [\.,] (\d+) $/x,
params => [ qw( second nanosecond) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
\&_add_hour,
\&_add_minute,
\&_fractional_second,
],
},
{
length => [ qw( 7 8 9 10 ) ],
regex => qr/^ T?? (\d\d) :?? (\d\d) :?? (\d\d) Z $/x,
params => [ qw( hour minute second ) ],
extra => { time_zone => 'UTC' },
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
],
},
{
regex => qr/^ T?? (\d\d) :?? (\d\d) :?? (\d\d) [\.,] (\d+) Z $/x,
params => [ qw( hour minute second nanosecond) ],
extra => { time_zone => 'UTC' },
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
\&_fractional_second
],
},
{
length => [ qw( 5 6 7 ) ],
regex => qr/^ T?? (\d\d) :?? (\d\d) Z $/x,
params => [ qw( hour minute ) ],
extra => { time_zone => 'UTC' },
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
],
},
{
length => [ qw( 3 4 ) ],
regex => qr/^ T?? (\d\d) Z $/x,
params => [ qw( hour ) ],
extra => { time_zone => 'UTC' },
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
],
},
{
length => [ qw( 11 12 14 15 ) ],
regex => qr/^ T?? (\d\d) :?? (\d\d) :?? (\d\d)
([+-] \d\d :?? \d\d) $/x,
params => [ qw( hour minute second time_zone ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
\&_normalize_offset,
],
},
{
regex => qr/^ T?? (\d\d) :?? (\d\d) :?? (\d\d) [\.,] (\d+)
([+-] \d\d :?? \d\d) $/x,
params => [ qw( hour minute second nanosecond time_zone ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
\&_fractional_second,
\&_normalize_offset,
],
},
{
length => [ qw( 9 10 11 12 ) ],
regex => qr/^ T?? (\d\d) :?? (\d\d) :?? (\d\d)
([+-] \d\d) $/x,
params => [ qw( hour minute second time_zone ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
\&_normalize_offset,
],
},
{
length => [ qw( 15 19 ) ],
regex => qr/^ (\d{4}) -?? (\d\d) -?? (\d\d)
T (\d\d) :?? (\d\d) :?? (\d\d) $/x,
params => [ qw( year month day hour minute second ) ],
extra => { time_zone => 'floating' },
},
{
regex => qr/^ (\d{4}) -?? (\d\d) -?? (\d\d)
T (\d\d) :?? (\d\d) :?? (\d\d) [\.,] (\d+) $/x,
params => [ qw( year month day hour minute second nanosecond ) ],
extra => { time_zone => 'floating' },
postprocess => [
\&_fractional_second,
],
},
{
length => [ qw( 16 20 ) ],
regex => qr/^ (\d{4}) -?? (\d\d) -?? (\d\d)
T (\d\d) :?? (\d\d) :?? (\d\d) Z $/x,
params => [ qw( year month day hour minute second ) ],
extra => { time_zone => 'UTC' },
},
{
regex => qr/^ (\d{4}) -?? (\d\d) -?? (\d\d)
T?? (\d\d) :?? (\d\d) :?? (\d\d) [\.,] (\d+)
Z$/x,
params => [ qw( year month day hour minute second nanosecond ) ],
extra => { time_zone => 'UTC' },
postprocess => [
\&_fractional_second,
],
},
{
length => [ qw( 20 25 ) ],
regex => qr/^ (\d{4}) -?? (\d\d) -?? (\d\d)
T (\d\d) :?? (\d\d) :?? (\d\d) ([+-] \d\d :?? \d\d) $/x,
params => [ qw( year month day hour minute second time_zone ) ],
postprocess => \&_normalize_offset,
},
{
regex => qr/^ (\d{4}) -?? (\d\d) -?? (\d\d)
T?? (\d\d) :?? (\d\d) :?? (\d\d) [\.,] (\d+)
([+-] \d\d :?? \d\d) $/x,
params => [ qw( year month day hour minute second nanosecond time_zone ) ],
postprocess => [
\&_fractional_second,
\&_normalize_offset,
],
},
{
length => [ qw( 18 22 ) ],
regex => qr/^ (\d{4}) -?? (\d\d) -?? (\d\d)
T (\d\d) :?? (\d\d) :?? (\d\d) ([+-] \d\d) $/x,
params => [ qw( year month day hour minute second time_zone ) ],
postprocess => \&_normalize_offset,
},
{
length => [ qw( 13 16 ) ],
regex => qr/^ (\d{4}) -?? (\d\d) -?? (\d\d)
T (\d\d) :?? (\d\d) $/x,
params => [ qw( year month day hour minute ) ],
extra => { time_zone => 'floating' },
},
{
length => [ qw( 13 15 ) ],
regex => qr/^ (\d{4}) -?? (\d{3}) T
(\d\d) :?? (\d\d) Z $/x,
params => [ qw( year day_of_year hour minute ) ],
extra => { time_zone => 'UTC' },
constructor => [ 'DateTime', 'from_day_of_year' ],
},
{
length => [ qw( 18 19 ) ],
regex => qr/^ (\d{4}) -?? W (\d\d) -?? (\d)
T (\d\d) :?? (\d\d) ([+-] \d{2,4}) $/x,
params => [ qw( year week day_of_year hour minute time_zone) ],
postprocess => [ \&_normalize_week, \&_normalize_offset ],
constructor => [ 'DateTime', 'from_day_of_year' ],
},
],
parse_time => [
{
length => [ qw( 6 7 ) ],
regex => qr/^ T?? (\d\d) (\d\d) (\d\d) $/x,
params => [ qw( hour minute second ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
],
},
{
length => [ qw( 4 5 ) ],
regex => qr/^ T?? (\d\d) (\d\d) $/x,
params => [ qw( hour minute ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
],
},
{
length => [ qw( 2 3 ) ],
regex => qr/^ T?? (\d\d) $/x,
params => [ qw( hour ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
],
},
{
length => 5,
regex => qr/^ - (\d\d) (\d\d) $/x,
params => [ qw( minute second ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
\&_add_hour,
],
},
{
length => 3,
regex => qr/^ - (\d\d) $/x,
params => [ qw( minute ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
\&_add_hour,
],
},
{
length => 4,
regex => qr/^ -- (\d\d) $/x,
params => [ qw( second ) ],
postprocess => [
\&_add_year,
\&_add_month,
\&_add_day,
\&_add_hour,
\&_add_minute,
],
},
],
}
);
sub _fix_1_digit_year {
my %p = @_;
no strict 'refs';
my $year = ( $p{ self }{ base_datetime } || DateTime->now )->year;
use strict;
$year =~ s/.$//;
$p{ parsed }{ year } = $year . $p{ parsed }{ year };
return 1;
}
sub _fix_2_digit_year {
my %p = @_;
no strict 'refs';
if ( exists $p{ self }{ legacy_year } ) {
if ( $p{ self }{ legacy_year } ) {
my $cutoff = exists $p{ self }{ cut_off_year }
? $p{ self }{ cut_off_year } : $p{ self }->DefaultCutOffYear;
$p{ parsed }{ year } += $p{ parsed }{ year } > $cutoff ? 1900 : 2000;
} else {
my $century = ( $p{ self }{ base_datetime } || DateTime->now )->strftime( '%C' );
$p{ parsed }{ year } += $century * 100;
}
} else {
my $cutoff = exists $p{ self }{ cut_off_year }
? $p{ self }{ cut_off_year } : $p{ self }->DefaultCutOffYear;
$p{ parsed }{ year } += $p{ parsed }{ year } > $cutoff ? 1900 : 2000;
}
use strict;
return 1;
}
sub _add_minute {
my %p = @_;
no strict 'refs';
$p{ parsed }{ minute } = ( $p{ self }{ base_datetime } || DateTime->now )->minute;
use strict;
return 1;
}
sub _add_hour {
my %p = @_;
no strict 'refs';
$p{ parsed }{ hour } = ( $p{ self }{ base_datetime } || DateTime->now )->hour;
use strict;
return 1;
}
sub _add_day {
my %p = @_;
no strict 'refs';
$p{ parsed }{ day } = ( $p{ self }{ base_datetime } || DateTime->now )->day;
use strict;
return 1;
}
sub _add_week {
my %p = @_;
no strict 'refs';
$p{ parsed }{ week } = ( $p{ self }{ base_datetime } || DateTime->now )->week;
use strict;
return 1;
}
sub _add_month {
my %p = @_;
no strict 'refs';
$p{ parsed }{ month } = ( $p{ self }{ base_datetime } || DateTime->now )->month;
use strict;
return 1;
}
sub _add_year {
my %p = @_;
no strict 'refs';
$p{ parsed }{ year } = ( $p{ self }{ base_datetime } || DateTime->now )->year;
use strict;
return 1;
}
sub _fractional_second {
my %p = @_;
$p{ parsed }{ nanosecond } = ".$p{ parsed }{ nanosecond }" * 10**9;
return 1;
}
sub _fractional_minute {
my %p = @_;
$p{ parsed }{ second } = ".$p{ parsed }{ second }" * 60;
return 1;
}
sub _fractional_hour {
my %p = @_;
$p{ parsed }{ minute } = ".$p{ parsed }{ minute }" * 60;
return 1;
}
sub _normalize_offset {
my %p = @_;
$p{ parsed }{ time_zone } =~ s/://;
if( length $p{ parsed }{ time_zone } == 3 ) {
$p{ parsed }{ time_zone } .= '00';
}
return 1;
}
sub _normalize_week {
my %p = @_;
my $dt = DateTime->new(
year => $p{ parsed }{ year },
);
if ( $dt->week_number == 1 ) {
$p{ parsed }{ week } -= 1;
}
$p{ parsed }{ week } *= 7;
if( defined $p{ parsed }{ day_of_year } ) {
$p{ parsed }{ week } -= $dt->day_of_week -1;
}
$p{ parsed }{ day_of_year } += $p{ parsed }{ week };
delete $p{ parsed }{ week };
return 1;
}
sub _normalize_century {
my %p = @_;
$p{ parsed }{ year } .= '01';
return 1;
}
1;
__END__