diff options
Diffstat (limited to 't/TestConfig.pm')
-rw-r--r-- | t/TestConfig.pm | 130 |
1 files changed, 130 insertions, 0 deletions
diff --git a/t/TestConfig.pm b/t/TestConfig.pm new file mode 100644 index 0000000..886e66b --- /dev/null +++ b/t/TestConfig.pm | |||
@@ -0,0 +1,130 @@ | |||
1 | package TestConfig; | ||
2 | |||
3 | use strict; | ||
4 | use warnings; | ||
5 | use Carp; | ||
6 | |||
7 | use Config::Tree qw(:sort); | ||
8 | use parent 'Config::Parser::Ini'; | ||
9 | use Data::Dumper; | ||
10 | use File::Temp; | ||
11 | |||
12 | =head1 CONSTRUCTOR | ||
13 | |||
14 | $obj = new TestConfig(KW => VAL, ...) | ||
15 | |||
16 | Key arguments: | ||
17 | |||
18 | =over 4 | ||
19 | |||
20 | =item B<text> | ||
21 | |||
22 | Text of the configuration file | ||
23 | |||
24 | =item expect | ||
25 | |||
26 | Reference to the list of expected errors | ||
27 | |||
28 | =back | ||
29 | |||
30 | =cut | ||
31 | |||
32 | sub new { | ||
33 | my $class = shift; | ||
34 | local %_ = @_; | ||
35 | |||
36 | my $file = new File::Temp(UNLINK => 1); | ||
37 | if (defined(my $text = delete $_{text})) { | ||
38 | print $file $text; | ||
39 | } else { | ||
40 | while (<main::DATA>) { | ||
41 | print $file $_; | ||
42 | } | ||
43 | } | ||
44 | close $file; | ||
45 | |||
46 | my $exp = delete $_{expect}; | ||
47 | # FIXME: Filter out fh and line keywords? | ||
48 | my $self = $class->SUPER::new(%_); | ||
49 | $self->{_expected_errors} = $exp if $exp; | ||
50 | $self->parse($file->filename); | ||
51 | $self->{_status} = $self->commit; | ||
52 | |||
53 | if ($exp && @{$self->{_expected_errors}}) { | ||
54 | $self->{_status} = 0; | ||
55 | $self->error("not all expected errors reported"); | ||
56 | } | ||
57 | return $self; | ||
58 | } | ||
59 | |||
60 | sub success { | ||
61 | my ($self) = @_; | ||
62 | return $self->{_status}; | ||
63 | } | ||
64 | |||
65 | sub canonical { | ||
66 | my $self = shift; | ||
67 | local %_ = @_; | ||
68 | carp "unknown parameters: " . join(', ', keys(%_)) if (keys(%_)); | ||
69 | return join $_{delim} // " ", map { | ||
70 | join('.', @{$_->[0]}) | ||
71 | . "=" | ||
72 | . Data::Dumper->new([$_->[1]->value]) | ||
73 | ->Useqq(1) | ||
74 | ->Terse(1) | ||
75 | ->Indent(0) | ||
76 | ->Dump | ||
77 | } $self->flatten(sort => SORT_PATH); | ||
78 | } | ||
79 | |||
80 | sub expected_error { | ||
81 | my ($self, $msg) = @_; | ||
82 | |||
83 | if (exists($self->{_expected_errors})) { | ||
84 | my ($i) = grep { ${$self->{_expected_errors}}[$_] eq $msg } | ||
85 | 0..$#{$self->{_expected_errors}}; | ||
86 | if (defined($i)) { | ||
87 | splice(@{$self->{_expected_errors}}, $i, 1); | ||
88 | return 1; | ||
89 | } | ||
90 | } | ||
91 | } | ||
92 | |||
93 | sub error { | ||
94 | my $self = shift; | ||
95 | my $err = shift; | ||
96 | local %_ = @_; | ||
97 | push @{$self->{_errors}}, { message => $err }; | ||
98 | unless ($self->expected_error($err)) { | ||
99 | print STDERR "$_{locus}: " if $_{locus}; | ||
100 | print STDERR "$err\n"; | ||
101 | } | ||
102 | } | ||
103 | |||
104 | sub errors { | ||
105 | my $self = shift; | ||
106 | return 0+@{$self->{_errors}}; | ||
107 | } | ||
108 | |||
109 | sub report { | ||
110 | my ($self, $err) = @_; | ||
111 | print STDERR "$err\n" | ||
112 | } | ||
113 | |||
114 | sub lint { | ||
115 | my $self = shift; | ||
116 | my $synt = shift; | ||
117 | local %_ = @_; | ||
118 | my $exp = $self->{_expected_errors} = delete $_{expect}; | ||
119 | carp "unknown parameters: " . join(', ', keys(%_)) if (keys(%_)); | ||
120 | |||
121 | my $ret = $self->SUPER::lint($synt); | ||
122 | |||
123 | if ($exp && @{$self->{_expected_errors}}) { | ||
124 | $self->{_status} = 0; | ||
125 | $self->report("not all expected errors reported: @{$self->{_expected_errors}}"); | ||
126 | } | ||
127 | return $ret; | ||
128 | } | ||
129 | |||
130 | 1; | ||