File Coverage

blib/lib/Config/Checker.pm
Criterion Covered Total %
statement 16 24 66.6
branch 1 6 16.6
condition 1 3 33.3
subroutine 6 7 85.7
pod 0 3 0.0
total 24 43 55.8


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__