DateTime-Format-Builder-0.81/0000775000175000017500000000000012126724561015620 5ustar autarchautarchDateTime-Format-Builder-0.81/MANIFEST0000644000175000017500000000167012126724561016753 0ustar autarchautarchChanges INSTALL LICENSE MANIFEST META.json META.yml Makefile.PL README dist.ini examples/Apache.pm examples/Fall.pm examples/ICal.pm examples/MySQL.pm examples/Simple.pm examples/Tivoli.pm examples/W3CDTF.pm lib/DateTime/Format/Builder.pm lib/DateTime/Format/Builder/Parser.pm lib/DateTime/Format/Builder/Parser/Dispatch.pm lib/DateTime/Format/Builder/Parser/Quick.pm lib/DateTime/Format/Builder/Parser/Regex.pm lib/DateTime/Format/Builder/Parser/Strptime.pm lib/DateTime/Format/Builder/Parser/generic.pm lib/DateTime/Format/Builder/Tutorial.pod t/99pod.t t/altcon.t t/basic.t t/clone.t t/create.t t/dispatch.t t/extra.t t/fall.t t/import.t t/lengths.t t/memory-cycle.t t/mergecb.t t/newclass.t t/nocon.t t/noredef.t t/on_fail.t t/on_fail_regex.t t/on_fail_sub.t t/param.t t/quick.t t/release-cpan-changes.t t/release-eol.t t/release-no-tabs.t t/release-pod-linkcheck.t t/release-pod-syntax.t t/self.t t/strptime.t t/taint.t t/verbose.t t/wholeclass.t DateTime-Format-Builder-0.81/t/0000775000175000017500000000000012126724561016063 5ustar autarchautarchDateTime-Format-Builder-0.81/t/self.t0000644000175000017500000000337512126724561017207 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; { my $sample = 'SampleClassWithSelf'; DateTime::Format::Builder->create_class( class => $sample, parsers => { parse_datetime => [ [ preprocess => sub { my %p = @_; my $self = $p{self}; $p{parsed}->{time_zone} = $self->{global} if $self->{global}; return $p{input}; }, ], { params => [qw( year month day hour minute second )], regex => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)(\d\d)(\d\d)$/, preprocess => sub { my %p = @_; my $self = $p{self}; $p{parsed}->{time_zone} = $self->{pre} if $self->{pre}; return $p{input}; }, postprocess => sub { my %p = @_; my $self = $p{self}; $p{parsed}->{time_zone} = $self->{post} if $self->{post}; return 1; }, }, ], } ); my %tests = ( global => 'Africa/Cairo', pre => 'Europe/London', post => 'Australia/Sydney', ); while ( my ( $callback, $value ) = each %tests ) { my $parser = $sample->new(); $parser->{$callback} = $value; my $dt = $parser->parse_datetime("20030716T163245"); is( $dt->time_zone->name, $value ); } } done_testing(); DateTime-Format-Builder-0.81/t/strptime.t0000644000175000017500000000205412126724561020116 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; my @tests = ( # Simple dates [ '%Y-%m-%d', '1998-12-31' ], [ '%y-%m-%d', '98-12-31' ], [ '%Y years, %j days', '1998 years, 312 days' ], [ '%b %d, %Y', 'Jan 24, 2003' ], [ '%B %d, %Y', 'January 24, 2003' ], # Simple times [ '%H:%M:%S', '23:45:56' ], [ '%l:%M:%S %p', '12:34:56 PM' ], # With Nanoseconds [ '%H:%M:%S.%N', '23:45:56.123456789' ], [ '%H:%M:%S.%6N', '23:45:56.123456' ], [ '%H:%M:%S.%3N', '23:45:56.123' ], # Complex dates [ '%Y;%j = %Y-%m-%d', '2003;056 = 2003-02-25' ], [ q|%d %b '%y = %Y-%m-%d|, q|25 Feb '03 = 2003-02-25| ], ); for my $test (@tests) { my ( $pattern, $data ) = @$test; my $parser = DateTime::Format::Builder->create_parser( strptime => $pattern ); my $parsed = $parser->parse( 'DateTime::Format::Builder', $data ); isa_ok( $parsed => 'DateTime' ); is( $parsed->strftime($pattern) => $data, $pattern ); } done_testing(); DateTime-Format-Builder-0.81/t/99pod.t0000644000175000017500000000023412126724561017211 0ustar autarchautarchuse strict; use warnings; use Test::More; eval "use Test::Pod 1.00"; plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; all_pod_files_ok(); DateTime-Format-Builder-0.81/t/mergecb.t0000644000175000017500000000245112126724561017654 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder::Parser; { my $new_sub = sub { my $x = shift; sub { $_[1] . $x } }; my @cbs = ( map { $new_sub->($_) } qw( a b c d e f g ) ); my $cb = DateTime::Format::Builder::Parser->merge_callbacks(@cbs); is( $cb->( input => "x" ) => "xabcdefg", "Callback chaining works." ); my $cbr = DateTime::Format::Builder::Parser->merge_callbacks( \@cbs ); is( $cbr->( input => "x" ) => "xabcdefg", "Callback chaining works on ref." ); } { my $inout = sub { $_[0] . "foo" }; my $cb = DateTime::Format::Builder::Parser->merge_callbacks($inout); is( $cb->("foo") => "foofoo", "Single callback works." ); } { my $empty = DateTime::Format::Builder::Parser->merge_callbacks(undef); ok( !defined $empty, "Given undef, do bugger all." ); $empty = DateTime::Format::Builder::Parser->merge_callbacks(); ok( !defined $empty, "Given nothing, do bugger all." ); $empty = DateTime::Format::Builder::Parser->merge_callbacks( [] ); ok( !defined $empty, "Given empty arrayref, do bugger all." ); } { my $error = eval { DateTime::Format::Builder::Parser->merge_callbacks( { foo => 4 } ); }; ok( $@, "Correctly faulted on bad arguments." ); } done_testing(); DateTime-Format-Builder-0.81/t/wholeclass.t0000644000175000017500000000171012126724561020411 0ustar autarchautarchuse strict; use warnings; use Test::More; package DateTime::Format::ICal15; use DateTime::Format::Builder; DateTime::Format::Builder->create_class( version => 4.00, parsers => { parse_datetime => [ { params => [qw( year month day hour minute second )], regex => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)(\d\d)(\d\d)$/, } ] }, ); package main; my $sample = "20030716T163245"; my $newclass = "DateTime::Format::ICal15"; my $parser = $newclass->new(); cmp_ok( $newclass->VERSION, '==', '4.00', "Version matches" ); { my $dt = $parser->parse_datetime($sample); isa_ok( $dt => "DateTime" ); my %methods = qw( hour 16 minute 32 second 45 year 2003 month 7 day 16 ); while ( my ( $method, $expected ) = each %methods ) { is( $dt->$method() => $expected, "\$dt->$method() == $expected" ); } } done_testing(); DateTime-Format-Builder-0.81/t/dispatch.t0000644000175000017500000000560512126724561020053 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; { eval q[ package SampleDispatch; use DateTime::Format::Builder ( parsers => { parse_datetime => [ { Dispatch => sub { return 'fnerk'; } } ] }, groups => { fnerk => [ { regex => qr/^(\d{4})(\d\d)(\d\d)$/, params => [qw( year month day )], }, ] } ); ]; ok( !$@, "No errors when creating the class." ); if ($@) { diag $@; exit } my $parser = SampleDispatch->new(); isa_ok( $parser => 'SampleDispatch' ); my $dt = eval { $parser->parse_datetime("20040506") }; ok( !$@, "No errors when parsing." ); if ($@) { diag $@; exit } isa_ok( $dt => 'DateTime' ); is( $dt->year => 2004, 'Year is 2004' ); is( $dt->month => 5, 'Month is 5' ); is( $dt->day => 6, 'Day is 6' ); eval { $parser->fnerk }; ok( $@, "There is no fnerk." ); } { eval q[ package SampleDispatchB; use DateTime::Format::Builder; DateTime::Format::Builder->create_class( parsers => { parse_datetime => [ { Dispatch => sub { return( 8, 6 ); } }, ], }, groups => { 8 => [ { regex => qr/^ (\d{4}) (\d\d) (\d\d) $/x, params => [ qw( year month day ) ], }, ], 6 => [ { regex => qr/^ (\d{4}) (\d\d) $/x, params => [ qw( year month ) ], }, ], } ); ]; ok( !$@, "No errors when creating the class." ); if ($@) { diag $@; exit } my $parser = SampleDispatchB->new(); isa_ok( $parser => 'SampleDispatchB' ); { my $dt = eval { $parser->parse_datetime("20040506") }; ok( !$@, "No errors when parsing." ); if ($@) { diag $@; exit } isa_ok( $dt => 'DateTime' ); is( $dt->year => 2004, 'Year is 2004' ); is( $dt->month => 5, 'Month is 5' ); is( $dt->day => 6, 'Day is 6' ); } { my $dt = eval { $parser->parse_datetime("200311") }; ok( !$@, "No errors when parsing." ); if ($@) { diag $@; exit } isa_ok( $dt => 'DateTime' ); is( $dt->year => 2003, 'Year is 2003' ); is( $dt->month => 11, 'Month is 11' ); is( $dt->day => 1, 'Day is 1' ); } eval { $parser->fnerk }; ok( $@, "There is no fnerk." ); } # ------------------------------------------------------------------------ pass "All done."; done_testing(); DateTime-Format-Builder-0.81/t/verbose.t0000644000175000017500000000331112126724561017711 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; # Does verbose() work properly? SKIP: { skip "This test requires perl 5.8", 4 unless $] >= 5.007; skip "Verbose is temporarily out of it", 4; my $str; undef $SampleClass1::fh; # just to un-warn eval q{ open $SampleClass1::fh, '>', \$str or die "Cannot open string for writing!"; }; eval q[ package SampleClass1; use DateTime::Format::Builder verbose => $SampleClass1::fh, parsers => { parse_datetime => [ [ preprocess => sub { my %args = @_; $args{input} }, ], { regex => qr/^(\d{4})(\d\d)(d\d)(\d\d)(\d\d)(\d\d)$/, params => [qw( year month day hour minute second )], on_fail => sub { my %args = @_; $args{input} }, }, { preprocess => sub { my %args = @_; $args{input} }, postprocess => sub { my %args = @_; $args{input} }, on_match => sub { my %args = @_; $args{input} }, regex => qr/^(\d{4})(\d\d)(\d\d)$/, params => [qw( year month day )], }, { length => 8, regex => qr/^abcdef$/, params => [qw( year month day )], } ], }; ]; ok( !$@, "No errors when creating the class." ); diag $@ if $@; my $parser = SampleClass1->new(); isa_ok( $parser => 'SampleClass1' ); my $input = "20040506"; my $dt = eval { $parser->parse_datetime($input) }; isa_ok( $dt => 'DateTime' ); # Should have some data awaiting us now. close $SampleClass1::fh; like( $str, qr/$input/, "Logging data contains input." ); } done_testing(); DateTime-Format-Builder-0.81/t/release-no-tabs.t0000644000175000017500000000045012126724561021226 0ustar autarchautarch BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::More; eval 'use Test::NoTabs'; plan skip_all => 'Test::NoTabs required' if $@; all_perl_files_ok(); DateTime-Format-Builder-0.81/t/nocon.t0000644000175000017500000000406312126724561017365 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; my %parsers = ( parsers => { parse_datetime => { length => 8, regex => qr/^abcdef$/, params => [qw( year month day )], } } ); # Verify constructor (non-)creation # Ensure we don't build a constructor when one isn't asked for { my $class = 'SampleClass1'; eval q[ package SampleClass1; use DateTime::Format::Builder constructor => undef, %parsers; 1; ]; ok( !$@, "No errors when creating the class." ); diag $@ if $@; { no strict 'refs'; ok( !( *{"${class}::new"}{CV} ), "There is indeed no 'new'" ); } my $parser = eval { $class->new() }; ok( $@, "Error when trying to instantiate (no new)" ); like( $@, qr/^Can't locate object method "new" via package "$class"/, "Right error" ); } # Ensure we don't have people wiping out their constructors { my $class = 'SampleClassHasNew'; sub SampleClassHasNew::new { return "4" } eval q[ package SampleClassHasNew; use DateTime::Format::Builder constructor => 1, %parsers; 1; ]; ok( $@, "Error when creating class." ); } # Ensure we're not accidentally overriding when we don't itnend to. { my $class = 'SampleClassDont'; sub SampleClassDont::new { return "5" } eval q[ package SampleClassDont; use DateTime::Format::Builder constructor => 0, %parsers; 1; ]; ok( !$@, "No error when creating class." ); diag $@ if $@; my $parser = eval { $class->new() }; is( $parser => 5, "Didn't override new()" ); } # Ensure we use the given constructor { my $class = 'SampleClassGiven'; eval q[ package SampleClassGiven; use DateTime::Format::Builder constructor => sub { return "6" }, %parsers; 1; ]; ok( !$@, "No error when creating class." ); diag $@ if $@; my $parser = eval { $class->new() }; is( $parser => 6, "Used given new()" ); } done_testing(); DateTime-Format-Builder-0.81/t/quick.t0000644000175000017500000000202312126724561017357 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; SKIP: { my @mods; for (qw( HTTP Mail IBeat )) { my $mod = "DateTime::Format::$_"; eval "require $mod"; push @mods, $mod if $@; } skip "@mods not installed.", 3 if @mods; eval q| package DTFB::Quick; use DateTime::Format::Builder ( parsers => { parse_datetime => [ { Quick => 'DateTime::Format::HTTP' }, { Quick => 'DateTime::Format::Mail' }, { Quick => 'DateTime::Format::IBeat' }, ]}); 1; |; die $@ if $@; my $get = sub { eval { DTFB::Quick->parse_datetime( $_[0] )->set_time_zone('UTC') ->datetime; }; }; for ( '@d19.07.03 @704', '20030719T155345Z' ) { my $dt = $get->($_); is $dt, "2003-07-19T15:53:45", "Can parse [$_]"; } for ('gibberish') { my $dt = $get->($_); ok( !defined $dt, "Shouldn't parse [$_]" ); } } done_testing(); DateTime-Format-Builder-0.81/t/memory-cycle.t0000644000175000017500000000215612126724561020657 0ustar autarchautarchuse strict; use warnings; use lib 't/lib'; use DateTime::Format::Builder; use Test::More; unless ( eval "use Test::Memory::Cycle; Devel::Cycle->can('_find_cycle_SCALAR'); " ) { plan skip_all => 'These tests require Test::Memory::Cycle and a working Devel::Cycle (> 1.07).'; exit; } { my $builder = DateTime::Format::Builder->new(); my $parser = $builder->parser( { strptime => '%Y-%m-%d' } ); memory_cycle_ok( $parser, 'Make sure parser object does not have circular refs' ); memory_cycle_ok( $builder, 'Make sure builder object does not have circular refs after making a single parser' ); } { my $builder = DateTime::Format::Builder->new(); my $parser = $builder->parser( { strptime => '%Y-%m-%d', strptime => '%d-%m-%Y', } ); memory_cycle_ok( $parser, 'Make sure parser object does not have circular refs' ); memory_cycle_ok( $builder, 'Make sure builder object does not have circular refs after making a multi parser' ); } done_testing(); DateTime-Format-Builder-0.81/t/taint.t0000644000175000017500000000014112126724561017361 0ustar autarchautarchuse strict; use warnings; use Test::More; use_ok 'DateTime::Format::Builder'; done_testing(); DateTime-Format-Builder-0.81/t/basic.t0000644000175000017500000000100112126724561017317 0ustar autarchautarchuse strict; use warnings; use Test::More 0.88; use DateTime::Format::Builder; # Does new() work properly? { eval { DateTime::Format::Builder->new('fnar') }; ok( ( $@ and $@ =~ /takes no param/ ), "Too many parameters exception" ); my $obj = eval { DateTime::Format::Builder->new() }; ok( !$@, "Created object" ); isa_ok( $obj, 'DateTime::Format::Builder' ); eval { $obj->parse_datetime("whenever") }; ok( ( $@ and $@ =~ /No parser/ ), "No parser exception" ); } done_testing(); DateTime-Format-Builder-0.81/t/release-pod-linkcheck.t0000644000175000017500000000077512126724561022410 0ustar autarchautarch#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::More; foreach my $env_skip ( qw( SKIP_POD_LINKCHECK ) ){ plan skip_all => "\$ENV{$env_skip} is set, skipping" if $ENV{$env_skip}; } eval "use Test::Pod::LinkCheck"; if ( $@ ) { plan skip_all => 'Test::Pod::LinkCheck required for testing POD'; } else { Test::Pod::LinkCheck->new->all_pod_ok; } DateTime-Format-Builder-0.81/t/param.t0000644000175000017500000000560012126724561017347 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; my $sample = 'SampleClassWithArgs1'; { my $parser = DateTime::Format::Builder->parser( { params => [qw( year month day hour minute second )], regex => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)(\d\d)(\d\d)$/, postprocess => sub { my %p = (@_); $p{parsed}->{time_zone} = $p{args}->[0]; 1; } } ); my $dt = $parser->parse_datetime( "20030716T163245", 'Europe/Berlin' ); is( $dt->time_zone->name, 'Europe/Berlin' ); } { DateTime::Format::Builder->create_class( class => $sample, parsers => { parse_datetime => [ [ preprocess => sub { my %p = (@_); $p{parsed}->{time_zone} = $p{args}->[0]; return $p{input}; }, ], { params => [qw( year month day hour minute second )], regex => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)(\d\d)(\d\d)$/, } ], }, ); my $dt = $sample->parse_datetime( "20030716T163245", 'Asia/Singapore' ); is( $dt->time_zone->name, 'Asia/Singapore' ); } { $sample++; DateTime::Format::Builder->create_class( class => $sample, parsers => { parse_datetime => [ [ preprocess => sub { my %p = @_; my %o = @{ $p{args} }; $p{parsed}->{time_zone} = $o{global} if $o{global}; return $p{input}; }, ], { params => [qw( year month day hour minute second )], regex => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)(\d\d)(\d\d)$/, preprocess => sub { my %p = @_; my %o = @{ $p{args} }; $p{parsed}->{time_zone} = $o{pre} if $o{pre}; return $p{input}; }, postprocess => sub { my %p = @_; my %o = @{ $p{args} }; $p{parsed}->{time_zone} = $o{post} if $o{post}; return 1; }, }, ], } ); my %tests = ( global => 'Africa/Cairo', pre => 'Europe/London', post => 'Australia/Sydney', ); while ( my ( $callback, $value ) = each %tests ) { my $parser = $sample->new(); my $dt = $parser->parse_datetime( "20030716T163245", $callback => $value, ); is( $dt->time_zone->name, $value ); } } done_testing(); DateTime-Format-Builder-0.81/t/fall.t0000644000175000017500000000214012126724561017161 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; SKIP: { my @three = map { "DateTime::Format::$_" } qw( HTTP Mail IBeat ); my @fails; for my $mod (@three) { eval "require $mod"; push @fails, $mod if $@; } skip "@fails not installed.", 3 if @fails; eval qq|package DateTime::Format::Fall;| . join( "", map { "use $_;\n" } @three ) . q| use DateTime::Format::Builder ( parsers => { parse_datetime => [ | . join( "", map { qq|sub { eval { $_->parse_datetime( \$_[1] ) } },\n| } @three ) . q| ]}); 1; |; die $@ if $@; my $get = sub { eval { DateTime::Format::Fall->parse_datetime( $_[0] ) ->set_time_zone('UTC')->datetime; }; }; for ( '@d19.07.03 @704', '20030719T155345Z' ) { my $dt = $get->($_); is $dt, "2003-07-19T15:53:45", "Can parse [$_]"; } for ('gibberish') { my $dt = $get->($_); ok( !defined $dt, "Shouldn't parse [$_]" ); } } done_testing(); DateTime-Format-Builder-0.81/t/release-eol.t0000644000175000017500000000047612126724561020452 0ustar autarchautarch BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use strict; use warnings; use Test::More; eval 'use Test::EOL'; plan skip_all => 'Test::EOL required' if $@; all_perl_files_ok({ trailing_whitespace => 1 }); DateTime-Format-Builder-0.81/t/newclass.t0000644000175000017500000000423512126724561020071 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; my %common = ( version => 4.00, parsers => { parse_datetime => { params => [qw( year month day hour minute second )], regex => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)(\d\d)(\d\d)$/, } }, ); # Does create_class() work properly? { my $sample = "20030716T163245"; my $newclass = "DateTime::Format::ICal15"; DateTime::Format::Builder->create_class( %common, class => $newclass, ); my $parser = $newclass->new(); cmp_ok( $newclass->VERSION, '==', '4.00', "Version matches" ); { my $dt = $parser->parse_datetime($sample); isa_ok( $dt => "DateTime" ); my %methods = qw( hour 16 minute 32 second 45 year 2003 month 7 day 16 ); while ( my ( $method, $expected ) = each %methods ) { is( $dt->$method() => $expected, "\$dt->$method() == $expected" ); } } # New with args { eval { $newclass->new( "with", "args" ) }; ok( $@, "Should have errors" ); like( $@, qr{ takes no parameters}, "Right error" ); } # New from object { my $new = $parser->new(); isa_ok( $new, $newclass, "New from object gives right class" ); } } # New class, with given new { my $newclass = "DateTime::Format::ICalTest"; DateTime::Format::Builder->create_class( %common, class => $newclass, constructor => sub { bless { "Foo" => "Bar" }, shift }, ); my $parser = $newclass->new(); cmp_ok( $newclass->VERSION, '==', '4.00', "Version matches" ); is( $parser->{"Foo"} => "Bar", "Used the right constructor" ); } # New class, with undef new { my $newclass = "DateTime::Format::ICalTestUndef"; eval { DateTime::Format::Builder->create_class( %common, class => $newclass, constructor => undef, ); }; ok( !$@, "Should be no errors with undef new" ); ok( !( UNIVERSAL::can( $newclass, 'new' ) ), "Should be no constructor" ); } done_testing(); DateTime-Format-Builder-0.81/t/import.t0000644000175000017500000000162012126724561017557 0ustar autarchautarchuse strict; use warnings; use Test::More; { eval q[ package SampleClass1; use DateTime::Format::Builder parsers => { parse_datetime => [ { regex => qr/^(\d{4})(\d\d)(d\d)(\d\d)(\d\d)(\d\d)$/, params => [qw( year month day hour minute second )], }, { regex => qr/^(\d{4})(\d\d)(\d\d)$/, params => [qw( year month day )], }, ], }; ]; ok( !$@, "No errors when creating the class." ); my $parser = SampleClass1->new(); isa_ok( $parser => 'SampleClass1' ); my $dt = eval { $parser->parse_datetime("20040506") }; isa_ok( $dt => 'DateTime' ); is( $dt->year => 2004, 'Year is 2004' ); is( $dt->month => 5, 'Year is 2004' ); is( $dt->day => 6, 'Year is 2004' ); eval { $parser->fnerk }; ok( $@, "There is no fnerk." ); } done_testing(); DateTime-Format-Builder-0.81/t/release-pod-syntax.t0000644000175000017500000000045012126724561021771 0ustar autarchautarch#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use Test::More; eval "use Test::Pod 1.41"; plan skip_all => "Test::Pod 1.41 required for testing POD" if $@; all_pod_files_ok(); DateTime-Format-Builder-0.81/t/on_fail_sub.t0000644000175000017500000000214112126724561020524 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; { eval q| package DTFB::Sub; use base qw( DateTime::Format::Builder ); sub on_fail { return undef; } 1; package DTFB::OnFailSubTest; BEGIN { DTFB::Sub->import( parsers => { parse_datetime => [ {strptime=> '%m/%d/%Y'}, {strptime=> '%Y/%m/%d'}, ] } ); } 1; |; ok( !$@, "Made class" ); diag $@ if $@; my $o = DTFB::OnFailSubTest->new; my $good_parse = $o->parse_datetime("2003/08/09"); isa_ok( $good_parse, 'DateTime' ); is( $good_parse->year => 2003, "Year good" ); is( $good_parse->month => 8, "Month good" ); is( $good_parse->day => 9, "Day good" ); my $bad_parse = eval { $o->parse_datetime("Fnerk") }; ok( !$@, "Bad parse gives no error" ); diag $@ if $@; ok( ( !defined($bad_parse) ), "Bad parse correctly gives undef" ); } done_testing(); DateTime-Format-Builder-0.81/t/lengths.t0000644000175000017500000000443712126724561017722 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; # Test multiple parsers having the same length { my $which; my @parsers = ( { length => 10, params => [qw( month year day )], regex => qr/^(\d\d)-(\d\d\d\d)-(\d\d)$/, postprocess => sub { $which = 1 }, }, { length => 10, params => [qw( year month day )], regex => qr/^(\d\d\d\d)-(\d\d)-(\d\d)$/, postprocess => sub { $which = 2 }, }, { length => 10, params => [qw( day month year )], regex => qr/^(\d\d)-(\d\d)-(\d\d\d\d)$/, postprocess => sub { $which = 3 }, }, ); my %data = ( 1 => "05-2003-10", 2 => "2003-04-07", 3 => "13-12-2006", ); { my $parser = DateTime::Format::Builder->parser(@parsers); isa_ok( $parser => 'DateTime::Format::Builder' ); for my $length ( sort keys %data ) { my $date = $data{$length}; my $dt = $parser->parse_datetime($date); isa_ok $dt => 'DateTime'; is( $which, $length, "Used length parser $length" ); } } } # Test single parser having multiple lengths { my $which = 0; my @parsers = ( { length => 4, regex => qr/bar/, params => [], preprocess => sub { $which = 4 } }, { length => 5, regex => qr/bar/, params => [], preprocess => sub { $which = 5 } }, { length => [qw( 4 5 )], regex => qr/(-?\d\d\d\d)/, params => [qw( year )], } ); my $parser = DateTime::Format::Builder->parser(@parsers); isa_ok( $parser => 'DateTime::Format::Builder' ); my %data = ( 4 => 2003, 5 => -2003, ); for my $length ( sort keys %data ) { my $year = $data{$length}; my $dt = $parser->parse_datetime($year); isa_ok( $dt => 'DateTime' ); is( $length, $which, "Parser length $length for $year" ); is( $dt->year, $year, "Year $year matches" ); } } done_testing(); DateTime-Format-Builder-0.81/t/clone.t0000644000175000017500000000101312126724561017341 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; my $clone_it = sub { my $obj = shift; my $method = shift; my $clone = $obj->$method(); isa_ok( $clone => 'DateTime::Format::Builder' ); my $p1 = $obj->get_parser(); my $p2 = $clone->get_parser(); is( $p1 => $p2, "Parser cloned" ); }; my $obj = DateTime::Format::Builder->new(); isa_ok( $obj => 'DateTime::Format::Builder' ); for my $method (qw( new clone )) { $clone_it->( $obj, $method ); } done_testing(); DateTime-Format-Builder-0.81/t/create.t0000644000175000017500000001102312126724561017506 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; my $should_fail; my @parsers = ( { params => [qw( year month day hour minute second )], regex => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)(\d\d)(\d\d)$/, on_fail => sub { ok( $should_fail, "on_fail called for $_[0]" ) }, on_match => sub { ok( !$should_fail, "on_match called for $_[0]" ) }, }, { length => 8, params => [qw( year month day )], regex => qr/^(\d\d\d\d)(\d\d)(\d\d)$/, on_fail => sub { ok( $should_fail, "on_fail called for $_[0]" ) }, on_match => sub { ok( !$should_fail, "on_match called for $_[0]" ) }, }, { length => 13, params => [qw( year month day hour minute )], regex => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)(\d\d)$/, on_fail => sub { ok( $should_fail, "on_fail called for $_[0]" ) }, on_match => sub { ok( !$should_fail, "on_match called for $_[0]" ) }, }, { length => 11, params => [qw( year month day hour )], regex => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)$/, on_fail => sub { ok( $should_fail, "on_fail called for $_[0]" ) }, on_match => sub { ok( !$should_fail, "on_match called for $_[0]" ) }, }, ); { my $parser = DateTime::Format::Builder->parser( %{ $parsers[0] } ); isa_ok( $parser => 'DateTime::Format::Builder' ); { $should_fail = 0; my $dt = $parser->parse_datetime("20030716T163245"); isa_ok( $dt => "DateTime" ); my %methods = qw( hour 16 minute 32 second 45 year 2003 month 7 day 16 ); while ( my ( $method, $expected ) = each %methods ) { is( $dt->$method() => $expected, "\$dt->$method() == $expected" ); } } { $should_fail = 1; my $dt = eval { $parser->parse_datetime("20030716T1632456") }; ok( $@, "Shouldn't've passed or rescued." ); } } { my $parser = DateTime::Format::Builder->parser(@parsers); isa_ok( $parser => 'DateTime::Format::Builder' ); my %times = ( '20030716T163245' => { qw( hour 16 minute 32 second 45 year 2003 month 7 day 16 ) }, '20030716T1632' => {qw( hour 16 minute 32 year 2003 month 7 day 16 )}, '20030716T16' => {qw( hour 16 year 2003 month 7 day 16 )}, '20030716' => {qw( year 2003 month 7 day 16 )}, ); for my $time ( sort keys %times ) { $should_fail = 0; my $dt = $parser->parse_datetime($time); isa_ok( $dt => "DateTime" ); while ( my ( $method, $expected ) = each %{ $times{$time} } ) { is( $dt->$method() => $expected, "\$dt->$method() == $expected" ); } } } # A class that already has a new { sub ClassHasNew::new { return 'new' } eval q[ package ClassHasNew; use DateTime::Format::Builder parsers => { parse_datetime => [ { regex => qr/^(\d{4})(\d\d)(d\d)(\d\d)(\d\d)(\d\d)$/, params => [qw( year month day hour minute second )], }, { regex => qr/^(\d{4})(\d\d)(\d\d)$/, params => [qw( year month day )], }, ], }; ]; ok( !$@, "No errors when creating the class." ); is( ClassHasNew->new, 'new', "Don't overwrite existing new() method" ); } # A class that tries to make a parser called 'new' { sub ClassHasNewMethod::new { return 'new' } eval q[ package ClassHasNewMethod; use DateTime::Format::Builder parsers => { new => { regex => qr/^(\d{4})(\d\d)(d\d)(\d\d)(\d\d)(\d\d)$/, params => [qw( year month day hour minute second )], }, }; ]; ok( $@, "Should have errors when creating class." ); like( $@, qr{Will not override a preexisting method}, "No overriding new with parser" ); is( ClassHasNewMethod->new, 'new', "Don't overwrite existing new() method" ); } # A class that tries to override an existing 'new' { sub ClassHasNewOver::new { return 'new' } eval q[ package ClassHasNewOver; use DateTime::Format::Builder constructor => 1, parsers => { parse_datetime => { regex => qr/^(\d{4})(\d\d)(d\d)(\d\d)(\d\d)(\d\d)$/, params => [qw( year month day hour minute second )], }, }; ]; ok( $@, "Should have errors when creating class." ); like( $@, qr{Will not override a preexisting constructor}, "No override new by intention" ); is( ClassHasNewOver->new, 'new', "Don't overwrite existing new() method" ); } done_testing(); DateTime-Format-Builder-0.81/t/on_fail_regex.t0000644000175000017500000000127512126724561021054 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; { eval q!package DTFB::FailRegexTest; use DateTime::Format::Builder ( parsers => { parse_datetime => [ { regex => qr|\d{4}-\d{2}-\d{2}|, params => [ qw(year month day) ] } ] } ); !; ok( !$@, "Made class" ); diag $@ if $@; my $o = DTFB::FailRegexTest->new(); my $str = eval { $o->parse_datetime("FooBlah") }; my $e = $@; my $file = __FILE__; like( $e, qr(at \Q$file\E), "Should croak from this file" ); } done_testing(); DateTime-Format-Builder-0.81/t/extra.t0000644000175000017500000000074012126724561017372 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; { my $parser = DateTime::Format::Builder->parser( { params => [qw( year month day hour minute second )], regex => qr/^(\d\d\d\d)(\d\d)(\d\d)T(\d\d)(\d\d)(\d\d)$/, extra => { time_zone => 'America/Chicago' }, } ); my $dt = $parser->parse_datetime("20030716T163245"); is( $dt->time_zone->name, 'America/Chicago' ); } done_testing(); DateTime-Format-Builder-0.81/t/altcon.t0000644000175000017500000000367012126724561017534 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; # ------------------------------------------------------------------------ sub do_check { my ( $parser, $date, $values ) = @_; my $parsed = $parser->parse( 'DateTime::Format::Builder', $date ); isa_ok( $parsed => 'DateTime' ); is( $parsed->year() => $values->[0], "Year is right" ); is( $parsed->month() => $values->[1], "Month is right" ); is( $parsed->day() => $values->[2], "Day is right" ); } { my $parser = DateTime::Format::Builder->create_parser( { #YYYY-DDD 1985-102 regex => qr/^ (\d{4}) -?? (\d{3}) $/x, params => [qw( year day_of_year )], constructor => [ 'DateTime', 'from_day_of_year' ], }, { regex => qr/^ (\d{4}) foo (\d{3}) $/x, params => [qw( year day_of_year )], constructor => sub { my $self = shift; DateTime->from_day_of_year(@_); }, } ); my %dates = ( '1985-102' => [ 1985, 4, 12 ], '2004-102' => [ 2004, 4, 11 ], # leap year ); for my $date ( sort keys %dates ) { my $values = $dates{$date}; do_check( $parser, $date, $values ); $date =~ s/-/foo/; do_check( $parser, $date, $values ); } } { my $parser = DateTime::Format::Builder->create_parser( { regex => qr/^ (\d+) $/x, params => [qw( epoch )], constructor => [ 'DateTime', 'from_epoch' ] } ); my %epochs = ( 1057279398 => '2003-07-04T00:43:18', ); for my $epoch ( sort keys %epochs ) { my $check = $epochs{$epoch}; my $dt = $parser->parse( 'DateTime::Format::Builder', $epoch ); isa_ok( $dt => 'DateTime' ); is( $dt->datetime => $check, "Epoch of $epoch to $check" ); } } pass 'All done'; done_testing(); DateTime-Format-Builder-0.81/t/release-cpan-changes.t0000644000175000017500000000047112126724561022215 0ustar autarchautarch#!perl BEGIN { unless ($ENV{RELEASE_TESTING}) { require Test::More; Test::More::plan(skip_all => 'these tests are for release candidate testing'); } } use Test::More; eval 'use Test::CPAN::Changes'; plan skip_all => 'Test::CPAN::Changes required for this test' if $@; changes_ok(); done_testing(); DateTime-Format-Builder-0.81/t/noredef.t0000644000175000017500000000122412126724561017667 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; my %parsers = ( parsers => { parse_datetime => { length => 8, regex => qr/^abcdef$/, params => [qw( year month day )], } } ); # Verify method (non-)creation # Ensure we don't have people wiping out their other methods { my $class = 'SampleClassHasParser'; sub SampleClassHasParser::parse_datetime { return "4" } eval q[ package SampleClassHasParser; use DateTime::Format::Builder constructor => 1, %parsers; 1; ]; ok( $@, "Error when creating class." ); } done_testing(); DateTime-Format-Builder-0.81/t/on_fail.t0000644000175000017500000000324312126724561017657 0ustar autarchautarchuse strict; use warnings; use Test::More; use DateTime::Format::Builder; { eval q| package DTFB::OnFailTest; use DateTime::Format::Builder( parsers => { parse_datetime => [ [ on_fail => \&on_fail ], { strptime => '%m/%d/%Y%n%I:%M%p'}, { strptime => '%Y/%m/%d%n%I:%M%p'}, { strptime => '%m-%d-%Y%n%I:%M%p'}, { strptime => '%F%n%I:%M%p'}, { strptime => '%b%n%d,%n%Y%n%I:%M%p'}, { strptime => '%m/%d/%Y%n%H:%M'}, { strptime => '%Y/%m/%d%n%H:%M'}, { strptime => '%m-%d-%Y%n%H:%M'}, { strptime => '%F%n%H:%M'}, { strptime => '%b%n%d,%n%Y%n%H:%M'}, { strptime => '%m/%d/%Y'}, { strptime => '%Y/%m/%d'}, { strptime => '%m-%d-%Y'}, { strptime => '%F'}, { strptime => '%b%n%d,%n%Y'} ] } ); sub on_fail { return undef; } 1; |; ok( !$@, "Made class" ); diag $@ if $@; my $o = DTFB::OnFailTest->new; my $good_parse = $o->parse_datetime("2003/08/09"); isa_ok( $good_parse, 'DateTime' ); is( $good_parse->year => 2003, "Year good" ); is( $good_parse->month => 8, "Month good" ); is( $good_parse->day => 9, "Day good" ); my $bad_parse = eval { $o->parse_datetime("Fnerk") }; ok( !$@, "Bad parse gives no error" ); ok( ( !defined($bad_parse) ), "Bad parse correctly gives undef" ); } done_testing(); DateTime-Format-Builder-0.81/lib/0000775000175000017500000000000012126724561016366 5ustar autarchautarchDateTime-Format-Builder-0.81/lib/DateTime/0000775000175000017500000000000012126724561020062 5ustar autarchautarchDateTime-Format-Builder-0.81/lib/DateTime/Format/0000775000175000017500000000000012126724561021312 5ustar autarchautarchDateTime-Format-Builder-0.81/lib/DateTime/Format/Builder.pm0000644000175000017500000006142612126724561023245 0ustar autarchautarchpackage DateTime::Format::Builder; { $DateTime::Format::Builder::VERSION = '0.81'; } use strict; use warnings; use 5.005; use Carp; use DateTime 1.00; use Params::Validate 0.72 qw( validate SCALAR ARRAYREF HASHREF SCALARREF CODEREF GLOB GLOBREF UNDEF ); use vars qw( %dispatch_data ); my $parser = 'DateTime::Format::Builder::Parser'; sub verbose { warn "Use of verbose() deprecated for the interim."; 1; } sub import { my $class = shift; $class->create_class( @_, class => (caller)[0] ) if @_; } sub create_class { my $class = shift; my %args = validate( @_, { class => { type => SCALAR, default => (caller)[0] }, version => { type => SCALAR, optional => 1 }, verbose => { type => SCALAR | GLOBREF | GLOB, optional => 1 }, parsers => { type => HASHREF }, groups => { type => HASHREF, optional => 1 }, constructor => { type => UNDEF | SCALAR | CODEREF, optional => 1 }, } ); verbose( $args{verbose} ) if exists $args{verbose}; my $target = $args{class}; # where we're writing our methods and such. # Create own lovely new package { no strict 'refs'; ${"${target}::VERSION"} = $args{version} if exists $args{version}; $class->create_constructor( $target, exists $args{constructor}, $args{constructor} ); # Turn groups of parser specs in to groups of parsers { my $specs = $args{groups}; my %groups; for my $label ( keys %$specs ) { my $parsers = $specs->{$label}; my $code = $class->create_parser($parsers); $groups{$label} = $code; } $dispatch_data{$target} = \%groups; } # Write all our parser methods, creating parsers as we go. while ( my ( $method, $parsers ) = each %{ $args{parsers} } ) { my $globname = $target . "::$method"; croak "Will not override a preexisting method $method()" if defined &{$globname}; *$globname = $class->create_end_parser($parsers); } } } sub create_constructor { my $class = shift; my ( $target, $intended, $value ) = @_; my $new = $target . "::new"; $value = 1 unless $intended; return unless $value; return if not $intended and defined &$new; croak "Will not override a preexisting constructor new()" if defined &$new; no strict 'refs'; return *$new = $value if ref $value eq 'CODE'; return *$new = sub { my $class = shift; croak "${class}->new takes no parameters." if @_; my $self = bless {}, ref($class) || $class; # If called on an object, clone, but we've nothing to # clone $self; }; } sub create_parser { my $class = shift; my @common = ( maker => $class ); if ( @_ == 1 ) { my $parsers = shift; my @parsers = ( ( ref $parsers eq 'HASH' ) ? %$parsers : ( ( ref $parsers eq 'ARRAY' ) ? @$parsers : $parsers ) ); $parser->create_parser( \@common, @parsers ); } else { $parser->create_parser( \@common, @_ ); } } sub create_end_parser { my ( $class, $parsers ) = @_; $class->create_method( $class->create_parser($parsers) ); } sub create_method { my ( $class, $parser ) = @_; return sub { my $self = shift; $parser->parse( $self, @_ ); } } sub on_fail { my ( $class, $input ) = @_; my $pkg; my $i = 0; while ( ($pkg) = caller( $i++ ) ) { last if ( !UNIVERSAL::isa( $pkg, 'DateTime::Format::Builder' ) && !UNIVERSAL::isa( $pkg, 'DateTime::Format::Builder::Parser' ) ); } local $Carp::CarpLevel = $i; croak "Invalid date format: $input"; } sub new { my $class = shift; croak "Constructor 'new' takes no parameters" if @_; my $self = bless { parser => sub { croak "No parser set." } }, ref($class) || $class; if ( ref $class ) { # If called on an object, clone $self->set_parser( $class->get_parser ); # and that's it. we don't store that much info per object } return $self; } sub parser { my $class = shift; my $parser = $class->create_end_parser( \@_ ); # Do we need to instantiate a new object for return, # or are we modifying an existing object? my $self; $self = ref $class ? $class : $class->new(); $self->set_parser($parser); $self; } sub clone { my $self = shift; croak "Calling object method as class method!" unless ref $self; return $self->new(); } sub set_parser { my ( $self, $parser ) = @_; croak "set_parser given something other than a coderef" unless $parser and ref $parser eq 'CODE'; $self->{parser} = $parser; $self; } sub get_parser { my ($self) = @_; return $self->{parser}; } sub parse_datetime { my $self = shift; croak "parse_datetime is an object method, not a class method." unless ref $self and $self->isa(__PACKAGE__); croak "No date specified." unless @_; return $self->{parser}->( $self, @_ ); } sub format_datetime { croak __PACKAGE__ . "::format_datetime not implemented."; } require DateTime::Format::Builder::Parser; 1; # ABSTRACT: Create DateTime parser classes and objects. __END__ =pod =head1 NAME DateTime::Format::Builder - Create DateTime parser classes and objects. =head1 VERSION version 0.81 =head1 SYNOPSIS package DateTime::Format::Brief; use DateTime::Format::Builder ( parsers => { parse_datetime => [ { regex => qr/^(\d{4})(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)$/, params => [qw( year month day hour minute second )], }, { regex => qr/^(\d{4})(\d\d)(\d\d)$/, params => [qw( year month day )], }, ], } ); =head1 DESCRIPTION DateTime::Format::Builder creates DateTime parsers. Many string formats of dates and times are simple and just require a basic regular expression to extract the relevant information. Builder provides a simple way to do this without writing reams of structural code. Builder provides a number of methods, most of which you'll never need, or at least rarely need. They're provided more for exposing of the module's innards to any subclasses, or for when you need to do something slightly beyond what I expected. This creates the end methods. Coderefs die on bad parses, return C objects on good parse. =head1 TUTORIAL See L. =head1 ERROR HANDLING AND BAD PARSES Often, I will speak of C being returned, however that's not strictly true. When a simple single specification is given for a method, the method isn't given a single parser directly. It's given a wrapper that will call C if the single parser returns C. The single parser must return C so that a multiple parser can work nicely and actual errors can be thrown from any of the callbacks. Similarly, any multiple parsers will only call C right at the end when it's tried all it could. C (see L) is defined, by default, to throw an error. Multiple parser specifications can also specify C with a coderef as an argument in the options block. This will take precedence over the inheritable and over-ridable method. That said, don't throw real errors from callbacks in multiple parser specifications unless you really want parsing to stop right there and not try any other parsers. In summary: calling a B will result in either a C object being returned or an error being thrown (unless you've overridden C or C, or you've specified a C key to a multiple parser specification). Individual B (be they multiple parsers or single parsers) will return either the C object or C. =head1 SINGLE SPECIFICATIONS A single specification is a hash ref of instructions on how to create a parser. The precise set of keys and values varies according to parser type. There are some common ones though: =over 4 =item * B is an optional parameter that can be used to specify that this particular I is only applicable to strings of a certain fixed length. This can be used to make parsers more efficient. It's strongly recommended that any parser that can use this parameter does. You may happily specify the same length twice. The parsers will be tried in order of specification. You can also specify multiple lengths by giving it an arrayref of numbers rather than just a single scalar. If doing so, please keep the number of lengths to a minimum. If any specifications without Is are given and the particular I parser fails, then the non-I parsers are tried. This parameter is ignored unless the specification is part of a multiple parser specification. =item * B