1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
|
package # hide from PAUSE
T;
use strict;
use warnings;
use Test::Builder;
use Test::More 0.96;
use Test::Fatal;
use DateTime::Format::Strptime;
use Exporter qw( import );
our @EXPORT_OK = qw( run_tests_from_data test_datetime_object utf8_output );
sub run_tests_from_data {
my $fh = shift;
for my $test ( _tests_from_fh($fh) ) {
subtest(
qq{$test->{name}},
sub {
utf8_output();
my $parser;
is(
exception {
$parser = DateTime::Format::Strptime->new(
pattern => $test->{pattern},
(
$test->{locale}
? ( locale => $test->{locale} )
: ()
),
strict => $test->{strict},
on_error => 'croak',
);
},
undef,
"no exception building parser for $test->{pattern}"
) or return;
( my $real_input = $test->{input} ) =~ s/\\n/\n/g;
my $dt;
is(
exception { $dt = $parser->parse_datetime($real_input) },
undef,
"no exception parsing $test->{input}"
) or return;
test_datetime_object( $dt, $test->{expect} );
unless ( $test->{skip_round_trip} ) {
is(
$parser->format_datetime($dt),
$real_input,
'round trip via strftime produces original input'
);
}
}
);
}
}
sub utf8_output {
binmode $_, ':encoding(UTF-8)'
or die $!
for map { Test::Builder->new->$_ }
qw( output failure_output todo_output );
}
sub test_datetime_object {
my $dt = shift;
my $expect = shift;
for my $meth ( sort keys %{$expect} ) {
is(
$dt->$meth,
$expect->{$meth},
"$meth is $expect->{$meth}"
);
}
}
sub _tests_from_fh {
my $fh = shift;
my @tests;
my $d = do { local $/ = undef; <$fh> };
my $test_re = qr/
\[(.+?)\]\n # test name
(.+?)\n # pattern
(.+?)\n # input
(?:locale\ =\ (.+?)\n)? # optional locale
(skip\ round\ trip\n)? # skip a round trip?
(strict\n)? # strict parsing flag?
(.+?)\n # k-v pairs for expected values
(?:\n|\z) # end of test
/xs;
while ( $d =~ /$test_re/g ) {
push @tests, {
name => $1,
pattern => $2,
input => $3,
locale => $4,
skip_round_trip => $5,
strict => ( $6 ? 1 : 0 ),
expect => {
map { split /\s+=>\s+/ } split /\n/, $7,
},
};
}
return @tests;
}
1;
|
