line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
#!/usr/bin/perl -c |
2
|
|
|
|
|
|
|
|
3
|
|
|
|
|
|
|
package Test::Assert; |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
=head1 NAME |
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
Test::Assert - Assertion methods for those who like JUnit. |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
=head1 SYNOPSIS |
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
# Use as imported methods |
12
|
|
|
|
|
|
|
# |
13
|
|
|
|
|
|
|
package My::Test; |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
use Test::Assert ':all'; |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
assert_true(1, "pass"); |
18
|
|
|
|
|
|
|
assert_true(0, "fail"); |
19
|
|
|
|
|
|
|
|
20
|
|
|
|
|
|
|
use Test::More; |
21
|
|
|
|
|
|
|
assert_test(sub { require_ok($module) }); |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
# Use for debugging purposes |
24
|
|
|
|
|
|
|
# Assertions are compiled only if Test::Assert was used |
25
|
|
|
|
|
|
|
# from the main package. |
26
|
|
|
|
|
|
|
# |
27
|
|
|
|
|
|
|
package My::Package; |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
use Test::Assert ':assert'; |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
my $state = do_something(); |
32
|
|
|
|
|
|
|
assert_true($state >= 1 && $state <=2) if ASSERT; |
33
|
|
|
|
|
|
|
if ($state == 1) { |
34
|
|
|
|
|
|
|
# 1st state |
35
|
|
|
|
|
|
|
do_foo(); |
36
|
|
|
|
|
|
|
} elsif ($state == 2) { |
37
|
|
|
|
|
|
|
# 2nd and last state |
38
|
|
|
|
|
|
|
do_bar(); |
39
|
|
|
|
|
|
|
} |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
my $a = get_a(); |
42
|
|
|
|
|
|
|
my $b = get_b(); |
43
|
|
|
|
|
|
|
assert_num_not_equals(0, $b) if ASSERT; |
44
|
|
|
|
|
|
|
my $c = $a / $b; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
# Clean the namespace |
47
|
|
|
|
|
|
|
no Test::Assert; |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
# From command line |
50
|
|
|
|
|
|
|
$ perl -MTest::Assert script.pl # sets Test::Assert::ASSERT to 1 |
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
=head1 DESCRIPTION |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
This class provides a set of assertion methods useful for writing tests. The |
55
|
|
|
|
|
|
|
API is based on JUnit4 and L and the methods die on failure. |
56
|
|
|
|
|
|
|
|
57
|
|
|
|
|
|
|
These assertion methods might be not useful for common L-based |
58
|
|
|
|
|
|
|
(L, L, etc.) test units. |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
The assertion methods can be used in class which is derived from |
61
|
|
|
|
|
|
|
C or used as standard Perl functions after importing them into |
62
|
|
|
|
|
|
|
user's namespace. |
63
|
|
|
|
|
|
|
|
64
|
|
|
|
|
|
|
C can also wrap standard L, L or other |
65
|
|
|
|
|
|
|
L-based tests. |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
The assertions can be also used for run-time checking. |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
=for readme stop |
70
|
|
|
|
|
|
|
|
71
|
|
|
|
|
|
|
=cut |
72
|
|
|
|
|
|
|
|
73
|
4
|
|
|
4
|
|
119732
|
use 5.006; |
|
4
|
|
|
|
|
14
|
|
|
4
|
|
|
|
|
187
|
|
74
|
|
|
|
|
|
|
|
75
|
4
|
|
|
4
|
|
21
|
use strict; |
|
4
|
|
|
|
|
17
|
|
|
4
|
|
|
|
|
143
|
|
76
|
4
|
|
|
4
|
|
27
|
use warnings; |
|
4
|
|
|
|
|
16
|
|
|
4
|
|
|
|
|
247
|
|
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
our $VERSION = '0.0504'; |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
use Exception::Base ( |
82
|
4
|
|
|
|
|
37
|
'ignore_class' => [ __PACKAGE__, 'Test::Builder' ], |
83
|
|
|
|
|
|
|
'Exception::Assertion', |
84
|
4
|
|
|
4
|
|
5605
|
); |
|
4
|
|
|
|
|
58177
|
|
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# TRUE and FALSE |
88
|
4
|
|
|
4
|
|
10044
|
use constant::boolean; |
|
4
|
|
|
|
|
1353
|
|
|
4
|
|
|
|
|
23
|
|
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
# Debug mode is disabled by default |
92
|
|
|
|
|
|
|
## no critic (ProhibitConstantPragma) |
93
|
4
|
|
|
4
|
|
175
|
use constant ASSERT => FALSE; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
269
|
|
94
|
|
|
|
|
|
|
|
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
# Export ASSERT flag, all assert_* methods and fail method |
97
|
4
|
|
|
4
|
|
3878
|
use Symbol::Util qw( export_package unexport_package stash ); |
|
4
|
|
|
|
|
14995
|
|
|
4
|
|
|
|
|
38
|
|
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
# Variable required for assert_deep_equal |
101
|
|
|
|
|
|
|
my $DNE = bless [], 'Test::Assert::Does::Not::Exist'; |
102
|
|
|
|
|
|
|
|
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# Enable debug mode |
105
|
|
|
|
|
|
|
sub import { |
106
|
8
|
|
|
8
|
|
23099
|
my ($package, @names) = @_; |
107
|
8
|
|
|
|
|
22
|
my $caller = caller(); |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
# Enable only if called from main |
110
|
8
|
100
|
|
|
|
38
|
if ($caller eq 'main') { |
111
|
2
|
|
|
|
|
9
|
undef *ASSERT; |
112
|
2
|
|
|
|
|
7
|
*ASSERT = sub () { TRUE; }; |
113
|
|
|
|
|
|
|
}; |
114
|
|
|
|
|
|
|
|
115
|
8
|
|
|
|
|
17
|
my @export_ok = ( 'ASSERT', grep { /^(assert_|fail)/ } keys %{ stash(__PACKAGE__) } ); |
|
251
|
|
|
|
|
578
|
|
|
8
|
|
|
|
|
32
|
|
116
|
160
|
|
|
|
|
321
|
my %export_tags = ( |
117
|
|
|
|
|
|
|
all => [ @export_ok ], |
118
|
8
|
|
|
|
|
53
|
assert => [ grep { /^(assert_|ASSERT$)/ } @export_ok ], |
119
|
|
|
|
|
|
|
); |
120
|
|
|
|
|
|
|
|
121
|
8
|
|
|
|
|
63
|
return export_package($caller, $package, { |
122
|
|
|
|
|
|
|
OK => \@export_ok, |
123
|
|
|
|
|
|
|
TAGS => \%export_tags, |
124
|
|
|
|
|
|
|
}, @names); |
125
|
|
|
|
|
|
|
}; |
126
|
|
|
|
|
|
|
|
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
# Disable debug mode |
129
|
|
|
|
|
|
|
sub unimport { |
130
|
3
|
|
|
3
|
|
160
|
my ($package, @names) = @_; |
131
|
3
|
|
|
|
|
9
|
my $caller = caller(); |
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
# Disable only if called from main |
134
|
3
|
100
|
|
|
|
196
|
if ($caller eq 'main') { |
135
|
1
|
|
|
|
|
9
|
undef *ASSERT; |
136
|
1
|
|
|
|
|
4
|
*ASSERT = sub () { FALSE; }; |
137
|
|
|
|
|
|
|
}; |
138
|
|
|
|
|
|
|
|
139
|
3
|
|
|
|
|
15
|
return unexport_package($caller, $package); |
140
|
|
|
|
|
|
|
}; |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
|
143
|
|
|
|
|
|
|
## no critic (ProhibitNegativeExpressionsInUnlessAndUntilConditions) |
144
|
|
|
|
|
|
|
## no critic (ProhibitSubroutinePrototypes) |
145
|
|
|
|
|
|
|
## no critic (RequireArgUnpacking) |
146
|
|
|
|
|
|
|
## no critic (RequireCheckingReturnValueOfEval) |
147
|
|
|
|
|
|
|
|
148
|
|
|
|
|
|
|
# Fails a test with the given name. |
149
|
|
|
|
|
|
|
sub fail (;$$) { |
150
|
|
|
|
|
|
|
# check if called as function |
151
|
123
|
100
|
|
123
|
1
|
253
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
152
|
123
|
|
|
|
|
293
|
my ($message, $reason) = @_; |
153
|
|
|
|
|
|
|
|
154
|
123
|
|
|
|
|
924
|
Exception::Assertion->throw( |
155
|
|
|
|
|
|
|
message => $message, |
156
|
|
|
|
|
|
|
reason => $reason, |
157
|
|
|
|
|
|
|
); |
158
|
|
|
|
|
|
|
|
159
|
0
|
|
|
|
|
0
|
assert_false("Should never occured") if ASSERT; |
160
|
0
|
|
|
|
|
0
|
return FALSE; |
161
|
|
|
|
|
|
|
}; |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
# Asserts that a condition is true. |
165
|
|
|
|
|
|
|
sub assert_true ($;$) { |
166
|
|
|
|
|
|
|
# check if called as function |
167
|
8
|
100
|
|
8
|
1
|
85
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
168
|
8
|
|
|
|
|
12
|
my ($boolean, $message) = @_; |
169
|
|
|
|
|
|
|
|
170
|
8
|
100
|
|
|
|
23
|
$self->fail($message, "Expected true value, got undef") unless defined $boolean; |
171
|
6
|
100
|
|
|
|
17
|
$self->fail($message, "Expected true value, got '$boolean'") unless $boolean; |
172
|
4
|
|
|
|
|
7
|
return TRUE; |
173
|
|
|
|
|
|
|
}; |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
# Asserts that a condition is false. |
177
|
|
|
|
|
|
|
sub assert_false ($;$) { |
178
|
|
|
|
|
|
|
# check if called as function |
179
|
8
|
100
|
|
8
|
1
|
135
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
180
|
8
|
|
|
|
|
12
|
my ($boolean, $message) = @_; |
181
|
|
|
|
|
|
|
|
182
|
8
|
100
|
|
|
|
25
|
$self->fail($message, "Expected false value, got '$boolean'") unless not $boolean; |
183
|
5
|
|
|
|
|
11
|
return TRUE; |
184
|
|
|
|
|
|
|
}; |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
# Asserts that a value is null. |
188
|
|
|
|
|
|
|
sub assert_null ($;$) { |
189
|
|
|
|
|
|
|
# check if called as function |
190
|
8
|
100
|
|
8
|
1
|
75
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
191
|
8
|
|
|
|
|
13
|
my ($value, $message) = @_; |
192
|
|
|
|
|
|
|
|
193
|
8
|
100
|
|
|
|
29
|
$self->fail($message, "'$value' is defined") unless not defined $value; |
194
|
3
|
|
|
|
|
6
|
return TRUE; |
195
|
|
|
|
|
|
|
}; |
196
|
|
|
|
|
|
|
|
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
# Asserts that a value is not null. |
199
|
|
|
|
|
|
|
sub assert_not_null ($;$) { |
200
|
|
|
|
|
|
|
# check if called as function |
201
|
9
|
100
|
|
9
|
1
|
251
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
202
|
9
|
|
|
|
|
16
|
my ($value, $message) = @_; |
203
|
|
|
|
|
|
|
|
204
|
9
|
100
|
|
|
|
22
|
$self->fail($message, 'undef unexpected') unless defined $value; |
205
|
7
|
|
|
|
|
14
|
return TRUE; |
206
|
|
|
|
|
|
|
}; |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
# Assert that two values are equal |
210
|
|
|
|
|
|
|
sub assert_equals ($$;$) { |
211
|
|
|
|
|
|
|
# check if called as function |
212
|
40
|
100
|
|
40
|
1
|
823
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
213
|
40
|
|
|
|
|
75
|
my ($value1, $value2, $message) = @_; |
214
|
|
|
|
|
|
|
|
215
|
40
|
100
|
66
|
|
|
150
|
return TRUE if (not defined $value1 and not defined $value2); |
216
|
37
|
100
|
|
|
|
367
|
$self->fail( |
217
|
|
|
|
|
|
|
$message, 'Expected value was undef; should be using assert_null?' |
218
|
|
|
|
|
|
|
) unless defined $value1; |
219
|
36
|
100
|
|
|
|
262
|
$self->fail($message, "Expected '$value1', got undef") unless defined $value2; |
220
|
34
|
100
|
100
|
|
|
409
|
if ($value1 =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/ and |
221
|
|
|
|
|
|
|
$value2 =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/) |
222
|
|
|
|
|
|
|
{ |
223
|
4
|
|
|
4
|
|
5061
|
no warnings 'numeric'; |
|
4
|
|
|
|
|
15
|
|
|
4
|
|
|
|
|
1285
|
|
224
|
15
|
100
|
|
|
|
72
|
$self->fail($message, 'Expected ' . (0+$value1) . ', got ' . (0+$value2)) unless $value1 == $value2; |
225
|
|
|
|
|
|
|
} |
226
|
|
|
|
|
|
|
else { |
227
|
19
|
100
|
|
|
|
62
|
$self->fail($message, "Expected '$value1', got '$value2'") unless $value1 eq $value2; |
228
|
|
|
|
|
|
|
}; |
229
|
21
|
|
|
|
|
66
|
return TRUE; |
230
|
|
|
|
|
|
|
}; |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
|
233
|
|
|
|
|
|
|
# Assert that two values are not equal |
234
|
|
|
|
|
|
|
sub assert_not_equals ($$;$) { |
235
|
|
|
|
|
|
|
# check if called as function |
236
|
31
|
100
|
|
31
|
1
|
5637
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
237
|
31
|
|
|
|
|
59
|
my ($value1, $value2, $message) = @_; |
238
|
|
|
|
|
|
|
|
239
|
31
|
100
|
66
|
|
|
86
|
if (not defined $value1 and not defined $value2) { |
240
|
2
|
|
|
|
|
8
|
$self->fail($message, 'Both values were undefined'); |
241
|
|
|
|
|
|
|
}; |
242
|
29
|
100
|
75
|
|
|
145
|
return TRUE if (not defined $value1 xor not defined $value2); |
243
|
25
|
100
|
100
|
|
|
250
|
if ($value1 =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/ and |
244
|
|
|
|
|
|
|
$value2 =~ /^[+-]?(\d+\.\d+|\d+\.|\.\d+|\d+)([eE][+-]?\d+)?$/) |
245
|
|
|
|
|
|
|
{ |
246
|
4
|
|
|
4
|
|
24
|
no warnings 'numeric'; |
|
4
|
|
|
|
|
14
|
|
|
4
|
|
|
|
|
793
|
|
247
|
16
|
100
|
|
|
|
101
|
$self->fail($message, (0+$value1) . ' and ' . (0+$value2) . ' should differ') unless $value1 != $value2; |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
else { |
250
|
9
|
100
|
|
|
|
32
|
$self->fail($message, "'$value1' and '$value2' should differ") unless $value1 ne $value2; |
251
|
|
|
|
|
|
|
}; |
252
|
14
|
|
|
|
|
32
|
return TRUE; |
253
|
|
|
|
|
|
|
}; |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
# Assert that two values are numerically equal |
257
|
|
|
|
|
|
|
sub assert_num_equals ($$;$) { |
258
|
|
|
|
|
|
|
# check if called as function |
259
|
20
|
100
|
|
20
|
1
|
121
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
260
|
|
|
|
|
|
|
|
261
|
20
|
|
|
|
|
37
|
my ($value1, $value2, $message) = @_; |
262
|
20
|
100
|
66
|
|
|
50
|
return TRUE if (not defined $value1 and not defined $value2); |
263
|
4
|
|
|
4
|
|
24
|
no warnings 'numeric'; |
|
4
|
|
|
|
|
9
|
|
|
4
|
|
|
|
|
949
|
|
264
|
17
|
100
|
|
|
|
34
|
$self->fail($message, 'Expected undef, got ' . (0+$value2)) if not defined $value1; |
265
|
15
|
100
|
|
|
|
28
|
$self->fail($message, 'Expected ' . (0+$value1) . ', got undef') if not defined $value2; |
266
|
14
|
100
|
|
|
|
69
|
$self->fail($message, 'Expected ' . (0+$value1) . ', got ' . (0+$value2)) unless $value1 == $value2; |
267
|
13
|
|
|
|
|
27
|
return TRUE; |
268
|
|
|
|
|
|
|
}; |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
# Assert that two values are numerically not equal |
272
|
|
|
|
|
|
|
sub assert_num_not_equals ($$;$) { |
273
|
|
|
|
|
|
|
# check if called as function |
274
|
18
|
100
|
|
18
|
1
|
201
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
275
|
|
|
|
|
|
|
|
276
|
18
|
|
|
|
|
35
|
my ($value1, $value2, $message) = @_; |
277
|
18
|
100
|
66
|
|
|
43
|
if (not defined $value1 and not defined $value2) { |
278
|
1
|
|
|
|
|
4
|
$self->fail($message, 'Both values were undefined'); |
279
|
|
|
|
|
|
|
}; |
280
|
17
|
100
|
75
|
|
|
79
|
return TRUE if (not defined $value1 xor not defined $value2); |
281
|
4
|
|
|
4
|
|
24
|
no warnings 'numeric'; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
19768
|
|
282
|
15
|
100
|
|
|
|
88
|
$self->fail($message, (0+$value1) . ' and ' . (0+$value2) . ' should differ') unless $value1 != $value2; |
283
|
3
|
|
|
|
|
6
|
return TRUE; |
284
|
|
|
|
|
|
|
}; |
285
|
|
|
|
|
|
|
|
286
|
|
|
|
|
|
|
|
287
|
|
|
|
|
|
|
# Assert that two strings are equal |
288
|
|
|
|
|
|
|
sub assert_str_equals ($$;$) { |
289
|
|
|
|
|
|
|
# check if called as function |
290
|
13
|
100
|
|
13
|
1
|
147
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
291
|
|
|
|
|
|
|
|
292
|
13
|
|
|
|
|
23
|
my ($value1, $value2, $message) = @_; |
293
|
13
|
100
|
66
|
|
|
41
|
return TRUE if (not defined $value1 and not defined $value2); |
294
|
10
|
100
|
|
|
|
22
|
$self->fail( |
295
|
|
|
|
|
|
|
$message, 'Expected value was undef; should be using assert_null?' |
296
|
|
|
|
|
|
|
) unless defined $value1; |
297
|
9
|
100
|
|
|
|
18
|
$self->fail($message, "Expected '$value1', got undef") unless defined $value2; |
298
|
8
|
100
|
|
|
|
34
|
$self->fail($message, "Expected '$value1', got '$value2'") unless "$value1" eq "$value2"; |
299
|
4
|
|
|
|
|
11
|
return TRUE; |
300
|
|
|
|
|
|
|
}; |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
# Assert that two strings are not equal |
304
|
|
|
|
|
|
|
sub assert_str_not_equals ($$;$) { |
305
|
|
|
|
|
|
|
# check if called as function |
306
|
13
|
100
|
|
13
|
1
|
137
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
307
|
|
|
|
|
|
|
|
308
|
13
|
|
|
|
|
24
|
my ($value1, $value2, $message) = @_; |
309
|
13
|
100
|
66
|
|
|
38
|
if (not defined $value1 and not defined $value2) { |
310
|
1
|
|
|
|
|
4
|
$self->fail($message, 'Both values were undefined'); |
311
|
|
|
|
|
|
|
}; |
312
|
12
|
100
|
75
|
|
|
59
|
return TRUE if (not defined $value1 xor not defined $value2); |
313
|
8
|
100
|
|
|
|
35
|
$self->fail($message, "'$value1' and '$value2' should differ") unless "$value1" ne "$value2"; |
314
|
4
|
|
|
|
|
10
|
return TRUE; |
315
|
|
|
|
|
|
|
}; |
316
|
|
|
|
|
|
|
|
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# Assert that string matches regexp |
319
|
|
|
|
|
|
|
sub assert_matches ($$;$) { |
320
|
|
|
|
|
|
|
# check if called as function |
321
|
9
|
100
|
|
9
|
1
|
1244
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
322
|
|
|
|
|
|
|
|
323
|
9
|
|
|
|
|
17
|
my ($regexp, $value, $message) = @_; |
324
|
9
|
100
|
|
|
|
33
|
$self->fail( |
325
|
|
|
|
|
|
|
$message, 'Expected value was undef; should be using assert_null?' |
326
|
|
|
|
|
|
|
) unless defined $regexp; |
327
|
8
|
100
|
|
|
|
21
|
$self->fail( |
328
|
|
|
|
|
|
|
$message, 'Argument 1 to assert_matches() must be a regexp' |
329
|
|
|
|
|
|
|
) unless ref $regexp eq 'Regexp'; |
330
|
7
|
100
|
|
|
|
19
|
$self->fail($message, "Expected /$regexp/, got undef") unless defined $value; |
331
|
6
|
100
|
|
|
|
38
|
$self->fail($message, "'$value' didn't match /$regexp/") unless $value =~ $regexp; |
332
|
5
|
|
|
|
|
22
|
return TRUE; |
333
|
|
|
|
|
|
|
}; |
334
|
|
|
|
|
|
|
|
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
# Assert that string matches regexp |
337
|
|
|
|
|
|
|
sub assert_not_matches ($$;$) { |
338
|
|
|
|
|
|
|
# check if called as function |
339
|
8
|
100
|
|
8
|
1
|
109
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
340
|
|
|
|
|
|
|
|
341
|
8
|
|
|
|
|
13
|
my ($regexp, $value, $message) = @_; |
342
|
8
|
100
|
|
|
|
21
|
$self->fail( |
343
|
|
|
|
|
|
|
$message, 'Expected value was undef; should be using assert_null?' |
344
|
|
|
|
|
|
|
) unless defined $regexp; |
345
|
6
|
100
|
|
|
|
15
|
return TRUE if not defined $value; |
346
|
3
|
100
|
|
|
|
24
|
$self->fail( |
347
|
|
|
|
|
|
|
$message, 'Argument 1 to assert_not_matches() must be a regexp' |
348
|
|
|
|
|
|
|
) unless ref $regexp eq 'Regexp'; |
349
|
2
|
100
|
|
|
|
14
|
$self->fail($message, "'$value' matched /$regexp/") unless $value !~ $regexp; |
350
|
1
|
|
|
|
|
4
|
return TRUE; |
351
|
|
|
|
|
|
|
}; |
352
|
|
|
|
|
|
|
|
353
|
|
|
|
|
|
|
|
354
|
|
|
|
|
|
|
# Assert that data structures are deeply equal |
355
|
|
|
|
|
|
|
sub assert_deep_equals ($$;$) { |
356
|
|
|
|
|
|
|
# check if called as function |
357
|
37
|
100
|
|
37
|
1
|
13043
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
358
|
|
|
|
|
|
|
|
359
|
37
|
|
|
|
|
80
|
my ($value1, $value2, $message) = @_; |
360
|
37
|
100
|
100
|
|
|
146
|
$self->fail($message, 'Both arguments were not references') unless ref $value1 or ref $value2; |
361
|
32
|
100
|
|
|
|
81
|
$self->fail($message, 'Argument 1 to assert_deep_equals() must be a reference') unless ref $value1; |
362
|
31
|
100
|
|
|
|
147
|
$self->fail($message, 'Argument 2 to assert_deep_equals() must be a reference') unless ref $value2; |
363
|
|
|
|
|
|
|
|
364
|
30
|
|
|
|
|
54
|
my $data_stack = []; |
365
|
30
|
|
|
|
|
51
|
my $seen_refs = {}; |
366
|
|
|
|
|
|
|
|
367
|
30
|
100
|
|
|
|
106
|
$self->fail( |
368
|
|
|
|
|
|
|
$message, $self->_format_stack($data_stack) |
369
|
|
|
|
|
|
|
) unless $self->_deep_check($value1, $value2, $data_stack, $seen_refs); |
370
|
|
|
|
|
|
|
|
371
|
15
|
|
|
|
|
68
|
return TRUE; |
372
|
|
|
|
|
|
|
}; |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
|
375
|
|
|
|
|
|
|
# Assert that data structures are deeply equal |
376
|
|
|
|
|
|
|
sub assert_deep_not_equals ($$;$) { |
377
|
|
|
|
|
|
|
# check if called as function |
378
|
15
|
100
|
|
15
|
1
|
272
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
379
|
|
|
|
|
|
|
|
380
|
15
|
|
|
|
|
33
|
my ($value1, $value2, $message) = @_; |
381
|
15
|
100
|
100
|
|
|
57
|
$self->fail($message, 'Both arguments were not references') unless ref $value1 or ref $value2; |
382
|
12
|
100
|
|
|
|
26
|
$self->fail($message, 'Argument 1 to assert_deep_equals() must be a reference') unless ref $value1; |
383
|
11
|
100
|
|
|
|
22
|
$self->fail($message, 'Argument 2 to assert_deep_equals() must be a reference') unless ref $value2; |
384
|
|
|
|
|
|
|
|
385
|
10
|
|
|
|
|
14
|
my $data_stack = []; |
386
|
10
|
|
|
|
|
14
|
my $seen_refs = {}; |
387
|
|
|
|
|
|
|
|
388
|
10
|
100
|
|
|
|
35
|
$self->fail( |
389
|
|
|
|
|
|
|
$message, 'Both structures should differ' |
390
|
|
|
|
|
|
|
) unless not $self->_deep_check($value1, $value2, $data_stack, $seen_refs); |
391
|
|
|
|
|
|
|
|
392
|
6
|
|
|
|
|
35
|
return TRUE; |
393
|
|
|
|
|
|
|
}; |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
|
396
|
|
|
|
|
|
|
# Assert that object is a class |
397
|
|
|
|
|
|
|
sub assert_isa ($$;$) { |
398
|
|
|
|
|
|
|
# check if called as function |
399
|
11
|
100
|
|
11
|
1
|
333
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
400
|
|
|
|
|
|
|
|
401
|
11
|
|
|
|
|
24
|
my ($class, $value, $message) = @_; |
402
|
|
|
|
|
|
|
|
403
|
11
|
100
|
|
|
|
31
|
$self->fail( |
404
|
|
|
|
|
|
|
$message, 'Class name was undef; should be using assert_null?' |
405
|
|
|
|
|
|
|
) unless defined $class; |
406
|
10
|
100
|
|
|
|
24
|
$self->fail($message, "Expected '$class' object or class, got undef") unless defined $value; |
407
|
9
|
100
|
|
|
|
20
|
if (not __isa($value, $class)) { |
408
|
2
|
100
|
|
|
|
12
|
$self->fail($message, "Expected '$class' object or class, got '" . ref($value) . "' reference") if ref $value; |
409
|
1
|
|
|
|
|
6
|
$self->fail($message, "Expected '$class' object or class, got '$value' value"); |
410
|
|
|
|
|
|
|
}; |
411
|
7
|
|
|
|
|
26
|
return TRUE; |
412
|
|
|
|
|
|
|
}; |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
# Assert that object is not a class |
416
|
|
|
|
|
|
|
sub assert_not_isa ($$;$) { |
417
|
|
|
|
|
|
|
# check if called as function |
418
|
7
|
100
|
|
7
|
1
|
460
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
419
|
|
|
|
|
|
|
|
420
|
7
|
|
|
|
|
14
|
my ($class, $value, $message) = @_; |
421
|
|
|
|
|
|
|
|
422
|
7
|
100
|
|
|
|
22
|
$self->fail( |
423
|
|
|
|
|
|
|
$message, 'Class name was undef; should be using assert_null?' |
424
|
|
|
|
|
|
|
) unless defined $class; |
425
|
6
|
100
|
|
|
|
12
|
if (__isa($value, $class)) { |
426
|
2
|
|
|
|
|
18
|
$self->fail($message, "'$value' is a '$class' object or class"); |
427
|
|
|
|
|
|
|
}; |
428
|
4
|
|
|
|
|
11
|
return TRUE; |
429
|
|
|
|
|
|
|
}; |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
# Assert that code throws an exception |
433
|
|
|
|
|
|
|
sub assert_raises ($&;$) { |
434
|
|
|
|
|
|
|
# check if called as function |
435
|
189
|
100
|
|
189
|
1
|
36150
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
436
|
|
|
|
|
|
|
|
437
|
189
|
|
|
|
|
413
|
my ($expected, $code, $message) = @_; |
438
|
|
|
|
|
|
|
|
439
|
189
|
|
|
|
|
261
|
eval { |
440
|
189
|
|
|
|
|
2971
|
$code->(); |
441
|
|
|
|
|
|
|
}; |
442
|
189
|
100
|
|
|
|
54021
|
if ($@) { |
443
|
187
|
|
|
|
|
1388
|
my $e = $@; |
444
|
187
|
100
|
100
|
|
|
1053
|
if (ref $e and __isa($e, 'Exception::Base')) { |
445
|
127
|
100
|
|
|
|
510
|
return TRUE if $e->matches($expected); |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
else { |
448
|
60
|
100
|
|
|
|
163
|
if (ref $expected eq 'Regexp') { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
449
|
53
|
100
|
|
|
|
562
|
return TRUE if "$e" =~ $expected; |
450
|
|
|
|
|
|
|
} |
451
|
|
|
|
|
|
|
elsif (ref $expected eq 'ARRAY') { |
452
|
3
|
100
|
|
|
|
5
|
return TRUE if grep { __isa($e, $_) } @{ $expected }; |
|
3
|
|
|
|
|
8
|
|
|
3
|
|
|
|
|
6
|
|
453
|
|
|
|
|
|
|
} |
454
|
|
|
|
|
|
|
elsif (not ref $expected) { |
455
|
4
|
|
|
|
|
10
|
my $caught_message = "$e"; |
456
|
4
|
|
|
|
|
14
|
while ($caught_message =~ s/\t\.\.\.propagated at (?!.*\bat\b.*).* line \d+( thread \d+)?\.\n$//s) { } |
457
|
4
|
|
|
|
|
35
|
$caught_message =~ s/( at (?!.*\bat\b.*).* line \d+( thread \d+)?\.)?\n$//s; |
458
|
4
|
100
|
|
|
|
16
|
return TRUE if $caught_message eq $expected; |
459
|
|
|
|
|
|
|
}; |
460
|
|
|
|
|
|
|
}; |
461
|
|
|
|
|
|
|
# Rethrow an exception |
462
|
|
|
|
|
|
|
## no critic (RequireCarping) |
463
|
5
|
|
|
|
|
92
|
die $e; |
464
|
|
|
|
|
|
|
} |
465
|
|
|
|
|
|
|
else { |
466
|
2
|
|
|
|
|
6
|
$self->fail( |
467
|
|
|
|
|
|
|
$message, 'Expected exception was not raised' |
468
|
|
|
|
|
|
|
); |
469
|
|
|
|
|
|
|
}; |
470
|
0
|
|
|
|
|
0
|
return TRUE; |
471
|
|
|
|
|
|
|
}; |
472
|
|
|
|
|
|
|
|
473
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
# Assert that Test::Builder method is ok |
475
|
|
|
|
|
|
|
sub assert_test (&;$) { |
476
|
|
|
|
|
|
|
# check if called as function |
477
|
0
|
0
|
|
0
|
1
|
0
|
my $self = __isa($_[0], __PACKAGE__) ? shift : __PACKAGE__; |
478
|
|
|
|
|
|
|
|
479
|
0
|
|
|
|
|
0
|
my ($code, $message) = @_; |
480
|
|
|
|
|
|
|
|
481
|
0
|
|
|
|
|
0
|
my $diag_message = ''; |
482
|
0
|
|
|
|
|
0
|
my $ok_message = ''; |
483
|
0
|
|
|
|
|
0
|
my $ok_return = TRUE; |
484
|
|
|
|
|
|
|
|
485
|
4
|
|
|
4
|
|
38
|
no warnings 'once', 'redefine'; |
|
4
|
|
|
|
|
8
|
|
|
4
|
|
|
|
|
7441
|
|
486
|
|
|
|
|
|
|
local *Test::Builder::diag = sub { |
487
|
0
|
0
|
|
0
|
|
0
|
$diag_message .= $_[1] if defined $_[1]; |
488
|
0
|
|
|
|
|
0
|
}; |
489
|
|
|
|
|
|
|
local *Test::Builder::ok = sub { |
490
|
0
|
0
|
|
0
|
|
0
|
$ok_message .= $_[2] if defined $_[2]; |
491
|
0
|
|
|
|
|
0
|
return $ok_return = $_[1]; |
492
|
0
|
|
|
|
|
0
|
}; |
493
|
|
|
|
|
|
|
|
494
|
0
|
|
|
|
|
0
|
$code->(); |
495
|
0
|
0
|
|
|
|
0
|
if (not $ok_return) { |
496
|
0
|
0
|
0
|
|
|
0
|
my $new_message = (defined $message ? $message : '') |
|
|
0
|
0
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
497
|
|
|
|
|
|
|
. (defined $message && $message ne '' && $ok_message ne '' ? ': ' : '') |
498
|
|
|
|
|
|
|
. ($ok_message =~ /\n/s ? "\n" : '') |
499
|
|
|
|
|
|
|
. $ok_message |
500
|
|
|
|
|
|
|
. ($ok_message ne '' && $diag_message ne '' ? ': ' : '') |
501
|
|
|
|
|
|
|
. ($diag_message =~ /\n/s ? "\n" : '') |
502
|
|
|
|
|
|
|
. $diag_message; |
503
|
0
|
0
|
|
|
|
0
|
$self->fail( |
504
|
|
|
|
|
|
|
$new_message, 'assert_test failed' |
505
|
|
|
|
|
|
|
) unless $ok_return; |
506
|
|
|
|
|
|
|
}; |
507
|
0
|
|
|
|
|
0
|
return TRUE; |
508
|
|
|
|
|
|
|
}; |
509
|
|
|
|
|
|
|
|
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
# Checks if deep structures are equal |
512
|
|
|
|
|
|
|
sub _deep_check { |
513
|
193
|
|
|
193
|
|
380
|
my ($self, $e1, $e2, $data_stack, $seen_refs) = @_; |
514
|
|
|
|
|
|
|
|
515
|
193
|
100
|
66
|
|
|
1137
|
if ( ! defined $e1 || ! defined $e2 ) { |
516
|
7
|
100
|
66
|
|
|
33
|
return TRUE if !defined $e1 && !defined $e2; |
517
|
4
|
|
|
|
|
13
|
push @$data_stack, { vals => [$e1, $e2] }; |
518
|
4
|
|
|
|
|
14
|
return FALSE; |
519
|
|
|
|
|
|
|
}; |
520
|
|
|
|
|
|
|
|
521
|
186
|
100
|
|
|
|
1361
|
return TRUE if $e1 eq $e2; |
522
|
|
|
|
|
|
|
|
523
|
87
|
100
|
100
|
|
|
455
|
if ( ref $e1 && ref $e2 ) { |
524
|
73
|
|
|
|
|
138
|
my $e2_ref = "$e2"; |
525
|
73
|
100
|
66
|
|
|
229
|
return TRUE if defined $seen_refs->{$e1} && $seen_refs->{$e1} eq $e2_ref; |
526
|
69
|
|
|
|
|
217
|
$seen_refs->{$e1} = $e2_ref; |
527
|
|
|
|
|
|
|
}; |
528
|
|
|
|
|
|
|
|
529
|
83
|
100
|
100
|
|
|
611
|
if (ref $e1 eq 'ARRAY' and ref $e2 eq 'ARRAY') { |
|
|
100
|
66
|
|
|
|
|
|
|
50
|
33
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
530
|
34
|
|
|
|
|
501
|
return $self->_eq_array($e1, $e2, $data_stack, $seen_refs); |
531
|
|
|
|
|
|
|
} |
532
|
|
|
|
|
|
|
elsif (ref $e1 eq 'HASH' and ref $e2 eq 'HASH') { |
533
|
29
|
|
|
|
|
83
|
return $self->_eq_hash($e1, $e2, $data_stack, $seen_refs); |
534
|
|
|
|
|
|
|
} |
535
|
|
|
|
|
|
|
elsif (ref $e1 eq 'REF' and ref $e2 eq 'REF') { |
536
|
0
|
|
|
|
|
0
|
push @$data_stack, { type => 'REF', vals => [$e1, $e2] }; |
537
|
0
|
|
|
|
|
0
|
my $ok = $self->_deep_check($$e1, $$e2, $data_stack, $seen_refs); |
538
|
0
|
0
|
|
|
|
0
|
pop @$data_stack if $ok; |
539
|
0
|
|
|
|
|
0
|
return $ok; |
540
|
|
|
|
|
|
|
} |
541
|
|
|
|
|
|
|
elsif (ref $e1 eq 'SCALAR' and ref $e2 eq 'SCALAR') { |
542
|
3
|
|
|
|
|
8
|
push @$data_stack, { type => 'REF', vals => [$e1, $e2] }; |
543
|
3
|
|
|
|
|
10
|
return $self->_deep_check($$e1, $$e2, $data_stack, $seen_refs); |
544
|
|
|
|
|
|
|
} |
545
|
|
|
|
|
|
|
else { |
546
|
17
|
|
|
|
|
69
|
push @$data_stack, { vals => [$e1, $e2] }; |
547
|
|
|
|
|
|
|
}; |
548
|
|
|
|
|
|
|
|
549
|
17
|
|
|
|
|
52
|
return FALSE; |
550
|
|
|
|
|
|
|
}; |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
|
553
|
|
|
|
|
|
|
# Checks if arrays are equal |
554
|
|
|
|
|
|
|
sub _eq_array { |
555
|
34
|
|
|
34
|
|
59
|
my ($self, $a1, $a2, $data_stack, $seen_refs) = @_; |
556
|
|
|
|
|
|
|
|
557
|
34
|
50
|
|
|
|
85
|
return TRUE if $a1 eq $a2; |
558
|
|
|
|
|
|
|
|
559
|
34
|
|
|
|
|
49
|
my $ok = TRUE; |
560
|
34
|
100
|
|
|
|
83
|
my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; |
561
|
|
|
|
|
|
|
|
562
|
34
|
|
|
|
|
82
|
foreach (0..$max) { |
563
|
104
|
100
|
|
|
|
212
|
my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; |
564
|
104
|
100
|
|
|
|
392
|
my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; |
565
|
|
|
|
|
|
|
|
566
|
104
|
|
|
|
|
461
|
push @$data_stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; |
567
|
104
|
|
|
|
|
296
|
$ok = $self->_deep_check($e1, $e2, $data_stack, $seen_refs); |
568
|
104
|
100
|
|
|
|
224
|
pop @$data_stack if $ok; |
569
|
|
|
|
|
|
|
|
570
|
104
|
100
|
|
|
|
380
|
last unless $ok; |
571
|
|
|
|
|
|
|
}; |
572
|
|
|
|
|
|
|
|
573
|
34
|
|
|
|
|
149
|
return $ok; |
574
|
|
|
|
|
|
|
}; |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
|
577
|
|
|
|
|
|
|
# Checks if hashes are equal |
578
|
|
|
|
|
|
|
sub _eq_hash { |
579
|
29
|
|
|
29
|
|
55
|
my ($self, $a1, $a2, $data_stack, $seen_refs) = @_; |
580
|
|
|
|
|
|
|
|
581
|
29
|
50
|
|
|
|
68
|
return TRUE if $a1 eq $a2; |
582
|
|
|
|
|
|
|
|
583
|
29
|
|
|
|
|
41
|
my $ok = TRUE; |
584
|
29
|
100
|
|
|
|
182
|
my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; |
585
|
29
|
|
|
|
|
68
|
foreach my $k (keys %$bigger) { |
586
|
46
|
50
|
|
|
|
110
|
my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; |
587
|
46
|
100
|
|
|
|
257
|
my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; |
588
|
|
|
|
|
|
|
|
589
|
46
|
|
|
|
|
175
|
push @$data_stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; |
590
|
46
|
|
|
|
|
129
|
$ok = $self->_deep_check($e1, $e2, $data_stack, $seen_refs); |
591
|
46
|
100
|
|
|
|
200
|
pop @$data_stack if $ok; |
592
|
|
|
|
|
|
|
|
593
|
46
|
100
|
|
|
|
149
|
last unless $ok; |
594
|
|
|
|
|
|
|
}; |
595
|
|
|
|
|
|
|
|
596
|
29
|
|
|
|
|
124
|
return $ok; |
597
|
|
|
|
|
|
|
}; |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
|
600
|
|
|
|
|
|
|
# Dumps the differences for deep structures |
601
|
|
|
|
|
|
|
sub _format_stack { |
602
|
15
|
|
|
15
|
|
23
|
my ($self, $data_stack) = @_; |
603
|
|
|
|
|
|
|
|
604
|
15
|
|
|
|
|
18
|
my $var = '$FOO'; |
605
|
15
|
|
|
|
|
78
|
my $did_arrow = 0; |
606
|
15
|
|
|
|
|
29
|
foreach my $entry (@$data_stack) { |
607
|
36
|
|
100
|
|
|
120
|
my $type = $entry->{type} || ''; |
608
|
36
|
|
|
|
|
44
|
my $idx = $entry->{'idx'}; |
609
|
36
|
100
|
|
|
|
150
|
if ($type eq 'HASH') { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
610
|
9
|
100
|
|
|
|
23
|
$var .= "->" unless $did_arrow++; |
611
|
9
|
|
|
|
|
20
|
$var .= "{$idx}"; |
612
|
|
|
|
|
|
|
} |
613
|
|
|
|
|
|
|
elsif ($type eq 'ARRAY') { |
614
|
10
|
100
|
|
|
|
86
|
$var .= "->" unless $did_arrow++; |
615
|
10
|
|
|
|
|
23
|
$var .= "[$idx]"; |
616
|
|
|
|
|
|
|
} |
617
|
|
|
|
|
|
|
elsif ($type eq 'REF') { |
618
|
2
|
|
|
|
|
4
|
$var = "\${$var}"; |
619
|
|
|
|
|
|
|
}; |
620
|
|
|
|
|
|
|
}; |
621
|
|
|
|
|
|
|
|
622
|
15
|
|
|
|
|
25
|
my @vals = @{$data_stack->[-1]{vals}}[0,1]; |
|
15
|
|
|
|
|
303
|
|
623
|
|
|
|
|
|
|
|
624
|
15
|
|
|
|
|
21
|
my @vars = (); |
625
|
15
|
|
|
|
|
193
|
($vars[0] = $var) =~ s/\$FOO/ \$a/; |
626
|
15
|
|
|
|
|
135
|
($vars[1] = $var) =~ s/\$FOO/ \$b/; |
627
|
|
|
|
|
|
|
|
628
|
15
|
|
|
|
|
21
|
my $out = "Structures begin differing at:\n"; |
629
|
15
|
|
|
|
|
36
|
foreach my $idx (0..$#vals) { |
630
|
30
|
|
|
|
|
41
|
my $val = $vals[$idx]; |
631
|
30
|
100
|
|
|
|
220
|
$vals[$idx] = !defined $val ? 'undef' : |
|
|
100
|
|
|
|
|
|
632
|
|
|
|
|
|
|
$val eq $DNE ? 'Does not exist' |
633
|
|
|
|
|
|
|
: "'$val'"; |
634
|
|
|
|
|
|
|
}; |
635
|
|
|
|
|
|
|
|
636
|
15
|
|
|
|
|
41
|
$out .= "$vars[0] = $vals[0]\n"; |
637
|
15
|
|
|
|
|
29
|
$out .= "$vars[1] = $vals[1]"; |
638
|
|
|
|
|
|
|
|
639
|
15
|
|
|
|
|
64
|
return $out; |
640
|
|
|
|
|
|
|
}; |
641
|
|
|
|
|
|
|
|
642
|
|
|
|
|
|
|
|
643
|
|
|
|
|
|
|
# Better, safe "isa" function |
644
|
|
|
|
|
|
|
sub __isa { |
645
|
715
|
|
|
715
|
|
2017
|
my ($object, $class) = @_; |
646
|
715
|
|
|
|
|
1635
|
local $@ = ''; |
647
|
715
|
|
|
|
|
3084
|
local $SIG{__DIE__} = ''; |
648
|
715
|
|
|
|
|
1166
|
return eval { $object->isa($class) }; |
|
715
|
|
|
|
|
8597
|
|
649
|
|
|
|
|
|
|
}; |
650
|
|
|
|
|
|
|
|
651
|
|
|
|
|
|
|
|
652
|
4
|
|
|
4
|
|
45
|
no constant::boolean; |
|
4
|
|
|
|
|
7
|
|
|
4
|
|
|
|
|
43
|
|
653
|
4
|
|
|
4
|
|
2641
|
no Symbol::Util; |
|
4
|
|
|
|
|
10
|
|
|
4
|
|
|
|
|
805
|
|
654
|
|
|
|
|
|
|
|
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
1; |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
|
659
|
|
|
|
|
|
|
=begin umlwiki |
660
|
|
|
|
|
|
|
|
661
|
|
|
|
|
|
|
= Component Diagram = |
662
|
|
|
|
|
|
|
|
663
|
|
|
|
|
|
|
[ Test::Assert | |
664
|
|
|
|
|
|
|
[Test::Assert {=}] |
665
|
|
|
|
|
|
|
[Exception::Assertion {=}] ] |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
= Class Diagram = |
668
|
|
|
|
|
|
|
|
669
|
|
|
|
|
|
|
[ <> |
670
|
|
|
|
|
|
|
Test::Assert |
671
|
|
|
|
|
|
|
---------------------------------------------------------------------------------- |
672
|
|
|
|
|
|
|
---------------------------------------------------------------------------------- |
673
|
|
|
|
|
|
|
fail( message : Str = undef, reason : Str = undef ) |
674
|
|
|
|
|
|
|
assert_true( boolean : Bool, message : Str = undef ) |
675
|
|
|
|
|
|
|
assert_false( boolean : Bool, message : Str = undef ) |
676
|
|
|
|
|
|
|
assert_null( value : Any, message : Str = undef ) |
677
|
|
|
|
|
|
|
assert_not_null( value : Any, message : Str = undef ) |
678
|
|
|
|
|
|
|
assert_equals( value1 : Defined, value2 : Defined, message : Str = undef ) |
679
|
|
|
|
|
|
|
assert_not_equals( value1 : Defined, value2 : Defined, message : Str = undef ) |
680
|
|
|
|
|
|
|
assert_num_equals( value1 : Defined, value2 : Defined, message : Str = undef ) |
681
|
|
|
|
|
|
|
assert_num_not_equals( value1 : Defined, value2 : Defined, message : Str = undef ) |
682
|
|
|
|
|
|
|
assert_str_equals( value1 : Defined, value2 : Defined, message : Str = undef ) |
683
|
|
|
|
|
|
|
assert_str_not_equals( value1 : Defined, value2 : Defined, message : Str = undef ) |
684
|
|
|
|
|
|
|
assert_matches( regexp : RegexpRef, value : Str, message : Str = undef ) |
685
|
|
|
|
|
|
|
assert_not_matches( regexp : RegexpRef, value : Str, message : Str = undef ) |
686
|
|
|
|
|
|
|
assert_deep_equals( value1 : Ref, value2 : Ref, message : Str = undef ) |
687
|
|
|
|
|
|
|
assert_deep_not_equals( value1 : Ref, value2 : Ref, message : Str = undef ) |
688
|
|
|
|
|
|
|
assert_isa( class : Str, object : Defined, message : Str = undef ) |
689
|
|
|
|
|
|
|
assert_not_isa( class : Str, object : Defined, message : Str = undef ) |
690
|
|
|
|
|
|
|
assert_raises( expected : Any, code : CodeRef, message : Str = undef ) |
691
|
|
|
|
|
|
|
assert_test( code : CodeRef, message : Str = undef ) |
692
|
|
|
|
|
|
|
<> ASSERT() : Bool ] |
693
|
|
|
|
|
|
|
|
694
|
|
|
|
|
|
|
[Test::Assert] ---> <> [Exception::Assertion] |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
[Exception::Assertion] ---|> [Exception::Base] |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
=end umlwiki |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
=head1 EXCEPTIONS |
701
|
|
|
|
|
|
|
|
702
|
|
|
|
|
|
|
=over |
703
|
|
|
|
|
|
|
|
704
|
|
|
|
|
|
|
=item Exception::Assertion |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
Thrown whether an assertion failed. |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
=back |
709
|
|
|
|
|
|
|
|
710
|
|
|
|
|
|
|
=head1 USAGE |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
By default, the class does not export its symbols. |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
=over |
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
=item use Test::Assert; |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
Enables debug mode if it is used in C package. |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
package main; |
721
|
|
|
|
|
|
|
use Test::Assert; # Test::Assert::ASSERT is set to TRUE |
722
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
$ perl -MTest::Assert script.pl # ditto |
724
|
|
|
|
|
|
|
|
725
|
|
|
|
|
|
|
=item use Test::Assert 'assert_true', 'fail', ...; |
726
|
|
|
|
|
|
|
|
727
|
|
|
|
|
|
|
Imports some methods. |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
=item use Test::Assert ':all'; |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
Imports all C methods, C method and C constant. |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
=item use Test::Assert ':assert'; |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
Imports all C methods and C constant. |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
=item no Test::Assert; |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
Disables debug mode if it is used in C package. |
740
|
|
|
|
|
|
|
|
741
|
|
|
|
|
|
|
=back |
742
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
=head1 CONSTANTS |
744
|
|
|
|
|
|
|
|
745
|
|
|
|
|
|
|
=over |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
=item ASSERT |
748
|
|
|
|
|
|
|
|
749
|
|
|
|
|
|
|
This constant is set to true value if C module is used from |
750
|
|
|
|
|
|
|
C package. It allows to enable debug mode globally from command line. |
751
|
|
|
|
|
|
|
The debug mode is disabled by default. |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
package My::Test; |
754
|
|
|
|
|
|
|
use Test::Assert ':assert'; |
755
|
|
|
|
|
|
|
assert_true( 0 ) if ASSERT; # fails only if debug mode is enabled |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
$ perl -MTest::Assert script.pl # enable debug mode |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
=back |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
=head1 METHODS |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
=over |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
=item fail( I : Str = undef, I : Str = undef ) |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
Immediate fail the test. The L object will have set |
768
|
|
|
|
|
|
|
I and I attribute based on arguments. |
769
|
|
|
|
|
|
|
|
770
|
|
|
|
|
|
|
=item assert_true( I : Bool, I : Str = undef ) |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
Checks if I expression returns true value. |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
=item assert_false( I : Bool, I : Str = undef ) |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
Checks if I expression returns false value. |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
=item assert_null( I : Any, I : Str = undef ) |
779
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
=item assert_not_null( I : Any, I : Str = undef ) |
781
|
|
|
|
|
|
|
|
782
|
|
|
|
|
|
|
Checks if I is defined or not defined. |
783
|
|
|
|
|
|
|
|
784
|
|
|
|
|
|
|
=item assert_equals( I : Defined, I : Defined, I : Str = undef ) |
785
|
|
|
|
|
|
|
|
786
|
|
|
|
|
|
|
=item assert_not_equals( I : Defined, I : Defined, I : Str = undef ) |
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
Checks if I and I are equals or not equals. If I and |
789
|
|
|
|
|
|
|
I look like numbers then they are compared with '==' operator, |
790
|
|
|
|
|
|
|
otherwise the string 'eq' operator is used. |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
=item assert_num_equals( I : Defined, I : Defined, I : Str = undef ) |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
=item assert_num_not_equals( I : Defined, I : Defined, I : Str = undef ) |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
Force numeric comparation. |
797
|
|
|
|
|
|
|
|
798
|
|
|
|
|
|
|
=item assert_str_equals( I : Defined, I : Defined, I : Str = undef ) |
799
|
|
|
|
|
|
|
|
800
|
|
|
|
|
|
|
=item assert_str_not_equals( I : Defined, I : Defined, I : Str = undef ) |
801
|
|
|
|
|
|
|
|
802
|
|
|
|
|
|
|
Force string comparation. |
803
|
|
|
|
|
|
|
|
804
|
|
|
|
|
|
|
=item assert_matches( I : RegexpRef, I : Str, I : Str = undef ) |
805
|
|
|
|
|
|
|
|
806
|
|
|
|
|
|
|
=item assert_not_matches( I : RegexpRef, I : Str, I : Str = undef ) |
807
|
|
|
|
|
|
|
|
808
|
|
|
|
|
|
|
Checks if I matches I regexp. |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
=item assert_deep_equals( I : Ref, I : Ref, I : Str = undef ) |
811
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
=item assert_deep_not_equals( I : Ref, I : Ref, I : Str = undef ) |
813
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
Checks if reference I is a deep copy of reference I or not. |
815
|
|
|
|
|
|
|
The references can be deep structure. If they are different, the message will |
816
|
|
|
|
|
|
|
display the place where they start differing. |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
=item assert_isa( I : Str, I |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
=item assert_not_isa( I : Str, I |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
Checks if I is a I or not. |
823
|
|
|
|
|
|
|
|
824
|
|
|
|
|
|
|
assert_isa( 'My::Class', $obj ); |
825
|
|
|
|
|
|
|
|
826
|
|
|
|
|
|
|
=item assert_raises( I : Any, I : CodeRef, I : Str = undef ) |
827
|
|
|
|
|
|
|
|
828
|
|
|
|
|
|
|
Runs the I and checks if it raises the I exception. |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
If raised exception is an L object, the assertion passes if |
831
|
|
|
|
|
|
|
the exception C I argument (via |
832
|
|
|
|
|
|
|
C-Ematches> method). |
833
|
|
|
|
|
|
|
|
834
|
|
|
|
|
|
|
If raised exception is not an L object, several conditions |
835
|
|
|
|
|
|
|
are checked. If I argument is a string or array reference, the |
836
|
|
|
|
|
|
|
assertion passes if the raised exception is a given class. If the argument is |
837
|
|
|
|
|
|
|
a regexp, the string representation of exception is matched against regexp. |
838
|
|
|
|
|
|
|
|
839
|
|
|
|
|
|
|
use Test::Assert 'assert_raises'; |
840
|
|
|
|
|
|
|
|
841
|
|
|
|
|
|
|
assert_raises( 'foo', sub { die 'foo' } ); |
842
|
|
|
|
|
|
|
assert_raises( ['Exception::Base'], sub { Exception::Base->throw } ); |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
=item assert_test( I : CodeRef, I : Str = undef ) |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
Wraps L based test function and throws L |
847
|
|
|
|
|
|
|
if the test is failed. The plan test have to be disabled manually. The |
848
|
|
|
|
|
|
|
L module imports the C method by default which conflicts |
849
|
|
|
|
|
|
|
with C C method. |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
use Test::Assert ':all'; |
852
|
|
|
|
|
|
|
use Test::More ignore => [ '!fail' ]; |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
Test::Builder->new->no_plan; |
855
|
|
|
|
|
|
|
Test::Builder->new->no_ending(1); |
856
|
|
|
|
|
|
|
|
857
|
|
|
|
|
|
|
assert_test( sub { cmp_ok($got, '==', $expected, $test_name) } ); |
858
|
|
|
|
|
|
|
|
859
|
|
|
|
|
|
|
=back |
860
|
|
|
|
|
|
|
|
861
|
|
|
|
|
|
|
=head1 SEE ALSO |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
L, L. |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
=head1 BUGS |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
If you find the bug or want to implement new features, please report it at |
868
|
|
|
|
|
|
|
L |
869
|
|
|
|
|
|
|
|
870
|
|
|
|
|
|
|
=for readme continue |
871
|
|
|
|
|
|
|
|
872
|
|
|
|
|
|
|
=head1 AUTHOR |
873
|
|
|
|
|
|
|
|
874
|
|
|
|
|
|
|
Piotr Roszatycki |
875
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
=head1 COPYRIGHT |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
Copyright (C) 2008, 2009 by Piotr Roszatycki . |
879
|
|
|
|
|
|
|
|
880
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it |
881
|
|
|
|
|
|
|
under the same terms as Perl itself. |
882
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
See L |