line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Data::Checker; |
2
|
|
|
|
|
|
|
# Copyright (c) 2013-2014 Sullivan Beck. All rights reserved. |
3
|
|
|
|
|
|
|
# This program is free software; you can redistribute it and/or modify it |
4
|
|
|
|
|
|
|
# under the same terms as Perl itself. |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
############################################################################### |
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
require 5.008; |
9
|
4
|
|
|
4
|
|
69643
|
use warnings 'all'; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
181
|
|
10
|
4
|
|
|
4
|
|
17
|
use strict; |
|
4
|
|
|
|
|
6
|
|
|
4
|
|
|
|
|
116
|
|
11
|
4
|
|
|
4
|
|
1844
|
use Module::Loaded; |
|
4
|
|
|
|
|
2034
|
|
|
4
|
|
|
|
|
289
|
|
12
|
4
|
|
|
4
|
|
2236
|
use Parallel::ForkManager 0.7.6; |
|
4
|
|
|
|
|
94374
|
|
|
4
|
|
|
|
|
1696
|
|
13
|
|
|
|
|
|
|
|
14
|
|
|
|
|
|
|
our($VERSION); |
15
|
|
|
|
|
|
|
$VERSION='1.05'; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
############################################################################### |
18
|
|
|
|
|
|
|
# BASE METHODS |
19
|
|
|
|
|
|
|
############################################################################### |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
sub version { |
22
|
0
|
|
|
0
|
1
|
0
|
my($self) = @_; |
23
|
|
|
|
|
|
|
|
24
|
0
|
|
|
|
|
0
|
return $VERSION; |
25
|
|
|
|
|
|
|
} |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
sub new { |
28
|
4
|
|
|
4
|
1
|
530
|
my($class,@args) = @_; |
29
|
|
|
|
|
|
|
|
30
|
4
|
|
|
|
|
15
|
my $self = { |
31
|
|
|
|
|
|
|
'parallel' => 1, |
32
|
|
|
|
|
|
|
}; |
33
|
|
|
|
|
|
|
|
34
|
4
|
|
|
|
|
10
|
bless $self, $class; |
35
|
|
|
|
|
|
|
|
36
|
4
|
|
|
|
|
13
|
return $self; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
# Some checks can be run in parallel. For these, passing in $n |
40
|
|
|
|
|
|
|
# has the following effect: |
41
|
|
|
|
|
|
|
# $n = 0 : all of them will run simultaneously |
42
|
|
|
|
|
|
|
# $n = 1 : only one check at a time |
43
|
|
|
|
|
|
|
# $n > 1 : $n checks at a time |
44
|
|
|
|
|
|
|
# |
45
|
|
|
|
|
|
|
sub parallel { |
46
|
0
|
|
|
0
|
1
|
0
|
my($self,$n) = @_; |
47
|
|
|
|
|
|
|
|
48
|
0
|
0
|
0
|
|
|
0
|
if (defined($n) && $n =~ /^\d+$/) { |
49
|
0
|
|
|
|
|
0
|
$n += 0; |
50
|
|
|
|
|
|
|
} else { |
51
|
0
|
|
|
|
|
0
|
warn "WARNING: Invalid argument to Data::Checker::parallel\n"; |
52
|
0
|
|
|
|
|
0
|
return; |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
|
55
|
0
|
|
|
|
|
0
|
$$self{'parallel'} = $n + 0; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
############################################################################### |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
sub check { |
61
|
23
|
|
|
23
|
1
|
65050
|
my($self,$data,$type,$opts) = @_; |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
# Check for data |
64
|
|
|
|
|
|
|
|
65
|
23
|
|
|
|
|
34
|
my (%data,$wantlist); |
66
|
23
|
100
|
|
|
|
72
|
if (ref($data) eq 'ARRAY') { |
|
|
50
|
|
|
|
|
|
67
|
21
|
|
|
|
|
40
|
%data = (map { $_,undef } @$data); |
|
52
|
|
|
|
|
152
|
|
68
|
21
|
|
|
|
|
52
|
$wantlist = 1; |
69
|
|
|
|
|
|
|
} elsif (ref($data) eq 'HASH') { |
70
|
2
|
|
|
|
|
10
|
%data = %$data; |
71
|
2
|
|
|
|
|
2
|
$wantlist = 0; |
72
|
|
|
|
|
|
|
} else { |
73
|
0
|
|
|
|
|
0
|
die "ERROR: invalid data passed to Data::Checker::check\n"; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
# Find the check function |
77
|
|
|
|
|
|
|
|
78
|
23
|
|
|
|
|
30
|
my $func; |
79
|
23
|
50
|
|
|
|
81
|
if (! defined($type)) { |
|
|
100
|
|
|
|
|
|
80
|
0
|
|
|
|
|
0
|
die "ERROR: invalid check function passed to Data::Checker::check\n"; |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
} elsif (ref($type) eq 'CODE') { |
83
|
1
|
|
|
|
|
2
|
$func = $type; |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
} else { |
86
|
22
|
|
|
|
|
78
|
my $caller = ( caller() )[0]; |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
TRY: |
89
|
22
|
|
|
|
|
124
|
foreach my $name ("${type}", |
90
|
|
|
|
|
|
|
"${type}::check", |
91
|
|
|
|
|
|
|
"${caller}::${type}", |
92
|
|
|
|
|
|
|
"${caller}::${type}::check", |
93
|
|
|
|
|
|
|
"Data::Checker::${type}", |
94
|
|
|
|
|
|
|
"Data::Checker::${type}::check", |
95
|
|
|
|
|
|
|
) { |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
# Ignore the case where $name does not have '::' because that means |
98
|
|
|
|
|
|
|
# we called it with the name of a function in the CALLER namespace |
99
|
|
|
|
|
|
|
# (so it'll get handled by one of the "${caller}::" cases, or $type |
100
|
|
|
|
|
|
|
# is a sub-namespace of Data::Checker. |
101
|
|
|
|
|
|
|
|
102
|
132
|
100
|
|
|
|
642
|
next if ($name !~ /^(.*)::(.+)$/); |
103
|
110
|
|
|
|
|
227
|
my($mod) = ($1); |
104
|
110
|
50
|
|
|
|
186
|
$mod = "main" if (! defined $mod); |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
# Try loading the module (but not main:: or CALLER:: |
107
|
|
|
|
|
|
|
|
108
|
110
|
100
|
66
|
|
|
566
|
if ($mod ne 'main' && |
|
|
|
100
|
|
|
|
|
109
|
|
|
|
|
|
|
$mod ne $caller && |
110
|
|
|
|
|
|
|
! is_loaded($mod)) { |
111
|
47
|
100
|
|
|
|
3498
|
next TRY if (! eval "require $mod"); |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
# Look for the function |
115
|
|
|
|
|
|
|
|
116
|
4
|
|
|
4
|
|
35
|
no strict 'refs'; |
|
4
|
|
|
|
|
5
|
|
|
4
|
|
|
|
|
2657
|
|
117
|
66
|
100
|
|
|
|
554
|
if (defined &{$name}) { |
|
66
|
|
|
|
|
436
|
|
118
|
22
|
|
|
|
|
48
|
$func = \&{$name}; |
|
22
|
|
|
|
|
73
|
|
119
|
22
|
|
|
|
|
44
|
last TRY; |
120
|
|
|
|
|
|
|
} |
121
|
|
|
|
|
|
|
} |
122
|
|
|
|
|
|
|
|
123
|
22
|
50
|
|
|
|
58
|
die "ERROR: no valid check function passed to Data::Checker::check\n" |
124
|
|
|
|
|
|
|
if (! defined $func); |
125
|
|
|
|
|
|
|
} |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
# Call parallel or serial check |
128
|
|
|
|
|
|
|
|
129
|
23
|
50
|
|
|
|
90
|
if ($$self{'parallel'} != 1) { |
130
|
0
|
|
|
|
|
0
|
return $self->_check_parallel(\%data,$wantlist,$func,$opts); |
131
|
|
|
|
|
|
|
} else { |
132
|
23
|
|
|
|
|
62
|
return $self->_check_serial(\%data,$wantlist,$func,$opts); |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
sub _check_parallel { |
137
|
0
|
|
|
0
|
|
0
|
my($self,$data,$func,$opts) = @_; |
138
|
|
|
|
|
|
|
# my(@pass,%fail,%notice); |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
# my @ele = keys %$data; |
141
|
|
|
|
|
|
|
# my $max_proc = ($$self{'parallel'} > 1 ? $$self{'parallel'} : @ele); |
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
# my $manager = Parallel::ForkManager->new($max_proc); |
144
|
|
|
|
|
|
|
# $manager->run_on_finish( |
145
|
|
|
|
|
|
|
# sub { |
146
|
|
|
|
|
|
|
# my($pid,$exit_code,$id,$signal,$core_dump,$data) = @_; |
147
|
|
|
|
|
|
|
# my($ele,$err,$note) = @$data; |
148
|
|
|
|
|
|
|
# if ($err) { |
149
|
|
|
|
|
|
|
# $fail{$ele} = $err; |
150
|
|
|
|
|
|
|
# } else { |
151
|
|
|
|
|
|
|
# $notice{$ele} = $note if ($note); |
152
|
|
|
|
|
|
|
# push(@pass,$ele); |
153
|
|
|
|
|
|
|
# } |
154
|
|
|
|
|
|
|
# } |
155
|
|
|
|
|
|
|
# ); |
156
|
|
|
|
|
|
|
|
157
|
|
|
|
|
|
|
# VAL: |
158
|
|
|
|
|
|
|
# foreach my $val (sort keys %{ $valsref }) { |
159
|
|
|
|
|
|
|
# $manager->start and next; |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# my($ele,$err,$note) = &$func($self,$val,$$valsref{$val},$opts,@args); |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
# $manager->finish(0,[$ele,$err,$note]); |
164
|
|
|
|
|
|
|
# } |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# $manager->wait_all_children(); |
167
|
|
|
|
|
|
|
# return (\@pass,\%fail,\%notice); |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
sub _check_serial { |
171
|
23
|
|
|
23
|
|
35
|
my($self,$data,$wantlist,$func,$opts) = @_; |
172
|
23
|
|
|
|
|
27
|
my(%pass,%fail,%info,%warn); |
173
|
|
|
|
|
|
|
|
174
|
23
|
|
|
|
|
116
|
ELE: |
175
|
23
|
|
|
|
|
25
|
foreach my $ele (sort keys %{ $data }) { |
176
|
57
|
|
|
|
|
163
|
my($element,$err,$warn,$info) = &$func($self,$ele,$$data{$ele},$opts); |
177
|
|
|
|
|
|
|
|
178
|
57
|
100
|
66
|
|
|
324
|
if (defined($err) && @$err) { |
179
|
33
|
|
|
|
|
67
|
$fail{$ele} = $err; |
180
|
|
|
|
|
|
|
} else { |
181
|
24
|
|
|
|
|
61
|
$pass{$ele} = $$data{$ele}; |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
|
184
|
57
|
100
|
66
|
|
|
223
|
if (defined($warn) && @$warn) { |
185
|
4
|
|
|
|
|
6
|
$warn{$ele} = $warn; |
186
|
|
|
|
|
|
|
} |
187
|
57
|
100
|
66
|
|
|
271
|
if (defined($info) && @$info) { |
188
|
4
|
|
|
|
|
5
|
$info{$ele} = $info; |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
} |
191
|
|
|
|
|
|
|
|
192
|
23
|
100
|
|
|
|
65
|
if ($wantlist) { |
193
|
21
|
|
|
|
|
89
|
my @pass = sort keys %pass; |
194
|
21
|
|
|
|
|
133
|
return (\@pass,\%fail,\%warn,\%info); |
195
|
|
|
|
|
|
|
} else { |
196
|
2
|
|
|
|
|
14
|
return (\%pass,\%fail,\%warn,\%info); |
197
|
|
|
|
|
|
|
} |
198
|
|
|
|
|
|
|
} |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
############################################################################### |
201
|
|
|
|
|
|
|
# CHECK OPTIONS METHODS |
202
|
|
|
|
|
|
|
############################################################################### |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
sub check_performed { |
205
|
223
|
|
|
223
|
1
|
243
|
my($self,$check_opts,$label) = @_; |
206
|
|
|
|
|
|
|
|
207
|
223
|
100
|
|
|
|
693
|
return 1 if (exists $$check_opts{$label}); |
208
|
135
|
|
|
|
|
344
|
return 0; |
209
|
|
|
|
|
|
|
} |
210
|
|
|
|
|
|
|
|
211
|
|
|
|
|
|
|
sub check_option { |
212
|
241
|
|
|
241
|
1
|
289
|
my($self,$check_opts,$opt,$default,$label) = @_; |
213
|
|
|
|
|
|
|
|
214
|
241
|
100
|
66
|
|
|
1175
|
if (defined $label && |
|
|
50
|
100
|
|
|
|
|
215
|
|
|
|
|
|
|
exists $$check_opts{$label} && |
216
|
|
|
|
|
|
|
exists $$check_opts{$label}{$opt}) { |
217
|
25
|
|
|
|
|
69
|
return $$check_opts{$label}{$opt}; |
218
|
|
|
|
|
|
|
|
219
|
|
|
|
|
|
|
} elsif (exists $$check_opts{$opt}) { |
220
|
0
|
|
|
|
|
0
|
return $$check_opts{$opt}; |
221
|
|
|
|
|
|
|
|
222
|
|
|
|
|
|
|
} else { |
223
|
216
|
|
|
|
|
343
|
return $default; |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
sub check_level { |
228
|
92
|
|
|
92
|
1
|
113
|
my($self,$check_opts,$label) = @_; |
229
|
92
|
|
|
|
|
172
|
return $self->check_option($check_opts,'level','err',$label); |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
sub check_message { |
233
|
29
|
|
|
29
|
1
|
50
|
my($self,$check_opts,$label,$element,$message,$level,$err,$warn,$info) = @_; |
234
|
|
|
|
|
|
|
|
235
|
29
|
|
|
|
|
60
|
my $mess = $self->check_option($check_opts,'message',$message,$label); |
236
|
29
|
|
|
|
|
38
|
my @mess; |
237
|
29
|
50
|
|
|
|
70
|
if (ref($mess) eq 'ARRAY') { |
238
|
0
|
|
|
|
|
0
|
@mess = @$mess; |
239
|
|
|
|
|
|
|
} else { |
240
|
29
|
|
|
|
|
47
|
@mess = ($mess); |
241
|
|
|
|
|
|
|
} |
242
|
29
|
|
|
|
|
51
|
foreach my $m (@mess) { |
243
|
29
|
|
|
|
|
92
|
$m =~ s/__ELEMENT__/$element/g; |
244
|
|
|
|
|
|
|
} |
245
|
|
|
|
|
|
|
|
246
|
29
|
50
|
|
|
|
84
|
if ($level eq 'info') { |
|
|
50
|
|
|
|
|
|
247
|
0
|
|
|
|
|
0
|
push(@$info,@mess); |
248
|
|
|
|
|
|
|
} elsif ($level eq 'warn') { |
249
|
0
|
|
|
|
|
0
|
push(@$warn,@mess); |
250
|
|
|
|
|
|
|
} else { |
251
|
29
|
|
|
|
|
71
|
push(@$err,@mess); |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
} |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
sub check_value { |
256
|
122
|
|
|
122
|
1
|
233
|
my($self,$check_opts,$label,$element,$value,$std_fail,$negate_fail, |
257
|
|
|
|
|
|
|
$err,$warn,$info) = @_; |
258
|
|
|
|
|
|
|
|
259
|
122
|
|
|
|
|
123
|
while (1) { |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
# We perform the check if the $label check is performed, or if |
262
|
|
|
|
|
|
|
# there is no label. |
263
|
|
|
|
|
|
|
|
264
|
122
|
100
|
100
|
|
|
392
|
my $do_check = 1 if (! $label || |
265
|
|
|
|
|
|
|
$self->check_performed($check_opts,$label)); |
266
|
122
|
100
|
|
|
|
233
|
last if (! $do_check); |
267
|
|
|
|
|
|
|
|
268
|
|
|
|
|
|
|
# Find the severity level and negate options (negate will never |
269
|
|
|
|
|
|
|
# occur if we didn't pass in a negate_fail message). |
270
|
|
|
|
|
|
|
|
271
|
92
|
|
|
|
|
162
|
my $level = $self->check_level($check_opts,$label); |
272
|
92
|
|
|
|
|
152
|
my $negate = $self->check_option($check_opts,'negate',0,$label); |
273
|
92
|
100
|
|
|
|
182
|
$negate = 0 if (! defined($negate_fail)); |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
# Check the value. |
276
|
|
|
|
|
|
|
|
277
|
92
|
100
|
100
|
|
|
483
|
if (! $negate && ! $value) { |
|
|
100
|
100
|
|
|
|
|
278
|
23
|
|
|
|
|
82
|
$self->check_message($check_opts,$label,$element,$std_fail, |
279
|
|
|
|
|
|
|
$level,$err,$warn,$info); |
280
|
|
|
|
|
|
|
} elsif ($negate && $value) { |
281
|
6
|
|
|
|
|
17
|
$self->check_message($check_opts,$label,$element,$negate_fail, |
282
|
|
|
|
|
|
|
$level,$err,$warn,$info); |
283
|
|
|
|
|
|
|
} |
284
|
|
|
|
|
|
|
|
285
|
92
|
|
|
|
|
119
|
last; |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
|
288
|
122
|
|
|
|
|
225
|
return ($element,$err,$warn,$info); |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
1; |
292
|
|
|
|
|
|
|
# Local Variables: |
293
|
|
|
|
|
|
|
# mode: cperl |
294
|
|
|
|
|
|
|
# indent-tabs-mode: nil |
295
|
|
|
|
|
|
|
# cperl-indent-level: 3 |
296
|
|
|
|
|
|
|
# cperl-continued-statement-offset: 2 |
297
|
|
|
|
|
|
|
# cperl-continued-brace-offset: 0 |
298
|
|
|
|
|
|
|
# cperl-brace-offset: 0 |
299
|
|
|
|
|
|
|
# cperl-brace-imaginary-offset: 0 |
300
|
|
|
|
|
|
|
# cperl-label-offset: 0 |
301
|
|
|
|
|
|
|
# End: |