line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
### |
2
|
|
|
|
|
|
|
### $Release: 0.0103 $ |
3
|
|
|
|
|
|
|
### $Copyright: copyright(c) 2010-2011 kuwata-lab.com all rights reserved $ |
4
|
|
|
|
|
|
|
### $License: MIT License $ |
5
|
|
|
|
|
|
|
### |
6
|
|
|
|
|
|
|
|
7
|
7
|
|
|
7
|
|
148739
|
use strict; |
|
7
|
|
|
|
|
18
|
|
|
7
|
|
|
|
|
237
|
|
8
|
7
|
|
|
7
|
|
35
|
use warnings; |
|
7
|
|
|
|
|
14
|
|
|
7
|
|
|
|
|
185
|
|
9
|
7
|
|
|
7
|
|
6527
|
use Data::Dumper; |
|
7
|
|
|
|
|
58769
|
|
|
7
|
|
|
|
|
576
|
|
10
|
|
|
|
|
|
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
package Oktest; |
14
|
7
|
|
|
7
|
|
55
|
use base 'Exporter'; |
|
7
|
|
|
|
|
13
|
|
|
7
|
|
|
|
|
14714
|
|
15
|
|
|
|
|
|
|
our @EXPORT = qw(OK pre_cond topic case_when spec before after before_all after_all at_end skip_when TODO); |
16
|
|
|
|
|
|
|
our @EXPORT_OK = qw(run main with); |
17
|
|
|
|
|
|
|
our $VERSION = ('$Release: 0.0103 $' =~ /\d+(\.\d+)*/ && $&); |
18
|
|
|
|
|
|
|
our @__assertion_objects = (); |
19
|
|
|
|
|
|
|
our @__at_end_blocks = (); |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
sub OK { |
22
|
348
|
|
|
348
|
1
|
78527
|
my ($actual) = shift; |
23
|
348
|
|
|
|
|
912
|
my ($pkgname, $filepath, $linenum) = caller(); |
24
|
348
|
|
|
|
|
807
|
my $location = [$filepath, $linenum, $pkgname]; |
25
|
348
|
|
|
|
|
1145
|
my $ao = Oktest::AssertionObject->new($actual, $location); |
26
|
348
|
|
|
|
|
562
|
push(@__assertion_objects, $ao); |
27
|
348
|
|
|
|
|
1271
|
return $ao; |
28
|
|
|
|
|
|
|
} |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
*pre_cond = *OK; ## alias of OK(), representing pre-condition |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
sub topic { |
33
|
221
|
|
|
221
|
1
|
23020
|
my ($topic_name, $block) = @_; |
34
|
221
|
|
|
|
|
566
|
my $to = Oktest::TopicObject->new($topic_name); |
35
|
221
|
|
|
|
|
402
|
return __yield_block($to, $block); |
36
|
|
|
|
|
|
|
} |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
sub case_when { |
39
|
19
|
|
|
19
|
1
|
1268
|
my ($description, $block) = @_; |
40
|
19
|
|
|
|
|
77
|
my $co = Oktest::CaseObject->new('When ' . $description, $block); |
41
|
19
|
|
|
|
|
41
|
return __yield_block($co, $block); |
42
|
|
|
|
|
|
|
}; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
sub __yield_block { |
45
|
240
|
|
|
240
|
|
244
|
my ($to, $block) = @_; |
46
|
240
|
|
|
|
|
216
|
my $parent = $Oktest::TopicObject::__current; |
47
|
240
|
100
|
|
|
|
379
|
if ($parent) { |
48
|
142
|
|
|
|
|
268
|
$parent->_add_topic($to); |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
else { |
51
|
98
|
|
|
|
|
133
|
push(@Oktest::TopicObject::__tops, $to); |
52
|
|
|
|
|
|
|
} |
53
|
240
|
|
|
|
|
235
|
$Oktest::TopicObject::__current = $to; |
54
|
240
|
|
|
|
|
521
|
$block->($to); |
55
|
240
|
|
|
|
|
273
|
$Oktest::TopicObject::__current = $parent; |
56
|
240
|
|
|
|
|
483
|
return $to; |
57
|
|
|
|
|
|
|
} |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
sub spec { |
60
|
352
|
|
|
352
|
1
|
2337
|
my ($spec_desc, $block) = @_; |
61
|
352
|
|
100
|
1
|
|
667
|
$block ||= sub { TODO("not implemented yet.") }; |
|
1
|
|
|
|
|
268
|
|
62
|
352
|
|
|
|
|
840
|
my $so = Oktest::SpecObject->new($spec_desc, $block); |
63
|
352
|
|
|
|
|
354
|
my $to = $Oktest::TopicObject::__current; |
64
|
352
|
100
|
|
|
|
855
|
$to->_add_spec($so) if $to; |
65
|
352
|
|
|
|
|
517
|
return $so; |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
sub _set_fixture { |
69
|
72
|
|
|
72
|
|
94
|
my ($name, $block) = @_; |
70
|
72
|
100
|
|
|
|
149
|
my $to = $Oktest::TopicObject::__current |
71
|
|
|
|
|
|
|
or die "$name() should be called in topic block."; |
72
|
68
|
|
|
|
|
188
|
$to->$name($block); |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
sub before(&) { |
76
|
21
|
|
|
21
|
1
|
1429
|
_set_fixture('before', @_); |
77
|
|
|
|
|
|
|
} |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
sub after(&) { |
80
|
19
|
|
|
19
|
1
|
1340
|
_set_fixture('after', @_); |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
sub before_all(&) { |
84
|
16
|
|
|
16
|
1
|
1158
|
_set_fixture('before_all', @_); |
85
|
|
|
|
|
|
|
} |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
sub after_all(&) { |
88
|
16
|
|
|
16
|
1
|
1354
|
_set_fixture('after_all', @_); |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
|
91
|
|
|
|
|
|
|
sub at_end(&) { |
92
|
4
|
|
|
4
|
0
|
318
|
my ($block) = @_; |
93
|
|
|
|
|
|
|
## todo: check whether at_end() is called in spec block. |
94
|
4
|
|
|
|
|
8
|
push(@Oktest::__at_end_blocks, $block); |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
sub __at_end_of_spec { |
98
|
|
|
|
|
|
|
## run closures in reverse order |
99
|
218
|
|
|
218
|
|
388
|
for my $block (reverse(@Oktest::__at_end_blocks)) { |
100
|
4
|
|
|
|
|
10
|
$block->(); |
101
|
|
|
|
|
|
|
} |
102
|
218
|
|
|
|
|
326
|
@Oktest::__at_end_blocks = (); |
103
|
|
|
|
|
|
|
} |
104
|
|
|
|
|
|
|
|
105
|
|
|
|
|
|
|
sub skip_when { |
106
|
27
|
|
|
27
|
1
|
657
|
my ($condition, $reason) = @_; |
107
|
27
|
100
|
|
|
|
144
|
if ($condition) { |
108
|
26
|
|
|
|
|
91
|
die "[Skipped] " . $reason . "\n"; |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
} |
111
|
|
|
|
|
|
|
|
112
|
|
|
|
|
|
|
sub TODO { |
113
|
27
|
|
|
27
|
1
|
411
|
my ($description) = @_; |
114
|
27
|
|
|
|
|
108
|
die "[TODO] " . $description . "\n"; |
115
|
|
|
|
|
|
|
} |
116
|
|
|
|
|
|
|
|
117
|
|
|
|
|
|
|
our %_default_opts = ( |
118
|
|
|
|
|
|
|
reporter => undef, |
119
|
|
|
|
|
|
|
style => 'tap', |
120
|
|
|
|
|
|
|
spec => undef, |
121
|
|
|
|
|
|
|
topic => undef, |
122
|
|
|
|
|
|
|
report_skipped => 0==1, |
123
|
|
|
|
|
|
|
report_todo => 0==1, |
124
|
|
|
|
|
|
|
); |
125
|
|
|
|
|
|
|
|
126
|
|
|
|
|
|
|
sub run { |
127
|
60
|
|
|
60
|
0
|
195
|
my %opts = @_; |
128
|
60
|
|
|
|
|
405
|
%opts = (%_default_opts, %opts); |
129
|
60
|
|
66
|
|
|
254
|
my $reporter = $opts{reporter} || Oktest::Reporter::create_instance($opts{style}); |
130
|
60
|
|
|
|
|
262
|
my $runner = $Oktest::Runner::RUNNER->new(); |
131
|
60
|
|
|
|
|
75
|
$runner->{reporter} = $reporter; |
132
|
60
|
|
|
|
|
96
|
$runner->{filter_spec} = $opts{spec}; |
133
|
60
|
|
|
|
|
85
|
$runner->{filter_topic} = $opts{topic}; |
134
|
60
|
|
100
|
|
|
243
|
$reporter->{report_skipped} ||= $opts{report_skipped}; |
135
|
60
|
|
100
|
|
|
203
|
$reporter->{report_todo} ||= $opts{report_todo}; |
136
|
60
|
|
|
|
|
102
|
my @topics = @Oktest::TopicObject::__tops; |
137
|
60
|
|
|
|
|
132
|
$runner->run_all(@topics); |
138
|
|
|
|
|
|
|
} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
sub main { |
141
|
26
|
|
|
26
|
1
|
150
|
Oktest::MainApp->new(@_)->execute(); |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
sub with(&) { |
145
|
0
|
|
|
0
|
0
|
0
|
my ($block) = @_; |
146
|
0
|
|
|
|
|
0
|
return $block; |
147
|
|
|
|
|
|
|
} |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
sub __clear { |
150
|
118
|
|
|
118
|
|
32361
|
@__assertion_objects = (); |
151
|
118
|
|
|
|
|
214
|
Oktest::TopicObject::__clear(); |
152
|
|
|
|
|
|
|
} |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
sub __at_exit { |
155
|
8
|
|
|
8
|
|
59
|
for my $ao (@__assertion_objects) { |
156
|
137
|
100
|
|
|
|
285
|
unless ($ao->{_done}) { |
157
|
1
|
|
|
|
|
2
|
my ($filepath, $linenum, $pkgname) = @{$ao->{location}}; |
|
1
|
|
|
|
|
2
|
|
158
|
1
|
|
|
|
|
7
|
warn "*** OK() called but not tested at '$filepath' line $linenum.\n"; |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
} |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
END { |
164
|
7
|
|
|
7
|
|
4103
|
__at_exit(); |
165
|
|
|
|
|
|
|
} |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub __sweep { |
168
|
219
|
|
|
219
|
|
448
|
@__assertion_objects = grep { ! $_->{_done} } @__assertion_objects; |
|
141
|
|
|
|
|
807
|
|
169
|
|
|
|
|
|
|
} |
170
|
|
|
|
|
|
|
|
171
|
|
|
|
|
|
|
|
172
|
|
|
|
|
|
|
|
173
|
|
|
|
|
|
|
package Oktest::TopicObject; |
174
|
|
|
|
|
|
|
|
175
|
|
|
|
|
|
|
our $__current = undef; |
176
|
|
|
|
|
|
|
our @__tops = (); |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
our $EXEC = 1; |
179
|
|
|
|
|
|
|
our $IGNORE = 0; |
180
|
|
|
|
|
|
|
our $ENTER = -1; |
181
|
|
|
|
|
|
|
|
182
|
|
|
|
|
|
|
sub __last { |
183
|
6
|
|
|
6
|
|
2598
|
return $__tops[$#__tops]; |
184
|
|
|
|
|
|
|
} |
185
|
|
|
|
|
|
|
|
186
|
|
|
|
|
|
|
sub __clear { |
187
|
118
|
|
|
118
|
|
134
|
$Oktest::TopicObject::__current = undef; |
188
|
118
|
|
|
|
|
284
|
@Oktest::TopicObject::__tops = (); |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
sub new { |
192
|
240
|
|
|
240
|
|
322
|
my ($class, $name, $parent) = @_; |
193
|
240
|
|
|
|
|
844
|
my $this = { |
194
|
|
|
|
|
|
|
name => $name, |
195
|
|
|
|
|
|
|
parent => $parent, |
196
|
|
|
|
|
|
|
topics => [], |
197
|
|
|
|
|
|
|
specs => [], |
198
|
|
|
|
|
|
|
status => $EXEC, |
199
|
|
|
|
|
|
|
}; |
200
|
240
|
|
|
|
|
604
|
return bless($this, $class); |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
sub accept { |
204
|
197
|
|
|
197
|
|
244
|
my ($this, $runner, $depth) = @_; |
205
|
197
|
|
|
|
|
341
|
return $runner->run_topic($this, $depth); |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
sub _add_topic { |
209
|
142
|
|
|
142
|
|
149
|
my ($this, $to) = @_; |
210
|
142
|
50
|
|
|
|
470
|
die unless $to->isa('Oktest::TopicObject'); |
211
|
142
|
|
|
|
|
123
|
push(@{$this->{topics}}, $to); |
|
142
|
|
|
|
|
267
|
|
212
|
142
|
|
|
|
|
191
|
$to->{parent} = $this; |
213
|
142
|
|
|
|
|
174
|
return $this; |
214
|
|
|
|
|
|
|
} |
215
|
|
|
|
|
|
|
|
216
|
|
|
|
|
|
|
sub _add_spec { |
217
|
349
|
|
|
349
|
|
375
|
my ($this, $so) = @_; |
218
|
349
|
50
|
|
|
|
875
|
die unless $so->isa('Oktest::SpecObject'); |
219
|
349
|
|
|
|
|
326
|
push(@{$this->{specs}}, $so); |
|
349
|
|
|
|
|
565
|
|
220
|
349
|
|
|
|
|
484
|
$so->{parent} = $this; |
221
|
349
|
|
|
|
|
383
|
return $this; |
222
|
|
|
|
|
|
|
} |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
sub _count_specs { |
225
|
127
|
|
|
127
|
|
116
|
my ($this) = @_; |
226
|
127
|
|
|
|
|
117
|
my $n = 0; |
227
|
127
|
|
|
|
|
120
|
for my $to (@{$this->{topics}}) { |
|
127
|
|
|
|
|
199
|
|
228
|
73
|
|
|
|
|
131
|
$n += $to->_count_specs(); |
229
|
|
|
|
|
|
|
} |
230
|
127
|
100
|
|
|
|
251
|
if ($this->{status} == $EXEC) { |
231
|
51
|
|
|
|
|
51
|
for my $so (@{$this->{specs}}) { |
|
51
|
|
|
|
|
80
|
|
232
|
63
|
100
|
|
|
|
162
|
$n++ if $so->{status} == $EXEC; |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
} |
235
|
127
|
|
|
|
|
250
|
return $n; |
236
|
|
|
|
|
|
|
} |
237
|
|
|
|
|
|
|
|
238
|
|
|
|
|
|
|
sub before { |
239
|
20
|
|
|
20
|
|
23
|
my ($this, $block) = @_; |
240
|
20
|
|
|
|
|
62
|
$this->{_before} = $block; |
241
|
|
|
|
|
|
|
} |
242
|
|
|
|
|
|
|
|
243
|
|
|
|
|
|
|
sub after { |
244
|
18
|
|
|
18
|
|
18
|
my ($this, $block) = @_; |
245
|
18
|
|
|
|
|
55
|
$this->{_after} = $block; |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
sub before_all { |
249
|
15
|
|
|
15
|
|
16
|
my ($this, $block) = @_; |
250
|
15
|
|
|
|
|
40
|
$this->{_before_all} = $block; |
251
|
|
|
|
|
|
|
} |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
sub after_all { |
254
|
15
|
|
|
15
|
|
16
|
my ($this, $block) = @_; |
255
|
15
|
|
|
|
|
37
|
$this->{_after_all} = $block; |
256
|
|
|
|
|
|
|
} |
257
|
|
|
|
|
|
|
|
258
|
|
|
|
|
|
|
$INC{'Oktest/TopicObject'} = __FILE__; |
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
package Oktest::CaseObject; |
263
|
|
|
|
|
|
|
our @ISA = ('Oktest::TopicObject'); |
264
|
|
|
|
|
|
|
|
265
|
|
|
|
|
|
|
sub new { |
266
|
19
|
|
|
19
|
|
27
|
my ($class, $desc) = @_; |
267
|
19
|
|
|
|
|
57
|
my $this = $class->SUPER::new($desc); |
268
|
19
|
|
|
|
|
30
|
return $this; |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
package Oktest::SpecObject; |
274
|
|
|
|
|
|
|
|
275
|
|
|
|
|
|
|
our $EXEC = $Oktest::TopicObject::EXEC; |
276
|
|
|
|
|
|
|
|
277
|
|
|
|
|
|
|
sub new { |
278
|
352
|
|
|
352
|
|
394
|
my ($class, $desc, $block) = @_; |
279
|
352
|
|
|
|
|
962
|
my $this = { |
280
|
|
|
|
|
|
|
desc => $desc, |
281
|
|
|
|
|
|
|
parent => undef, |
282
|
|
|
|
|
|
|
block => $block, |
283
|
|
|
|
|
|
|
status => $EXEC, |
284
|
|
|
|
|
|
|
}; |
285
|
352
|
|
|
|
|
798
|
return bless($this, $class); |
286
|
|
|
|
|
|
|
} |
287
|
|
|
|
|
|
|
|
288
|
|
|
|
|
|
|
sub accept { |
289
|
219
|
|
|
219
|
|
245
|
my ($this, $runner, $depth) = @_; |
290
|
219
|
|
|
|
|
353
|
return $runner->run_spec($this, $depth); |
291
|
|
|
|
|
|
|
} |
292
|
|
|
|
|
|
|
|
293
|
|
|
|
|
|
|
|
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
package Oktest::AssertionObject; |
296
|
7
|
|
|
7
|
|
4852
|
use Text::Diff; |
|
7
|
|
|
|
|
67495
|
|
|
7
|
|
|
|
|
500
|
|
297
|
7
|
|
|
7
|
|
58
|
use Scalar::Util qw(refaddr); |
|
7
|
|
|
|
|
14
|
|
|
7
|
|
|
|
|
896
|
|
298
|
7
|
|
|
7
|
|
38
|
use Data::Dumper; |
|
7
|
|
|
|
|
16
|
|
|
7
|
|
|
|
|
7138
|
|
299
|
|
|
|
|
|
|
|
300
|
|
|
|
|
|
|
sub new { |
301
|
349
|
|
|
349
|
|
524
|
my ($class, $actual, $location) = @_; |
302
|
349
|
|
|
|
|
1174
|
my $this = { |
303
|
|
|
|
|
|
|
actual => $actual, |
304
|
|
|
|
|
|
|
location => $location, |
305
|
|
|
|
|
|
|
_done => 0==1, |
306
|
|
|
|
|
|
|
}; |
307
|
349
|
|
|
|
|
1031
|
return bless($this, $class); |
308
|
|
|
|
|
|
|
} |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
sub _done { |
311
|
355
|
|
|
355
|
|
395
|
my ($this) = @_; |
312
|
355
|
|
|
|
|
628
|
$this->{_done} = 1==1; |
313
|
355
|
|
|
|
|
427
|
return $this; |
314
|
|
|
|
|
|
|
} |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
our $__dumped_with_indent; |
317
|
|
|
|
|
|
|
{ |
318
|
|
|
|
|
|
|
local $Data::Dumper::Terse = 1; |
319
|
|
|
|
|
|
|
$_ = Dumper([1]); |
320
|
|
|
|
|
|
|
$__dumped_with_indent = / 1/m; ## true for Perl<=5.22, false for Perl>=5.14 |
321
|
|
|
|
|
|
|
} |
322
|
|
|
|
|
|
|
|
323
|
|
|
|
|
|
|
sub _repr { |
324
|
163
|
|
|
163
|
|
229
|
my ($arg) = @_; |
325
|
163
|
|
|
|
|
223
|
local $Data::Dumper::Terse = 1; |
326
|
163
|
50
|
|
|
|
275
|
if ($__dumped_with_indent) { |
327
|
0
|
|
|
|
|
0
|
return Dumper($arg); |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
else { |
330
|
163
|
|
|
|
|
238
|
local $Data::Dumper::Pad = ' '; |
331
|
163
|
|
|
|
|
464
|
my $s = Dumper($arg); |
332
|
163
|
|
|
|
|
8376
|
$s =~ s/^ //; |
333
|
163
|
|
|
|
|
576
|
return $s; |
334
|
|
|
|
|
|
|
} |
335
|
|
|
|
|
|
|
} |
336
|
|
|
|
|
|
|
|
337
|
|
|
|
|
|
|
sub _validate_expected { |
338
|
165
|
|
|
165
|
|
205
|
my ($this, $expected, $op) = @_; |
339
|
165
|
|
|
|
|
168
|
my $msg; |
340
|
165
|
100
|
|
|
|
338
|
if (Oktest::Util::is_string($expected)) { |
341
|
1
|
|
|
|
|
7
|
$msg = |
342
|
|
|
|
|
|
|
"[ERROR] right hand of '" . $op . "' should not be a string.\n" . |
343
|
|
|
|
|
|
|
" \$actual: " . _repr($this->{actual}) . |
344
|
|
|
|
|
|
|
" \$expected: " . _repr($expected); |
345
|
|
|
|
|
|
|
} |
346
|
165
|
|
|
|
|
291
|
return $msg; |
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
sub _failed_message { |
350
|
49
|
|
|
49
|
|
76
|
my ($this, $actual, $op, $expected) = @_; |
351
|
49
|
|
|
|
|
172
|
my $msg = |
352
|
|
|
|
|
|
|
"[Failed] \$actual " . $op . " \$expected : failed.\n" . |
353
|
|
|
|
|
|
|
" \$actual: " . _repr($actual) . |
354
|
|
|
|
|
|
|
" \$expected: " . _repr($expected); |
355
|
49
|
|
|
|
|
108
|
return $msg; |
356
|
|
|
|
|
|
|
} |
357
|
|
|
|
|
|
|
|
358
|
|
|
|
|
|
|
sub _die { |
359
|
111
|
|
|
111
|
|
165
|
my ($this, $errmsg) = @_; |
360
|
111
|
|
|
|
|
210
|
my $stacktrace = _stacktrace(2, 20); |
361
|
111
|
100
|
|
|
|
428
|
$errmsg .= "\n" unless $errmsg =~ /\n$/; |
362
|
111
|
|
|
|
|
872
|
die $errmsg . $stacktrace; |
363
|
|
|
|
|
|
|
} |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
sub _stacktrace { |
366
|
111
|
|
|
111
|
|
149
|
my ($depth) = @_; |
367
|
111
|
|
|
|
|
126
|
my $max = 20; |
368
|
111
|
|
|
|
|
125
|
my $i = $depth; |
369
|
111
|
|
|
|
|
271
|
for (; $i < $max; $i++) { |
370
|
197
|
|
|
|
|
1155
|
my ($pkgname, $filename, $linenum, @rest) = caller($i); |
371
|
197
|
100
|
|
|
|
792
|
last if $filename ne __FILE__; |
372
|
|
|
|
|
|
|
} |
373
|
111
|
|
|
|
|
168
|
my $str = ""; |
374
|
111
|
|
|
|
|
230
|
for (; $i < $max; $i++) { |
375
|
306
|
|
|
|
|
1226
|
my ($pkgname, $filename, $linenum, @rest) = caller($i); |
376
|
306
|
100
|
100
|
|
|
1356
|
last if ! $filename || $filename eq __FILE__; |
377
|
195
|
|
|
|
|
456
|
$str .= "File '$filename', line $linenum:\n"; |
378
|
195
|
50
|
|
|
|
2945
|
if (-f $filename) { |
379
|
195
|
|
|
|
|
407
|
my $line = Oktest::Util::read_line_from($filename, $linenum); |
380
|
195
|
|
|
|
|
407
|
$str .= " " . Oktest::Util::strip($line) . "\n"; |
381
|
|
|
|
|
|
|
} |
382
|
|
|
|
|
|
|
} |
383
|
111
|
|
|
|
|
212
|
return $str; |
384
|
|
|
|
|
|
|
} |
385
|
|
|
|
|
|
|
|
386
|
|
|
|
|
|
|
sub _assert(&@) { |
387
|
211
|
|
|
211
|
|
368
|
my ($closure, $op, $validate, $this, $expected) = @_; |
388
|
211
|
|
|
|
|
355
|
$this->_done(); |
389
|
211
|
100
|
|
|
|
389
|
if ($validate) { |
390
|
165
|
|
|
|
|
314
|
my $msg = $this->_validate_expected($expected, $op); |
391
|
165
|
100
|
|
|
|
340
|
die $msg if $msg; |
392
|
|
|
|
|
|
|
} |
393
|
|
|
|
|
|
|
#unless (defined($expected)) { |
394
|
|
|
|
|
|
|
# my $msg = |
395
|
|
|
|
|
|
|
# "[ERROR] OK() $op \$expected: \$expected is undefined value.\n" . |
396
|
|
|
|
|
|
|
# " \$expected: " . _repr($expected); |
397
|
|
|
|
|
|
|
# $this->_die($msg); |
398
|
|
|
|
|
|
|
#} |
399
|
210
|
|
|
|
|
309
|
my $actual = $this->{actual}; |
400
|
|
|
|
|
|
|
#unless (defined($actual)) { |
401
|
|
|
|
|
|
|
# my $msg = |
402
|
|
|
|
|
|
|
# "[ERROR] OK(\$actual): \$actual is undefined value.\n" . |
403
|
|
|
|
|
|
|
# " \$actual: " . _repr($actual); |
404
|
|
|
|
|
|
|
# $this->_die($msg); |
405
|
|
|
|
|
|
|
#} |
406
|
210
|
100
|
|
|
|
404
|
return $this if $closure->($actual, $expected); |
407
|
49
|
|
|
|
|
138
|
my $msg = $this->_failed_message($actual, $op, $expected); |
408
|
49
|
|
|
|
|
123
|
$this->_die($msg); |
409
|
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
use overload |
412
|
7
|
|
|
|
|
174
|
'==' => \&_num_eq, |
413
|
|
|
|
|
|
|
'!=' => \&_num_ne, |
414
|
|
|
|
|
|
|
'>' => \&_num_gt, |
415
|
|
|
|
|
|
|
'>=' => \&_num_ge, |
416
|
|
|
|
|
|
|
'<' => \&_num_lt, |
417
|
|
|
|
|
|
|
'<=' => \&_num_le, |
418
|
|
|
|
|
|
|
'eq' => \&_str_eq, |
419
|
|
|
|
|
|
|
'ne' => \&_str_ne, |
420
|
|
|
|
|
|
|
'lt' => \&_str_lt, |
421
|
|
|
|
|
|
|
'le' => \&_str_le, |
422
|
|
|
|
|
|
|
'gt' => \&_str_gt, |
423
|
7
|
|
|
7
|
|
57
|
'ge' => \&_str_ge; |
|
7
|
|
|
|
|
11
|
|
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
sub _num_eq { |
426
|
|
|
|
|
|
|
#my ($this, $expected) = @_; |
427
|
7
|
|
|
7
|
|
1239
|
no warnings 'uninitialized'; # suppress warning 'Use of uninitialized value' |
|
7
|
|
|
|
|
11
|
|
|
7
|
|
|
|
|
651
|
|
428
|
135
|
|
|
135
|
|
441
|
return _assert { $_[0] == $_[1] } '==', 1, @_; |
|
136
|
|
|
136
|
|
497
|
|
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
sub _num_ne { |
432
|
|
|
|
|
|
|
#my ($this, $expected) = @_; |
433
|
7
|
|
|
7
|
|
104
|
no warnings 'uninitialized'; |
|
7
|
|
|
|
|
11
|
|
|
7
|
|
|
|
|
571
|
|
434
|
5
|
|
|
5
|
|
21
|
return _assert { $_[0] != $_[1] } '!=', 1, @_; |
|
5
|
|
|
5
|
|
26
|
|
435
|
|
|
|
|
|
|
} |
436
|
|
|
|
|
|
|
|
437
|
|
|
|
|
|
|
sub _num_gt { |
438
|
7
|
|
|
7
|
|
31
|
no warnings 'uninitialized'; |
|
7
|
|
|
|
|
13
|
|
|
7
|
|
|
|
|
431
|
|
439
|
6
|
|
|
6
|
|
27
|
return _assert { $_[0] > $_[1] } '>', 1, @_; |
|
6
|
|
|
6
|
|
32
|
|
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
sub _num_ge { |
443
|
7
|
|
|
7
|
|
28
|
no warnings 'uninitialized'; |
|
7
|
|
|
|
|
9
|
|
|
7
|
|
|
|
|
474
|
|
444
|
6
|
|
|
6
|
|
35
|
return _assert { $_[0] >= $_[1] } '>=', 1, @_; |
|
6
|
|
|
6
|
|
50
|
|
445
|
|
|
|
|
|
|
} |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
sub _num_lt { |
448
|
7
|
|
|
7
|
|
32
|
no warnings 'uninitialized'; |
|
7
|
|
|
|
|
8
|
|
|
7
|
|
|
|
|
475
|
|
449
|
6
|
|
|
6
|
|
32
|
return _assert { $_[0] < $_[1] } '<', 1, @_; |
|
6
|
|
|
6
|
|
143
|
|
450
|
|
|
|
|
|
|
} |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
sub _num_le { |
453
|
7
|
|
|
7
|
|
45
|
no warnings 'uninitialized'; |
|
7
|
|
|
|
|
8
|
|
|
7
|
|
|
|
|
536
|
|
454
|
6
|
|
|
6
|
|
43
|
return _assert { $_[0] <= $_[1] } '<=', 1, @_; |
|
6
|
|
|
6
|
|
52
|
|
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
sub _str_eq { |
458
|
7
|
|
|
7
|
|
30
|
no warnings 'uninitialized'; |
|
7
|
|
|
|
|
9
|
|
|
7
|
|
|
|
|
1994
|
|
459
|
|
|
|
|
|
|
#return _assert { $_[0] eq $_[1] } 'eq', 0, @_; |
460
|
22
|
|
|
22
|
|
38
|
my ($this, $expected) = @_; |
461
|
22
|
|
|
|
|
116
|
$this->_done(); |
462
|
22
|
|
|
|
|
42
|
my $actual = $this->{actual}; |
463
|
22
|
100
|
|
|
|
85
|
return $this if $actual eq $expected; |
464
|
7
|
100
|
100
|
|
|
54
|
if ($actual !~ /\n/ && $expected !~ /\n/) { |
465
|
3
|
|
|
|
|
12
|
my $msg = |
466
|
|
|
|
|
|
|
"[Failed] \$actual eq \$expected : failed.\n" . |
467
|
|
|
|
|
|
|
" \$actual: " . _repr($actual) . |
468
|
|
|
|
|
|
|
" \$expected: " . _repr($expected); |
469
|
3
|
|
|
|
|
14
|
$this->_die($msg); |
470
|
|
|
|
|
|
|
} |
471
|
|
|
|
|
|
|
else { |
472
|
|
|
|
|
|
|
#if ($actual !~ /\n$/ || $expected !~ /\n$/) { |
473
|
4
|
|
|
|
|
7
|
my $append = "\\ No newline at end\n"; |
474
|
4
|
100
|
|
|
|
20
|
$actual .= $append if $actual !~ /\n$/; |
475
|
4
|
100
|
|
|
|
22
|
$expected .= $append if $expected !~ /\n$/; |
476
|
|
|
|
|
|
|
#} |
477
|
4
|
|
|
|
|
27
|
my $diff = Text::Diff::diff(\$expected, \$actual, {STYLE=>'Unified'}); |
478
|
4
|
|
|
|
|
1516
|
my $msg = |
479
|
|
|
|
|
|
|
"[Failed] \$actual eq \$expected : failed.\n" . |
480
|
|
|
|
|
|
|
"--- \$expected\n" . |
481
|
|
|
|
|
|
|
"+++ \$actual\n" . |
482
|
|
|
|
|
|
|
$diff; |
483
|
4
|
|
|
|
|
13
|
$this->_die($msg); |
484
|
|
|
|
|
|
|
} |
485
|
|
|
|
|
|
|
} |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
sub _str_ne { |
488
|
7
|
|
|
7
|
|
40
|
no warnings 'uninitialized'; |
|
7
|
|
|
|
|
25
|
|
|
7
|
|
|
|
|
567
|
|
489
|
8
|
|
|
8
|
|
31
|
return _assert { $_[0] ne $_[1] } 'ne', 0, @_; |
|
8
|
|
|
8
|
|
41
|
|
490
|
|
|
|
|
|
|
} |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
sub _str_gt { |
493
|
7
|
|
|
7
|
|
35
|
no warnings 'uninitialized'; |
|
7
|
|
|
|
|
15
|
|
|
7
|
|
|
|
|
512
|
|
494
|
6
|
|
|
6
|
|
22
|
return _assert { $_[0] gt $_[1] } 'gt', 0, @_; |
|
6
|
|
|
6
|
|
28
|
|
495
|
|
|
|
|
|
|
} |
496
|
|
|
|
|
|
|
|
497
|
|
|
|
|
|
|
sub _str_ge { |
498
|
7
|
|
|
7
|
|
32
|
no warnings 'uninitialized'; |
|
7
|
|
|
|
|
11
|
|
|
7
|
|
|
|
|
469
|
|
499
|
6
|
|
|
6
|
|
25
|
return _assert { $_[0] ge $_[1] } 'ge', 0, @_; |
|
6
|
|
|
6
|
|
27
|
|
500
|
|
|
|
|
|
|
} |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
sub _str_lt { |
503
|
7
|
|
|
7
|
|
35
|
no warnings 'uninitialized'; |
|
7
|
|
|
|
|
9
|
|
|
7
|
|
|
|
|
536
|
|
504
|
6
|
|
|
6
|
|
21
|
return _assert { $_[0] lt $_[1] } 'lt', 0, @_; |
|
6
|
|
|
6
|
|
30
|
|
505
|
|
|
|
|
|
|
} |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
sub _str_le { |
508
|
7
|
|
|
7
|
|
31
|
no warnings 'uninitialized'; |
|
7
|
|
|
|
|
11
|
|
|
7
|
|
|
|
|
5053
|
|
509
|
6
|
|
|
6
|
|
24
|
return _assert { $_[0] le $_[1] } 'le', 0, @_; |
|
6
|
|
|
6
|
|
32
|
|
510
|
|
|
|
|
|
|
} |
511
|
|
|
|
|
|
|
|
512
|
|
|
|
|
|
|
sub cmp { |
513
|
15
|
|
|
15
|
|
24
|
my ($this, $op, $expected) = @_; |
514
|
15
|
100
|
|
|
|
107
|
if ($op eq '==') { return $this->_num_eq($expected); } |
|
1
|
100
|
|
|
|
4
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
515
|
1
|
|
|
|
|
5
|
elsif ($op eq '!=') { return $this->_num_ne($expected); } |
516
|
1
|
|
|
|
|
5
|
elsif ($op eq '<' ) { return $this->_num_lt($expected); } |
517
|
1
|
|
|
|
|
5
|
elsif ($op eq '<=') { return $this->_num_le($expected); } |
518
|
1
|
|
|
|
|
6
|
elsif ($op eq '>' ) { return $this->_num_gt($expected); } |
519
|
1
|
|
|
|
|
5
|
elsif ($op eq '>=') { return $this->_num_ge($expected); } |
520
|
1
|
|
|
|
|
5
|
elsif ($op eq 'eq') { return $this->_str_eq($expected); } |
521
|
1
|
|
|
|
|
5
|
elsif ($op eq 'ne') { return $this->_str_ne($expected); } |
522
|
1
|
|
|
|
|
4
|
elsif ($op eq 'lt') { return $this->_str_lt($expected); } |
523
|
1
|
|
|
|
|
5
|
elsif ($op eq 'le') { return $this->_str_le($expected); } |
524
|
1
|
|
|
|
|
4
|
elsif ($op eq 'gt') { return $this->_str_gt($expected); } |
525
|
1
|
|
|
|
|
5
|
elsif ($op eq 'ge') { return $this->_str_ge($expected); } |
526
|
1
|
|
|
|
|
4
|
elsif ($op eq '=~') { return $this->matches($expected); } |
527
|
1
|
|
|
|
|
4
|
elsif ($op eq '!~') { return $this->not_match($expected); } |
528
|
1
|
|
|
|
|
6
|
else { $this->_die("[ERROR] OK()->cmp(): '$op': unknown operator.\n"); } |
529
|
|
|
|
|
|
|
} |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
sub in_delta { |
532
|
4
|
|
|
4
|
|
7
|
my ($this, $expected, $delta) = @_; |
533
|
4
|
|
|
|
|
7
|
$this->_done(); |
534
|
4
|
|
|
|
|
7
|
my $actual = $this->{actual}; |
535
|
4
|
|
|
|
|
11
|
my ($min, $max) = ($expected - $delta, $expected + $delta); |
536
|
4
|
100
|
|
|
|
10
|
unless ($min <= $actual) { |
537
|
1
|
|
|
|
|
20
|
my $msg = |
538
|
|
|
|
|
|
|
'[Failed] $expected - $delta <= $actual : failed.\n' . |
539
|
|
|
|
|
|
|
' $expected - $delta: ' . $min . '\n' . |
540
|
|
|
|
|
|
|
' $actual: ' . $actual . '\n'; |
541
|
1
|
|
|
|
|
6
|
$msg =~ s/\\n/\n/g; |
542
|
1
|
|
|
|
|
3
|
$this->_die($msg); |
543
|
|
|
|
|
|
|
} |
544
|
3
|
100
|
|
|
|
10
|
unless ($actual <= $max) { |
545
|
1
|
|
|
|
|
10
|
my $msg = |
546
|
|
|
|
|
|
|
'[Failed] $actual <= $expected + $delta : failed.\n' . |
547
|
|
|
|
|
|
|
' $actual: ' . $actual . '\n' . |
548
|
|
|
|
|
|
|
' $expected + $delta: ' . $max . '\n'; |
549
|
1
|
|
|
|
|
6
|
$msg =~ s/\\n/\n/g; |
550
|
1
|
|
|
|
|
4
|
$this->_die($msg); |
551
|
|
|
|
|
|
|
} |
552
|
2
|
|
|
|
|
4
|
return $this; |
553
|
|
|
|
|
|
|
} |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
sub matches { |
556
|
8
|
|
|
8
|
|
11
|
my ($this, $expected) = @_; |
557
|
8
|
|
|
|
|
17
|
$this->_done(); |
558
|
8
|
100
|
|
|
|
23
|
defined($expected) |
559
|
|
|
|
|
|
|
or $this->_die("[ERROR] OK(): use matches(qr/pattern/) instead of matches(/pattern/)."); |
560
|
7
|
|
|
7
|
|
28
|
return _assert { $_[0] =~ $_[1] } '=~', 0, @_; |
|
7
|
|
|
|
|
63
|
|
561
|
|
|
|
|
|
|
} |
562
|
|
|
|
|
|
|
|
563
|
|
|
|
|
|
|
sub not_match { |
564
|
8
|
|
|
8
|
|
11
|
my ($this, $expected) = @_; |
565
|
8
|
|
|
|
|
18
|
$this->_done(); |
566
|
8
|
100
|
|
|
|
27
|
defined($expected) |
567
|
|
|
|
|
|
|
or $this->_die("[ERROR] OK(): use not_match(qr/pattern/) instead of not_match(/pattern/)."); |
568
|
7
|
|
|
7
|
|
26
|
return _assert { $_[0] !~ $_[1] } '!~', 0, @_; |
|
7
|
|
|
|
|
41
|
|
569
|
|
|
|
|
|
|
} |
570
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
sub is_a { |
572
|
7
|
|
|
7
|
|
38
|
no warnings 'misc'; # suppress warning of "Can't locate package %s for %s::ISA" (for Perl 5.8) |
|
7
|
|
|
|
|
11
|
|
|
7
|
|
|
|
|
249
|
|
573
|
7
|
|
|
7
|
|
32
|
no warnings 'syntax'; # suppress warning of "Can't locate package %s for %s::ISA" (for Perl 5.10 or later) |
|
7
|
|
|
|
|
12
|
|
|
7
|
|
|
|
|
1011
|
|
574
|
6
|
|
|
6
|
|
11
|
my ($this, $expected) = @_; |
575
|
6
|
|
|
|
|
18
|
$this->_done(); |
576
|
|
|
|
|
|
|
#return _assert { $_[0]->isa($_[1]) } ' instanceof ', 0, @_; |
577
|
6
|
|
|
|
|
8
|
my $actual = $this->{actual}; |
578
|
6
|
100
|
|
|
|
46
|
unless ($actual->isa($expected)) { |
579
|
|
|
|
|
|
|
#my $msg = $this->_failed_message($actual, $op, $expected); |
580
|
2
|
|
|
|
|
7
|
my $msg = "[Failed] \$actual->isa(\$expected) : failed.\n" |
581
|
|
|
|
|
|
|
. " \$actual: " . _repr($actual) |
582
|
|
|
|
|
|
|
. " \$expected: " . _repr($expected); |
583
|
2
|
|
|
|
|
6
|
$this->_die($msg); |
584
|
|
|
|
|
|
|
} |
585
|
4
|
|
|
|
|
9
|
return $this; |
586
|
|
|
|
|
|
|
} |
587
|
|
|
|
|
|
|
|
588
|
|
|
|
|
|
|
sub not_a { |
589
|
7
|
|
|
7
|
|
31
|
no warnings 'misc'; # suppress warning of "Can't locate package %s for %s::ISA" (for Perl 5.8) |
|
7
|
|
|
|
|
14
|
|
|
7
|
|
|
|
|
268
|
|
590
|
7
|
|
|
7
|
|
32
|
no warnings 'syntax'; # suppress warning of "Can't locate package %s for %s::ISA" (for Perl 5.10 or later) |
|
7
|
|
|
|
|
11
|
|
|
7
|
|
|
|
|
43150
|
|
591
|
3
|
|
|
3
|
|
6
|
my ($this, $expected) = @_; |
592
|
3
|
|
|
|
|
6
|
$this->_done(); |
593
|
|
|
|
|
|
|
#return _assert { ! $_[0]->isa($_[1]) } ' instanceof ', 0, @_; |
594
|
3
|
|
|
|
|
4
|
my $actual = $this->{actual}; |
595
|
3
|
100
|
|
|
|
16
|
if ($actual->isa($expected)) { |
596
|
|
|
|
|
|
|
#my $msg = $this->_failed_message($actual, $op, $expected); |
597
|
1
|
|
|
|
|
3
|
my $msg = "[Failed] ! \$actual->isa(\$expected) : failed.\n" |
598
|
|
|
|
|
|
|
. " \$actual: " . _repr($actual) |
599
|
|
|
|
|
|
|
. " \$expected: " . _repr($expected); |
600
|
1
|
|
|
|
|
4
|
$this->_die($msg); |
601
|
|
|
|
|
|
|
} |
602
|
2
|
|
|
|
|
6
|
return $this; |
603
|
|
|
|
|
|
|
} |
604
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
sub dies { |
606
|
12
|
|
|
12
|
|
24
|
my ($this, $errmsg) = @_; |
607
|
12
|
|
|
|
|
35
|
$this->_done(); |
608
|
12
|
100
|
|
|
|
34
|
$errmsg = '' unless defined($errmsg); |
609
|
12
|
|
|
|
|
24
|
my $actual = $this->{actual}; |
610
|
12
|
|
|
|
|
22
|
undef $@; |
611
|
12
|
|
|
|
|
25
|
eval { $actual->() }; |
|
12
|
|
|
|
|
38
|
|
612
|
12
|
100
|
|
|
|
83
|
unless ($@) { |
613
|
3
|
|
|
|
|
10
|
my $msg = |
614
|
|
|
|
|
|
|
"[Failed] exception expected but nothing thrown.\n" . |
615
|
|
|
|
|
|
|
" \$expected: " . _repr($errmsg); |
616
|
3
|
|
|
|
|
12
|
$this->_die($msg); |
617
|
|
|
|
|
|
|
} |
618
|
9
|
|
|
|
|
15
|
my $ok = 1==1; |
619
|
9
|
|
|
|
|
12
|
my $op; |
620
|
9
|
100
|
|
|
|
36
|
if (! $errmsg) { |
|
|
100
|
|
|
|
|
|
621
|
|
|
|
|
|
|
# pass |
622
|
|
|
|
|
|
|
} |
623
|
|
|
|
|
|
|
elsif (ref($errmsg) eq 'Regexp') { |
624
|
4
|
|
|
|
|
25
|
$ok = $@ =~ $errmsg; |
625
|
4
|
|
|
|
|
10
|
$op = '=~'; |
626
|
|
|
|
|
|
|
} |
627
|
|
|
|
|
|
|
else { |
628
|
4
|
|
|
|
|
9
|
$ok = $@ eq $errmsg; |
629
|
4
|
100
|
|
|
|
15
|
if (! $ok) { |
630
|
1
|
|
|
|
|
7
|
my $s = substr($@, 0, length($errmsg)); |
631
|
1
|
|
|
|
|
4
|
my $rest = substr($@, length($errmsg)); |
632
|
1
|
|
33
|
|
|
6
|
$ok = $s eq $errmsg && $rest =~ / at .*/; |
633
|
|
|
|
|
|
|
}; |
634
|
4
|
|
|
|
|
8
|
$op = 'eq'; |
635
|
|
|
|
|
|
|
} |
636
|
9
|
100
|
|
|
|
26
|
unless ($ok) { |
637
|
3
|
|
|
|
|
17
|
my $msg = |
638
|
|
|
|
|
|
|
'[Failed] $@ ' . $op . ' $expected : failed.' . "\n" . |
639
|
|
|
|
|
|
|
' $@: ' . _repr($@) . |
640
|
|
|
|
|
|
|
' $expected: ' . _repr($errmsg); |
641
|
3
|
|
|
|
|
13
|
$this->_die($msg); |
642
|
|
|
|
|
|
|
} |
643
|
6
|
|
|
|
|
11
|
return $this; |
644
|
|
|
|
|
|
|
} |
645
|
|
|
|
|
|
|
|
646
|
|
|
|
|
|
|
sub not_die { |
647
|
7
|
|
|
7
|
|
9
|
my ($this) = @_; |
648
|
7
|
|
|
|
|
15
|
$this->_done(); |
649
|
7
|
|
|
|
|
12
|
my $actual = $this->{actual}; |
650
|
7
|
|
|
|
|
7
|
undef $@; |
651
|
7
|
|
|
|
|
11
|
eval { $actual->() }; |
|
7
|
|
|
|
|
46
|
|
652
|
7
|
100
|
|
|
|
34
|
if ($@) { |
653
|
3
|
|
|
|
|
8
|
my $msg = |
654
|
|
|
|
|
|
|
"[Failed] no exception expected but thrown.\n" . |
655
|
|
|
|
|
|
|
" \$\@: " . _repr($@); |
656
|
3
|
|
|
|
|
6
|
undef $@; |
657
|
3
|
|
|
|
|
9
|
$this->_die($msg); |
658
|
|
|
|
|
|
|
} |
659
|
4
|
|
|
|
|
8
|
return $this; |
660
|
|
|
|
|
|
|
} |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
sub warns { |
663
|
10
|
|
|
10
|
|
14
|
my ($this, $expected) = @_; |
664
|
10
|
|
|
|
|
21
|
$this->_done(); |
665
|
10
|
|
|
|
|
17
|
my $actual = $this->{actual}; |
666
|
|
|
|
|
|
|
#my $warning = &Oktest::Util::capture_stderr(sub { $actual->() }); |
667
|
10
|
|
|
|
|
12
|
my $warning; |
668
|
10
|
|
|
8
|
|
82
|
local $SIG{__WARN__} = sub { $warning = shift }; |
|
8
|
|
|
|
|
65
|
|
669
|
10
|
|
|
|
|
26
|
$actual->(); |
670
|
10
|
100
|
|
|
|
25
|
unless ($warning) { |
671
|
2
|
|
|
|
|
12
|
my $msg = |
672
|
|
|
|
|
|
|
"[Failed] warning expected : failed (nothing printed).\n" . |
673
|
|
|
|
|
|
|
" \$expected: " . _repr($expected); |
674
|
2
|
|
|
|
|
8
|
$this->_die($msg); |
675
|
|
|
|
|
|
|
} |
676
|
|
|
|
|
|
|
my $new_msg = sub { |
677
|
3
|
|
|
3
|
|
6
|
my ($op) = @_; |
678
|
|
|
|
|
|
|
return |
679
|
3
|
|
|
|
|
13
|
"[Failed] \$warning $op \$expected : failed.\n" . |
680
|
|
|
|
|
|
|
" \$warning: " . _repr($warning) . |
681
|
|
|
|
|
|
|
" \$expected: " . _repr($expected); |
682
|
8
|
|
|
|
|
36
|
}; |
683
|
8
|
100
|
|
|
|
23
|
if (ref($expected) eq 'Regexp') { |
684
|
|
|
|
|
|
|
#$this->_die($new_msg->('=~')) unless $warning =~ $expected; |
685
|
4
|
100
|
|
|
|
23
|
unless ($warning =~ $expected) { |
686
|
2
|
|
|
|
|
7
|
my $msg = $new_msg->('=~'); |
687
|
2
|
|
|
|
|
7
|
$this->_die($msg); |
688
|
|
|
|
|
|
|
} |
689
|
|
|
|
|
|
|
} |
690
|
|
|
|
|
|
|
else { |
691
|
|
|
|
|
|
|
#$this->_die($new_msg->('eq')) unless $warning eq $expected; |
692
|
4
|
100
|
|
|
|
13
|
unless ($warning eq $expected) { |
693
|
1
|
|
|
|
|
3
|
my $msg = $new_msg->('eq'); |
694
|
1
|
|
|
|
|
5
|
$this->_die($msg); |
695
|
|
|
|
|
|
|
} |
696
|
|
|
|
|
|
|
} |
697
|
5
|
|
|
|
|
39
|
return $this; |
698
|
|
|
|
|
|
|
} |
699
|
|
|
|
|
|
|
|
700
|
|
|
|
|
|
|
sub not_warn { |
701
|
3
|
|
|
3
|
|
6
|
my ($this) = @_; |
702
|
3
|
|
|
|
|
7
|
$this->_done(); |
703
|
3
|
|
|
|
|
5
|
my $actual = $this->{actual}; |
704
|
3
|
|
|
3
|
|
23
|
my $warning = &Oktest::Util::capture_stderr(sub { $actual->() }); |
|
3
|
|
|
|
|
9
|
|
705
|
3
|
100
|
|
|
|
17
|
unless (! $warning) { |
706
|
1
|
|
|
|
|
4
|
my $msg = |
707
|
|
|
|
|
|
|
"[Failed] no warning expected : failed.\n" . |
708
|
|
|
|
|
|
|
" \$warning: " . _repr($warning); |
709
|
1
|
|
|
|
|
4
|
$this->_die($msg); |
710
|
|
|
|
|
|
|
} |
711
|
2
|
|
|
|
|
7
|
return $this; |
712
|
|
|
|
|
|
|
} |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
sub is_string { |
715
|
3
|
|
|
3
|
|
6
|
my ($this) = @_; |
716
|
3
|
|
|
|
|
12
|
return $this->_is_type('string', Oktest::Util::is_string($this->{actual})); |
717
|
|
|
|
|
|
|
} |
718
|
|
|
|
|
|
|
|
719
|
|
|
|
|
|
|
sub is_number { |
720
|
4
|
|
|
4
|
|
6
|
my ($this) = @_; |
721
|
4
|
|
|
|
|
15
|
return $this->_is_type('number', Oktest::Util::is_number($this->{actual})); |
722
|
|
|
|
|
|
|
} |
723
|
|
|
|
|
|
|
|
724
|
|
|
|
|
|
|
sub is_integer { |
725
|
3
|
|
|
3
|
|
8
|
my ($this) = @_; |
726
|
3
|
|
|
|
|
8
|
return $this->_is_type('integer', Oktest::Util::is_integer($this->{actual})); |
727
|
|
|
|
|
|
|
} |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
sub is_float { |
730
|
3
|
|
|
3
|
|
4
|
my ($this) = @_; |
731
|
3
|
|
|
|
|
11
|
return $this->_is_type('float', Oktest::Util::is_float($this->{actual})); |
732
|
|
|
|
|
|
|
} |
733
|
|
|
|
|
|
|
|
734
|
|
|
|
|
|
|
sub _is_type { |
735
|
13
|
|
|
13
|
|
23
|
my ($this, $type, $bool) = @_; |
736
|
13
|
|
|
|
|
30
|
$this->_done(); |
737
|
13
|
|
|
|
|
18
|
my $actual = $this->{actual}; |
738
|
13
|
100
|
|
|
|
34
|
if (! $bool) { |
739
|
8
|
|
|
|
|
30
|
my $msg = |
740
|
|
|
|
|
|
|
"[Failed] \$actual : $type expected, but not.\n" . |
741
|
|
|
|
|
|
|
" \$actual: " . _repr($actual); |
742
|
8
|
|
|
|
|
22
|
$this->_die($msg); |
743
|
|
|
|
|
|
|
} |
744
|
5
|
|
|
|
|
15
|
return $this; |
745
|
|
|
|
|
|
|
} |
746
|
|
|
|
|
|
|
|
747
|
|
|
|
|
|
|
sub is_ref { |
748
|
7
|
|
|
7
|
|
13
|
my ($this, $expected) = @_; |
749
|
7
|
|
|
|
|
18
|
return $this->_is_reference($expected, 'eq', 1==1); |
750
|
|
|
|
|
|
|
} |
751
|
|
|
|
|
|
|
|
752
|
|
|
|
|
|
|
sub not_ref { |
753
|
5
|
|
|
5
|
|
9
|
my ($this, $expected) = @_; |
754
|
5
|
|
|
|
|
13
|
return $this->_is_reference($expected, 'ne', 0==1); |
755
|
|
|
|
|
|
|
} |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
sub _is_reference { |
758
|
12
|
|
|
12
|
|
21
|
my ($this, $expected, $op, $bool) = @_; |
759
|
12
|
|
|
|
|
25
|
$this->_done(); |
760
|
12
|
|
|
|
|
20
|
my $actual = $this->{actual}; |
761
|
12
|
100
|
|
|
|
35
|
unless ((ref($actual) eq $expected) == $bool) { |
762
|
6
|
|
|
|
|
26
|
my $msg = |
763
|
|
|
|
|
|
|
"[Failed] ref(\$actual) $op '$expected' : failed.\n" . |
764
|
|
|
|
|
|
|
" ref(\$actual): '" . ref($actual) . "'\n" . |
765
|
|
|
|
|
|
|
" \$actual: " . _repr($actual); |
766
|
6
|
|
|
|
|
18
|
$this->_die($msg); |
767
|
|
|
|
|
|
|
} |
768
|
6
|
|
|
|
|
16
|
return $this; |
769
|
|
|
|
|
|
|
} |
770
|
|
|
|
|
|
|
|
771
|
|
|
|
|
|
|
#sub is_arrayref { |
772
|
|
|
|
|
|
|
# my ($this) = @_; |
773
|
|
|
|
|
|
|
# return $this->_is_reftype('ARRAY'); |
774
|
|
|
|
|
|
|
#} |
775
|
|
|
|
|
|
|
# |
776
|
|
|
|
|
|
|
#sub is_hashref { |
777
|
|
|
|
|
|
|
# my ($this) = @_; |
778
|
|
|
|
|
|
|
# return $this->_is_reftype('HASH'); |
779
|
|
|
|
|
|
|
#} |
780
|
|
|
|
|
|
|
# |
781
|
|
|
|
|
|
|
#sub is_coderef { |
782
|
|
|
|
|
|
|
# my ($this) = @_; |
783
|
|
|
|
|
|
|
# return $this->_is_reftype('CODE'); |
784
|
|
|
|
|
|
|
#} |
785
|
|
|
|
|
|
|
# |
786
|
|
|
|
|
|
|
#sub _is_reftype { |
787
|
|
|
|
|
|
|
# my ($this, $reftype) = @_; |
788
|
|
|
|
|
|
|
# $this->_done(); |
789
|
|
|
|
|
|
|
# my $actual = $this->{actual}; |
790
|
|
|
|
|
|
|
# if (ref($actual) ne $reftype) { |
791
|
|
|
|
|
|
|
# my $msg = |
792
|
|
|
|
|
|
|
# "[Failed] ref(\$actual) : $reftype expected, but got " . ref($actual) . ".\n" . |
793
|
|
|
|
|
|
|
# " \$actual: " . _repr($actual); |
794
|
|
|
|
|
|
|
# $this->_die($msg); |
795
|
|
|
|
|
|
|
# } |
796
|
|
|
|
|
|
|
# return $this; |
797
|
|
|
|
|
|
|
#} |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
sub length { |
800
|
3
|
|
|
3
|
|
5
|
my ($this, $expected) = @_; |
801
|
3
|
|
|
|
|
8
|
$this->_done(); |
802
|
3
|
|
|
|
|
5
|
my $actual = $this->{actual}; |
803
|
3
|
100
|
|
|
|
8
|
if (Oktest::Util::is_string($actual)) { |
|
|
100
|
|
|
|
|
|
804
|
1
|
50
|
|
|
|
5
|
unless (CORE::length($actual) == $expected) { |
805
|
0
|
|
|
|
|
0
|
my $msg = |
806
|
|
|
|
|
|
|
"[Failed] length(\$actual) == \$expected : failed.\n" . |
807
|
|
|
|
|
|
|
" \$actual: " . _repr($actual) . |
808
|
|
|
|
|
|
|
" \$expected: " . _repr($expected); |
809
|
0
|
|
|
|
|
0
|
$this->_die($msg); |
810
|
|
|
|
|
|
|
} |
811
|
|
|
|
|
|
|
} |
812
|
|
|
|
|
|
|
elsif (ref($actual)) { |
813
|
1
|
|
|
|
|
3
|
my $n = $#{$actual} + 1; |
|
1
|
|
|
|
|
3
|
|
814
|
1
|
50
|
|
|
|
5
|
unless ($n == $expected) { |
815
|
0
|
|
|
|
|
0
|
my $msg = |
816
|
|
|
|
|
|
|
"[Failed] \$\#{$actual} + 1 == \$expected : failed.\n" . |
817
|
|
|
|
|
|
|
" \$actual+1: $n\n" . |
818
|
|
|
|
|
|
|
" \$expected: $expected\n"; |
819
|
0
|
|
|
|
|
0
|
$this->_die($msg); |
820
|
|
|
|
|
|
|
} |
821
|
|
|
|
|
|
|
} |
822
|
|
|
|
|
|
|
else { |
823
|
1
|
|
|
|
|
3
|
my $msg = |
824
|
|
|
|
|
|
|
"[ERROR] \$actual : string or array expected.\n" . |
825
|
|
|
|
|
|
|
" \$actual: " . _repr($actual); |
826
|
1
|
|
|
|
|
4
|
$this->_die($msg); |
827
|
|
|
|
|
|
|
} |
828
|
2
|
|
|
|
|
7
|
return $this; |
829
|
|
|
|
|
|
|
} |
830
|
|
|
|
|
|
|
|
831
|
|
|
|
|
|
|
sub has { |
832
|
4
|
|
|
4
|
|
8
|
my ($this, $name, $expected) = @_; |
833
|
4
|
|
|
|
|
9
|
$this->_done(); |
834
|
4
|
|
|
|
|
7
|
my $actual = $this->{actual}; |
835
|
4
|
100
|
|
|
|
12
|
unless (defined($actual->{$name})) { |
836
|
1
|
|
|
|
|
5
|
my $msg = |
837
|
|
|
|
|
|
|
"[Failed] defined(\$actual->{$name}) : failed.\n" . |
838
|
|
|
|
|
|
|
' $actual: ' . _repr($actual); |
839
|
1
|
|
|
|
|
5
|
$this->_die($msg); |
840
|
|
|
|
|
|
|
} |
841
|
3
|
100
|
|
|
|
9
|
if ($#_ == 2) { # when expected value is passed |
842
|
2
|
100
|
|
|
|
7
|
unless ($actual->{$name} eq $expected) { |
843
|
1
|
|
|
|
|
8
|
my $msg = |
844
|
|
|
|
|
|
|
"[Failed] \$actual->{$name} eq \$expected : failed.\n" . |
845
|
|
|
|
|
|
|
" \$actual->{$name}: " . _repr($actual->{$name}) . |
846
|
|
|
|
|
|
|
" \$expected: " . _repr($expected); |
847
|
1
|
|
|
|
|
3
|
$this->_die($msg); |
848
|
|
|
|
|
|
|
} |
849
|
|
|
|
|
|
|
} |
850
|
2
|
|
|
|
|
6
|
return $this; |
851
|
|
|
|
|
|
|
} |
852
|
|
|
|
|
|
|
|
853
|
|
|
|
|
|
|
sub can_ { |
854
|
5
|
|
|
5
|
|
8
|
my ($this, $method) = @_; |
855
|
5
|
|
|
|
|
16
|
return $this->_can_or_not($method, 1==1, 'can_', ''); |
856
|
|
|
|
|
|
|
} |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
sub can_not { |
859
|
3
|
|
|
3
|
|
5
|
my ($this, $method) = @_; |
860
|
3
|
|
|
|
|
7
|
return $this->_can_or_not($method, 0==1, 'can_not', '! '); |
861
|
|
|
|
|
|
|
} |
862
|
|
|
|
|
|
|
|
863
|
|
|
|
|
|
|
sub _can_or_not { |
864
|
8
|
|
|
8
|
|
16
|
my ($this, $method, $bool, $caller, $op) = @_; |
865
|
8
|
|
|
|
|
19
|
$this->_done(); |
866
|
8
|
|
|
|
|
14
|
my $actual = $this->{actual}; |
867
|
8
|
100
|
|
|
|
19
|
unless ($method) { |
868
|
2
|
|
|
|
|
6
|
my $msg = |
869
|
|
|
|
|
|
|
"[ERROR] OK()->$caller(): method name required.\n"; |
870
|
2
|
|
|
|
|
7
|
$this->_die($msg); |
871
|
|
|
|
|
|
|
} |
872
|
6
|
100
|
|
|
|
51
|
unless (!! $actual->can($method) == $bool) { |
873
|
3
|
|
|
|
|
14
|
my $msg = |
874
|
|
|
|
|
|
|
"[Failed] $op\$actual->can('$method') : failed.\n" . |
875
|
|
|
|
|
|
|
" \$actual: " . _repr($actual); |
876
|
3
|
|
|
|
|
24
|
$this->_die($msg); |
877
|
|
|
|
|
|
|
} |
878
|
3
|
|
|
|
|
10
|
return $this; |
879
|
|
|
|
|
|
|
} |
880
|
|
|
|
|
|
|
|
881
|
|
|
|
|
|
|
sub same { |
882
|
2
|
|
|
2
|
|
96
|
my ($this, $expected) = @_; |
883
|
2
|
|
|
|
|
9
|
return $this->_same_or_not($expected, '==', 1==1); |
884
|
|
|
|
|
|
|
} |
885
|
|
|
|
|
|
|
|
886
|
|
|
|
|
|
|
sub not_same { |
887
|
2
|
|
|
2
|
|
3
|
my ($this, $expected) = @_; |
888
|
2
|
|
|
|
|
6
|
return $this->_same_or_not($expected, '!=', 1!=1); |
889
|
|
|
|
|
|
|
} |
890
|
|
|
|
|
|
|
|
891
|
|
|
|
|
|
|
sub _same_or_not { |
892
|
4
|
|
|
4
|
|
9
|
my ($this, $expected, $op, $bool) = @_; |
893
|
4
|
|
|
|
|
9
|
$this->_done(); |
894
|
4
|
|
|
|
|
5
|
my $actual = $this->{actual}; |
895
|
4
|
100
|
|
|
|
20
|
unless ((refaddr($actual) == refaddr($expected)) == $bool) { |
896
|
2
|
|
|
|
|
8
|
my $msg = |
897
|
|
|
|
|
|
|
'[Failed] refaddr($actual) ' . $op . ' refaddr($expected) : failed.' . "\n" . |
898
|
|
|
|
|
|
|
' $actual: ' . _repr($actual) . |
899
|
|
|
|
|
|
|
' $expected: ' . _repr($expected); |
900
|
2
|
|
|
|
|
6
|
$this->_die($msg); |
901
|
|
|
|
|
|
|
} |
902
|
2
|
|
|
|
|
6
|
return $this; |
903
|
|
|
|
|
|
|
} |
904
|
|
|
|
|
|
|
|
905
|
|
|
|
|
|
|
sub is_truthy { |
906
|
4
|
|
|
4
|
|
6
|
my ($this) = @_; |
907
|
4
|
|
|
|
|
12
|
$this->_done(); |
908
|
4
|
100
|
|
|
|
18
|
unless ($this->{actual}) { |
909
|
2
|
|
|
|
|
9
|
my $msg = |
910
|
|
|
|
|
|
|
"[Failed] OK(\$expression) : assertion failed.\n" . |
911
|
|
|
|
|
|
|
" \$expression: " . _repr($this->{actual}); |
912
|
2
|
|
|
|
|
9
|
$this->_die($msg); |
913
|
|
|
|
|
|
|
} |
914
|
2
|
|
|
|
|
5
|
return $this; |
915
|
|
|
|
|
|
|
} |
916
|
|
|
|
|
|
|
|
917
|
|
|
|
|
|
|
sub is_falsy { |
918
|
2
|
|
|
2
|
|
3
|
my ($this) = @_; |
919
|
2
|
|
|
|
|
6
|
$this->_done(); |
920
|
2
|
100
|
|
|
|
8
|
unless (! $this->{actual}) { |
921
|
1
|
|
|
|
|
3
|
my $msg = |
922
|
|
|
|
|
|
|
"[Failed] OK(! \$expression) : assertion failed.\n" . |
923
|
|
|
|
|
|
|
" \$expression: " . _repr($this->{actual}); |
924
|
1
|
|
|
|
|
3
|
$this->_die($msg); |
925
|
|
|
|
|
|
|
} |
926
|
1
|
|
|
|
|
4
|
return $this; |
927
|
|
|
|
|
|
|
} |
928
|
|
|
|
|
|
|
|
929
|
|
|
|
|
|
|
sub is_defined { |
930
|
3
|
|
|
3
|
|
4
|
my ($this) = @_; |
931
|
3
|
|
|
|
|
8
|
$this->_done(); |
932
|
3
|
|
|
|
|
5
|
my $actual = $this->{actual}; |
933
|
3
|
100
|
|
|
|
9
|
unless (defined($actual)) { |
934
|
1
|
|
|
|
|
4
|
my $msg = |
935
|
|
|
|
|
|
|
"[Failed] defined(\$actual) : failed.\n" . |
936
|
|
|
|
|
|
|
" \$actual: " . _repr($actual); |
937
|
1
|
|
|
|
|
4
|
$this->_die($msg); |
938
|
|
|
|
|
|
|
} |
939
|
2
|
|
|
|
|
6
|
return $this; |
940
|
|
|
|
|
|
|
} |
941
|
|
|
|
|
|
|
|
942
|
|
|
|
|
|
|
sub not_defined { |
943
|
2
|
|
|
2
|
|
4
|
my ($this) = @_; |
944
|
2
|
|
|
|
|
5
|
$this->_done(); |
945
|
2
|
|
|
|
|
4
|
my $actual = $this->{actual}; |
946
|
2
|
100
|
|
|
|
6
|
unless (! defined($actual)) { |
947
|
1
|
|
|
|
|
4
|
my $msg = |
948
|
|
|
|
|
|
|
"[Failed] ! defined(\$actual) : failed.\n" . |
949
|
|
|
|
|
|
|
" \$actual: " . _repr($actual); |
950
|
1
|
|
|
|
|
4
|
$this->_die($msg); |
951
|
|
|
|
|
|
|
} |
952
|
1
|
|
|
|
|
2
|
return $this; |
953
|
|
|
|
|
|
|
} |
954
|
|
|
|
|
|
|
|
955
|
|
|
|
|
|
|
sub equals { ## !! EXPERIMENTAL !! |
956
|
4
|
|
|
4
|
|
6
|
my ($this, $expected) = @_; |
957
|
4
|
|
|
|
|
10
|
$this->_done(); |
958
|
4
|
|
|
|
|
64
|
my $actual = $this->{actual}; |
959
|
|
|
|
|
|
|
# |
960
|
4
|
50
|
|
|
|
13
|
unless (ref($actual) eq ref($expected)) { |
961
|
0
|
|
|
|
|
0
|
my $msg = |
962
|
|
|
|
|
|
|
'[Failed] ref($actual) eq ref($expected) : failed.' . "\n" . |
963
|
|
|
|
|
|
|
' ref($actual): ' . _repr(ref($actual)) . |
964
|
|
|
|
|
|
|
' ref($expected): ' . _repr(ref($expected)) . |
965
|
|
|
|
|
|
|
' $actual: ' . _repr($actual) . |
966
|
|
|
|
|
|
|
' $expected: ' . _repr($expected); |
967
|
0
|
|
|
|
|
0
|
$this->_die($msg); |
968
|
|
|
|
|
|
|
} |
969
|
|
|
|
|
|
|
# |
970
|
4
|
|
|
|
|
11
|
my $actual_dump = Dumper($actual); # _repr($actual); |
971
|
4
|
|
|
|
|
224
|
my $expected_dump = Dumper($expected); # _repr($expected); |
972
|
4
|
100
|
|
|
|
257
|
unless ($actual_dump eq $expected_dump) { |
973
|
2
|
|
|
|
|
14
|
my $diff = Text::Diff::diff(\$expected_dump, \$actual_dump, {STYLE=>'Unified'}); |
974
|
2
|
|
|
|
|
665
|
my $msg = |
975
|
|
|
|
|
|
|
"[Failed] \$actual equals to \$expected : failed.\n" . |
976
|
|
|
|
|
|
|
"--- Dumper(\$expected)\n" . |
977
|
|
|
|
|
|
|
"+++ Dumper(\$actual)\n" . |
978
|
|
|
|
|
|
|
$diff; |
979
|
2
|
|
|
|
|
6
|
$this->_die($msg); |
980
|
|
|
|
|
|
|
}; |
981
|
|
|
|
|
|
|
# |
982
|
2
|
|
|
|
|
3
|
return $this; |
983
|
|
|
|
|
|
|
} |
984
|
|
|
|
|
|
|
|
985
|
|
|
|
|
|
|
sub not_equal { ## !! EXPERIMENTAL !! |
986
|
0
|
|
|
0
|
|
0
|
my ($this, $expected) = @_; |
987
|
0
|
|
|
|
|
0
|
$this->_done(); |
988
|
0
|
|
|
|
|
0
|
my $actual = $this->{actual}; |
989
|
0
|
0
|
|
|
|
0
|
if (Dumper($actual) eq Dumper($expected)) { |
990
|
0
|
|
|
|
|
0
|
my $msg = |
991
|
|
|
|
|
|
|
"[Failed] \$actual and \$expected are not equal: failed.\n" . |
992
|
|
|
|
|
|
|
" \$actual and \$expected: " . _repr($actual); |
993
|
0
|
|
|
|
|
0
|
$this->_die($msg); |
994
|
|
|
|
|
|
|
}; |
995
|
0
|
|
|
|
|
0
|
return $this; |
996
|
|
|
|
|
|
|
} |
997
|
|
|
|
|
|
|
|
998
|
|
|
|
|
|
|
sub all { |
999
|
0
|
|
|
0
|
|
0
|
my ($this, $block) = @_; |
1000
|
0
|
|
|
|
|
0
|
$this->_done(); |
1001
|
0
|
|
|
|
|
0
|
my $actual = $this->{actual}; |
1002
|
0
|
|
|
|
|
0
|
my $index = &Oktest::Util::index_denied($block, @$actual); |
1003
|
0
|
|
|
|
|
0
|
my $found = $index >= 0; |
1004
|
0
|
0
|
|
|
|
0
|
if ($found) { |
1005
|
0
|
|
|
|
|
0
|
my $msg = |
1006
|
|
|
|
|
|
|
"[Failed] OK(\$actual)->all(sub{...}) : failed at index=$index.\n" . |
1007
|
|
|
|
|
|
|
" \$actual->[$index]: " . _repr($actual->[$index]); |
1008
|
0
|
|
|
|
|
0
|
$this->_die($msg); |
1009
|
|
|
|
|
|
|
} |
1010
|
0
|
|
|
|
|
0
|
return $this; |
1011
|
|
|
|
|
|
|
} |
1012
|
|
|
|
|
|
|
|
1013
|
|
|
|
|
|
|
sub any { |
1014
|
0
|
|
|
0
|
|
0
|
my ($this, $block) = @_; |
1015
|
0
|
|
|
|
|
0
|
$this->_done(); |
1016
|
0
|
|
|
|
|
0
|
my $actual = $this->{actual}; |
1017
|
0
|
|
|
|
|
0
|
my $found = &Oktest::Util::index($block, @$actual) >= 0; |
1018
|
0
|
0
|
|
|
|
0
|
unless ($found) { |
1019
|
0
|
|
|
|
|
0
|
my $msg = |
1020
|
|
|
|
|
|
|
"[Failed] OK(\$actual)->any(sub{...}) : failed.\n" . |
1021
|
|
|
|
|
|
|
" \$actual: " . _repr($actual); |
1022
|
0
|
|
|
|
|
0
|
$this->_die($msg); |
1023
|
|
|
|
|
|
|
} |
1024
|
0
|
|
|
|
|
0
|
return $this; |
1025
|
|
|
|
|
|
|
} |
1026
|
|
|
|
|
|
|
|
1027
|
|
|
|
|
|
|
sub file_exists { |
1028
|
0
|
|
|
0
|
|
0
|
my ($this) = @_; |
1029
|
0
|
|
|
|
|
0
|
return $this->_file_or_dir_exists('file', '-f', -f $this->{actual}); |
1030
|
|
|
|
|
|
|
} |
1031
|
|
|
|
|
|
|
|
1032
|
|
|
|
|
|
|
sub dir_exists { |
1033
|
0
|
|
|
0
|
|
0
|
my ($this) = @_; |
1034
|
0
|
|
|
|
|
0
|
return $this->_file_or_dir_exists('directory', '-d', -d $this->{actual}); |
1035
|
|
|
|
|
|
|
} |
1036
|
|
|
|
|
|
|
|
1037
|
|
|
|
|
|
|
sub _file_or_dir_exists { |
1038
|
0
|
|
|
0
|
|
0
|
my ($this, $kind, $op, $bool) = @_; |
1039
|
0
|
|
|
|
|
0
|
$this->_done(); |
1040
|
0
|
|
|
|
|
0
|
my $actual = $this->{actual}; |
1041
|
0
|
0
|
|
|
|
0
|
unless ($bool) { |
1042
|
0
|
0
|
|
|
|
0
|
my $msg = ! -e $actual |
1043
|
|
|
|
|
|
|
? "[Failed] $op \$actual : failed ($kind not exist).\n" |
1044
|
|
|
|
|
|
|
: "[Failed] $op \$actual : failed (not a $kind).\n"; |
1045
|
0
|
|
|
|
|
0
|
$msg .= " \$actual: " . _repr($actual); |
1046
|
0
|
|
|
|
|
0
|
$this->_die($msg); |
1047
|
|
|
|
|
|
|
} |
1048
|
0
|
|
|
|
|
0
|
return $this; |
1049
|
|
|
|
|
|
|
} |
1050
|
|
|
|
|
|
|
|
1051
|
|
|
|
|
|
|
#sub not_file { |
1052
|
|
|
|
|
|
|
# my ($this) = @_; |
1053
|
|
|
|
|
|
|
# return $this->_not_file_or_dir('file', '-f', -f $this->{actual}); |
1054
|
|
|
|
|
|
|
#} |
1055
|
|
|
|
|
|
|
# |
1056
|
|
|
|
|
|
|
#sub not_dir { |
1057
|
|
|
|
|
|
|
# my ($this) = @_; |
1058
|
|
|
|
|
|
|
# return $this->_not_file_or_dir('directory', '-d', -d $this->{actual}); |
1059
|
|
|
|
|
|
|
#} |
1060
|
|
|
|
|
|
|
# |
1061
|
|
|
|
|
|
|
#sub _not_file_or_dir { |
1062
|
|
|
|
|
|
|
# my ($this, $kind, $op, $bool) = @_; |
1063
|
|
|
|
|
|
|
# $this->_done(); |
1064
|
|
|
|
|
|
|
# my $actual = $this->{actual}; |
1065
|
|
|
|
|
|
|
# unless (! $bool) { |
1066
|
|
|
|
|
|
|
# my $msg = |
1067
|
|
|
|
|
|
|
# "[Failed] ! $op \$actual : failed ($kind exists).\n" . |
1068
|
|
|
|
|
|
|
# " \$actual: " . _repr($actual); |
1069
|
|
|
|
|
|
|
# $this->_die($msg); |
1070
|
|
|
|
|
|
|
# } |
1071
|
|
|
|
|
|
|
# return $this; |
1072
|
|
|
|
|
|
|
#} |
1073
|
|
|
|
|
|
|
# |
1074
|
|
|
|
|
|
|
#sub exist { |
1075
|
|
|
|
|
|
|
# my ($this) = @_; |
1076
|
|
|
|
|
|
|
# $this->_done(); |
1077
|
|
|
|
|
|
|
# my $actual = $this->{actual}; |
1078
|
|
|
|
|
|
|
# unless (-e $actual) { |
1079
|
|
|
|
|
|
|
# my $msg = |
1080
|
|
|
|
|
|
|
# "[Failed] -e \$actual : failed (file or directory not found).\n" . |
1081
|
|
|
|
|
|
|
# " \$actual: " . _repr($actual); |
1082
|
|
|
|
|
|
|
# $this->_die($msg); |
1083
|
|
|
|
|
|
|
# } |
1084
|
|
|
|
|
|
|
# return $this; |
1085
|
|
|
|
|
|
|
#} |
1086
|
|
|
|
|
|
|
|
1087
|
|
|
|
|
|
|
sub not_exist { |
1088
|
0
|
|
|
0
|
|
0
|
my ($this) = @_; |
1089
|
0
|
|
|
|
|
0
|
$this->_done(); |
1090
|
0
|
|
|
|
|
0
|
my $actual = $this->{actual}; |
1091
|
0
|
0
|
|
|
|
0
|
unless (! -e $actual) { |
1092
|
0
|
|
|
|
|
0
|
my $msg = |
1093
|
|
|
|
|
|
|
"[Failed] ! -e \$actual : failed (file or directory exists).\n" . |
1094
|
|
|
|
|
|
|
" \$actual: " . _repr($actual); |
1095
|
0
|
|
|
|
|
0
|
$this->_die($msg); |
1096
|
|
|
|
|
|
|
} |
1097
|
0
|
|
|
|
|
0
|
return $this; |
1098
|
|
|
|
|
|
|
} |
1099
|
|
|
|
|
|
|
|
1100
|
|
|
|
|
|
|
|
1101
|
|
|
|
|
|
|
|
1102
|
|
|
|
|
|
|
package Oktest::Runner; |
1103
|
|
|
|
|
|
|
|
1104
|
|
|
|
|
|
|
our $RUNNER = 'Oktest::Runner::DefaultRunner'; |
1105
|
|
|
|
|
|
|
|
1106
|
|
|
|
|
|
|
|
1107
|
|
|
|
|
|
|
|
1108
|
|
|
|
|
|
|
package Oktest::Runner::Base; |
1109
|
|
|
|
|
|
|
|
1110
|
|
|
|
|
|
|
sub new { |
1111
|
61
|
|
|
61
|
|
70
|
my ($class) = @_; |
1112
|
61
|
|
|
|
|
118
|
my $this = { |
1113
|
|
|
|
|
|
|
'reporter' => undef, |
1114
|
|
|
|
|
|
|
}; |
1115
|
61
|
|
|
|
|
147
|
return bless($this, $class); |
1116
|
|
|
|
|
|
|
} |
1117
|
|
|
|
|
|
|
|
1118
|
|
|
|
|
|
|
sub reporter { |
1119
|
880
|
|
|
880
|
|
961
|
my ($this) = @_; |
1120
|
880
|
|
33
|
|
|
1559
|
$this->{reporter} ||= $Oktest::Reporter::REPORTER->new(); |
1121
|
880
|
|
|
|
|
2154
|
return $this->{reporter}; |
1122
|
|
|
|
|
|
|
} |
1123
|
|
|
|
|
|
|
|
1124
|
|
|
|
|
|
|
sub run_all { |
1125
|
0
|
|
|
0
|
|
0
|
my ($this, @topics) = @_; |
1126
|
|
|
|
|
|
|
} |
1127
|
|
|
|
|
|
|
|
1128
|
|
|
|
|
|
|
sub run_topic { |
1129
|
0
|
|
|
0
|
|
0
|
my ($this, $to, $depth) = @_; |
1130
|
|
|
|
|
|
|
} |
1131
|
|
|
|
|
|
|
|
1132
|
|
|
|
|
|
|
sub run_spec { |
1133
|
0
|
|
|
0
|
|
0
|
my ($this, $so, $depth) = @_; |
1134
|
|
|
|
|
|
|
} |
1135
|
|
|
|
|
|
|
|
1136
|
|
|
|
|
|
|
sub detect_status { |
1137
|
219
|
|
|
219
|
|
270
|
my ($this, $errmsg) = @_; |
1138
|
219
|
100
|
|
|
|
424
|
return '.' unless $errmsg; |
1139
|
105
|
100
|
|
|
|
256
|
return 'f' if $errmsg =~ /^\[Failed\]/; |
1140
|
77
|
50
|
|
|
|
133
|
return 'E' if $errmsg =~ /^\[ERROR\]/; |
1141
|
77
|
100
|
|
|
|
214
|
return 's' if $errmsg =~ /^\[Skipped\]/; |
1142
|
52
|
100
|
|
|
|
132
|
return 't' if $errmsg =~ /^\[TODO\]/; |
1143
|
|
|
|
|
|
|
#return '?'; |
1144
|
27
|
|
|
|
|
53
|
return 'E'; |
1145
|
|
|
|
|
|
|
} |
1146
|
|
|
|
|
|
|
|
1147
|
|
|
|
|
|
|
|
1148
|
|
|
|
|
|
|
|
1149
|
|
|
|
|
|
|
package Oktest::Runner::DefaultRunner; |
1150
|
|
|
|
|
|
|
our @ISA = ('Oktest::Runner::Base'); |
1151
|
|
|
|
|
|
|
|
1152
|
|
|
|
|
|
|
our $EXEC = $Oktest::TopicObject::EXEC; |
1153
|
|
|
|
|
|
|
our $IGNORE = $Oktest::TopicObject::IGNORE; |
1154
|
|
|
|
|
|
|
our $ENTER = $Oktest::TopicObject::ENTER; |
1155
|
|
|
|
|
|
|
|
1156
|
|
|
|
|
|
|
sub new { |
1157
|
61
|
|
|
61
|
|
86
|
my ($class) = @_; |
1158
|
61
|
|
|
|
|
168
|
my $this = $class->SUPER::new(); |
1159
|
61
|
|
|
|
|
130
|
$this->{depth} = 0; |
1160
|
61
|
|
|
|
|
84
|
return $this; |
1161
|
|
|
|
|
|
|
} |
1162
|
|
|
|
|
|
|
|
1163
|
|
|
|
|
|
|
sub run_all { |
1164
|
60
|
|
|
60
|
|
138
|
my ($this, @topics) = @_; |
1165
|
60
|
|
|
|
|
126
|
$this->_filter(@topics); |
1166
|
60
|
|
|
|
|
128
|
$this->reporter->enter_all(@topics); |
1167
|
60
|
|
|
|
|
98
|
for my $to (@topics) { |
1168
|
|
|
|
|
|
|
#$this->run_topic($to, 0); |
1169
|
87
|
|
|
|
|
150
|
$to->accept($this, 0); |
1170
|
|
|
|
|
|
|
} |
1171
|
60
|
|
|
|
|
108
|
$this->reporter->exit_all(@topics); |
1172
|
|
|
|
|
|
|
} |
1173
|
|
|
|
|
|
|
|
1174
|
|
|
|
|
|
|
sub run_topic { |
1175
|
197
|
|
|
197
|
|
203
|
my ($this, $to, $depth) = @_; ## $to is a TopicObject |
1176
|
197
|
100
|
|
|
|
401
|
return if $to->{status} == $IGNORE; |
1177
|
161
|
|
|
|
|
244
|
$this->reporter->enter_topic($to, $depth); |
1178
|
161
|
100
|
|
|
|
418
|
$to->{_before_all}->() if $to->{_before_all}; |
1179
|
|
|
|
|
|
|
# |
1180
|
161
|
100
|
|
|
|
301
|
if ($to->{status} == $EXEC) { |
1181
|
147
|
|
|
|
|
121
|
for my $so (@{$to->{specs}}) { |
|
147
|
|
|
|
|
246
|
|
1182
|
|
|
|
|
|
|
#$this->run_spec($so, $depth + 1) if $so->{status} == $EXEC; |
1183
|
222
|
100
|
|
|
|
690
|
$so->accept($this, $depth + 1) if $so->{status} == $EXEC; |
1184
|
|
|
|
|
|
|
} |
1185
|
|
|
|
|
|
|
} |
1186
|
|
|
|
|
|
|
# |
1187
|
161
|
|
|
|
|
197
|
for my $child (@{$to->{topics}}) { |
|
161
|
|
|
|
|
276
|
|
1188
|
|
|
|
|
|
|
#$this->run_topic($child, $depth + 1); |
1189
|
110
|
|
|
|
|
242
|
$child->accept($this, $depth + 1); |
1190
|
|
|
|
|
|
|
} |
1191
|
|
|
|
|
|
|
# |
1192
|
161
|
100
|
|
|
|
331
|
$to->{_after_all}->() if $to->{_after_all}; |
1193
|
161
|
|
|
|
|
264
|
$this->reporter->exit_topic($to, $depth); |
1194
|
|
|
|
|
|
|
} |
1195
|
|
|
|
|
|
|
|
1196
|
|
|
|
|
|
|
sub run_spec { |
1197
|
219
|
|
|
219
|
|
219
|
my ($this, $so, $depth) = @_; ## $so is a SpecObject |
1198
|
219
|
|
|
|
|
327
|
$this->reporter->enter_spec($so, $depth); |
1199
|
219
|
|
|
|
|
655
|
my $context = { |
1200
|
|
|
|
|
|
|
spec => $so->{desc}, |
1201
|
|
|
|
|
|
|
topic => $so->{parent}->{name}, |
1202
|
|
|
|
|
|
|
}; |
1203
|
219
|
|
|
|
|
216
|
my $errmsg; |
1204
|
219
|
|
|
|
|
206
|
undef $@; |
1205
|
219
|
|
|
|
|
253
|
eval { $this->_run_befores($so, $context) }; |
|
219
|
|
|
|
|
360
|
|
1206
|
219
|
100
|
|
|
|
399
|
if ($@) { |
1207
|
1
|
|
|
|
|
2
|
$errmsg = $@; |
1208
|
1
|
|
|
|
|
2
|
undef $@; |
1209
|
|
|
|
|
|
|
} |
1210
|
|
|
|
|
|
|
else { |
1211
|
218
|
|
|
|
|
201
|
eval { $so->{block}->($context) }; |
|
218
|
|
|
|
|
524
|
|
1212
|
218
|
|
|
|
|
1117
|
$errmsg = $@; |
1213
|
218
|
|
|
|
|
237
|
undef $@; |
1214
|
218
|
|
|
|
|
225
|
eval { Oktest::__at_end_of_spec() }; |
|
218
|
|
|
|
|
283
|
|
1215
|
218
|
50
|
|
|
|
337
|
$errmsg .= $@ if $@; |
1216
|
218
|
|
|
|
|
209
|
undef $@; |
1217
|
218
|
|
|
|
|
227
|
eval { $this->_run_afters($so, $context) }; |
|
218
|
|
|
|
|
389
|
|
1218
|
218
|
100
|
|
|
|
338
|
$errmsg .= $@ if $@; |
1219
|
218
|
|
|
|
|
229
|
undef $@; |
1220
|
|
|
|
|
|
|
} |
1221
|
219
|
|
|
|
|
379
|
my $status = $this->detect_status($errmsg); |
1222
|
219
|
|
|
|
|
387
|
$this->reporter->exit_spec($so, $depth, $status, $errmsg); |
1223
|
219
|
|
|
|
|
430
|
Oktest::__sweep(); |
1224
|
|
|
|
|
|
|
} |
1225
|
|
|
|
|
|
|
|
1226
|
|
|
|
|
|
|
sub _run_befores { |
1227
|
219
|
|
|
219
|
|
235
|
my ($this, $so, $context) = @_; |
1228
|
219
|
|
|
|
|
247
|
my $to = $so->{parent}; |
1229
|
|
|
|
|
|
|
## parent-first |
1230
|
219
|
|
|
|
|
237
|
my @arr = (); |
1231
|
219
|
|
|
|
|
366
|
while ($to) { |
1232
|
447
|
|
|
|
|
451
|
push(@arr, $to); |
1233
|
447
|
|
|
|
|
778
|
$to = $to->{parent}; |
1234
|
|
|
|
|
|
|
} |
1235
|
219
|
|
|
|
|
303
|
for $to (reverse(@arr)) { |
1236
|
447
|
100
|
|
|
|
1089
|
$to->{_before}->($context) if $to->{_before}; |
1237
|
|
|
|
|
|
|
} |
1238
|
|
|
|
|
|
|
} |
1239
|
|
|
|
|
|
|
|
1240
|
|
|
|
|
|
|
sub _run_afters { |
1241
|
218
|
|
|
218
|
|
251
|
my ($this, $so, $context) = @_; |
1242
|
218
|
|
|
|
|
373
|
my $to = $so->{parent}; |
1243
|
|
|
|
|
|
|
## child-first |
1244
|
218
|
|
|
|
|
399
|
while ($to) { |
1245
|
446
|
100
|
|
|
|
730
|
$to->{_after}->($context) if $to->{_after}; |
1246
|
445
|
|
|
|
|
949
|
$to = $to->{parent}; |
1247
|
|
|
|
|
|
|
} |
1248
|
|
|
|
|
|
|
} |
1249
|
|
|
|
|
|
|
|
1250
|
|
|
|
|
|
|
sub _filter { |
1251
|
60
|
|
|
60
|
|
76
|
my ($this, @topics) = @_; |
1252
|
|
|
|
|
|
|
# |
1253
|
60
|
|
|
|
|
77
|
my $pat1 = $this->{filter_spec}; |
1254
|
60
|
100
|
|
|
|
122
|
_filter_specs($pat1, @topics) if $pat1; |
1255
|
|
|
|
|
|
|
# |
1256
|
60
|
|
|
|
|
75
|
my $pat2 = $this->{filter_topic}; |
1257
|
60
|
100
|
|
|
|
106
|
_filter_topics($pat2, @topics) if $pat2; |
1258
|
|
|
|
|
|
|
# |
1259
|
60
|
100
|
100
|
|
|
263
|
if ($pat1 || $pat2) { |
1260
|
10
|
|
|
|
|
31
|
_change_status_recursively($_) for @topics; |
1261
|
|
|
|
|
|
|
} |
1262
|
|
|
|
|
|
|
} |
1263
|
|
|
|
|
|
|
|
1264
|
|
|
|
|
|
|
sub _filter_specs { |
1265
|
38
|
|
|
38
|
|
50
|
my ($pat, @topics) = @_; |
1266
|
38
|
|
|
|
|
75
|
for my $to (@topics) { |
1267
|
34
|
|
|
|
|
35
|
my $found = 0==1; |
1268
|
34
|
|
|
|
|
30
|
for my $so (@{$to->{specs}}) { |
|
34
|
|
|
|
|
58
|
|
1269
|
62
|
100
|
|
|
|
173
|
if ($so->{desc} =~ $pat) { |
1270
|
6
|
|
|
|
|
11
|
$found = 1==1; |
1271
|
|
|
|
|
|
|
} |
1272
|
|
|
|
|
|
|
else { |
1273
|
56
|
|
|
|
|
93
|
$so->{status} = $IGNORE; |
1274
|
|
|
|
|
|
|
} |
1275
|
|
|
|
|
|
|
} |
1276
|
34
|
100
|
|
|
|
66
|
$to->{status} = $IGNORE unless $found; |
1277
|
34
|
|
|
|
|
31
|
_filter_specs($pat, @{$to->{topics}}); |
|
34
|
|
|
|
|
69
|
|
1278
|
|
|
|
|
|
|
} |
1279
|
|
|
|
|
|
|
} |
1280
|
|
|
|
|
|
|
|
1281
|
|
|
|
|
|
|
sub _filter_topics { |
1282
|
53
|
|
|
53
|
|
77
|
my ($pat, @topics) = @_; |
1283
|
53
|
|
|
|
|
109
|
for my $to (@topics) { |
1284
|
54
|
100
|
|
|
|
205
|
unless ($to->{name} =~ $pat) { |
1285
|
47
|
|
|
|
|
53
|
$to->{status} = $IGNORE; |
1286
|
47
|
|
|
|
|
40
|
_filter_topics($pat, @{$to->{topics}}); |
|
47
|
|
|
|
|
109
|
|
1287
|
|
|
|
|
|
|
} |
1288
|
|
|
|
|
|
|
} |
1289
|
|
|
|
|
|
|
} |
1290
|
|
|
|
|
|
|
|
1291
|
|
|
|
|
|
|
sub _change_status_recursively { |
1292
|
90
|
|
|
90
|
|
88
|
my ($to) = @_; |
1293
|
90
|
|
|
|
|
82
|
my $flag = 0==1; |
1294
|
90
|
|
|
|
|
72
|
for my $child (@{$to->{topics}}) { |
|
90
|
|
|
|
|
133
|
|
1295
|
56
|
|
|
|
|
91
|
my $ret = _change_status_recursively($child); |
1296
|
56
|
100
|
|
|
|
112
|
$flag = 1==1 if $ret; |
1297
|
|
|
|
|
|
|
} |
1298
|
90
|
100
|
|
|
|
169
|
if ($to->{status} != $IGNORE) { |
|
|
100
|
|
|
|
|
|
1299
|
14
|
|
|
|
|
27
|
return 1==1; # not ignored |
1300
|
|
|
|
|
|
|
} |
1301
|
|
|
|
|
|
|
elsif ($flag) { |
1302
|
14
|
|
|
|
|
15
|
$to->{status} = $ENTER; |
1303
|
14
|
|
|
|
|
33
|
return 1==1; # not ignored, because non-ignored topic exists in topics |
1304
|
|
|
|
|
|
|
} |
1305
|
|
|
|
|
|
|
else { |
1306
|
62
|
|
|
|
|
106
|
return 0==1; # ignored |
1307
|
|
|
|
|
|
|
} |
1308
|
|
|
|
|
|
|
} |
1309
|
|
|
|
|
|
|
|
1310
|
|
|
|
|
|
|
|
1311
|
|
|
|
|
|
|
|
1312
|
|
|
|
|
|
|
package Oktest::Reporter; |
1313
|
|
|
|
|
|
|
|
1314
|
|
|
|
|
|
|
our $REPORTER = 'Oktest::Reporter::TapReporter'; |
1315
|
|
|
|
|
|
|
|
1316
|
|
|
|
|
|
|
our %_registered = ( |
1317
|
|
|
|
|
|
|
tap => 'Oktest::Reporter::TapReporter', |
1318
|
|
|
|
|
|
|
verbose => 'Oktest::Reporter::VerboseReporter', |
1319
|
|
|
|
|
|
|
simple => 'Oktest::Reporter::SimpleReporter', |
1320
|
|
|
|
|
|
|
plain => 'Oktest::Reporter::PlainReporter', |
1321
|
|
|
|
|
|
|
't' => 'Oktest::Reporter::TapReporter', |
1322
|
|
|
|
|
|
|
'v' => 'Oktest::Reporter::VerboseReporter', |
1323
|
|
|
|
|
|
|
's' => 'Oktest::Reporter::SimpleReporter', |
1324
|
|
|
|
|
|
|
'p' => 'Oktest::Reporter::PlainReporter', |
1325
|
|
|
|
|
|
|
); |
1326
|
|
|
|
|
|
|
|
1327
|
|
|
|
|
|
|
sub create_instance { |
1328
|
61
|
|
|
61
|
|
77
|
my ($style) = @_; |
1329
|
61
|
|
100
|
|
|
119
|
$style ||= 'tap'; # default: 'tap' style |
1330
|
61
|
|
|
|
|
103
|
my $class = $Oktest::Reporter::_registered{$style}; |
1331
|
61
|
50
|
|
|
|
99
|
return unless $class; |
1332
|
61
|
|
|
|
|
337
|
return $class->new(); |
1333
|
|
|
|
|
|
|
} |
1334
|
|
|
|
|
|
|
|
1335
|
|
|
|
|
|
|
|
1336
|
|
|
|
|
|
|
|
1337
|
|
|
|
|
|
|
package Oktest::Reporter::Base; |
1338
|
7
|
|
|
7
|
|
8273
|
use Time::HiRes qw(gettimeofday tv_interval); |
|
7
|
|
|
|
|
13320
|
|
|
7
|
|
|
|
|
34
|
|
1339
|
|
|
|
|
|
|
|
1340
|
|
|
|
|
|
|
our %STATUS_LABELS = ( |
1341
|
|
|
|
|
|
|
'.' => 'ok', |
1342
|
|
|
|
|
|
|
'f' => 'Failed', |
1343
|
|
|
|
|
|
|
'E' => 'ERROR', |
1344
|
|
|
|
|
|
|
's' => 'Skipped', |
1345
|
|
|
|
|
|
|
't' => 'TODO', |
1346
|
|
|
|
|
|
|
'?' => '???', |
1347
|
|
|
|
|
|
|
); |
1348
|
|
|
|
|
|
|
|
1349
|
|
|
|
|
|
|
sub new { |
1350
|
61
|
|
|
61
|
|
68
|
my ($class) = @_; |
1351
|
61
|
|
|
|
|
226
|
my $this = { |
1352
|
|
|
|
|
|
|
count => 0, |
1353
|
|
|
|
|
|
|
counts => {}, |
1354
|
|
|
|
|
|
|
separator => '-' x 70, |
1355
|
|
|
|
|
|
|
}; |
1356
|
61
|
|
|
|
|
287
|
return bless($this, $class); |
1357
|
|
|
|
|
|
|
} |
1358
|
|
|
|
|
|
|
|
1359
|
|
|
|
|
|
|
sub _indent { |
1360
|
180
|
|
|
180
|
|
199
|
my ($this, $depth) = @_; |
1361
|
180
|
|
|
|
|
583
|
return ' ' x $depth; |
1362
|
|
|
|
|
|
|
} |
1363
|
|
|
|
|
|
|
|
1364
|
|
|
|
|
|
|
sub enter_all { |
1365
|
60
|
|
|
60
|
|
83
|
my ($this, @topics) = @_; |
1366
|
60
|
|
|
|
|
285
|
$this->{_started_at} = [gettimeofday()]; |
1367
|
|
|
|
|
|
|
}; |
1368
|
|
|
|
|
|
|
|
1369
|
|
|
|
|
|
|
sub exit_all { |
1370
|
60
|
|
|
60
|
|
97
|
my ($this, @topics) = @_; |
1371
|
60
|
|
|
|
|
179
|
my $elapsed = tv_interval($this->{_started_at}); |
1372
|
60
|
|
|
|
|
649
|
undef $this->{_started_at}; |
1373
|
60
|
|
|
|
|
89
|
my $c = $this->{counts}; |
1374
|
60
|
|
100
|
|
|
1075
|
my $s = sprintf("## ok:%s, failed:%s, error:%s, skipped:%s, todo:%s (elapsed: %.3f)\n", |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
1375
|
|
|
|
|
|
|
$c->{'.'}||0, $c->{'f'}||0, $c->{'E'}||0, $c->{'s'}||0, $c->{'t'}||0, $elapsed); |
1376
|
60
|
|
|
|
|
111
|
print $s; |
1377
|
|
|
|
|
|
|
} |
1378
|
|
|
|
|
|
|
|
1379
|
|
|
|
|
|
|
sub enter_topic { |
1380
|
94
|
|
|
94
|
|
128
|
my ($this, $to, $depth) = @_; |
1381
|
|
|
|
|
|
|
}; |
1382
|
|
|
|
|
|
|
|
1383
|
|
|
|
|
|
|
sub exit_topic { |
1384
|
159
|
|
|
159
|
|
306
|
my ($this, $to, $depth) = @_; |
1385
|
|
|
|
|
|
|
}; |
1386
|
|
|
|
|
|
|
|
1387
|
|
|
|
|
|
|
sub enter_spec { |
1388
|
219
|
|
|
219
|
|
288
|
my ($this, $so, $depth) = @_; |
1389
|
|
|
|
|
|
|
}; |
1390
|
|
|
|
|
|
|
|
1391
|
|
|
|
|
|
|
sub exit_spec { |
1392
|
219
|
|
|
219
|
|
272
|
my ($this, $so, $depth, $status, $errmsg) = @_; |
1393
|
219
|
|
|
|
|
384
|
++$this->{counts}->{$status}; |
1394
|
219
|
|
|
|
|
314
|
++$this->{count}; |
1395
|
|
|
|
|
|
|
}; |
1396
|
|
|
|
|
|
|
|
1397
|
|
|
|
|
|
|
sub _error_should_be_reported { |
1398
|
124
|
|
|
124
|
|
135
|
my ($this, $status) = @_; |
1399
|
124
|
100
|
100
|
|
|
333
|
return 1==1 if $status eq 's' && $this->{report_skipped}; |
1400
|
116
|
100
|
100
|
|
|
346
|
return 1==1 if $status eq 't' && $this->{report_todo}; |
1401
|
108
|
100
|
100
|
|
|
425
|
return 1==1 if $status ne 's' && $status ne 't'; |
1402
|
48
|
|
|
|
|
114
|
return 0==1; |
1403
|
|
|
|
|
|
|
} |
1404
|
|
|
|
|
|
|
|
1405
|
|
|
|
|
|
|
sub _report_errmsg_list { |
1406
|
73
|
|
|
73
|
|
89
|
my ($this, @exc_items) = @_; |
1407
|
73
|
|
|
|
|
106
|
for (@exc_items) { |
1408
|
57
|
|
|
|
|
82
|
my ($so, $depth, $status, $errmsg) = @$_; |
1409
|
57
|
|
|
|
|
118
|
$this->_print_separator(); |
1410
|
57
|
|
|
|
|
210
|
$this->_report_errmsg($so, $status, $errmsg); |
1411
|
|
|
|
|
|
|
} |
1412
|
73
|
100
|
|
|
|
169
|
$this->_print_separator() if @exc_items; |
1413
|
|
|
|
|
|
|
} |
1414
|
|
|
|
|
|
|
|
1415
|
|
|
|
|
|
|
sub _print_separator { |
1416
|
103
|
|
|
103
|
|
108
|
my ($this) = @_; |
1417
|
103
|
|
|
|
|
191
|
print '# ', $this->{separator}, "\n"; |
1418
|
|
|
|
|
|
|
} |
1419
|
|
|
|
|
|
|
|
1420
|
|
|
|
|
|
|
sub _report_errmsg { |
1421
|
67
|
|
|
67
|
|
90
|
my ($this, $so, $status, $errmsg) = @_; |
1422
|
67
|
100
|
|
|
|
165
|
if ($status eq 'f') { $errmsg =~ s/^\[Failed\]/Assertion:/ } |
|
28
|
100
|
|
|
|
103
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1423
|
|
|
|
|
|
|
elsif ($status eq 'E') { } |
1424
|
6
|
|
|
|
|
21
|
elsif ($status eq 's') { $errmsg =~ s/^\[Skipped\]/Reason:/ } |
1425
|
6
|
|
|
|
|
21
|
elsif ($status eq 't') { $errmsg =~ s/^\[TODO\]/Description:/ } |
1426
|
|
|
|
|
|
|
else { } |
1427
|
67
|
|
|
|
|
193
|
print '# [', $STATUS_LABELS{$status}, '] * ', $this->_breadcrumb($so), "\n"; |
1428
|
67
|
|
|
|
|
100
|
$_ = $errmsg; |
1429
|
67
|
|
|
|
|
305
|
s/^/# /mg; |
1430
|
67
|
|
|
|
|
176
|
s/\n$//; |
1431
|
67
|
|
|
|
|
124
|
print $_, "\n"; |
1432
|
|
|
|
|
|
|
} |
1433
|
|
|
|
|
|
|
|
1434
|
|
|
|
|
|
|
sub _breadcrumb { |
1435
|
67
|
|
|
67
|
|
80
|
my ($this, $so) = @_; |
1436
|
67
|
|
|
|
|
137
|
my @arr = $this->_path_elems($so); |
1437
|
67
|
|
|
|
|
209
|
return join(' > ', @arr); |
1438
|
|
|
|
|
|
|
} |
1439
|
|
|
|
|
|
|
|
1440
|
|
|
|
|
|
|
sub _path_elems { |
1441
|
67
|
|
|
67
|
|
69
|
my ($this, $so) = @_; |
1442
|
67
|
|
|
|
|
66
|
my @arr; |
1443
|
67
|
|
|
|
|
81
|
my $x = $so->{desc}; |
1444
|
67
|
|
|
|
|
90
|
push(@arr, $so->{desc}); |
1445
|
67
|
|
|
|
|
71
|
my $to = $so->{parent}; |
1446
|
67
|
|
|
|
|
119
|
while ($to) { |
1447
|
129
|
|
|
|
|
141
|
push(@arr, $to->{name}); |
1448
|
129
|
|
|
|
|
271
|
$to = $to->{parent}; |
1449
|
|
|
|
|
|
|
} |
1450
|
67
|
|
|
|
|
190
|
return reverse(@arr); |
1451
|
|
|
|
|
|
|
} |
1452
|
|
|
|
|
|
|
|
1453
|
|
|
|
|
|
|
sub _itemize { |
1454
|
127
|
|
|
127
|
|
144
|
my ($this, $to) = @_; |
1455
|
127
|
100
|
|
|
|
737
|
return $to->isa('Oktest::CaseObject') ? '- ' : '* '; |
1456
|
|
|
|
|
|
|
} |
1457
|
|
|
|
|
|
|
|
1458
|
|
|
|
|
|
|
|
1459
|
|
|
|
|
|
|
package Oktest::Reporter::TapReporter; |
1460
|
|
|
|
|
|
|
our @ISA = ('Oktest::Reporter::Base'); |
1461
|
|
|
|
|
|
|
|
1462
|
|
|
|
|
|
|
sub enter_all { |
1463
|
27
|
|
|
27
|
|
43
|
my ($this, @topics) = @_; |
1464
|
27
|
|
|
|
|
92
|
$this->SUPER::enter_all(@topics); |
1465
|
27
|
|
|
|
|
33
|
my $n = 0; |
1466
|
27
|
|
|
|
|
47
|
for my $to (@topics) { |
1467
|
54
|
|
|
|
|
97
|
$n += $to->_count_specs(); |
1468
|
|
|
|
|
|
|
} |
1469
|
27
|
|
|
|
|
163
|
print "1..$n\n"; |
1470
|
|
|
|
|
|
|
} |
1471
|
|
|
|
|
|
|
|
1472
|
|
|
|
|
|
|
sub enter_topic { |
1473
|
65
|
|
|
65
|
|
74
|
my ($this, $to, $depth) = @_; |
1474
|
65
|
|
|
|
|
128
|
print '## ', $this->_indent($depth), $this->_itemize($to), $to->{name}, "\n"; |
1475
|
|
|
|
|
|
|
}; |
1476
|
|
|
|
|
|
|
|
1477
|
|
|
|
|
|
|
sub exit_spec { |
1478
|
60
|
|
|
60
|
|
95
|
my ($this, $so, $depth, $status, $errmsg) = @_; |
1479
|
60
|
|
|
|
|
131
|
$this->SUPER::exit_spec($so, $depth, $status, $errmsg); |
1480
|
60
|
|
|
|
|
73
|
my $n = $this->{count}; |
1481
|
60
|
100
|
|
|
|
138
|
if (! $errmsg) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
1482
|
48
|
|
|
|
|
98
|
print 'ok ', $n, ' - ', $so->{desc}, "\n"; |
1483
|
|
|
|
|
|
|
} |
1484
|
|
|
|
|
|
|
elsif ($status eq 's') { |
1485
|
1
|
|
|
|
|
3
|
my $reason = $errmsg; |
1486
|
1
|
|
|
|
|
5
|
$reason =~ s/^\[Skipped\] ?//; |
1487
|
1
|
|
|
|
|
3
|
chomp($reason); |
1488
|
1
|
|
|
|
|
4
|
print 'ok ', $n, ' - ', $so->{desc}, ' # skip - ', $reason, "\n"; |
1489
|
|
|
|
|
|
|
} |
1490
|
|
|
|
|
|
|
elsif ($status eq 't') { |
1491
|
1
|
|
|
|
|
2
|
my $desc = $errmsg; |
1492
|
1
|
|
|
|
|
4
|
$desc =~ s/^\[TODO\] ?//; |
1493
|
1
|
|
|
|
|
2
|
chomp($desc); |
1494
|
1
|
|
|
|
|
3
|
print 'not ok ', $n, ' - ', $so->{desc}, ' # TODO - ', $desc, "\n"; |
1495
|
|
|
|
|
|
|
} |
1496
|
|
|
|
|
|
|
else { |
1497
|
10
|
|
|
|
|
26
|
print 'not ok ', $n, ' - ', $so->{desc}, "\n"; |
1498
|
10
|
|
|
|
|
32
|
$this->_print_separator(); |
1499
|
10
|
|
|
|
|
28
|
$this->_report_errmsg($so, $status, $errmsg); |
1500
|
10
|
|
|
|
|
20
|
$this->_print_separator(); |
1501
|
|
|
|
|
|
|
} |
1502
|
|
|
|
|
|
|
} |
1503
|
|
|
|
|
|
|
|
1504
|
|
|
|
|
|
|
|
1505
|
|
|
|
|
|
|
|
1506
|
|
|
|
|
|
|
package Oktest::Reporter::VerboseReporter; |
1507
|
|
|
|
|
|
|
our @ISA = ('Oktest::Reporter::Base'); |
1508
|
|
|
|
|
|
|
|
1509
|
|
|
|
|
|
|
sub enter_all { |
1510
|
11
|
|
|
11
|
|
17
|
my ($this, @topics) = @_; |
1511
|
11
|
|
|
|
|
31
|
$this->SUPER::enter_all(@topics); |
1512
|
11
|
|
|
|
|
92
|
$this->{exc_stack} = []; |
1513
|
|
|
|
|
|
|
} |
1514
|
|
|
|
|
|
|
|
1515
|
|
|
|
|
|
|
sub enter_topic { |
1516
|
32
|
|
|
32
|
|
35
|
my ($this, $to, $depth) = @_; |
1517
|
32
|
|
|
|
|
69
|
$this->SUPER::enter_topic($to, $depth); |
1518
|
32
|
|
|
|
|
31
|
push(@{$this->{exc_stack}}, []); |
|
32
|
|
|
|
|
60
|
|
1519
|
32
|
|
|
|
|
67
|
print $this->_indent($depth), $this->_itemize($to), $to->{name}, "\n"; |
1520
|
|
|
|
|
|
|
}; |
1521
|
|
|
|
|
|
|
|
1522
|
|
|
|
|
|
|
sub exit_topic { |
1523
|
32
|
|
|
32
|
|
39
|
my ($this, $to, $depth) = @_; |
1524
|
32
|
|
|
|
|
78
|
$this->SUPER::exit_topic($to, $depth); |
1525
|
32
|
|
|
|
|
29
|
my $exc_items = pop(@{$this->{exc_stack}}); |
|
32
|
|
|
|
|
46
|
|
1526
|
32
|
|
|
|
|
70
|
$this->_report_errmsg_list(@$exc_items); |
1527
|
32
|
|
|
|
|
98
|
undef @$exc_items; |
1528
|
|
|
|
|
|
|
}; |
1529
|
|
|
|
|
|
|
|
1530
|
|
|
|
|
|
|
sub exit_spec { |
1531
|
53
|
|
|
53
|
|
79
|
my ($this, $so, $depth, $status, $errmsg) = @_; |
1532
|
53
|
|
|
|
|
105
|
$this->SUPER::exit_spec($so, $depth, $status, $errmsg); |
1533
|
53
|
|
|
|
|
74
|
my $label = $Oktest::Reporter::Base::STATUS_LABELS{$status}; |
1534
|
53
|
|
|
|
|
83
|
print $this->_indent($depth), "- [", $label, "] ", $so->{desc}; |
1535
|
53
|
100
|
|
|
|
111
|
if ($errmsg) { |
1536
|
31
|
100
|
100
|
|
|
118
|
if ($status eq 's' || $status eq 't') { |
1537
|
16
|
|
|
|
|
24
|
$_ = $errmsg; |
1538
|
16
|
|
|
|
|
68
|
s/^\[(Skipped|TODO)\] ?//; |
1539
|
16
|
|
|
|
|
26
|
chomp(); |
1540
|
16
|
|
|
|
|
28
|
print ' ## ', $_; |
1541
|
|
|
|
|
|
|
} |
1542
|
31
|
100
|
|
|
|
68
|
if ($this->_error_should_be_reported($status)) { |
1543
|
19
|
|
|
|
|
18
|
my $arr = Oktest::Util::last_item(@{$this->{exc_stack}}); |
|
19
|
|
|
|
|
42
|
|
1544
|
19
|
|
|
|
|
50
|
push(@$arr, [$so, $depth, $status, $errmsg]); |
1545
|
|
|
|
|
|
|
} |
1546
|
|
|
|
|
|
|
} |
1547
|
53
|
|
|
|
|
100
|
print "\n"; |
1548
|
|
|
|
|
|
|
} |
1549
|
|
|
|
|
|
|
|
1550
|
|
|
|
|
|
|
|
1551
|
|
|
|
|
|
|
|
1552
|
|
|
|
|
|
|
package Oktest::Reporter::SimpleReporter; |
1553
|
|
|
|
|
|
|
our @ISA = ('Oktest::Reporter::Base'); |
1554
|
|
|
|
|
|
|
|
1555
|
|
|
|
|
|
|
sub enter_all { |
1556
|
11
|
|
|
11
|
|
24
|
my ($this, @topics) = @_; |
1557
|
11
|
|
|
|
|
34
|
$this->SUPER::enter_all(@topics); |
1558
|
11
|
|
|
|
|
21
|
$this->{exc_stack} = []; |
1559
|
11
|
|
|
|
|
42
|
$this->{_nl} = 1==1; |
1560
|
|
|
|
|
|
|
} |
1561
|
|
|
|
|
|
|
|
1562
|
|
|
|
|
|
|
sub enter_topic { |
1563
|
32
|
|
|
32
|
|
37
|
my ($this, $to, $depth) = @_; |
1564
|
32
|
100
|
|
|
|
138
|
return if $to->isa('Oktest::CaseObject'); |
1565
|
30
|
|
|
|
|
63
|
$this->SUPER::enter_topic($to, $depth); |
1566
|
30
|
|
|
|
|
25
|
push(@{$this->{exc_stack}}, []); |
|
30
|
|
|
|
|
57
|
|
1567
|
30
|
100
|
|
|
|
72
|
print "\n" unless $this->{_nl}; |
1568
|
30
|
|
|
|
|
59
|
print $this->_indent($depth), $this->_itemize($to), $to->{name}; |
1569
|
30
|
100
|
|
|
|
43
|
print ": " if @{$to->{specs}}; |
|
30
|
|
|
|
|
86
|
|
1570
|
30
|
|
|
|
|
57
|
$this->{_nl} = 0==1; |
1571
|
|
|
|
|
|
|
}; |
1572
|
|
|
|
|
|
|
|
1573
|
|
|
|
|
|
|
sub exit_topic { |
1574
|
32
|
|
|
32
|
|
40
|
my ($this, $to, $depth) = @_; |
1575
|
32
|
100
|
|
|
|
143
|
return if $to->isa('Oktest::CaseObject'); |
1576
|
30
|
|
|
|
|
72
|
$this->SUPER::exit_topic($to, $depth); |
1577
|
30
|
|
|
|
|
25
|
my $exc_items = pop(@{$this->{exc_stack}}); |
|
30
|
|
|
|
|
44
|
|
1578
|
30
|
100
|
|
|
|
77
|
print "\n" unless $this->{_nl}; |
1579
|
30
|
|
|
|
|
46
|
$this->{_nl} = 1==1; |
1580
|
30
|
|
|
|
|
58
|
$this->_report_errmsg_list(@$exc_items); |
1581
|
30
|
|
|
|
|
87
|
undef @$exc_items; |
1582
|
|
|
|
|
|
|
}; |
1583
|
|
|
|
|
|
|
|
1584
|
|
|
|
|
|
|
sub exit_spec { |
1585
|
53
|
|
|
53
|
|
78
|
my ($this, $so, $depth, $status, $errmsg) = @_; |
1586
|
53
|
|
|
|
|
112
|
$this->SUPER::exit_spec($so, $depth, $status, $errmsg); |
1587
|
53
|
|
|
|
|
91
|
print $status; |
1588
|
53
|
100
|
|
|
|
116
|
if ($errmsg) { |
1589
|
31
|
100
|
|
|
|
66
|
if ($this->_error_should_be_reported($status)) { |
1590
|
|
|
|
|
|
|
#my @stack = @{$this->{exc_stack}}; |
1591
|
|
|
|
|
|
|
#my $arr = $stack[$#stack]; |
1592
|
19
|
|
|
|
|
21
|
my $arr = Oktest::Util::last_item(@{$this->{exc_stack}}); |
|
19
|
|
|
|
|
44
|
|
1593
|
19
|
|
|
|
|
59
|
push(@$arr, [$so, $depth, $status, $errmsg]); |
1594
|
|
|
|
|
|
|
} |
1595
|
|
|
|
|
|
|
} |
1596
|
|
|
|
|
|
|
} |
1597
|
|
|
|
|
|
|
|
1598
|
|
|
|
|
|
|
|
1599
|
|
|
|
|
|
|
|
1600
|
|
|
|
|
|
|
package Oktest::Reporter::PlainReporter; |
1601
|
|
|
|
|
|
|
our @ISA = ('Oktest::Reporter::Base'); |
1602
|
|
|
|
|
|
|
|
1603
|
|
|
|
|
|
|
sub enter_all { |
1604
|
11
|
|
|
11
|
|
26
|
my ($this, @topics) = @_; |
1605
|
11
|
|
|
|
|
35
|
$this->SUPER::enter_all(@topics); |
1606
|
11
|
|
|
|
|
26
|
$this->{exc_items} = []; |
1607
|
|
|
|
|
|
|
} |
1608
|
|
|
|
|
|
|
|
1609
|
|
|
|
|
|
|
sub exit_all { |
1610
|
11
|
|
|
11
|
|
17
|
my ($this, @topics) = @_; |
1611
|
11
|
|
|
|
|
17
|
print "\n"; |
1612
|
11
|
|
|
|
|
15
|
$this->_report_errmsg_list(@{$this->{exc_items}}); |
|
11
|
|
|
|
|
38
|
|
1613
|
11
|
|
|
|
|
32
|
$this->SUPER::exit_all(@topics); |
1614
|
|
|
|
|
|
|
} |
1615
|
|
|
|
|
|
|
|
1616
|
|
|
|
|
|
|
sub exit_spec { |
1617
|
53
|
|
|
53
|
|
76
|
my ($this, $so, $depth, $status, $errmsg) = @_; |
1618
|
53
|
|
|
|
|
110
|
$this->SUPER::exit_spec($so, $depth, $status, $errmsg); |
1619
|
53
|
|
|
|
|
93
|
print $status; |
1620
|
53
|
100
|
|
|
|
117
|
if ($errmsg) { |
1621
|
31
|
|
|
|
|
61
|
my $v = $this->_error_should_be_reported($status); |
1622
|
31
|
100
|
|
|
|
59
|
if ($this->_error_should_be_reported($status)) { |
1623
|
19
|
|
|
|
|
19
|
push(@{$this->{exc_items}}, [$so, $depth, $status, $errmsg]); |
|
19
|
|
|
|
|
64
|
|
1624
|
|
|
|
|
|
|
} |
1625
|
|
|
|
|
|
|
} |
1626
|
|
|
|
|
|
|
} |
1627
|
|
|
|
|
|
|
|
1628
|
|
|
|
|
|
|
|
1629
|
|
|
|
|
|
|
|
1630
|
|
|
|
|
|
|
package Oktest::Util; |
1631
|
7
|
|
|
7
|
|
18701
|
use base 'Exporter'; |
|
7
|
|
|
|
|
15
|
|
|
7
|
|
|
|
|
8583
|
|
1632
|
|
|
|
|
|
|
our @EXPORT_OK = qw(strip last_item length |
1633
|
|
|
|
|
|
|
is_string is_number is_integer is_float |
1634
|
|
|
|
|
|
|
read_file write_file read_line_from rm_rf system3 |
1635
|
|
|
|
|
|
|
capture capture_stdouterr capture_stdout capture_stderr); |
1636
|
|
|
|
|
|
|
|
1637
|
|
|
|
|
|
|
sub strip { |
1638
|
196
|
|
|
196
|
0
|
235
|
my ($s) = @_; |
1639
|
196
|
|
|
|
|
660
|
$s =~ s/^\s+//; |
1640
|
196
|
|
|
|
|
824
|
$s =~ s/\s+$//; |
1641
|
196
|
|
|
|
|
998
|
return $s; |
1642
|
|
|
|
|
|
|
} |
1643
|
|
|
|
|
|
|
|
1644
|
|
|
|
|
|
|
sub last_item { |
1645
|
39
|
|
|
39
|
0
|
829
|
my (@arr) = @_; |
1646
|
39
|
50
|
|
|
|
107
|
return $arr[$#arr] if @arr; |
1647
|
0
|
|
|
|
|
0
|
return; |
1648
|
|
|
|
|
|
|
} |
1649
|
|
|
|
|
|
|
|
1650
|
|
|
|
|
|
|
sub length { |
1651
|
1
|
|
|
1
|
0
|
470
|
my (@arr) = @_; |
1652
|
1
|
|
|
|
|
4
|
return $#arr + 1; |
1653
|
|
|
|
|
|
|
} |
1654
|
|
|
|
|
|
|
|
1655
|
|
|
|
|
|
|
sub index(&@) { |
1656
|
2
|
|
|
2
|
0
|
832
|
my ($block, @arr) = @_; |
1657
|
2
|
|
|
|
|
3
|
my $i = 0; |
1658
|
2
|
|
|
|
|
4
|
for (@arr) { |
1659
|
9
|
100
|
|
|
|
17
|
return $i if $block->($_); |
1660
|
8
|
|
|
|
|
31
|
$i++; |
1661
|
|
|
|
|
|
|
} |
1662
|
1
|
|
|
|
|
2
|
return -1; |
1663
|
|
|
|
|
|
|
} |
1664
|
|
|
|
|
|
|
|
1665
|
|
|
|
|
|
|
sub index_denied(&@) { |
1666
|
2
|
|
|
2
|
0
|
862
|
my ($block, @arr) = @_; |
1667
|
2
|
|
|
|
|
5
|
my $i = 0; |
1668
|
2
|
|
|
|
|
3
|
for (@arr) { |
1669
|
9
|
100
|
|
|
|
15
|
return $i unless $block->($_); |
1670
|
8
|
|
|
|
|
30
|
$i++; |
1671
|
|
|
|
|
|
|
} |
1672
|
1
|
|
|
|
|
3
|
return -1; |
1673
|
|
|
|
|
|
|
} |
1674
|
|
|
|
|
|
|
|
1675
|
|
|
|
|
|
|
sub is_string { |
1676
|
181
|
|
|
181
|
0
|
692
|
my ($arg) = @_; |
1677
|
181
|
100
|
|
|
|
381
|
return 0 if ref($arg); # not scalar |
1678
|
177
|
100
|
|
|
|
325
|
return 0 unless defined($arg); # undef |
1679
|
174
|
100
|
|
|
|
623
|
return 0 if ($arg ^ $arg) eq '0'; # number |
1680
|
5
|
|
|
|
|
21
|
return 1; # string |
1681
|
|
|
|
|
|
|
} |
1682
|
|
|
|
|
|
|
|
1683
|
|
|
|
|
|
|
sub is_number { |
1684
|
40
|
|
|
40
|
0
|
460
|
my ($arg) = @_; |
1685
|
40
|
100
|
|
|
|
120
|
return 0 if ref($arg); # not scalar |
1686
|
31
|
100
|
|
|
|
80
|
return 0 unless defined($arg); # undef |
1687
|
25
|
100
|
|
|
|
175
|
return 1 if ($arg ^ $arg) eq '0'; # number |
1688
|
9
|
|
|
|
|
45
|
return 0; # string |
1689
|
|
|
|
|
|
|
} |
1690
|
|
|
|
|
|
|
|
1691
|
|
|
|
|
|
|
sub is_integer { |
1692
|
13
|
|
|
13
|
0
|
416
|
my ($arg) = @_; |
1693
|
13
|
100
|
100
|
|
|
27
|
return is_number($arg) && $arg =~ /^-?\d+$/ ? 1 : 0; |
1694
|
|
|
|
|
|
|
} |
1695
|
|
|
|
|
|
|
|
1696
|
|
|
|
|
|
|
sub is_float { |
1697
|
13
|
|
|
13
|
0
|
416
|
my ($arg) = @_; |
1698
|
13
|
100
|
100
|
|
|
21
|
return is_number($arg) && $arg =~ /^-?\d+\.\d+$/ ? 1 : 0; |
1699
|
|
|
|
|
|
|
} |
1700
|
|
|
|
|
|
|
|
1701
|
|
|
|
|
|
|
sub read_file { |
1702
|
2
|
|
|
2
|
0
|
807
|
my ($filename) = @_; |
1703
|
2
|
50
|
|
|
|
179
|
open(my $fh, '<', $filename) |
1704
|
|
|
|
|
|
|
or die "$filename: $!"; |
1705
|
2
|
|
|
|
|
9
|
local $/ = undef; |
1706
|
2
|
|
|
|
|
81
|
my $content = <$fh>; |
1707
|
2
|
50
|
|
|
|
48
|
close($fh) |
1708
|
|
|
|
|
|
|
or die "$filename: $!"; |
1709
|
2
|
|
|
|
|
13
|
return $content; |
1710
|
|
|
|
|
|
|
} |
1711
|
|
|
|
|
|
|
|
1712
|
|
|
|
|
|
|
sub write_file { |
1713
|
32
|
|
|
32
|
0
|
4658
|
my ($filename, $content) = @_; |
1714
|
32
|
50
|
|
|
|
2155
|
open(my $fh, '>', $filename) |
1715
|
|
|
|
|
|
|
or die "$filename: $!"; |
1716
|
32
|
|
|
|
|
307
|
print $fh $content; |
1717
|
32
|
50
|
|
|
|
1441
|
close($fh) |
1718
|
|
|
|
|
|
|
or die "$filename: $!"; |
1719
|
|
|
|
|
|
|
} |
1720
|
|
|
|
|
|
|
|
1721
|
|
|
|
|
|
|
our $__read_filename = ''; |
1722
|
|
|
|
|
|
|
our @__read_lines = (); |
1723
|
|
|
|
|
|
|
|
1724
|
|
|
|
|
|
|
sub read_line_from { |
1725
|
196
|
|
|
196
|
0
|
811
|
my ($filename, $linenum) = @_; |
1726
|
196
|
100
|
|
|
|
456
|
if ($filename ne $__read_filename) { |
1727
|
6
|
50
|
|
|
|
270
|
open(my $fh, '<', $filename) |
1728
|
|
|
|
|
|
|
or die "$filename: $!"; |
1729
|
6
|
|
|
|
|
2724
|
@__read_lines = <$fh>; |
1730
|
6
|
50
|
|
|
|
217
|
close($fh) |
1731
|
|
|
|
|
|
|
or die "$filename: $!"; |
1732
|
6
|
|
|
|
|
24
|
$__read_filename = $filename; |
1733
|
|
|
|
|
|
|
} |
1734
|
196
|
|
|
|
|
508
|
return $__read_lines[$linenum-1]; |
1735
|
|
|
|
|
|
|
} |
1736
|
|
|
|
|
|
|
|
1737
|
|
|
|
|
|
|
sub rm_rf { |
1738
|
1
|
|
|
1
|
0
|
1018
|
my (@patterns) = @_; |
1739
|
1
|
|
|
|
|
3
|
for my $pattern (@patterns) { |
1740
|
1
|
|
|
|
|
200
|
for my $path (glob($pattern)) { |
1741
|
2
|
50
|
|
|
|
25
|
_rm_rf($path) if -e $path; |
1742
|
|
|
|
|
|
|
} |
1743
|
|
|
|
|
|
|
} |
1744
|
|
|
|
|
|
|
} |
1745
|
|
|
|
|
|
|
|
1746
|
|
|
|
|
|
|
sub _rm_rf { |
1747
|
5
|
|
|
5
|
|
7
|
my ($path) = @_; |
1748
|
5
|
100
|
|
|
|
64
|
if (-f $path) { |
|
|
50
|
|
|
|
|
|
1749
|
3
|
|
|
|
|
148
|
unlink($path); |
1750
|
|
|
|
|
|
|
} |
1751
|
|
|
|
|
|
|
elsif (-d $path) { |
1752
|
2
|
|
|
|
|
31
|
opendir(my $dh, $path); |
1753
|
2
|
|
|
|
|
53
|
my @children = readdir($dh); |
1754
|
2
|
|
|
|
|
20
|
closedir($dh); |
1755
|
2
|
|
|
|
|
5
|
for (@children) { |
1756
|
7
|
100
|
100
|
|
|
38
|
_rm_rf("$path/$_") unless $_ eq '.' || $_ eq '..'; |
1757
|
|
|
|
|
|
|
} |
1758
|
2
|
|
|
|
|
156
|
rmdir($path); |
1759
|
|
|
|
|
|
|
} |
1760
|
|
|
|
|
|
|
} |
1761
|
|
|
|
|
|
|
|
1762
|
|
|
|
|
|
|
sub system3 { |
1763
|
7
|
|
|
7
|
|
6750
|
use IPC::Open3; |
|
7
|
|
|
|
|
31216
|
|
|
7
|
|
|
|
|
405
|
|
1764
|
7
|
|
|
7
|
|
54
|
use Symbol; |
|
7
|
|
|
|
|
15
|
|
|
7
|
|
|
|
|
3949
|
|
1765
|
3
|
|
|
3
|
0
|
4887
|
my ($command, $input) = @_; |
1766
|
3
|
|
|
|
|
26
|
my ($IN, $OUT, $ERR) = (gensym, gensym, gensym); |
1767
|
3
|
|
|
|
|
135
|
open3($IN, $OUT, $ERR, $command); |
1768
|
3
|
100
|
|
|
|
26954
|
print $IN $input if $input; |
1769
|
3
|
|
|
|
|
46
|
close $IN; |
1770
|
3
|
|
|
|
|
3279
|
my @output = <$OUT>; |
1771
|
3
|
|
|
|
|
105
|
my @error = <$ERR>; |
1772
|
3
|
|
|
|
|
83
|
close $OUT; |
1773
|
3
|
|
|
|
|
36
|
close $ERR; |
1774
|
3
|
|
|
|
|
174
|
return join("", @output), join("", @error); |
1775
|
|
|
|
|
|
|
} |
1776
|
|
|
|
|
|
|
|
1777
|
|
|
|
|
|
|
sub capture(&) { |
1778
|
1
|
|
|
1
|
0
|
2286
|
my ($block) = @_; |
1779
|
1
|
|
|
|
|
53
|
my $sout = tie(local *STDOUT, 'Oktest::Util::__PrintHandler'); |
1780
|
1
|
|
|
|
|
10
|
local *STDERR = *STDOUT; |
1781
|
1
|
|
|
|
|
14
|
$block->(); |
1782
|
1
|
|
|
|
|
6
|
return $sout->output; |
1783
|
|
|
|
|
|
|
} |
1784
|
|
|
|
|
|
|
|
1785
|
|
|
|
|
|
|
sub capture_stdouterr(&) { |
1786
|
7
|
|
|
7
|
0
|
4379
|
my ($block) = @_; |
1787
|
7
|
|
|
|
|
56
|
my $sout = tie(local *STDOUT, 'Oktest::Util::__PrintHandler'); |
1788
|
7
|
|
|
|
|
38
|
my $serr = tie(local *STDERR, 'Oktest::Util::__PrintHandler'); |
1789
|
7
|
|
|
|
|
30
|
$block->(); |
1790
|
7
|
|
|
|
|
38
|
return ($sout->output, $serr->output); |
1791
|
|
|
|
|
|
|
} |
1792
|
|
|
|
|
|
|
|
1793
|
|
|
|
|
|
|
sub capture_stdout(&) { |
1794
|
64
|
|
|
64
|
0
|
1740
|
my ($block) = @_; |
1795
|
64
|
|
|
|
|
404
|
my $sout = tie(local *STDOUT, 'Oktest::Util::__PrintHandler'); |
1796
|
64
|
|
|
|
|
209
|
$block->(); |
1797
|
64
|
|
|
|
|
375
|
return $sout->output; |
1798
|
|
|
|
|
|
|
} |
1799
|
|
|
|
|
|
|
|
1800
|
|
|
|
|
|
|
sub capture_stderr(&) { |
1801
|
4
|
|
|
4
|
0
|
16
|
my ($block) = @_; |
1802
|
4
|
|
|
|
|
37
|
my $serr = tie(local *STDERR, 'Oktest::Util::__PrintHandler'); |
1803
|
4
|
|
|
|
|
14
|
$block->(); |
1804
|
4
|
|
|
|
|
18
|
return $serr->output; |
1805
|
|
|
|
|
|
|
} |
1806
|
|
|
|
|
|
|
|
1807
|
|
|
|
|
|
|
$INC{'Oktest/Util.pm'} = __FILE__; |
1808
|
|
|
|
|
|
|
|
1809
|
|
|
|
|
|
|
|
1810
|
|
|
|
|
|
|
|
1811
|
|
|
|
|
|
|
package Oktest::Util::__PrintHandler; |
1812
|
|
|
|
|
|
|
|
1813
|
|
|
|
|
|
|
sub TIEHANDLE { |
1814
|
83
|
|
|
83
|
|
153
|
my ($class) = @_; |
1815
|
83
|
|
|
|
|
223
|
my $this = { output => "" }; |
1816
|
83
|
|
|
|
|
292
|
return bless($this, $class); |
1817
|
|
|
|
|
|
|
} |
1818
|
|
|
|
|
|
|
|
1819
|
|
|
|
|
|
|
sub PRINT { |
1820
|
850
|
|
|
850
|
|
1639
|
my ($this, @args) = @_; |
1821
|
850
|
|
|
|
|
1098
|
for my $arg (@args) { |
1822
|
2281
|
|
|
|
|
4592
|
$this->{output} .= $arg; |
1823
|
|
|
|
|
|
|
} |
1824
|
|
|
|
|
|
|
} |
1825
|
|
|
|
|
|
|
|
1826
|
|
|
|
|
|
|
sub output { |
1827
|
83
|
|
|
83
|
|
123
|
my ($this) = @_; |
1828
|
83
|
|
|
|
|
432
|
return $this->{output}; |
1829
|
|
|
|
|
|
|
} |
1830
|
|
|
|
|
|
|
|
1831
|
|
|
|
|
|
|
|
1832
|
|
|
|
|
|
|
|
1833
|
|
|
|
|
|
|
package Oktest::Migration::TestMore; ## !! EXPERIMENTAL !! |
1834
|
7
|
|
|
7
|
|
39
|
use base 'Exporter'; |
|
7
|
|
|
|
|
16
|
|
|
7
|
|
|
|
|
736
|
|
1835
|
|
|
|
|
|
|
our @EXPORT = qw(ok is isnt like unlike cmp_ok is_deeply can_ok isa_ok pass fail |
1836
|
|
|
|
|
|
|
throws_ok dies_ok lives_ok lives_and warning_like diag note explain); |
1837
|
|
|
|
|
|
|
#use Oktest; |
1838
|
7
|
|
|
7
|
|
34
|
no warnings 'void'; |
|
7
|
|
|
|
|
13
|
|
|
7
|
|
|
|
|
9132
|
|
1839
|
|
|
|
|
|
|
|
1840
|
|
|
|
|
|
|
sub ok { |
1841
|
2
|
|
|
2
|
0
|
34
|
my ($condition, $test_name) = @_; |
1842
|
2
|
|
|
|
|
6
|
Oktest::OK ($condition)->is_truthy(); |
1843
|
1
|
|
|
|
|
14
|
return 1==1; |
1844
|
|
|
|
|
|
|
} |
1845
|
|
|
|
|
|
|
|
1846
|
|
|
|
|
|
|
sub is { |
1847
|
2
|
|
|
2
|
0
|
44
|
my ($this, $that, $test_name) = @_; |
1848
|
2
|
|
|
|
|
4
|
Oktest::OK ($this) eq $that; |
1849
|
1
|
|
|
|
|
4
|
return 1==1; |
1850
|
|
|
|
|
|
|
} |
1851
|
|
|
|
|
|
|
|
1852
|
|
|
|
|
|
|
sub isnt { |
1853
|
2
|
|
|
2
|
0
|
39
|
my ($this, $that, $test_name) = @_; |
1854
|
2
|
|
|
|
|
4
|
Oktest::OK ($this) ne $that; |
1855
|
1
|
|
|
|
|
7
|
return 1==1; |
1856
|
|
|
|
|
|
|
} |
1857
|
|
|
|
|
|
|
|
1858
|
|
|
|
|
|
|
sub like { |
1859
|
2
|
|
|
2
|
0
|
42
|
my ($this, $regexp, $test_name) = @_; |
1860
|
2
|
|
|
|
|
5
|
Oktest::OK ($this)->matches($regexp); |
1861
|
1
|
|
|
|
|
4
|
return 1==1; |
1862
|
|
|
|
|
|
|
} |
1863
|
|
|
|
|
|
|
|
1864
|
|
|
|
|
|
|
sub unlike { |
1865
|
2
|
|
|
2
|
0
|
615
|
my ($this, $regexp, $test_name) = @_; |
1866
|
2
|
|
|
|
|
5
|
Oktest::OK ($this)->not_match($regexp); |
1867
|
1
|
|
|
|
|
4
|
return 1==1; |
1868
|
|
|
|
|
|
|
} |
1869
|
|
|
|
|
|
|
|
1870
|
|
|
|
|
|
|
sub cmp_ok { |
1871
|
15
|
|
|
15
|
0
|
514
|
my ($this, $op, $that, $test_name) = @_; |
1872
|
15
|
100
|
|
|
|
150
|
if ($op eq '==') { Oktest::OK ($this) == $that } |
|
2
|
100
|
|
|
|
4
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1873
|
1
|
|
|
|
|
2
|
elsif ($op eq '!=') { Oktest::OK ($this) != $that } |
1874
|
1
|
|
|
|
|
2
|
elsif ($op eq '>' ) { Oktest::OK ($this) > $that } |
1875
|
1
|
|
|
|
|
3
|
elsif ($op eq '>=') { Oktest::OK ($this) >= $that } |
1876
|
1
|
|
|
|
|
2
|
elsif ($op eq '<' ) { Oktest::OK ($this) < $that } |
1877
|
1
|
|
|
|
|
2
|
elsif ($op eq '<=') { Oktest::OK ($this) <= $that } |
1878
|
1
|
|
|
|
|
3
|
elsif ($op eq 'eq') { Oktest::OK ($this) eq $that } |
1879
|
1
|
|
|
|
|
1
|
elsif ($op eq 'ne') { Oktest::OK ($this) ne $that } |
1880
|
1
|
|
|
|
|
2
|
elsif ($op eq 'gt') { Oktest::OK ($this) gt $that } |
1881
|
1
|
|
|
|
|
3
|
elsif ($op eq 'ge') { Oktest::OK ($this) ge $that } |
1882
|
1
|
|
|
|
|
2
|
elsif ($op eq 'lt') { Oktest::OK ($this) lt $that } |
1883
|
1
|
|
|
|
|
3
|
elsif ($op eq 'le') { Oktest::OK ($this) le $that } |
1884
|
1
|
|
|
|
|
4
|
elsif ($op eq '=~') { Oktest::OK ($this)->matches($that) } |
1885
|
1
|
|
|
|
|
2
|
elsif ($op eq '!~') { Oktest::OK ($this)->not_match($that) } |
1886
|
0
|
|
|
|
|
0
|
else { die "Oktest::TestMoreMigration::cmp_ok(): operator '$op' not supported.\n" }; |
1887
|
14
|
|
|
|
|
62
|
return 1==1; |
1888
|
|
|
|
|
|
|
} |
1889
|
|
|
|
|
|
|
|
1890
|
|
|
|
|
|
|
sub is_deeply { |
1891
|
3
|
|
|
3
|
0
|
37
|
my ($complex_structure1, $complex_structure2, $test_name) = @_; |
1892
|
3
|
|
|
|
|
12
|
Oktest::OK ($complex_structure1)->equals($complex_structure2); |
1893
|
2
|
|
|
|
|
7
|
return 1==1; |
1894
|
|
|
|
|
|
|
} |
1895
|
|
|
|
|
|
|
|
1896
|
|
|
|
|
|
|
sub can_ok { |
1897
|
2
|
|
|
2
|
0
|
38
|
my ($module, @methods) = @_; |
1898
|
2
|
|
|
|
|
6
|
Oktest::OK ($module)->can_($_) for (@methods); |
1899
|
1
|
|
|
|
|
3
|
return 1==1; |
1900
|
|
|
|
|
|
|
} |
1901
|
|
|
|
|
|
|
|
1902
|
|
|
|
|
|
|
sub isa_ok { |
1903
|
2
|
|
|
2
|
0
|
33
|
my ($object, $class) = @_; |
1904
|
2
|
|
|
|
|
4
|
Oktest::OK ($object)->is_a($class); |
1905
|
1
|
|
|
|
|
4
|
return 1==1; |
1906
|
|
|
|
|
|
|
} |
1907
|
|
|
|
|
|
|
|
1908
|
|
|
|
|
|
|
sub pass { |
1909
|
3
|
|
|
3
|
0
|
21
|
my ($test_name) = @_; |
1910
|
3
|
|
|
|
|
10
|
return 1==1; |
1911
|
|
|
|
|
|
|
} |
1912
|
|
|
|
|
|
|
|
1913
|
|
|
|
|
|
|
sub fail { |
1914
|
1
|
|
|
1
|
0
|
12
|
my ($test_name) = @_; |
1915
|
1
|
|
|
|
|
3
|
my $msg = |
1916
|
|
|
|
|
|
|
"[Failed] $test_name\n"; |
1917
|
1
|
|
|
|
|
2
|
Oktest::OK()->_done()->_die($msg); |
1918
|
0
|
|
|
|
|
0
|
return; |
1919
|
|
|
|
|
|
|
} |
1920
|
|
|
|
|
|
|
|
1921
|
|
|
|
|
|
|
#sub eq_array { |
1922
|
|
|
|
|
|
|
# my ($this, $that) = @_; |
1923
|
|
|
|
|
|
|
# Oktest::OK ($this)->equals($that); |
1924
|
|
|
|
|
|
|
#} |
1925
|
|
|
|
|
|
|
# |
1926
|
|
|
|
|
|
|
#sub eq_hash { |
1927
|
|
|
|
|
|
|
# my ($this, $that) = @_; |
1928
|
|
|
|
|
|
|
# Oktest::OK ($this)->equals($that); |
1929
|
|
|
|
|
|
|
#} |
1930
|
|
|
|
|
|
|
# |
1931
|
|
|
|
|
|
|
#sub eq_set { |
1932
|
|
|
|
|
|
|
# my ($this, $that) = @_; |
1933
|
|
|
|
|
|
|
# Oktest::OK ($this)->equals($that); |
1934
|
|
|
|
|
|
|
#} |
1935
|
|
|
|
|
|
|
|
1936
|
|
|
|
|
|
|
sub throws_ok(&$;$) { |
1937
|
4
|
|
|
4
|
0
|
52
|
my ($coderef, $pattern, $description) = @_; |
1938
|
4
|
|
|
|
|
7
|
Oktest::OK ($coderef)->dies($pattern); |
1939
|
2
|
|
|
|
|
7
|
return 1==1; |
1940
|
|
|
|
|
|
|
} |
1941
|
|
|
|
|
|
|
|
1942
|
|
|
|
|
|
|
sub dies_ok(&;$) { |
1943
|
2
|
|
|
2
|
0
|
454
|
my ($coderef, $description) = @_; |
1944
|
2
|
|
|
|
|
4
|
Oktest::OK ($coderef)->dies(); |
1945
|
1
|
|
|
|
|
6
|
return 1==1; |
1946
|
|
|
|
|
|
|
} |
1947
|
|
|
|
|
|
|
|
1948
|
|
|
|
|
|
|
sub lives_ok(&;$) { |
1949
|
2
|
|
|
2
|
0
|
60
|
my ($coderef, $description) = @_; |
1950
|
2
|
|
|
|
|
4
|
Oktest::OK ($coderef)->not_die(); |
1951
|
1
|
|
|
|
|
4
|
return 1==1; |
1952
|
|
|
|
|
|
|
} |
1953
|
|
|
|
|
|
|
|
1954
|
|
|
|
|
|
|
sub lives_and(&;$) { |
1955
|
2
|
|
|
2
|
0
|
32
|
my ($test, $description) = @_; |
1956
|
2
|
|
|
|
|
4
|
Oktest::OK ($test)->not_die(); |
1957
|
1
|
|
|
|
|
4
|
return 1==1; |
1958
|
|
|
|
|
|
|
} |
1959
|
|
|
|
|
|
|
|
1960
|
|
|
|
|
|
|
sub warning_like(&$;$) { |
1961
|
4
|
|
|
4
|
0
|
468
|
my ($coderef, $pattern, $test_name) = @_; |
1962
|
4
|
|
|
|
|
6
|
Oktest::OK ($coderef)->warns($pattern); |
1963
|
2
|
|
|
|
|
6
|
return 1==1; |
1964
|
|
|
|
|
|
|
} |
1965
|
|
|
|
|
|
|
|
1966
|
|
|
|
|
|
|
sub diag { |
1967
|
1
|
|
|
1
|
0
|
5
|
my ($message) = @_; |
1968
|
1
|
|
|
|
|
6
|
print STDOUT "# $message\n"; |
1969
|
1
|
|
|
|
|
2
|
return 0==1; |
1970
|
|
|
|
|
|
|
} |
1971
|
|
|
|
|
|
|
|
1972
|
|
|
|
|
|
|
sub note { ## TODO: check original spec |
1973
|
1
|
|
|
1
|
0
|
3
|
my ($message) = @_; |
1974
|
1
|
|
|
|
|
4
|
print STDOUT "# $message\n"; |
1975
|
1
|
|
|
|
|
2
|
return 0==1; |
1976
|
|
|
|
|
|
|
} |
1977
|
|
|
|
|
|
|
|
1978
|
|
|
|
|
|
|
sub explain { ## TODO: check original spec |
1979
|
1
|
|
|
1
|
0
|
17
|
my ($value) = @_; |
1980
|
7
|
|
|
7
|
|
56
|
use Data::Dumper; |
|
7
|
|
|
|
|
174
|
|
|
7
|
|
|
|
|
13190
|
|
1981
|
1
|
|
|
|
|
1
|
local $Data::Dumper::Terse = 1; |
1982
|
1
|
|
|
|
|
33
|
$_ = Dumper($value); |
1983
|
1
|
|
|
|
|
47
|
s/^ //mg; |
1984
|
1
|
|
|
|
|
3
|
return $_; |
1985
|
|
|
|
|
|
|
} |
1986
|
|
|
|
|
|
|
|
1987
|
|
|
|
|
|
|
$INC{'Oktest/Migration/TestMore.pm'} = __FILE__; |
1988
|
|
|
|
|
|
|
|
1989
|
|
|
|
|
|
|
|
1990
|
|
|
|
|
|
|
|
1991
|
|
|
|
|
|
|
package Oktest::MainApp; |
1992
|
|
|
|
|
|
|
|
1993
|
|
|
|
|
|
|
our $optdef_table = [ |
1994
|
|
|
|
|
|
|
## name, short, long, argname, desc |
1995
|
|
|
|
|
|
|
['help', 'h', 'help', '', 'show help'], |
1996
|
|
|
|
|
|
|
['version', 'v', 'version', '', 'show version'], |
1997
|
|
|
|
|
|
|
['style', 's', 'style', 'name', 'reporting style (tap/verbose/simple/plain, or t/v/s/p)'], |
1998
|
|
|
|
|
|
|
['spec', '', 'spec', 'regexp', 'filter by spec description'], |
1999
|
|
|
|
|
|
|
['topic', '', 'topic', 'regexp', 'filter by topic name'], |
2000
|
|
|
|
|
|
|
['r_skipped', '', 'report-skipped', '', 'report detail of skipped items'], |
2001
|
|
|
|
|
|
|
['r_todo', '', 'report-todo', '', 'report detail of TODO items'], |
2002
|
|
|
|
|
|
|
['debug', 'D', 'debug', '', ''], |
2003
|
|
|
|
|
|
|
]; |
2004
|
|
|
|
|
|
|
|
2005
|
|
|
|
|
|
|
our $optdef_list = []; |
2006
|
|
|
|
|
|
|
our $optdef_dict = {}; |
2007
|
|
|
|
|
|
|
for (@$optdef_table) { |
2008
|
|
|
|
|
|
|
my ($name, $short, $long, $argname, $desc) = @$_; |
2009
|
|
|
|
|
|
|
my $item = { name=>$name, short=>$short, long=>$long, argname=>$argname, desc=>$desc, }; |
2010
|
|
|
|
|
|
|
push(@$optdef_list, $item); |
2011
|
|
|
|
|
|
|
$optdef_dict->{$short} = $item if $short; |
2012
|
|
|
|
|
|
|
$optdef_dict->{$long} = $item if $long; |
2013
|
|
|
|
|
|
|
} |
2014
|
|
|
|
|
|
|
|
2015
|
|
|
|
|
|
|
sub new { |
2016
|
45
|
|
|
45
|
|
8220
|
my ($class, $argv, $command) = @_; |
2017
|
45
|
|
100
|
|
|
261
|
my $this = { |
|
|
|
66
|
|
|
|
|
2018
|
|
|
|
|
|
|
argv => $argv || \@ARGV, |
2019
|
|
|
|
|
|
|
command => $command || ($0 =~ /([-\w.]+)$/ and $1), |
2020
|
|
|
|
|
|
|
}; |
2021
|
45
|
|
|
|
|
161
|
return bless($this, $class); |
2022
|
|
|
|
|
|
|
} |
2023
|
|
|
|
|
|
|
|
2024
|
|
|
|
|
|
|
sub _help_message { |
2025
|
2
|
|
|
2
|
|
2
|
my ($this) = @_; |
2026
|
2
|
|
|
|
|
7
|
my $str = |
2027
|
|
|
|
|
|
|
$this->{command} . " - a new-style testing library.\n" . |
2028
|
|
|
|
|
|
|
"Usage: oktest.pl [options] file_or_dir [file_or_dir2...]\n"; |
2029
|
2
|
|
|
|
|
4
|
for my $item (@$optdef_list) { |
2030
|
16
|
|
|
|
|
15
|
$_ = $item; |
2031
|
16
|
|
|
|
|
36
|
my ($name, $short, $long, $argname, $desc) = |
2032
|
|
|
|
|
|
|
($_->{name}, $_->{short}, $_->{long}, $_->{argname}, $_->{desc}); |
2033
|
16
|
100
|
|
|
|
26
|
next unless $desc; |
2034
|
14
|
100
|
66
|
|
|
61
|
my $s = $short && $long ? "-$short, --$long" . ($argname ? "=$argname" : "") |
|
|
0
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
2035
|
|
|
|
|
|
|
: $short ? "-$short" . ($argname ? " $argname" : "") |
2036
|
|
|
|
|
|
|
: $long ? " --$long" . ($argname ? "=$argname" : "") |
2037
|
|
|
|
|
|
|
: undef; |
2038
|
14
|
|
|
|
|
35
|
$str .= sprintf(" %-20s : %s\n", $s, $desc); |
2039
|
|
|
|
|
|
|
} |
2040
|
2
|
|
|
|
|
7
|
return $str; |
2041
|
|
|
|
|
|
|
} |
2042
|
|
|
|
|
|
|
|
2043
|
|
|
|
|
|
|
sub execute { |
2044
|
29
|
|
|
29
|
|
37
|
my ($this) = @_; |
2045
|
29
|
|
|
|
|
62
|
my ($opts, $props) = $this->_parse_argv(); |
2046
|
29
|
|
|
|
|
43
|
my $DEBUG = $opts->{debug}; |
2047
|
|
|
|
|
|
|
## help |
2048
|
29
|
100
|
|
|
|
60
|
if ($opts->{help}) { |
2049
|
2
|
|
|
|
|
6
|
print $this->_help_message(); |
2050
|
2
|
|
|
|
|
6
|
return; |
2051
|
|
|
|
|
|
|
} |
2052
|
|
|
|
|
|
|
## version |
2053
|
27
|
100
|
|
|
|
54
|
if ($opts->{version}) { |
2054
|
2
|
|
|
|
|
5
|
print $Oktest::VERSION, "\n"; |
2055
|
2
|
|
|
|
|
5
|
return; |
2056
|
|
|
|
|
|
|
} |
2057
|
|
|
|
|
|
|
## reporter |
2058
|
25
|
50
|
|
|
|
59
|
my $reporter = Oktest::Reporter::create_instance($opts->{style}) |
2059
|
|
|
|
|
|
|
or die "-s $opts->{style}: unknown reporting style.\n"; |
2060
|
25
|
100
|
|
|
|
62
|
$reporter->{report_skipped} = 1==1 if $opts->{r_skipped}; |
2061
|
25
|
100
|
|
|
|
47
|
$reporter->{report_todo} = 1==1 if $opts->{r_todo}; |
2062
|
|
|
|
|
|
|
## options for Oktest::run() |
2063
|
25
|
|
|
|
|
81
|
my $run_options = { |
2064
|
|
|
|
|
|
|
reporter => $reporter, |
2065
|
|
|
|
|
|
|
spec => _str_or_rexp($opts->{spec}), |
2066
|
|
|
|
|
|
|
topic => _str_or_rexp($opts->{topic}), |
2067
|
|
|
|
|
|
|
}; |
2068
|
|
|
|
|
|
|
## load files |
2069
|
25
|
|
|
|
|
57
|
my @filepaths = (); |
2070
|
25
|
|
|
|
|
26
|
for my $arg (@{$this->{argv}}) { |
|
25
|
|
|
|
|
49
|
|
2071
|
27
|
100
|
|
|
|
341
|
-e $arg |
2072
|
|
|
|
|
|
|
or die "$arg: no such file or directory.\n"; |
2073
|
26
|
100
|
|
|
|
255
|
my @arr = -d $arg ? _find_files($arg, qr/\.t$/) : ($arg); |
2074
|
26
|
|
|
|
|
72
|
push(@filepaths, @arr); |
2075
|
|
|
|
|
|
|
} |
2076
|
24
|
|
|
|
|
39
|
for my $fpath (@filepaths) { |
2077
|
47
|
50
|
|
|
|
294
|
print "## require '$fpath'\n" if $DEBUG; |
2078
|
47
|
|
|
|
|
12441
|
require $fpath; |
2079
|
|
|
|
|
|
|
} |
2080
|
|
|
|
|
|
|
## |
2081
|
24
|
|
|
|
|
141
|
Oktest::run(%$run_options); |
2082
|
|
|
|
|
|
|
} |
2083
|
|
|
|
|
|
|
|
2084
|
|
|
|
|
|
|
sub _str_or_rexp { |
2085
|
50
|
|
|
50
|
|
82
|
my ($pattern) = @_; |
2086
|
50
|
100
|
100
|
|
|
120
|
if ($pattern && $pattern =~ /^\/(.*)\/$/) { |
2087
|
2
|
|
|
|
|
27
|
my $rexp = qr/$1/; |
2088
|
2
|
|
|
|
|
9
|
return $rexp; |
2089
|
|
|
|
|
|
|
} |
2090
|
48
|
|
|
|
|
133
|
return $pattern; |
2091
|
|
|
|
|
|
|
} |
2092
|
|
|
|
|
|
|
|
2093
|
|
|
|
|
|
|
sub _parse_argv { |
2094
|
42
|
|
|
42
|
|
72
|
my ($this) = @_; |
2095
|
42
|
|
|
|
|
133
|
my $argv = $this->{argv}; |
2096
|
42
|
|
|
|
|
55
|
my $command = $this->{command}; |
2097
|
42
|
|
|
|
|
53
|
my $opts = {}; |
2098
|
|
|
|
|
|
|
#my $props = {}; |
2099
|
42
|
|
100
|
|
|
263
|
while ($argv->[0] && $argv->[0] =~ /^-/) { |
2100
|
50
|
|
|
|
|
77
|
my $optstr = shift(@$argv); |
2101
|
50
|
100
|
|
|
|
104
|
last if $optstr eq '--'; |
2102
|
49
|
100
|
|
|
|
111
|
if ($optstr =~ /^--/) { |
2103
|
24
|
50
|
|
|
|
118
|
$optstr =~ /^--(\w[-\w]*)(=(.*))?$/ |
2104
|
|
|
|
|
|
|
or die "$command: $optstr: invalid option.\n"; |
2105
|
|
|
|
|
|
|
#$props->{$1} = $2 ? $3 : 1; |
2106
|
24
|
|
|
|
|
47
|
my $has_arg = !! $2; |
2107
|
24
|
100
|
|
|
|
71
|
my ($key, $val) = ($1, $has_arg ? $3 : 1); |
2108
|
24
|
100
|
|
|
|
80
|
my $item = $optdef_dict->{$key} |
2109
|
|
|
|
|
|
|
or die "$command: $optstr: unknown option.\n"; |
2110
|
22
|
|
|
|
|
39
|
my $arg_required = !! $item->{argname}; |
2111
|
22
|
100
|
100
|
|
|
72
|
$arg_required && ! $has_arg |
2112
|
|
|
|
|
|
|
and die "$command: $optstr: argument required.\n"; |
2113
|
21
|
100
|
100
|
|
|
83
|
! $arg_required && $has_arg |
2114
|
|
|
|
|
|
|
and die "$command: $optstr: unexpected argument.\n"; |
2115
|
|
|
|
|
|
|
#$opts->{$key} = $val; |
2116
|
20
|
|
|
|
|
121
|
$opts->{$item->{name}} = $val; |
2117
|
|
|
|
|
|
|
} |
2118
|
|
|
|
|
|
|
else { |
2119
|
25
|
|
|
|
|
102
|
my @optchars = split('', substr($optstr, 1)); |
2120
|
25
|
|
|
|
|
69
|
while (my $ch = shift(@optchars)) { |
2121
|
30
|
100
|
|
|
|
89
|
my $item = $optdef_dict->{$ch} |
2122
|
|
|
|
|
|
|
or die "$command: -$ch: unknown option.\n"; |
2123
|
28
|
|
|
|
|
28
|
my $val; |
2124
|
28
|
|
|
|
|
45
|
my $argname = $item->{argname}; |
2125
|
28
|
100
|
|
|
|
99
|
if (! $argname) { $val = 1; } |
|
12
|
100
|
|
|
|
14
|
|
|
|
100
|
|
|
|
|
|
2126
|
13
|
|
|
|
|
22
|
elsif (@optchars) { $val = join('', @optchars); @optchars = (); } |
|
13
|
|
|
|
|
25
|
|
2127
|
1
|
|
|
|
|
3
|
elsif (@$argv) { $val = shift(@$argv); } |
2128
|
2
|
|
|
|
|
16
|
else { die "$command: -$ch: argument required.\n"; } |
2129
|
26
|
|
|
|
|
183
|
$opts->{$item->{name}} = $val; |
2130
|
|
|
|
|
|
|
} |
2131
|
|
|
|
|
|
|
} |
2132
|
|
|
|
|
|
|
} |
2133
|
|
|
|
|
|
|
#return $opts, $props; |
2134
|
34
|
|
|
|
|
72
|
return $opts; |
2135
|
|
|
|
|
|
|
}; |
2136
|
|
|
|
|
|
|
|
2137
|
|
|
|
|
|
|
sub _find_files { |
2138
|
32
|
|
|
32
|
|
43
|
my ($arg, $rexp) = @_; |
2139
|
32
|
100
|
|
|
|
340
|
if (-f $arg) { |
|
|
50
|
|
|
|
|
|
2140
|
27
|
50
|
33
|
|
|
176
|
return if $rexp && $arg !~ $rexp; |
2141
|
27
|
|
|
|
|
61
|
return ($arg); |
2142
|
|
|
|
|
|
|
} |
2143
|
|
|
|
|
|
|
elsif (-d $arg) { |
2144
|
5
|
|
|
|
|
8
|
my @arr = (); |
2145
|
5
|
|
|
|
|
571
|
for (glob("$arg/*")) { |
2146
|
27
|
|
|
|
|
49
|
push(@arr, _find_files($_, $rexp)); |
2147
|
|
|
|
|
|
|
} |
2148
|
5
|
|
|
|
|
20
|
return @arr; |
2149
|
|
|
|
|
|
|
} |
2150
|
|
|
|
|
|
|
else { |
2151
|
0
|
|
|
|
|
|
die "_find_files(): $arg: not file nor directory.\n"; |
2152
|
|
|
|
|
|
|
} |
2153
|
|
|
|
|
|
|
} |
2154
|
|
|
|
|
|
|
|
2155
|
|
|
|
|
|
|
|
2156
|
|
|
|
|
|
|
|
2157
|
|
|
|
|
|
|
1; |
2158
|
|
|
|
|
|
|
|
2159
|
|
|
|
|
|
|
|
2160
|
|
|
|
|
|
|
__END__ |