line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
2
|
|
|
2
|
|
780
|
use 5.008; |
|
2
|
|
|
|
|
7
|
|
|
2
|
|
|
|
|
86
|
|
2
|
2
|
|
|
2
|
|
12
|
use strict; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
64
|
|
3
|
2
|
|
|
2
|
|
10
|
use warnings; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
100
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
package Error::Hierarchy::Util; |
6
|
|
|
|
|
|
|
BEGIN { |
7
|
2
|
|
|
2
|
|
53
|
$Error::Hierarchy::Util::VERSION = '1.103530'; |
8
|
|
|
|
|
|
|
} |
9
|
|
|
|
|
|
|
# ABSTRACT: Assertions and other tools |
10
|
2
|
|
|
2
|
|
1988
|
use Data::Miscellany 'is_defined'; |
|
2
|
|
|
|
|
2862
|
|
|
2
|
|
|
|
|
154
|
|
11
|
2
|
|
|
2
|
|
677
|
use Error::Hierarchy::Mixin; # to get UNIVERSAL::throw() |
|
2
|
|
|
|
|
5
|
|
|
2
|
|
|
|
|
50
|
|
12
|
2
|
|
|
2
|
|
9
|
use Exporter qw(import); |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
2555
|
|
13
|
|
|
|
|
|
|
our %EXPORT_TAGS = ( |
14
|
|
|
|
|
|
|
ref => [ |
15
|
|
|
|
|
|
|
qw{ |
16
|
|
|
|
|
|
|
assert_arrayref assert_nonempty_arrayref |
17
|
|
|
|
|
|
|
assert_hashref assert_nonempty_hashref |
18
|
|
|
|
|
|
|
} |
19
|
|
|
|
|
|
|
], |
20
|
|
|
|
|
|
|
misc => [ |
21
|
|
|
|
|
|
|
qw{ |
22
|
|
|
|
|
|
|
assert_class assert_defined assert_read_only assert_is_integer |
23
|
|
|
|
|
|
|
assert_getopt assert_enum assert_named_args load_class |
24
|
|
|
|
|
|
|
} |
25
|
|
|
|
|
|
|
], |
26
|
|
|
|
|
|
|
); |
27
|
|
|
|
|
|
|
our @EXPORT_OK = @{ $EXPORT_TAGS{all} = [ map { @$_ } values %EXPORT_TAGS ] }; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
sub assert_class ($$) { |
30
|
0
|
|
|
0
|
1
|
0
|
my ($obj, $class) = @_; |
31
|
0
|
0
|
0
|
|
|
0
|
return if ref $obj && $obj->isa($class); |
32
|
0
|
|
|
|
|
0
|
local $Error::Depth = $Error::Depth + 2; |
33
|
0
|
|
|
|
|
0
|
throw Error::Hierarchy::Internal::Class( |
34
|
|
|
|
|
|
|
class_expected => $class, |
35
|
|
|
|
|
|
|
class_got => ref($obj), |
36
|
|
|
|
|
|
|
); |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
sub assert_read_only { |
40
|
0
|
0
|
|
0
|
1
|
0
|
return unless @_; |
41
|
0
|
|
|
|
|
0
|
local $Error::Depth = $Error::Depth + 2; |
42
|
0
|
|
|
|
|
0
|
my $sub = (caller(1))[3]; |
43
|
0
|
|
|
|
|
0
|
throw Error::Hierarchy::Internal::ReadOnlyAttribute(attribute => $sub,); |
44
|
|
|
|
|
|
|
} |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# In assert_condition we use |
47
|
|
|
|
|
|
|
# |
48
|
|
|
|
|
|
|
# local $Error::Depth = $Error::Depth + 3; |
49
|
|
|
|
|
|
|
# |
50
|
|
|
|
|
|
|
# because: |
51
|
|
|
|
|
|
|
# |
52
|
|
|
|
|
|
|
# +1 to make assert_condition invisible to caller |
53
|
|
|
|
|
|
|
# |
54
|
|
|
|
|
|
|
# +1 to make assert_defined and friends invisible to caller |
55
|
|
|
|
|
|
|
# |
56
|
|
|
|
|
|
|
# +1 to make the one who called assert_* invisible to caller, since we |
57
|
|
|
|
|
|
|
# want to report the location where the method that checks its args using |
58
|
|
|
|
|
|
|
# assert_* was called from. |
59
|
|
|
|
|
|
|
sub assert_condition ($$$) { |
60
|
2
|
|
|
2
|
1
|
6
|
my ($condition, $exception_class, $custom_message) = @_; |
61
|
2
|
50
|
|
|
|
6
|
return if $condition; |
62
|
|
|
|
|
|
|
|
63
|
|
|
|
|
|
|
# get the name of the first sub an assert_* sub was called with the unmet |
64
|
|
|
|
|
|
|
# assertion |
65
|
2
|
|
|
|
|
2
|
my ($level, $sub); |
66
|
2
|
|
|
|
|
3
|
do { |
67
|
4
|
|
|
|
|
39
|
$sub = (caller(++$level))[3]; |
68
|
|
|
|
|
|
|
} until $sub !~ /^.*::assert_/; |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
# XXX: shouldn't we use $level here instead of 3? |
71
|
2
|
|
|
|
|
5
|
local $Error::Depth = $Error::Depth + 3; |
72
|
2
|
|
|
|
|
20
|
$exception_class->throw(custom_message => "[$sub] $custom_message"); |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
sub assert_defined ($$) { |
76
|
1
|
|
|
1
|
1
|
603
|
my ($val, $custom_message) = @_; |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
# If it's a value object, it might have been autogenerated; see |
79
|
|
|
|
|
|
|
# value_object accessor generator, in which case it might not have a value |
80
|
|
|
|
|
|
|
# yet, but $val would be defined - it's the empty value object. |
81
|
|
|
|
|
|
|
# Performance optimization: Because this function is called so often, we |
82
|
|
|
|
|
|
|
# don't call assert_condition() unless it is necessary. |
83
|
1
|
50
|
|
|
|
7
|
return if is_defined($val); |
84
|
1
|
|
|
|
|
11
|
assert_condition(0, 'Error::Hierarchy::Internal::ValueUndefined', |
85
|
|
|
|
|
|
|
$custom_message); |
86
|
|
|
|
|
|
|
} |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
sub assert_arrayref ($$) { |
89
|
0
|
|
|
0
|
1
|
0
|
my ($val, $custom_message) = @_; |
90
|
0
|
|
0
|
|
|
0
|
assert_condition( |
91
|
|
|
|
|
|
|
(defined($val) && ref($val) eq 'ARRAY'), |
92
|
|
|
|
|
|
|
'Error::Hierarchy::Internal::NoArrayRef', |
93
|
|
|
|
|
|
|
$custom_message |
94
|
|
|
|
|
|
|
); |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
sub assert_nonempty_arrayref ($$) { |
98
|
0
|
|
|
0
|
1
|
0
|
my ($val, $custom_message) = @_; |
99
|
0
|
|
0
|
|
|
0
|
assert_condition( |
100
|
|
|
|
|
|
|
(defined($val) && ref($val) eq 'ARRAY' && scalar @$val), |
101
|
|
|
|
|
|
|
'Error::Hierarchy::Internal::EmptyArrayRef', |
102
|
|
|
|
|
|
|
$custom_message |
103
|
|
|
|
|
|
|
); |
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
sub assert_hashref ($$) { |
107
|
0
|
|
|
0
|
1
|
0
|
my ($val, $custom_message) = @_; |
108
|
0
|
|
0
|
|
|
0
|
assert_condition( |
109
|
|
|
|
|
|
|
(defined($val) && ref($val) eq 'HASH'), |
110
|
|
|
|
|
|
|
'Error::Hierarchy::Internal::NoHashRef', |
111
|
|
|
|
|
|
|
$custom_message |
112
|
|
|
|
|
|
|
); |
113
|
|
|
|
|
|
|
} |
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
sub assert_nonempty_hashref ($$) { |
116
|
0
|
|
|
0
|
1
|
0
|
my ($val, $custom_message) = @_; |
117
|
0
|
|
0
|
|
|
0
|
assert_condition( |
118
|
|
|
|
|
|
|
(defined($val) && ref($val) eq 'HASH' && scalar keys %$val), |
119
|
|
|
|
|
|
|
'Error::Hierarchy::Internal::EmptyHashRef', |
120
|
|
|
|
|
|
|
$custom_message |
121
|
|
|
|
|
|
|
); |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
sub assert_is_integer ($) { |
125
|
1
|
|
|
1
|
1
|
567
|
my $val = shift; |
126
|
1
|
|
|
|
|
7
|
assert_condition( |
127
|
|
|
|
|
|
|
($val =~ /^[1-9]$/), |
128
|
|
|
|
|
|
|
'Error::Hierarchy::Internal::CustomMessage', |
129
|
|
|
|
|
|
|
'expected an integer value from 1 to 9' |
130
|
|
|
|
|
|
|
); |
131
|
|
|
|
|
|
|
} |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
# In Data::Conveyor, this function is called by service methods to verify |
134
|
|
|
|
|
|
|
# options passed to it. If the value given is true, we just return. If it is |
135
|
|
|
|
|
|
|
# false, we throw a special "help exception". When the shell service interface |
136
|
|
|
|
|
|
|
# calls a service method, it catches this help exception and prints |
137
|
|
|
|
|
|
|
# manpage-like help information for that method. |
138
|
|
|
|
|
|
|
sub assert_getopt ($$) { |
139
|
0
|
|
|
0
|
1
|
|
my ($val, $custom_message) = @_; |
140
|
0
|
0
|
|
|
|
|
return if $val; |
141
|
0
|
|
|
|
|
|
Data::Conveyor::Exception::ServiceMethodHelp->throw( |
142
|
|
|
|
|
|
|
custom_message => $custom_message); |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
sub assert_named_args { |
146
|
0
|
|
|
0
|
1
|
|
my ($args, @args_spec) = @_; |
147
|
0
|
|
|
|
|
|
my (%supported_args, @required_args); |
148
|
0
|
|
|
|
|
|
for (@args_spec) { |
149
|
0
|
|
|
|
|
|
/(^\+)?(.*)/; |
150
|
0
|
|
0
|
|
|
|
my $required = defined $1 && $1 eq '+'; |
151
|
0
|
|
|
|
|
|
$supported_args{$2}++; |
152
|
0
|
0
|
|
|
|
|
push @required_args => $2 if $required; |
153
|
|
|
|
|
|
|
} |
154
|
0
|
|
|
|
|
|
my @unsupported_args = grep { !$supported_args{$_} } keys %$args; |
|
0
|
|
|
|
|
|
|
155
|
0
|
|
|
|
|
|
my @missing_required_args = grep { !defined $args->{$_} } @required_args; |
|
0
|
|
|
|
|
|
|
156
|
0
|
0
|
0
|
|
|
|
return if @unsupported_args == 0 && @missing_required_args == 0; |
157
|
0
|
|
|
|
|
|
my $sub = (caller(1))[3]; |
158
|
0
|
|
|
|
|
|
my $message = "$sub() called with illegal named arguments:\n"; |
159
|
0
|
0
|
|
|
|
|
if (@missing_required_args) { |
160
|
0
|
|
|
|
|
|
local $" = ', '; |
161
|
0
|
|
|
|
|
|
$message .= " missing required arguments: @missing_required_args\n"; |
162
|
|
|
|
|
|
|
} |
163
|
0
|
0
|
|
|
|
|
if (@unsupported_args) { |
164
|
0
|
|
|
|
|
|
local $" = ', '; |
165
|
0
|
|
|
|
|
|
$message .= " unsupported arguments: @unsupported_args\n"; |
166
|
|
|
|
|
|
|
} |
167
|
0
|
|
|
|
|
|
Error::Hierarchy::Internal::CustomMessage->throw(custom_message => $message); |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
sub assert_enum { |
171
|
0
|
|
|
0
|
1
|
|
my ($val, $enum_arrayref, $custom_message) = @_; |
172
|
0
|
|
|
|
|
|
for my $valid_value (@$enum_arrayref) { |
173
|
0
|
0
|
|
|
|
|
return if $val eq $valid_value; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
throw Error::Hierarchy::Internal::CustomMessage( |
176
|
0
|
|
|
|
|
|
custom_message => "$custom_message: invalid value [$val]"); |
177
|
|
|
|
|
|
|
} |
178
|
|
|
|
|
|
|
|
179
|
|
|
|
|
|
|
# support for "virtual" classes that do not exist as files. |
180
|
|
|
|
|
|
|
# this is of no use for payload reinstantiation in a new |
181
|
|
|
|
|
|
|
# process, as Storable calls require() before touching any |
182
|
|
|
|
|
|
|
# accessor. it does allow a few things, though: |
183
|
|
|
|
|
|
|
# load_class XYZ, 1 for example, or calling static methods |
184
|
|
|
|
|
|
|
# directly, such as XYZ->DEFAULTS. |
185
|
|
|
|
|
|
|
sub loader_callback { |
186
|
0
|
0
|
|
0
|
1
|
|
shift if $_[0] eq __PACKAGE__; |
187
|
0
|
|
|
|
|
|
our $loader_callback; |
188
|
0
|
0
|
|
|
|
|
if (my $callback = shift) { |
189
|
0
|
0
|
|
|
|
|
throw Error::Hierarchy::Internal::CustomMessage( |
190
|
|
|
|
|
|
|
custom_message => "argument must be a coderef") |
191
|
|
|
|
|
|
|
unless ref $callback eq 'CODE'; |
192
|
0
|
|
|
|
|
|
$loader_callback = $callback; |
193
|
|
|
|
|
|
|
} |
194
|
0
|
|
|
|
|
|
$loader_callback; |
195
|
|
|
|
|
|
|
} |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
sub load_class ($$) { |
198
|
0
|
|
|
0
|
1
|
|
my ($class, $verbose) = @_; |
199
|
0
|
|
|
|
|
|
assert_defined $class, 'called without class argument.'; |
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
# An attempt at optimization: This sub is called very often. By relying on |
202
|
|
|
|
|
|
|
# every class defining a $VERSION, we can shortcut costly processing. |
203
|
|
|
|
|
|
|
{ |
204
|
2
|
|
|
2
|
|
13
|
no strict 'refs'; |
|
2
|
|
|
|
|
4
|
|
|
2
|
|
|
|
|
372
|
|
|
0
|
|
|
|
|
|
|
205
|
0
|
0
|
|
|
|
|
return if ${"$class\::VERSION"}; |
|
0
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
# report errors from perspective of caller |
209
|
0
|
|
|
|
|
|
local $Error::Depth = $Error::Depth + 1; |
210
|
0
|
|
|
|
|
|
eval "require $class"; |
211
|
0
|
0
|
0
|
|
|
|
if (defined($@) && $@ ne '') { |
212
|
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
# allow for dynamic class generation |
214
|
0
|
0
|
|
|
|
|
if (my $code = __PACKAGE__->loader_callback) { |
215
|
0
|
0
|
|
|
|
|
return $class if $code->($class); |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
|
218
|
|
|
|
|
|
|
# this error is so severe we want to print it during test mode |
219
|
0
|
0
|
|
|
|
|
print $@ if $verbose; |
220
|
0
|
|
|
|
|
|
throw Error::Hierarchy::Internal::CustomMessage(custom_message => |
221
|
|
|
|
|
|
|
sprintf("Couldn't load package [%s]: %s", $class, $@),); |
222
|
|
|
|
|
|
|
} |
223
|
0
|
|
|
|
|
|
$class; |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
1; |
226
|
|
|
|
|
|
|
|
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
__END__ |