line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
|
2
|
|
|
|
|
|
|
package Config::Checker; |
3
|
|
|
|
|
|
|
|
4
|
1
|
|
|
1
|
|
2653
|
use strict; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
27
|
|
5
|
1
|
|
|
1
|
|
4
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
25
|
|
6
|
1
|
|
|
1
|
|
786
|
use Eval::LineNumbers qw(eval_line_numbers); |
|
1
|
|
|
|
|
229
|
|
|
1
|
|
|
|
|
89
|
|
7
|
|
|
|
|
|
|
require Exporter; |
8
|
|
|
|
|
|
|
require Config::YAMLMacros::YAML; |
9
|
|
|
|
|
|
|
require Module::Load; |
10
|
|
|
|
|
|
|
require Time::ParseDate; |
11
|
|
|
|
|
|
|
require Carp; |
12
|
1
|
|
|
1
|
|
498
|
use Config::YAMLMacros::YAML; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
440
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
our @ISA = qw(Exporter); |
15
|
|
|
|
|
|
|
our @EXPORT = qw(config_checker_source); |
16
|
|
|
|
|
|
|
our @EXPORT_OK = (@EXPORT, qw(unique split_listify)); |
17
|
|
|
|
|
|
|
our $VERSION = 0.42; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
our %mults = ( |
20
|
|
|
|
|
|
|
K => 1024, |
21
|
|
|
|
|
|
|
M => 1024**2, |
22
|
|
|
|
|
|
|
G => 1024**3, |
23
|
|
|
|
|
|
|
T => 1024**4, |
24
|
|
|
|
|
|
|
P => 1024**5, |
25
|
|
|
|
|
|
|
); |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
# |
28
|
|
|
|
|
|
|
# We are returning this code as text for the recipient to compile so that |
29
|
|
|
|
|
|
|
# it will have access to the recipient's lexical variables. |
30
|
|
|
|
|
|
|
# |
31
|
|
|
|
|
|
|
sub config_checker_source |
32
|
|
|
|
|
|
|
{ |
33
|
6
|
|
|
6
|
0
|
6281
|
return eval_line_numbers(<<'END_SOURCE'); |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
import Config::Checker qw(unique split_listify); |
36
|
|
|
|
|
|
|
sub { |
37
|
|
|
|
|
|
|
my ($config, $prototype_string, $where) = @_; |
38
|
|
|
|
|
|
|
$prototype_string =~ s/^(\t+)/" " x length($1) * 8/e; |
39
|
|
|
|
|
|
|
my $proto = ref($prototype_string) |
40
|
|
|
|
|
|
|
? $prototype_string |
41
|
|
|
|
|
|
|
: Config::YAMLMacros::YAML::Load($prototype_string); |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
my %checker; |
44
|
|
|
|
|
|
|
my $error; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
local(%Config::Checker::unique); |
47
|
|
|
|
|
|
|
|
48
|
|
|
|
|
|
|
my $cleaner = sub { |
49
|
|
|
|
|
|
|
my ($spec) = @_; |
50
|
|
|
|
|
|
|
Carp::confess if ref($spec); |
51
|
|
|
|
|
|
|
my $desc = $spec; |
52
|
|
|
|
|
|
|
my $quantity = ''; |
53
|
|
|
|
|
|
|
my $default; |
54
|
|
|
|
|
|
|
my $name_entry; |
55
|
|
|
|
|
|
|
$desc =~ s/^=// |
56
|
|
|
|
|
|
|
and $name_entry = 1; |
57
|
|
|
|
|
|
|
$desc =~ s/^([*%+?])// |
58
|
|
|
|
|
|
|
and $quantity = $1 || ''; |
59
|
|
|
|
|
|
|
if ($quantity eq '?') { |
60
|
|
|
|
|
|
|
$desc =~ s/^<([^<>]*)>// |
61
|
|
|
|
|
|
|
and $default = $1; |
62
|
|
|
|
|
|
|
} elsif ($quantity eq '+' || $quantity eq '*') { |
63
|
|
|
|
|
|
|
$desc =~ s/^<([^<>]*)>// |
64
|
|
|
|
|
|
|
and $default = qr/$1/; |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
my $type = ''; |
67
|
|
|
|
|
|
|
$desc =~ s/\[(.*)\]$// |
68
|
|
|
|
|
|
|
and $type = $1 || ''; |
69
|
|
|
|
|
|
|
my $code = ''; |
70
|
|
|
|
|
|
|
$desc =~ s/\{(.*)\}$// |
71
|
|
|
|
|
|
|
and $code = $1 || ''; |
72
|
|
|
|
|
|
|
return ($desc, $type, $code, $quantity, $default); |
73
|
|
|
|
|
|
|
}; |
74
|
|
|
|
|
|
|
my $validate = sub { |
75
|
|
|
|
|
|
|
my ($ref, $context, $spec) = @_; |
76
|
|
|
|
|
|
|
Carp::confess if ref($spec); |
77
|
|
|
|
|
|
|
my $value = $$ref; |
78
|
|
|
|
|
|
|
my ($desc, $type, $code, $quantity, $default) = $cleaner->($spec); |
79
|
|
|
|
|
|
|
#no warnings; |
80
|
|
|
|
|
|
|
#print <
|
81
|
|
|
|
|
|
|
#---------------- |
82
|
|
|
|
|
|
|
#DESC: $desc |
83
|
|
|
|
|
|
|
#TYPE: $type |
84
|
|
|
|
|
|
|
#CODE: $code |
85
|
|
|
|
|
|
|
#QNTY: $quantity |
86
|
|
|
|
|
|
|
#DFLT: $default |
87
|
|
|
|
|
|
|
#END |
88
|
|
|
|
|
|
|
if (ref $value) { |
89
|
|
|
|
|
|
|
die "Not expecting a ".ref($value)." for $context $where"; |
90
|
|
|
|
|
|
|
} |
91
|
|
|
|
|
|
|
if ($type eq 'MODULE_NAME') { |
92
|
|
|
|
|
|
|
eval { Module::Load::load $value }; |
93
|
|
|
|
|
|
|
die "Could not load module $value for $context ($proto): $@ $where" if $@; |
94
|
|
|
|
|
|
|
} elsif ($type eq 'PATH') { |
95
|
|
|
|
|
|
|
die "Illegal characters in path '$value' for $context $where" |
96
|
|
|
|
|
|
|
if $value =~ /\s/; |
97
|
|
|
|
|
|
|
} elsif ($type eq 'DATE') { |
98
|
|
|
|
|
|
|
die "Could not understand date '$value' for $context $where" |
99
|
|
|
|
|
|
|
unless Time::ParseDate::parsedate($value); |
100
|
|
|
|
|
|
|
} elsif ($type eq 'INTEGER') { |
101
|
|
|
|
|
|
|
die "An integer is required, not '$value' for $context $where" |
102
|
|
|
|
|
|
|
unless $value =~ /^\d+$/; |
103
|
|
|
|
|
|
|
} elsif ($type eq 'HOSTNAME') { |
104
|
|
|
|
|
|
|
die "A hostname is required: '$value' does not resovle' for $context $where" |
105
|
|
|
|
|
|
|
unless gethostbyname($value); |
106
|
|
|
|
|
|
|
} elsif ($type eq 'WORD') { |
107
|
|
|
|
|
|
|
die "Text that can be used as a filename require. '$value' is not okay for $context $where" |
108
|
|
|
|
|
|
|
if $value =~ m{[/\n\r]}; |
109
|
|
|
|
|
|
|
} elsif ($type eq 'STRING') { |
110
|
|
|
|
|
|
|
# anything goes |
111
|
|
|
|
|
|
|
} elsif ($type eq 'BOOLEAN') { |
112
|
|
|
|
|
|
|
if ($value =~ /^no?$/i || $value =~ /^false$/ || $value eq '0') { |
113
|
|
|
|
|
|
|
$$ref = 0; |
114
|
|
|
|
|
|
|
} elsif ($value =~ /^y(es)?$/i || $value =~ /^true$/ || $value eq '1') { |
115
|
|
|
|
|
|
|
$$ref = 1; |
116
|
|
|
|
|
|
|
} else { |
117
|
|
|
|
|
|
|
die "True/False/Yes/No/0/1 expected, got '$value' instead for $context $where"; |
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
} elsif ($type eq 'TEXT') { |
120
|
|
|
|
|
|
|
die "Illegal characters in $context ($proto): '$value' $where" |
121
|
|
|
|
|
|
|
if $value =~ /[^-\w_\s]/; |
122
|
|
|
|
|
|
|
die "Must set a value for $context ($proto) $where" |
123
|
|
|
|
|
|
|
unless $value =~ /\S/; |
124
|
|
|
|
|
|
|
} elsif ($type eq 'SIZE') { |
125
|
|
|
|
|
|
|
if ($value =~ /^\d+$/) { |
126
|
|
|
|
|
|
|
# just fine |
127
|
|
|
|
|
|
|
} elsif ($value =~ /^(\d+)([KMGTP])$/) { |
128
|
|
|
|
|
|
|
$$ref = $1 * $Config::Checker::mults{$2}; |
129
|
|
|
|
|
|
|
} else { |
130
|
|
|
|
|
|
|
die "Expected a size, like 25M, got '$value' for $context $where"; |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
} elsif ($type eq 'CODE') { |
134
|
|
|
|
|
|
|
# don't bother to verify here |
135
|
|
|
|
|
|
|
} elsif ($type eq 'FREQUENCY') { |
136
|
|
|
|
|
|
|
# don't bother to verify here |
137
|
|
|
|
|
|
|
} elsif ($type eq 'TIMESPAN') { |
138
|
|
|
|
|
|
|
# don't bother to verify here |
139
|
|
|
|
|
|
|
} elsif ($type ne '') { |
140
|
|
|
|
|
|
|
die "Unknown type specification '$type' for $context $where"; |
141
|
|
|
|
|
|
|
} |
142
|
|
|
|
|
|
|
if ($code) { |
143
|
|
|
|
|
|
|
my $override = $code =~ s/^=//; |
144
|
|
|
|
|
|
|
undef $error; |
145
|
|
|
|
|
|
|
unless ($checker{$code}) { |
146
|
|
|
|
|
|
|
$checker{$code} = eval qq{ sub { $code } }; |
147
|
|
|
|
|
|
|
die "validation code '$code' is broken for validating $context: $@ $where" if $@; |
148
|
|
|
|
|
|
|
} |
149
|
|
|
|
|
|
|
my $valid = $checker{$code}->($value); |
150
|
|
|
|
|
|
|
die $error." $where\n" if $error; |
151
|
|
|
|
|
|
|
die "Invalid $context value, should be $desc ($code) $where" unless $valid; |
152
|
|
|
|
|
|
|
$$ref = $valid if $override; |
153
|
|
|
|
|
|
|
} |
154
|
|
|
|
|
|
|
}; |
155
|
|
|
|
|
|
|
# This is self-referential and will leak. Oh, well. |
156
|
|
|
|
|
|
|
my $compare; |
157
|
|
|
|
|
|
|
$compare = sub { |
158
|
|
|
|
|
|
|
my ($context, $config, $proto) = @_; |
159
|
|
|
|
|
|
|
for my $uk (keys %$config) { |
160
|
|
|
|
|
|
|
next if defined $proto->{$uk}; |
161
|
|
|
|
|
|
|
die "Unexpected configuration key: '$uk' $where"; |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
for my $k (keys %$proto) { |
164
|
|
|
|
|
|
|
my $spec = $proto->{$k}; |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
if (ref $spec) { |
167
|
|
|
|
|
|
|
if (ref($spec) eq 'ARRAY') { |
168
|
|
|
|
|
|
|
next unless $config->{$k}; |
169
|
|
|
|
|
|
|
$config->{$k} = [ $config->{$k} ] |
170
|
|
|
|
|
|
|
unless ref($config->{$k}) eq 'ARRAY'; |
171
|
|
|
|
|
|
|
my $name_entry; |
172
|
|
|
|
|
|
|
if (ref($spec->[0]) eq 'HASH') { |
173
|
|
|
|
|
|
|
($name_entry) = grep { (!ref $spec->[0]{$_}) && $spec->[0]{$_} =~ /^=/ } keys %{$spec->[0]}; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
my $count = 1; |
176
|
|
|
|
|
|
|
for my $i (@{$config->{$k}}) { |
177
|
|
|
|
|
|
|
my $sub = "[$count]"; |
178
|
|
|
|
|
|
|
$sub = "{$i->{$name_entry}}" |
179
|
|
|
|
|
|
|
if $name_entry && ref($i) eq 'HASH' && $i->{$name_entry}; |
180
|
|
|
|
|
|
|
$compare->("$context : $k $sub", $i, $spec->[0]); |
181
|
|
|
|
|
|
|
$count++; |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
} elsif (ref($spec) eq 'HASH') { |
184
|
|
|
|
|
|
|
next unless $config->{$k}; |
185
|
|
|
|
|
|
|
die "Expecting key/values for $context $k $where" |
186
|
|
|
|
|
|
|
unless ref($config->{$k}) eq 'HASH'; |
187
|
|
|
|
|
|
|
my @sk = keys %$spec; |
188
|
|
|
|
|
|
|
my $user_supplied = grep { /[][]/ } @sk; |
189
|
|
|
|
|
|
|
if ($user_supplied) { |
190
|
|
|
|
|
|
|
die "expected only one key $where" unless @sk == 1; |
191
|
|
|
|
|
|
|
for my $hk (keys %{$config->{$k}}) { |
192
|
|
|
|
|
|
|
$validate->(\$hk, "$context : $hk (key)", $sk[0]); |
193
|
|
|
|
|
|
|
$compare->("$context : $hk", $config->{$k}{$hk}, $spec->{$sk[0]}); |
194
|
|
|
|
|
|
|
} |
195
|
|
|
|
|
|
|
} else { |
196
|
|
|
|
|
|
|
$compare->("$context : $k", $config->{$k}, $spec); |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
} else { |
200
|
|
|
|
|
|
|
my ($desc, $type, $code, $quantity, $default) = $cleaner->($spec); |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
if ($quantity eq '*') { |
203
|
|
|
|
|
|
|
# zero or more |
204
|
|
|
|
|
|
|
next unless exists $config->{$k}; |
205
|
|
|
|
|
|
|
$config->{$k} = split_listify($config->{$k}, $default) |
206
|
|
|
|
|
|
|
unless ref $config->{$k}; |
207
|
|
|
|
|
|
|
my $count = 1; |
208
|
|
|
|
|
|
|
for my $i (@{$config->{$k}}) { |
209
|
|
|
|
|
|
|
$validate->(\$i, "$context : $k [$count]", $spec); |
210
|
|
|
|
|
|
|
$count++; |
211
|
|
|
|
|
|
|
} |
212
|
|
|
|
|
|
|
} elsif ($quantity eq '+') { |
213
|
|
|
|
|
|
|
# one or more |
214
|
|
|
|
|
|
|
die "Missing required item $k ($desc) in $context $where" |
215
|
|
|
|
|
|
|
unless exists $config->{$k}; |
216
|
|
|
|
|
|
|
$config->{$k} = split_listify($config->{$k}, $default) |
217
|
|
|
|
|
|
|
unless ref $config->{$k}; |
218
|
|
|
|
|
|
|
my $count = 1; |
219
|
|
|
|
|
|
|
for my $i (@{$config->{$k}}) { |
220
|
|
|
|
|
|
|
$validate->(\$i, "$context : $k [$count]", $spec); |
221
|
|
|
|
|
|
|
$count++; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
} elsif ($quantity eq '?') { |
224
|
|
|
|
|
|
|
# optional |
225
|
|
|
|
|
|
|
$config->{$k} = $default |
226
|
|
|
|
|
|
|
if defined($default) and ! exists $config->{$k}; |
227
|
|
|
|
|
|
|
$validate->(\$config->{$k}, "$context : $k", $spec) |
228
|
|
|
|
|
|
|
if exists $config->{$k}; |
229
|
|
|
|
|
|
|
} elsif ($quantity eq '%') { |
230
|
|
|
|
|
|
|
next unless exists $config->{$k}; |
231
|
|
|
|
|
|
|
die "Expecting key/values (HASH) for $k ($desc) in $context $where but got '$config->{$k}'" |
232
|
|
|
|
|
|
|
unless ref($config->{$k}) eq 'HASH'; |
233
|
|
|
|
|
|
|
} elsif (! exists $config->{$k}) { |
234
|
|
|
|
|
|
|
die "Missing required item $k ($desc) in $context $where"; |
235
|
|
|
|
|
|
|
} else { |
236
|
|
|
|
|
|
|
$validate->(\$config->{$k}, "$context : $k", $spec); |
237
|
|
|
|
|
|
|
} |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
}; |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
$compare->("config", $config, $proto); |
243
|
|
|
|
|
|
|
} |
244
|
|
|
|
|
|
|
END_SOURCE |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
sub split_listify |
248
|
|
|
|
|
|
|
{ |
249
|
2
|
|
|
2
|
0
|
6
|
my ($val, $sep) = @_; |
250
|
|
|
|
|
|
|
|
251
|
2
|
50
|
33
|
|
|
10
|
if (defined($sep) && $sep ne '') { |
252
|
0
|
|
|
|
|
0
|
my @vals = split(/$sep/, $val); |
253
|
0
|
0
|
|
|
|
0
|
if (@vals > 1) { |
254
|
|
|
|
|
|
|
do { |
255
|
0
|
|
|
|
|
0
|
s/^\s+//; |
256
|
0
|
|
|
|
|
0
|
s/\s+\Z//; |
257
|
0
|
|
|
|
|
0
|
} for @vals; |
258
|
|
|
|
|
|
|
} |
259
|
0
|
|
|
|
|
0
|
return \@vals; |
260
|
|
|
|
|
|
|
} else { |
261
|
2
|
|
|
|
|
8
|
return [ $val ]; |
262
|
|
|
|
|
|
|
} |
263
|
|
|
|
|
|
|
} |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
our %unique; |
266
|
|
|
|
|
|
|
sub unique |
267
|
|
|
|
|
|
|
{ |
268
|
0
|
|
|
0
|
0
|
|
my ($thing, $value) = @_; |
269
|
0
|
0
|
|
|
|
|
die "$thing '$value' isn't unique" |
270
|
|
|
|
|
|
|
if $unique{$thing}{$value}++; |
271
|
|
|
|
|
|
|
} |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
1; |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
__END__ |