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
123
124
125
126
127
|
use strict;
use warnings;
use vars qw( $SILENT );
use constant SEPTOR => q{[AGENT]};
use constant RE_SEPTOR => qr{ \Q[AGENT]\E }xms;
use Carp qw( croak );
use File::Spec;
use File::Basename;
use IO::File;
use Test::More;
use File::Find qw( find );
my $COMMENT = q{Parse::HTTP::UserAgent test file};
my @todo;
END {
if ( @todo && ! $SILENT ) {
diag( 'Tests marked as TODO are listed below' );
diag("$_->[0]: '$_->[1]'") for @todo;
}
}
sub database {
my $opt = shift || {};
my @buf;
my $tests = merge_files();
my $id = 0;
foreach my $test ( split RE_SEPTOR, $tests ) {
next if ! $test;
my $raw = trim( strip_comments( $test ) ) || next;
my($string, $frozen) = split m{ \n }xms, $raw, 2;
push @buf, {
string => $string,
struct => $frozen && $opt->{thaw} ? { thaw( $frozen ) } : $frozen,
id => ++$id,
};
}
return @buf;
}
sub merge_files {
my $base = 't/data';
local *DIR;
opendir DIR, $base or die "Can't opendir($base): $!";
my %base_file;
while ( my $file = readdir DIR ) {
my $exact = join q{/}, $base, $file;
next if $file eq '.' || $file eq '..' || -d $exact;
$base_file{ $exact } = 1;
}
closedir DIR;
my @files;
my $probe = sub {
return if -d;
return if basename( $_ ) =~ m{ \A [.] }xms;
return if $base_file{ $_ };
push @files, $_;
};
find {
no_chdir => 1,
wanted => $probe,
}, $base;
my $raw = q{};
foreach my $file ( @files ) {
my @raw = split RE_SEPTOR, slurp( $file );
$raw .= join SEPTOR, map { qq{\n\n#$COMMENT $file\n\n$_} } @raw;
}
return $raw;
}
sub thaw {
my $s = shift || die "Frozen?\n";
my %rv;
my $eok = eval "\%rv = (\n $s \n);";
die "Can not restore data: $@\n\t>> $s <<" if $@ || ! $eok;
return %rv;
}
sub trim {
my $s = shift;
return $s if ! $s;
$s =~ s{ \A \s+ }{}xms;
$s =~ s{ \s+ \z }{}xms;
return $s;
}
sub strip_comments {
my $s = shift;
return $s if ! $s;
my $buf = q{};
my $file;
foreach my $line ( split m{ \n }xms, $s ) {
chomp $line;
next if ! $line;
if ( my @m = $line =~ m{ \A [#] (.+?)? \z }xms ) {
next if ! $m[0]; # line only had a hash and nothing else
if ( my @f = $m[0] =~ m{ \A \Q$COMMENT\E (.+?) \z }xms ) {
$file = trim( $f[0] );
}
if ( my @n = $m[0] =~ m{ \A TODO: \s? (.+?) \z }xms ) {
push @todo, [ $file, $n[0] ];
}
next;
}
$buf .= $line . "\n";
}
return $buf;
}
sub slurp {
my $file = shift;
my $FH = IO::File->new;
$FH->open( $file, 'r')
or croak sprintf 'Can not open DB @ %s: %s', $file, $!;
my $rv = do { local $/; my $s = <$FH>; $s };
$FH->close;
return $rv;
}
1;
__END__
|
