1 | package Test::More;
|
---|
2 |
|
---|
3 | use 5.004;
|
---|
4 |
|
---|
5 | use strict;
|
---|
6 |
|
---|
7 |
|
---|
8 | # Can't use Carp because it might cause use_ok() to accidentally succeed
|
---|
9 | # even though the module being used forgot to use Carp. Yes, this
|
---|
10 | # actually happened.
|
---|
11 | sub _carp {
|
---|
12 | my($file, $line) = (caller(1))[1,2];
|
---|
13 | warn @_, " at $file line $line\n";
|
---|
14 | }
|
---|
15 |
|
---|
16 |
|
---|
17 |
|
---|
18 | use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
|
---|
19 | $VERSION = '0.62';
|
---|
20 | $VERSION = eval $VERSION; # make the alpha version come out as a number
|
---|
21 |
|
---|
22 | use Test::Builder::Module;
|
---|
23 | @ISA = qw(Test::Builder::Module);
|
---|
24 | @EXPORT = qw(ok use_ok require_ok
|
---|
25 | is isnt like unlike is_deeply
|
---|
26 | cmp_ok
|
---|
27 | skip todo todo_skip
|
---|
28 | pass fail
|
---|
29 | eq_array eq_hash eq_set
|
---|
30 | $TODO
|
---|
31 | plan
|
---|
32 | can_ok isa_ok
|
---|
33 | diag
|
---|
34 | BAIL_OUT
|
---|
35 | );
|
---|
36 |
|
---|
37 |
|
---|
38 | =head1 NAME
|
---|
39 |
|
---|
40 | Test::More - yet another framework for writing test scripts
|
---|
41 |
|
---|
42 | =head1 SYNOPSIS
|
---|
43 |
|
---|
44 | use Test::More tests => $Num_Tests;
|
---|
45 | # or
|
---|
46 | use Test::More qw(no_plan);
|
---|
47 | # or
|
---|
48 | use Test::More skip_all => $reason;
|
---|
49 |
|
---|
50 | BEGIN { use_ok( 'Some::Module' ); }
|
---|
51 | require_ok( 'Some::Module' );
|
---|
52 |
|
---|
53 | # Various ways to say "ok"
|
---|
54 | ok($this eq $that, $test_name);
|
---|
55 |
|
---|
56 | is ($this, $that, $test_name);
|
---|
57 | isnt($this, $that, $test_name);
|
---|
58 |
|
---|
59 | # Rather than print STDERR "# here's what went wrong\n"
|
---|
60 | diag("here's what went wrong");
|
---|
61 |
|
---|
62 | like ($this, qr/that/, $test_name);
|
---|
63 | unlike($this, qr/that/, $test_name);
|
---|
64 |
|
---|
65 | cmp_ok($this, '==', $that, $test_name);
|
---|
66 |
|
---|
67 | is_deeply($complex_structure1, $complex_structure2, $test_name);
|
---|
68 |
|
---|
69 | SKIP: {
|
---|
70 | skip $why, $how_many unless $have_some_feature;
|
---|
71 |
|
---|
72 | ok( foo(), $test_name );
|
---|
73 | is( foo(42), 23, $test_name );
|
---|
74 | };
|
---|
75 |
|
---|
76 | TODO: {
|
---|
77 | local $TODO = $why;
|
---|
78 |
|
---|
79 | ok( foo(), $test_name );
|
---|
80 | is( foo(42), 23, $test_name );
|
---|
81 | };
|
---|
82 |
|
---|
83 | can_ok($module, @methods);
|
---|
84 | isa_ok($object, $class);
|
---|
85 |
|
---|
86 | pass($test_name);
|
---|
87 | fail($test_name);
|
---|
88 |
|
---|
89 | BAIL_OUT($why);
|
---|
90 |
|
---|
91 | # UNIMPLEMENTED!!!
|
---|
92 | my @status = Test::More::status;
|
---|
93 |
|
---|
94 |
|
---|
95 | =head1 DESCRIPTION
|
---|
96 |
|
---|
97 | B<STOP!> If you're just getting started writing tests, have a look at
|
---|
98 | Test::Simple first. This is a drop in replacement for Test::Simple
|
---|
99 | which you can switch to once you get the hang of basic testing.
|
---|
100 |
|
---|
101 | The purpose of this module is to provide a wide range of testing
|
---|
102 | utilities. Various ways to say "ok" with better diagnostics,
|
---|
103 | facilities to skip tests, test future features and compare complicated
|
---|
104 | data structures. While you can do almost anything with a simple
|
---|
105 | C<ok()> function, it doesn't provide good diagnostic output.
|
---|
106 |
|
---|
107 |
|
---|
108 | =head2 I love it when a plan comes together
|
---|
109 |
|
---|
110 | Before anything else, you need a testing plan. This basically declares
|
---|
111 | how many tests your script is going to run to protect against premature
|
---|
112 | failure.
|
---|
113 |
|
---|
114 | The preferred way to do this is to declare a plan when you C<use Test::More>.
|
---|
115 |
|
---|
116 | use Test::More tests => $Num_Tests;
|
---|
117 |
|
---|
118 | There are rare cases when you will not know beforehand how many tests
|
---|
119 | your script is going to run. In this case, you can declare that you
|
---|
120 | have no plan. (Try to avoid using this as it weakens your test.)
|
---|
121 |
|
---|
122 | use Test::More qw(no_plan);
|
---|
123 |
|
---|
124 | B<NOTE>: using no_plan requires a Test::Harness upgrade else it will
|
---|
125 | think everything has failed. See L<CAVEATS and NOTES>).
|
---|
126 |
|
---|
127 | In some cases, you'll want to completely skip an entire testing script.
|
---|
128 |
|
---|
129 | use Test::More skip_all => $skip_reason;
|
---|
130 |
|
---|
131 | Your script will declare a skip with the reason why you skipped and
|
---|
132 | exit immediately with a zero (success). See L<Test::Harness> for
|
---|
133 | details.
|
---|
134 |
|
---|
135 | If you want to control what functions Test::More will export, you
|
---|
136 | have to use the 'import' option. For example, to import everything
|
---|
137 | but 'fail', you'd do:
|
---|
138 |
|
---|
139 | use Test::More tests => 23, import => ['!fail'];
|
---|
140 |
|
---|
141 | Alternatively, you can use the plan() function. Useful for when you
|
---|
142 | have to calculate the number of tests.
|
---|
143 |
|
---|
144 | use Test::More;
|
---|
145 | plan tests => keys %Stuff * 3;
|
---|
146 |
|
---|
147 | or for deciding between running the tests at all:
|
---|
148 |
|
---|
149 | use Test::More;
|
---|
150 | if( $^O eq 'MacOS' ) {
|
---|
151 | plan skip_all => 'Test irrelevant on MacOS';
|
---|
152 | }
|
---|
153 | else {
|
---|
154 | plan tests => 42;
|
---|
155 | }
|
---|
156 |
|
---|
157 | =cut
|
---|
158 |
|
---|
159 | sub plan {
|
---|
160 | my $tb = Test::More->builder;
|
---|
161 |
|
---|
162 | $tb->plan(@_);
|
---|
163 | }
|
---|
164 |
|
---|
165 |
|
---|
166 | # This implements "use Test::More 'no_diag'" but the behavior is
|
---|
167 | # deprecated.
|
---|
168 | sub import_extra {
|
---|
169 | my $class = shift;
|
---|
170 | my $list = shift;
|
---|
171 |
|
---|
172 | my @other = ();
|
---|
173 | my $idx = 0;
|
---|
174 | while( $idx <= $#{$list} ) {
|
---|
175 | my $item = $list->[$idx];
|
---|
176 |
|
---|
177 | if( defined $item and $item eq 'no_diag' ) {
|
---|
178 | $class->builder->no_diag(1);
|
---|
179 | }
|
---|
180 | else {
|
---|
181 | push @other, $item;
|
---|
182 | }
|
---|
183 |
|
---|
184 | $idx++;
|
---|
185 | }
|
---|
186 |
|
---|
187 | @$list = @other;
|
---|
188 | }
|
---|
189 |
|
---|
190 |
|
---|
191 | =head2 Test names
|
---|
192 |
|
---|
193 | By convention, each test is assigned a number in order. This is
|
---|
194 | largely done automatically for you. However, it's often very useful to
|
---|
195 | assign a name to each test. Which would you rather see:
|
---|
196 |
|
---|
197 | ok 4
|
---|
198 | not ok 5
|
---|
199 | ok 6
|
---|
200 |
|
---|
201 | or
|
---|
202 |
|
---|
203 | ok 4 - basic multi-variable
|
---|
204 | not ok 5 - simple exponential
|
---|
205 | ok 6 - force == mass * acceleration
|
---|
206 |
|
---|
207 | The later gives you some idea of what failed. It also makes it easier
|
---|
208 | to find the test in your script, simply search for "simple
|
---|
209 | exponential".
|
---|
210 |
|
---|
211 | All test functions take a name argument. It's optional, but highly
|
---|
212 | suggested that you use it.
|
---|
213 |
|
---|
214 |
|
---|
215 | =head2 I'm ok, you're not ok.
|
---|
216 |
|
---|
217 | The basic purpose of this module is to print out either "ok #" or "not
|
---|
218 | ok #" depending on if a given test succeeded or failed. Everything
|
---|
219 | else is just gravy.
|
---|
220 |
|
---|
221 | All of the following print "ok" or "not ok" depending on if the test
|
---|
222 | succeeded or failed. They all also return true or false,
|
---|
223 | respectively.
|
---|
224 |
|
---|
225 | =over 4
|
---|
226 |
|
---|
227 | =item B<ok>
|
---|
228 |
|
---|
229 | ok($this eq $that, $test_name);
|
---|
230 |
|
---|
231 | This simply evaluates any expression (C<$this eq $that> is just a
|
---|
232 | simple example) and uses that to determine if the test succeeded or
|
---|
233 | failed. A true expression passes, a false one fails. Very simple.
|
---|
234 |
|
---|
235 | For example:
|
---|
236 |
|
---|
237 | ok( $exp{9} == 81, 'simple exponential' );
|
---|
238 | ok( Film->can('db_Main'), 'set_db()' );
|
---|
239 | ok( $p->tests == 4, 'saw tests' );
|
---|
240 | ok( !grep !defined $_, @items, 'items populated' );
|
---|
241 |
|
---|
242 | (Mnemonic: "This is ok.")
|
---|
243 |
|
---|
244 | $test_name is a very short description of the test that will be printed
|
---|
245 | out. It makes it very easy to find a test in your script when it fails
|
---|
246 | and gives others an idea of your intentions. $test_name is optional,
|
---|
247 | but we B<very> strongly encourage its use.
|
---|
248 |
|
---|
249 | Should an ok() fail, it will produce some diagnostics:
|
---|
250 |
|
---|
251 | not ok 18 - sufficient mucus
|
---|
252 | # Failed test 'sufficient mucus'
|
---|
253 | # in foo.t at line 42.
|
---|
254 |
|
---|
255 | This is actually Test::Simple's ok() routine.
|
---|
256 |
|
---|
257 | =cut
|
---|
258 |
|
---|
259 | sub ok ($;$) {
|
---|
260 | my($test, $name) = @_;
|
---|
261 | my $tb = Test::More->builder;
|
---|
262 |
|
---|
263 | $tb->ok($test, $name);
|
---|
264 | }
|
---|
265 |
|
---|
266 | =item B<is>
|
---|
267 |
|
---|
268 | =item B<isnt>
|
---|
269 |
|
---|
270 | is ( $this, $that, $test_name );
|
---|
271 | isnt( $this, $that, $test_name );
|
---|
272 |
|
---|
273 | Similar to ok(), is() and isnt() compare their two arguments
|
---|
274 | with C<eq> and C<ne> respectively and use the result of that to
|
---|
275 | determine if the test succeeded or failed. So these:
|
---|
276 |
|
---|
277 | # Is the ultimate answer 42?
|
---|
278 | is( ultimate_answer(), 42, "Meaning of Life" );
|
---|
279 |
|
---|
280 | # $foo isn't empty
|
---|
281 | isnt( $foo, '', "Got some foo" );
|
---|
282 |
|
---|
283 | are similar to these:
|
---|
284 |
|
---|
285 | ok( ultimate_answer() eq 42, "Meaning of Life" );
|
---|
286 | ok( $foo ne '', "Got some foo" );
|
---|
287 |
|
---|
288 | (Mnemonic: "This is that." "This isn't that.")
|
---|
289 |
|
---|
290 | So why use these? They produce better diagnostics on failure. ok()
|
---|
291 | cannot know what you are testing for (beyond the name), but is() and
|
---|
292 | isnt() know what the test was and why it failed. For example this
|
---|
293 | test:
|
---|
294 |
|
---|
295 | my $foo = 'waffle'; my $bar = 'yarblokos';
|
---|
296 | is( $foo, $bar, 'Is foo the same as bar?' );
|
---|
297 |
|
---|
298 | Will produce something like this:
|
---|
299 |
|
---|
300 | not ok 17 - Is foo the same as bar?
|
---|
301 | # Failed test 'Is foo the same as bar?'
|
---|
302 | # in foo.t at line 139.
|
---|
303 | # got: 'waffle'
|
---|
304 | # expected: 'yarblokos'
|
---|
305 |
|
---|
306 | So you can figure out what went wrong without rerunning the test.
|
---|
307 |
|
---|
308 | You are encouraged to use is() and isnt() over ok() where possible,
|
---|
309 | however do not be tempted to use them to find out if something is
|
---|
310 | true or false!
|
---|
311 |
|
---|
312 | # XXX BAD!
|
---|
313 | is( exists $brooklyn{tree}, 1, 'A tree grows in Brooklyn' );
|
---|
314 |
|
---|
315 | This does not check if C<exists $brooklyn{tree}> is true, it checks if
|
---|
316 | it returns 1. Very different. Similar caveats exist for false and 0.
|
---|
317 | In these cases, use ok().
|
---|
318 |
|
---|
319 | ok( exists $brooklyn{tree}, 'A tree grows in Brooklyn' );
|
---|
320 |
|
---|
321 | For those grammatical pedants out there, there's an C<isn't()>
|
---|
322 | function which is an alias of isnt().
|
---|
323 |
|
---|
324 | =cut
|
---|
325 |
|
---|
326 | sub is ($$;$) {
|
---|
327 | my $tb = Test::More->builder;
|
---|
328 |
|
---|
329 | $tb->is_eq(@_);
|
---|
330 | }
|
---|
331 |
|
---|
332 | sub isnt ($$;$) {
|
---|
333 | my $tb = Test::More->builder;
|
---|
334 |
|
---|
335 | $tb->isnt_eq(@_);
|
---|
336 | }
|
---|
337 |
|
---|
338 | *isn't = \&isnt;
|
---|
339 |
|
---|
340 |
|
---|
341 | =item B<like>
|
---|
342 |
|
---|
343 | like( $this, qr/that/, $test_name );
|
---|
344 |
|
---|
345 | Similar to ok(), like() matches $this against the regex C<qr/that/>.
|
---|
346 |
|
---|
347 | So this:
|
---|
348 |
|
---|
349 | like($this, qr/that/, 'this is like that');
|
---|
350 |
|
---|
351 | is similar to:
|
---|
352 |
|
---|
353 | ok( $this =~ /that/, 'this is like that');
|
---|
354 |
|
---|
355 | (Mnemonic "This is like that".)
|
---|
356 |
|
---|
357 | The second argument is a regular expression. It may be given as a
|
---|
358 | regex reference (i.e. C<qr//>) or (for better compatibility with older
|
---|
359 | perls) as a string that looks like a regex (alternative delimiters are
|
---|
360 | currently not supported):
|
---|
361 |
|
---|
362 | like( $this, '/that/', 'this is like that' );
|
---|
363 |
|
---|
364 | Regex options may be placed on the end (C<'/that/i'>).
|
---|
365 |
|
---|
366 | Its advantages over ok() are similar to that of is() and isnt(). Better
|
---|
367 | diagnostics on failure.
|
---|
368 |
|
---|
369 | =cut
|
---|
370 |
|
---|
371 | sub like ($$;$) {
|
---|
372 | my $tb = Test::More->builder;
|
---|
373 |
|
---|
374 | $tb->like(@_);
|
---|
375 | }
|
---|
376 |
|
---|
377 |
|
---|
378 | =item B<unlike>
|
---|
379 |
|
---|
380 | unlike( $this, qr/that/, $test_name );
|
---|
381 |
|
---|
382 | Works exactly as like(), only it checks if $this B<does not> match the
|
---|
383 | given pattern.
|
---|
384 |
|
---|
385 | =cut
|
---|
386 |
|
---|
387 | sub unlike ($$;$) {
|
---|
388 | my $tb = Test::More->builder;
|
---|
389 |
|
---|
390 | $tb->unlike(@_);
|
---|
391 | }
|
---|
392 |
|
---|
393 |
|
---|
394 | =item B<cmp_ok>
|
---|
395 |
|
---|
396 | cmp_ok( $this, $op, $that, $test_name );
|
---|
397 |
|
---|
398 | Halfway between ok() and is() lies cmp_ok(). This allows you to
|
---|
399 | compare two arguments using any binary perl operator.
|
---|
400 |
|
---|
401 | # ok( $this eq $that );
|
---|
402 | cmp_ok( $this, 'eq', $that, 'this eq that' );
|
---|
403 |
|
---|
404 | # ok( $this == $that );
|
---|
405 | cmp_ok( $this, '==', $that, 'this == that' );
|
---|
406 |
|
---|
407 | # ok( $this && $that );
|
---|
408 | cmp_ok( $this, '&&', $that, 'this && that' );
|
---|
409 | ...etc...
|
---|
410 |
|
---|
411 | Its advantage over ok() is when the test fails you'll know what $this
|
---|
412 | and $that were:
|
---|
413 |
|
---|
414 | not ok 1
|
---|
415 | # Failed test in foo.t at line 12.
|
---|
416 | # '23'
|
---|
417 | # &&
|
---|
418 | # undef
|
---|
419 |
|
---|
420 | It's also useful in those cases where you are comparing numbers and
|
---|
421 | is()'s use of C<eq> will interfere:
|
---|
422 |
|
---|
423 | cmp_ok( $big_hairy_number, '==', $another_big_hairy_number );
|
---|
424 |
|
---|
425 | =cut
|
---|
426 |
|
---|
427 | sub cmp_ok($$$;$) {
|
---|
428 | my $tb = Test::More->builder;
|
---|
429 |
|
---|
430 | $tb->cmp_ok(@_);
|
---|
431 | }
|
---|
432 |
|
---|
433 |
|
---|
434 | =item B<can_ok>
|
---|
435 |
|
---|
436 | can_ok($module, @methods);
|
---|
437 | can_ok($object, @methods);
|
---|
438 |
|
---|
439 | Checks to make sure the $module or $object can do these @methods
|
---|
440 | (works with functions, too).
|
---|
441 |
|
---|
442 | can_ok('Foo', qw(this that whatever));
|
---|
443 |
|
---|
444 | is almost exactly like saying:
|
---|
445 |
|
---|
446 | ok( Foo->can('this') &&
|
---|
447 | Foo->can('that') &&
|
---|
448 | Foo->can('whatever')
|
---|
449 | );
|
---|
450 |
|
---|
451 | only without all the typing and with a better interface. Handy for
|
---|
452 | quickly testing an interface.
|
---|
453 |
|
---|
454 | No matter how many @methods you check, a single can_ok() call counts
|
---|
455 | as one test. If you desire otherwise, use:
|
---|
456 |
|
---|
457 | foreach my $meth (@methods) {
|
---|
458 | can_ok('Foo', $meth);
|
---|
459 | }
|
---|
460 |
|
---|
461 | =cut
|
---|
462 |
|
---|
463 | sub can_ok ($@) {
|
---|
464 | my($proto, @methods) = @_;
|
---|
465 | my $class = ref $proto || $proto;
|
---|
466 | my $tb = Test::More->builder;
|
---|
467 |
|
---|
468 | unless( @methods ) {
|
---|
469 | my $ok = $tb->ok( 0, "$class->can(...)" );
|
---|
470 | $tb->diag(' can_ok() called with no methods');
|
---|
471 | return $ok;
|
---|
472 | }
|
---|
473 |
|
---|
474 | my @nok = ();
|
---|
475 | foreach my $method (@methods) {
|
---|
476 | local($!, $@); # don't interfere with caller's $@
|
---|
477 | # eval sometimes resets $!
|
---|
478 | eval { $proto->can($method) } || push @nok, $method;
|
---|
479 | }
|
---|
480 |
|
---|
481 | my $name;
|
---|
482 | $name = @methods == 1 ? "$class->can('$methods[0]')"
|
---|
483 | : "$class->can(...)";
|
---|
484 |
|
---|
485 | my $ok = $tb->ok( !@nok, $name );
|
---|
486 |
|
---|
487 | $tb->diag(map " $class->can('$_') failed\n", @nok);
|
---|
488 |
|
---|
489 | return $ok;
|
---|
490 | }
|
---|
491 |
|
---|
492 | =item B<isa_ok>
|
---|
493 |
|
---|
494 | isa_ok($object, $class, $object_name);
|
---|
495 | isa_ok($ref, $type, $ref_name);
|
---|
496 |
|
---|
497 | Checks to see if the given C<< $object->isa($class) >>. Also checks to make
|
---|
498 | sure the object was defined in the first place. Handy for this sort
|
---|
499 | of thing:
|
---|
500 |
|
---|
501 | my $obj = Some::Module->new;
|
---|
502 | isa_ok( $obj, 'Some::Module' );
|
---|
503 |
|
---|
504 | where you'd otherwise have to write
|
---|
505 |
|
---|
506 | my $obj = Some::Module->new;
|
---|
507 | ok( defined $obj && $obj->isa('Some::Module') );
|
---|
508 |
|
---|
509 | to safeguard against your test script blowing up.
|
---|
510 |
|
---|
511 | It works on references, too:
|
---|
512 |
|
---|
513 | isa_ok( $array_ref, 'ARRAY' );
|
---|
514 |
|
---|
515 | The diagnostics of this test normally just refer to 'the object'. If
|
---|
516 | you'd like them to be more specific, you can supply an $object_name
|
---|
517 | (for example 'Test customer').
|
---|
518 |
|
---|
519 | =cut
|
---|
520 |
|
---|
521 | sub isa_ok ($$;$) {
|
---|
522 | my($object, $class, $obj_name) = @_;
|
---|
523 | my $tb = Test::More->builder;
|
---|
524 |
|
---|
525 | my $diag;
|
---|
526 | $obj_name = 'The object' unless defined $obj_name;
|
---|
527 | my $name = "$obj_name isa $class";
|
---|
528 | if( !defined $object ) {
|
---|
529 | $diag = "$obj_name isn't defined";
|
---|
530 | }
|
---|
531 | elsif( !ref $object ) {
|
---|
532 | $diag = "$obj_name isn't a reference";
|
---|
533 | }
|
---|
534 | else {
|
---|
535 | # We can't use UNIVERSAL::isa because we want to honor isa() overrides
|
---|
536 | local($@, $!); # eval sometimes resets $!
|
---|
537 | my $rslt = eval { $object->isa($class) };
|
---|
538 | if( $@ ) {
|
---|
539 | if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
|
---|
540 | if( !UNIVERSAL::isa($object, $class) ) {
|
---|
541 | my $ref = ref $object;
|
---|
542 | $diag = "$obj_name isn't a '$class' it's a '$ref'";
|
---|
543 | }
|
---|
544 | } else {
|
---|
545 | die <<WHOA;
|
---|
546 | WHOA! I tried to call ->isa on your object and got some weird error.
|
---|
547 | This should never happen. Please contact the author immediately.
|
---|
548 | Here's the error.
|
---|
549 | $@
|
---|
550 | WHOA
|
---|
551 | }
|
---|
552 | }
|
---|
553 | elsif( !$rslt ) {
|
---|
554 | my $ref = ref $object;
|
---|
555 | $diag = "$obj_name isn't a '$class' it's a '$ref'";
|
---|
556 | }
|
---|
557 | }
|
---|
558 |
|
---|
559 |
|
---|
560 |
|
---|
561 | my $ok;
|
---|
562 | if( $diag ) {
|
---|
563 | $ok = $tb->ok( 0, $name );
|
---|
564 | $tb->diag(" $diag\n");
|
---|
565 | }
|
---|
566 | else {
|
---|
567 | $ok = $tb->ok( 1, $name );
|
---|
568 | }
|
---|
569 |
|
---|
570 | return $ok;
|
---|
571 | }
|
---|
572 |
|
---|
573 |
|
---|
574 | =item B<pass>
|
---|
575 |
|
---|
576 | =item B<fail>
|
---|
577 |
|
---|
578 | pass($test_name);
|
---|
579 | fail($test_name);
|
---|
580 |
|
---|
581 | Sometimes you just want to say that the tests have passed. Usually
|
---|
582 | the case is you've got some complicated condition that is difficult to
|
---|
583 | wedge into an ok(). In this case, you can simply use pass() (to
|
---|
584 | declare the test ok) or fail (for not ok). They are synonyms for
|
---|
585 | ok(1) and ok(0).
|
---|
586 |
|
---|
587 | Use these very, very, very sparingly.
|
---|
588 |
|
---|
589 | =cut
|
---|
590 |
|
---|
591 | sub pass (;$) {
|
---|
592 | my $tb = Test::More->builder;
|
---|
593 | $tb->ok(1, @_);
|
---|
594 | }
|
---|
595 |
|
---|
596 | sub fail (;$) {
|
---|
597 | my $tb = Test::More->builder;
|
---|
598 | $tb->ok(0, @_);
|
---|
599 | }
|
---|
600 |
|
---|
601 | =back
|
---|
602 |
|
---|
603 |
|
---|
604 | =head2 Module tests
|
---|
605 |
|
---|
606 | You usually want to test if the module you're testing loads ok, rather
|
---|
607 | than just vomiting if its load fails. For such purposes we have
|
---|
608 | C<use_ok> and C<require_ok>.
|
---|
609 |
|
---|
610 | =over 4
|
---|
611 |
|
---|
612 | =item B<use_ok>
|
---|
613 |
|
---|
614 | BEGIN { use_ok($module); }
|
---|
615 | BEGIN { use_ok($module, @imports); }
|
---|
616 |
|
---|
617 | These simply use the given $module and test to make sure the load
|
---|
618 | happened ok. It's recommended that you run use_ok() inside a BEGIN
|
---|
619 | block so its functions are exported at compile-time and prototypes are
|
---|
620 | properly honored.
|
---|
621 |
|
---|
622 | If @imports are given, they are passed through to the use. So this:
|
---|
623 |
|
---|
624 | BEGIN { use_ok('Some::Module', qw(foo bar)) }
|
---|
625 |
|
---|
626 | is like doing this:
|
---|
627 |
|
---|
628 | use Some::Module qw(foo bar);
|
---|
629 |
|
---|
630 | Version numbers can be checked like so:
|
---|
631 |
|
---|
632 | # Just like "use Some::Module 1.02"
|
---|
633 | BEGIN { use_ok('Some::Module', 1.02) }
|
---|
634 |
|
---|
635 | Don't try to do this:
|
---|
636 |
|
---|
637 | BEGIN {
|
---|
638 | use_ok('Some::Module');
|
---|
639 |
|
---|
640 | ...some code that depends on the use...
|
---|
641 | ...happening at compile time...
|
---|
642 | }
|
---|
643 |
|
---|
644 | because the notion of "compile-time" is relative. Instead, you want:
|
---|
645 |
|
---|
646 | BEGIN { use_ok('Some::Module') }
|
---|
647 | BEGIN { ...some code that depends on the use... }
|
---|
648 |
|
---|
649 |
|
---|
650 | =cut
|
---|
651 |
|
---|
652 | sub use_ok ($;@) {
|
---|
653 | my($module, @imports) = @_;
|
---|
654 | @imports = () unless @imports;
|
---|
655 | my $tb = Test::More->builder;
|
---|
656 |
|
---|
657 | my($pack,$filename,$line) = caller;
|
---|
658 |
|
---|
659 | local($@,$!); # eval sometimes interferes with $!
|
---|
660 |
|
---|
661 | if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
|
---|
662 | # probably a version check. Perl needs to see the bare number
|
---|
663 | # for it to work with non-Exporter based modules.
|
---|
664 | eval <<USE;
|
---|
665 | package $pack;
|
---|
666 | use $module $imports[0];
|
---|
667 | USE
|
---|
668 | }
|
---|
669 | else {
|
---|
670 | eval <<USE;
|
---|
671 | package $pack;
|
---|
672 | use $module \@imports;
|
---|
673 | USE
|
---|
674 | }
|
---|
675 |
|
---|
676 | my $ok = $tb->ok( !$@, "use $module;" );
|
---|
677 |
|
---|
678 | unless( $ok ) {
|
---|
679 | chomp $@;
|
---|
680 | $@ =~ s{^BEGIN failed--compilation aborted at .*$}
|
---|
681 | {BEGIN failed--compilation aborted at $filename line $line.}m;
|
---|
682 | $tb->diag(<<DIAGNOSTIC);
|
---|
683 | Tried to use '$module'.
|
---|
684 | Error: $@
|
---|
685 | DIAGNOSTIC
|
---|
686 |
|
---|
687 | }
|
---|
688 |
|
---|
689 | return $ok;
|
---|
690 | }
|
---|
691 |
|
---|
692 | =item B<require_ok>
|
---|
693 |
|
---|
694 | require_ok($module);
|
---|
695 | require_ok($file);
|
---|
696 |
|
---|
697 | Like use_ok(), except it requires the $module or $file.
|
---|
698 |
|
---|
699 | =cut
|
---|
700 |
|
---|
701 | sub require_ok ($) {
|
---|
702 | my($module) = shift;
|
---|
703 | my $tb = Test::More->builder;
|
---|
704 |
|
---|
705 | my $pack = caller;
|
---|
706 |
|
---|
707 | # Try to deterine if we've been given a module name or file.
|
---|
708 | # Module names must be barewords, files not.
|
---|
709 | $module = qq['$module'] unless _is_module_name($module);
|
---|
710 |
|
---|
711 | local($!, $@); # eval sometimes interferes with $!
|
---|
712 | eval <<REQUIRE;
|
---|
713 | package $pack;
|
---|
714 | require $module;
|
---|
715 | REQUIRE
|
---|
716 |
|
---|
717 | my $ok = $tb->ok( !$@, "require $module;" );
|
---|
718 |
|
---|
719 | unless( $ok ) {
|
---|
720 | chomp $@;
|
---|
721 | $tb->diag(<<DIAGNOSTIC);
|
---|
722 | Tried to require '$module'.
|
---|
723 | Error: $@
|
---|
724 | DIAGNOSTIC
|
---|
725 |
|
---|
726 | }
|
---|
727 |
|
---|
728 | return $ok;
|
---|
729 | }
|
---|
730 |
|
---|
731 |
|
---|
732 | sub _is_module_name {
|
---|
733 | my $module = shift;
|
---|
734 |
|
---|
735 | # Module names start with a letter.
|
---|
736 | # End with an alphanumeric.
|
---|
737 | # The rest is an alphanumeric or ::
|
---|
738 | $module =~ s/\b::\b//g;
|
---|
739 | $module =~ /^[a-zA-Z]\w*$/;
|
---|
740 | }
|
---|
741 |
|
---|
742 | =back
|
---|
743 |
|
---|
744 |
|
---|
745 | =head2 Complex data structures
|
---|
746 |
|
---|
747 | Not everything is a simple eq check or regex. There are times you
|
---|
748 | need to see if two data structures are equivalent. For these
|
---|
749 | instances Test::More provides a handful of useful functions.
|
---|
750 |
|
---|
751 | B<NOTE> I'm not quite sure what will happen with filehandles.
|
---|
752 |
|
---|
753 | =over 4
|
---|
754 |
|
---|
755 | =item B<is_deeply>
|
---|
756 |
|
---|
757 | is_deeply( $this, $that, $test_name );
|
---|
758 |
|
---|
759 | Similar to is(), except that if $this and $that are references, it
|
---|
760 | does a deep comparison walking each data structure to see if they are
|
---|
761 | equivalent. If the two structures are different, it will display the
|
---|
762 | place where they start differing.
|
---|
763 |
|
---|
764 | is_deeply() compares the dereferenced values of references, the
|
---|
765 | references themselves (except for their type) are ignored. This means
|
---|
766 | aspects such as blessing and ties are not considered "different".
|
---|
767 |
|
---|
768 | is_deeply() current has very limited handling of function reference
|
---|
769 | and globs. It merely checks if they have the same referent. This may
|
---|
770 | improve in the future.
|
---|
771 |
|
---|
772 | Test::Differences and Test::Deep provide more in-depth functionality
|
---|
773 | along these lines.
|
---|
774 |
|
---|
775 | =cut
|
---|
776 |
|
---|
777 | use vars qw(@Data_Stack %Refs_Seen);
|
---|
778 | my $DNE = bless [], 'Does::Not::Exist';
|
---|
779 | sub is_deeply {
|
---|
780 | my $tb = Test::More->builder;
|
---|
781 |
|
---|
782 | unless( @_ == 2 or @_ == 3 ) {
|
---|
783 | my $msg = <<WARNING;
|
---|
784 | is_deeply() takes two or three args, you gave %d.
|
---|
785 | This usually means you passed an array or hash instead
|
---|
786 | of a reference to it
|
---|
787 | WARNING
|
---|
788 | chop $msg; # clip off newline so carp() will put in line/file
|
---|
789 |
|
---|
790 | _carp sprintf $msg, scalar @_;
|
---|
791 |
|
---|
792 | return $tb->ok(0);
|
---|
793 | }
|
---|
794 |
|
---|
795 | my($this, $that, $name) = @_;
|
---|
796 |
|
---|
797 | $tb->_unoverload_str(\$that, \$this);
|
---|
798 |
|
---|
799 | my $ok;
|
---|
800 | if( !ref $this and !ref $that ) { # neither is a reference
|
---|
801 | $ok = $tb->is_eq($this, $that, $name);
|
---|
802 | }
|
---|
803 | elsif( !ref $this xor !ref $that ) { # one's a reference, one isn't
|
---|
804 | $ok = $tb->ok(0, $name);
|
---|
805 | $tb->diag( _format_stack({ vals => [ $this, $that ] }) );
|
---|
806 | }
|
---|
807 | else { # both references
|
---|
808 | local @Data_Stack = ();
|
---|
809 | if( _deep_check($this, $that) ) {
|
---|
810 | $ok = $tb->ok(1, $name);
|
---|
811 | }
|
---|
812 | else {
|
---|
813 | $ok = $tb->ok(0, $name);
|
---|
814 | $tb->diag(_format_stack(@Data_Stack));
|
---|
815 | }
|
---|
816 | }
|
---|
817 |
|
---|
818 | return $ok;
|
---|
819 | }
|
---|
820 |
|
---|
821 | sub _format_stack {
|
---|
822 | my(@Stack) = @_;
|
---|
823 |
|
---|
824 | my $var = '$FOO';
|
---|
825 | my $did_arrow = 0;
|
---|
826 | foreach my $entry (@Stack) {
|
---|
827 | my $type = $entry->{type} || '';
|
---|
828 | my $idx = $entry->{'idx'};
|
---|
829 | if( $type eq 'HASH' ) {
|
---|
830 | $var .= "->" unless $did_arrow++;
|
---|
831 | $var .= "{$idx}";
|
---|
832 | }
|
---|
833 | elsif( $type eq 'ARRAY' ) {
|
---|
834 | $var .= "->" unless $did_arrow++;
|
---|
835 | $var .= "[$idx]";
|
---|
836 | }
|
---|
837 | elsif( $type eq 'REF' ) {
|
---|
838 | $var = "\${$var}";
|
---|
839 | }
|
---|
840 | }
|
---|
841 |
|
---|
842 | my @vals = @{$Stack[-1]{vals}}[0,1];
|
---|
843 | my @vars = ();
|
---|
844 | ($vars[0] = $var) =~ s/\$FOO/ \$got/;
|
---|
845 | ($vars[1] = $var) =~ s/\$FOO/\$expected/;
|
---|
846 |
|
---|
847 | my $out = "Structures begin differing at:\n";
|
---|
848 | foreach my $idx (0..$#vals) {
|
---|
849 | my $val = $vals[$idx];
|
---|
850 | $vals[$idx] = !defined $val ? 'undef' :
|
---|
851 | $val eq $DNE ? "Does not exist" :
|
---|
852 | ref $val ? "$val" :
|
---|
853 | "'$val'";
|
---|
854 | }
|
---|
855 |
|
---|
856 | $out .= "$vars[0] = $vals[0]\n";
|
---|
857 | $out .= "$vars[1] = $vals[1]\n";
|
---|
858 |
|
---|
859 | $out =~ s/^/ /msg;
|
---|
860 | return $out;
|
---|
861 | }
|
---|
862 |
|
---|
863 |
|
---|
864 | sub _type {
|
---|
865 | my $thing = shift;
|
---|
866 |
|
---|
867 | return '' if !ref $thing;
|
---|
868 |
|
---|
869 | for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
|
---|
870 | return $type if UNIVERSAL::isa($thing, $type);
|
---|
871 | }
|
---|
872 |
|
---|
873 | return '';
|
---|
874 | }
|
---|
875 |
|
---|
876 | =back
|
---|
877 |
|
---|
878 |
|
---|
879 | =head2 Diagnostics
|
---|
880 |
|
---|
881 | If you pick the right test function, you'll usually get a good idea of
|
---|
882 | what went wrong when it failed. But sometimes it doesn't work out
|
---|
883 | that way. So here we have ways for you to write your own diagnostic
|
---|
884 | messages which are safer than just C<print STDERR>.
|
---|
885 |
|
---|
886 | =over 4
|
---|
887 |
|
---|
888 | =item B<diag>
|
---|
889 |
|
---|
890 | diag(@diagnostic_message);
|
---|
891 |
|
---|
892 | Prints a diagnostic message which is guaranteed not to interfere with
|
---|
893 | test output. Like C<print> @diagnostic_message is simply concatenated
|
---|
894 | together.
|
---|
895 |
|
---|
896 | Handy for this sort of thing:
|
---|
897 |
|
---|
898 | ok( grep(/foo/, @users), "There's a foo user" ) or
|
---|
899 | diag("Since there's no foo, check that /etc/bar is set up right");
|
---|
900 |
|
---|
901 | which would produce:
|
---|
902 |
|
---|
903 | not ok 42 - There's a foo user
|
---|
904 | # Failed test 'There's a foo user'
|
---|
905 | # in foo.t at line 52.
|
---|
906 | # Since there's no foo, check that /etc/bar is set up right.
|
---|
907 |
|
---|
908 | You might remember C<ok() or diag()> with the mnemonic C<open() or
|
---|
909 | die()>.
|
---|
910 |
|
---|
911 | B<NOTE> The exact formatting of the diagnostic output is still
|
---|
912 | changing, but it is guaranteed that whatever you throw at it it won't
|
---|
913 | interfere with the test.
|
---|
914 |
|
---|
915 | =cut
|
---|
916 |
|
---|
917 | sub diag {
|
---|
918 | my $tb = Test::More->builder;
|
---|
919 |
|
---|
920 | $tb->diag(@_);
|
---|
921 | }
|
---|
922 |
|
---|
923 |
|
---|
924 | =back
|
---|
925 |
|
---|
926 |
|
---|
927 | =head2 Conditional tests
|
---|
928 |
|
---|
929 | Sometimes running a test under certain conditions will cause the
|
---|
930 | test script to die. A certain function or method isn't implemented
|
---|
931 | (such as fork() on MacOS), some resource isn't available (like a
|
---|
932 | net connection) or a module isn't available. In these cases it's
|
---|
933 | necessary to skip tests, or declare that they are supposed to fail
|
---|
934 | but will work in the future (a todo test).
|
---|
935 |
|
---|
936 | For more details on the mechanics of skip and todo tests see
|
---|
937 | L<Test::Harness>.
|
---|
938 |
|
---|
939 | The way Test::More handles this is with a named block. Basically, a
|
---|
940 | block of tests which can be skipped over or made todo. It's best if I
|
---|
941 | just show you...
|
---|
942 |
|
---|
943 | =over 4
|
---|
944 |
|
---|
945 | =item B<SKIP: BLOCK>
|
---|
946 |
|
---|
947 | SKIP: {
|
---|
948 | skip $why, $how_many if $condition;
|
---|
949 |
|
---|
950 | ...normal testing code goes here...
|
---|
951 | }
|
---|
952 |
|
---|
953 | This declares a block of tests that might be skipped, $how_many tests
|
---|
954 | there are, $why and under what $condition to skip them. An example is
|
---|
955 | the easiest way to illustrate:
|
---|
956 |
|
---|
957 | SKIP: {
|
---|
958 | eval { require HTML::Lint };
|
---|
959 |
|
---|
960 | skip "HTML::Lint not installed", 2 if $@;
|
---|
961 |
|
---|
962 | my $lint = new HTML::Lint;
|
---|
963 | isa_ok( $lint, "HTML::Lint" );
|
---|
964 |
|
---|
965 | $lint->parse( $html );
|
---|
966 | is( $lint->errors, 0, "No errors found in HTML" );
|
---|
967 | }
|
---|
968 |
|
---|
969 | If the user does not have HTML::Lint installed, the whole block of
|
---|
970 | code I<won't be run at all>. Test::More will output special ok's
|
---|
971 | which Test::Harness interprets as skipped, but passing, tests.
|
---|
972 |
|
---|
973 | It's important that $how_many accurately reflects the number of tests
|
---|
974 | in the SKIP block so the # of tests run will match up with your plan.
|
---|
975 | If your plan is C<no_plan> $how_many is optional and will default to 1.
|
---|
976 |
|
---|
977 | It's perfectly safe to nest SKIP blocks. Each SKIP block must have
|
---|
978 | the label C<SKIP>, or Test::More can't work its magic.
|
---|
979 |
|
---|
980 | You don't skip tests which are failing because there's a bug in your
|
---|
981 | program, or for which you don't yet have code written. For that you
|
---|
982 | use TODO. Read on.
|
---|
983 |
|
---|
984 | =cut
|
---|
985 |
|
---|
986 | #'#
|
---|
987 | sub skip {
|
---|
988 | my($why, $how_many) = @_;
|
---|
989 | my $tb = Test::More->builder;
|
---|
990 |
|
---|
991 | unless( defined $how_many ) {
|
---|
992 | # $how_many can only be avoided when no_plan is in use.
|
---|
993 | _carp "skip() needs to know \$how_many tests are in the block"
|
---|
994 | unless $tb->has_plan eq 'no_plan';
|
---|
995 | $how_many = 1;
|
---|
996 | }
|
---|
997 |
|
---|
998 | for( 1..$how_many ) {
|
---|
999 | $tb->skip($why);
|
---|
1000 | }
|
---|
1001 |
|
---|
1002 | local $^W = 0;
|
---|
1003 | last SKIP;
|
---|
1004 | }
|
---|
1005 |
|
---|
1006 |
|
---|
1007 | =item B<TODO: BLOCK>
|
---|
1008 |
|
---|
1009 | TODO: {
|
---|
1010 | local $TODO = $why if $condition;
|
---|
1011 |
|
---|
1012 | ...normal testing code goes here...
|
---|
1013 | }
|
---|
1014 |
|
---|
1015 | Declares a block of tests you expect to fail and $why. Perhaps it's
|
---|
1016 | because you haven't fixed a bug or haven't finished a new feature:
|
---|
1017 |
|
---|
1018 | TODO: {
|
---|
1019 | local $TODO = "URI::Geller not finished";
|
---|
1020 |
|
---|
1021 | my $card = "Eight of clubs";
|
---|
1022 | is( URI::Geller->your_card, $card, 'Is THIS your card?' );
|
---|
1023 |
|
---|
1024 | my $spoon;
|
---|
1025 | URI::Geller->bend_spoon;
|
---|
1026 | is( $spoon, 'bent', "Spoon bending, that's original" );
|
---|
1027 | }
|
---|
1028 |
|
---|
1029 | With a todo block, the tests inside are expected to fail. Test::More
|
---|
1030 | will run the tests normally, but print out special flags indicating
|
---|
1031 | they are "todo". Test::Harness will interpret failures as being ok.
|
---|
1032 | Should anything succeed, it will report it as an unexpected success.
|
---|
1033 | You then know the thing you had todo is done and can remove the
|
---|
1034 | TODO flag.
|
---|
1035 |
|
---|
1036 | The nice part about todo tests, as opposed to simply commenting out a
|
---|
1037 | block of tests, is it's like having a programmatic todo list. You know
|
---|
1038 | how much work is left to be done, you're aware of what bugs there are,
|
---|
1039 | and you'll know immediately when they're fixed.
|
---|
1040 |
|
---|
1041 | Once a todo test starts succeeding, simply move it outside the block.
|
---|
1042 | When the block is empty, delete it.
|
---|
1043 |
|
---|
1044 | B<NOTE>: TODO tests require a Test::Harness upgrade else it will
|
---|
1045 | treat it as a normal failure. See L<CAVEATS and NOTES>).
|
---|
1046 |
|
---|
1047 |
|
---|
1048 | =item B<todo_skip>
|
---|
1049 |
|
---|
1050 | TODO: {
|
---|
1051 | todo_skip $why, $how_many if $condition;
|
---|
1052 |
|
---|
1053 | ...normal testing code...
|
---|
1054 | }
|
---|
1055 |
|
---|
1056 | With todo tests, it's best to have the tests actually run. That way
|
---|
1057 | you'll know when they start passing. Sometimes this isn't possible.
|
---|
1058 | Often a failing test will cause the whole program to die or hang, even
|
---|
1059 | inside an C<eval BLOCK> with and using C<alarm>. In these extreme
|
---|
1060 | cases you have no choice but to skip over the broken tests entirely.
|
---|
1061 |
|
---|
1062 | The syntax and behavior is similar to a C<SKIP: BLOCK> except the
|
---|
1063 | tests will be marked as failing but todo. Test::Harness will
|
---|
1064 | interpret them as passing.
|
---|
1065 |
|
---|
1066 | =cut
|
---|
1067 |
|
---|
1068 | sub todo_skip {
|
---|
1069 | my($why, $how_many) = @_;
|
---|
1070 | my $tb = Test::More->builder;
|
---|
1071 |
|
---|
1072 | unless( defined $how_many ) {
|
---|
1073 | # $how_many can only be avoided when no_plan is in use.
|
---|
1074 | _carp "todo_skip() needs to know \$how_many tests are in the block"
|
---|
1075 | unless $tb->has_plan eq 'no_plan';
|
---|
1076 | $how_many = 1;
|
---|
1077 | }
|
---|
1078 |
|
---|
1079 | for( 1..$how_many ) {
|
---|
1080 | $tb->todo_skip($why);
|
---|
1081 | }
|
---|
1082 |
|
---|
1083 | local $^W = 0;
|
---|
1084 | last TODO;
|
---|
1085 | }
|
---|
1086 |
|
---|
1087 | =item When do I use SKIP vs. TODO?
|
---|
1088 |
|
---|
1089 | B<If it's something the user might not be able to do>, use SKIP.
|
---|
1090 | This includes optional modules that aren't installed, running under
|
---|
1091 | an OS that doesn't have some feature (like fork() or symlinks), or maybe
|
---|
1092 | you need an Internet connection and one isn't available.
|
---|
1093 |
|
---|
1094 | B<If it's something the programmer hasn't done yet>, use TODO. This
|
---|
1095 | is for any code you haven't written yet, or bugs you have yet to fix,
|
---|
1096 | but want to put tests in your testing script (always a good idea).
|
---|
1097 |
|
---|
1098 |
|
---|
1099 | =back
|
---|
1100 |
|
---|
1101 |
|
---|
1102 | =head2 Test control
|
---|
1103 |
|
---|
1104 | =over 4
|
---|
1105 |
|
---|
1106 | =item B<BAIL_OUT>
|
---|
1107 |
|
---|
1108 | BAIL_OUT($reason);
|
---|
1109 |
|
---|
1110 | Incidates to the harness that things are going so badly all testing
|
---|
1111 | should terminate. This includes the running any additional test scripts.
|
---|
1112 |
|
---|
1113 | This is typically used when testing cannot continue such as a critical
|
---|
1114 | module failing to compile or a necessary external utility not being
|
---|
1115 | available such as a database connection failing.
|
---|
1116 |
|
---|
1117 | The test will exit with 255.
|
---|
1118 |
|
---|
1119 | =cut
|
---|
1120 |
|
---|
1121 | sub BAIL_OUT {
|
---|
1122 | my $reason = shift;
|
---|
1123 | my $tb = Test::More->builder;
|
---|
1124 |
|
---|
1125 | $tb->BAIL_OUT($reason);
|
---|
1126 | }
|
---|
1127 |
|
---|
1128 | =back
|
---|
1129 |
|
---|
1130 |
|
---|
1131 | =head2 Discouraged comparison functions
|
---|
1132 |
|
---|
1133 | The use of the following functions is discouraged as they are not
|
---|
1134 | actually testing functions and produce no diagnostics to help figure
|
---|
1135 | out what went wrong. They were written before is_deeply() existed
|
---|
1136 | because I couldn't figure out how to display a useful diff of two
|
---|
1137 | arbitrary data structures.
|
---|
1138 |
|
---|
1139 | These functions are usually used inside an ok().
|
---|
1140 |
|
---|
1141 | ok( eq_array(\@this, \@that) );
|
---|
1142 |
|
---|
1143 | C<is_deeply()> can do that better and with diagnostics.
|
---|
1144 |
|
---|
1145 | is_deeply( \@this, \@that );
|
---|
1146 |
|
---|
1147 | They may be deprecated in future versions.
|
---|
1148 |
|
---|
1149 | =over 4
|
---|
1150 |
|
---|
1151 | =item B<eq_array>
|
---|
1152 |
|
---|
1153 | my $is_eq = eq_array(\@this, \@that);
|
---|
1154 |
|
---|
1155 | Checks if two arrays are equivalent. This is a deep check, so
|
---|
1156 | multi-level structures are handled correctly.
|
---|
1157 |
|
---|
1158 | =cut
|
---|
1159 |
|
---|
1160 | #'#
|
---|
1161 | sub eq_array {
|
---|
1162 | local @Data_Stack;
|
---|
1163 | _deep_check(@_);
|
---|
1164 | }
|
---|
1165 |
|
---|
1166 | sub _eq_array {
|
---|
1167 | my($a1, $a2) = @_;
|
---|
1168 |
|
---|
1169 | if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
|
---|
1170 | warn "eq_array passed a non-array ref";
|
---|
1171 | return 0;
|
---|
1172 | }
|
---|
1173 |
|
---|
1174 | return 1 if $a1 eq $a2;
|
---|
1175 |
|
---|
1176 | my $ok = 1;
|
---|
1177 | my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
|
---|
1178 | for (0..$max) {
|
---|
1179 | my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
|
---|
1180 | my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
|
---|
1181 |
|
---|
1182 | push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
|
---|
1183 | $ok = _deep_check($e1,$e2);
|
---|
1184 | pop @Data_Stack if $ok;
|
---|
1185 |
|
---|
1186 | last unless $ok;
|
---|
1187 | }
|
---|
1188 |
|
---|
1189 | return $ok;
|
---|
1190 | }
|
---|
1191 |
|
---|
1192 | sub _deep_check {
|
---|
1193 | my($e1, $e2) = @_;
|
---|
1194 | my $tb = Test::More->builder;
|
---|
1195 |
|
---|
1196 | my $ok = 0;
|
---|
1197 |
|
---|
1198 | # Effectively turn %Refs_Seen into a stack. This avoids picking up
|
---|
1199 | # the same referenced used twice (such as [\$a, \$a]) to be considered
|
---|
1200 | # circular.
|
---|
1201 | local %Refs_Seen = %Refs_Seen;
|
---|
1202 |
|
---|
1203 | {
|
---|
1204 | # Quiet uninitialized value warnings when comparing undefs.
|
---|
1205 | local $^W = 0;
|
---|
1206 |
|
---|
1207 | $tb->_unoverload_str(\$e1, \$e2);
|
---|
1208 |
|
---|
1209 | # Either they're both references or both not.
|
---|
1210 | my $same_ref = !(!ref $e1 xor !ref $e2);
|
---|
1211 | my $not_ref = (!ref $e1 and !ref $e2);
|
---|
1212 |
|
---|
1213 | if( defined $e1 xor defined $e2 ) {
|
---|
1214 | $ok = 0;
|
---|
1215 | }
|
---|
1216 | elsif ( $e1 == $DNE xor $e2 == $DNE ) {
|
---|
1217 | $ok = 0;
|
---|
1218 | }
|
---|
1219 | elsif ( $same_ref and ($e1 eq $e2) ) {
|
---|
1220 | $ok = 1;
|
---|
1221 | }
|
---|
1222 | elsif ( $not_ref ) {
|
---|
1223 | push @Data_Stack, { type => '', vals => [$e1, $e2] };
|
---|
1224 | $ok = 0;
|
---|
1225 | }
|
---|
1226 | else {
|
---|
1227 | if( $Refs_Seen{$e1} ) {
|
---|
1228 | return $Refs_Seen{$e1} eq $e2;
|
---|
1229 | }
|
---|
1230 | else {
|
---|
1231 | $Refs_Seen{$e1} = "$e2";
|
---|
1232 | }
|
---|
1233 |
|
---|
1234 | my $type = _type($e1);
|
---|
1235 | $type = 'DIFFERENT' unless _type($e2) eq $type;
|
---|
1236 |
|
---|
1237 | if( $type eq 'DIFFERENT' ) {
|
---|
1238 | push @Data_Stack, { type => $type, vals => [$e1, $e2] };
|
---|
1239 | $ok = 0;
|
---|
1240 | }
|
---|
1241 | elsif( $type eq 'ARRAY' ) {
|
---|
1242 | $ok = _eq_array($e1, $e2);
|
---|
1243 | }
|
---|
1244 | elsif( $type eq 'HASH' ) {
|
---|
1245 | $ok = _eq_hash($e1, $e2);
|
---|
1246 | }
|
---|
1247 | elsif( $type eq 'REF' ) {
|
---|
1248 | push @Data_Stack, { type => $type, vals => [$e1, $e2] };
|
---|
1249 | $ok = _deep_check($$e1, $$e2);
|
---|
1250 | pop @Data_Stack if $ok;
|
---|
1251 | }
|
---|
1252 | elsif( $type eq 'SCALAR' ) {
|
---|
1253 | push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
|
---|
1254 | $ok = _deep_check($$e1, $$e2);
|
---|
1255 | pop @Data_Stack if $ok;
|
---|
1256 | }
|
---|
1257 | elsif( $type ) {
|
---|
1258 | push @Data_Stack, { type => $type, vals => [$e1, $e2] };
|
---|
1259 | $ok = 0;
|
---|
1260 | }
|
---|
1261 | else {
|
---|
1262 | _whoa(1, "No type in _deep_check");
|
---|
1263 | }
|
---|
1264 | }
|
---|
1265 | }
|
---|
1266 |
|
---|
1267 | return $ok;
|
---|
1268 | }
|
---|
1269 |
|
---|
1270 |
|
---|
1271 | sub _whoa {
|
---|
1272 | my($check, $desc) = @_;
|
---|
1273 | if( $check ) {
|
---|
1274 | die <<WHOA;
|
---|
1275 | WHOA! $desc
|
---|
1276 | This should never happen! Please contact the author immediately!
|
---|
1277 | WHOA
|
---|
1278 | }
|
---|
1279 | }
|
---|
1280 |
|
---|
1281 |
|
---|
1282 | =item B<eq_hash>
|
---|
1283 |
|
---|
1284 | my $is_eq = eq_hash(\%this, \%that);
|
---|
1285 |
|
---|
1286 | Determines if the two hashes contain the same keys and values. This
|
---|
1287 | is a deep check.
|
---|
1288 |
|
---|
1289 | =cut
|
---|
1290 |
|
---|
1291 | sub eq_hash {
|
---|
1292 | local @Data_Stack;
|
---|
1293 | return _deep_check(@_);
|
---|
1294 | }
|
---|
1295 |
|
---|
1296 | sub _eq_hash {
|
---|
1297 | my($a1, $a2) = @_;
|
---|
1298 |
|
---|
1299 | if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
|
---|
1300 | warn "eq_hash passed a non-hash ref";
|
---|
1301 | return 0;
|
---|
1302 | }
|
---|
1303 |
|
---|
1304 | return 1 if $a1 eq $a2;
|
---|
1305 |
|
---|
1306 | my $ok = 1;
|
---|
1307 | my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
|
---|
1308 | foreach my $k (keys %$bigger) {
|
---|
1309 | my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
|
---|
1310 | my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
|
---|
1311 |
|
---|
1312 | push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
|
---|
1313 | $ok = _deep_check($e1, $e2);
|
---|
1314 | pop @Data_Stack if $ok;
|
---|
1315 |
|
---|
1316 | last unless $ok;
|
---|
1317 | }
|
---|
1318 |
|
---|
1319 | return $ok;
|
---|
1320 | }
|
---|
1321 |
|
---|
1322 | =item B<eq_set>
|
---|
1323 |
|
---|
1324 | my $is_eq = eq_set(\@this, \@that);
|
---|
1325 |
|
---|
1326 | Similar to eq_array(), except the order of the elements is B<not>
|
---|
1327 | important. This is a deep check, but the irrelevancy of order only
|
---|
1328 | applies to the top level.
|
---|
1329 |
|
---|
1330 | ok( eq_set(\@this, \@that) );
|
---|
1331 |
|
---|
1332 | Is better written:
|
---|
1333 |
|
---|
1334 | is_deeply( [sort @this], [sort @that] );
|
---|
1335 |
|
---|
1336 | B<NOTE> By historical accident, this is not a true set comparison.
|
---|
1337 | While the order of elements does not matter, duplicate elements do.
|
---|
1338 |
|
---|
1339 | B<NOTE> eq_set() does not know how to deal with references at the top
|
---|
1340 | level. The following is an example of a comparison which might not work:
|
---|
1341 |
|
---|
1342 | eq_set([\1, \2], [\2, \1]);
|
---|
1343 |
|
---|
1344 | Test::Deep contains much better set comparison functions.
|
---|
1345 |
|
---|
1346 | =cut
|
---|
1347 |
|
---|
1348 | sub eq_set {
|
---|
1349 | my($a1, $a2) = @_;
|
---|
1350 | return 0 unless @$a1 == @$a2;
|
---|
1351 |
|
---|
1352 | # There's faster ways to do this, but this is easiest.
|
---|
1353 | local $^W = 0;
|
---|
1354 |
|
---|
1355 | # It really doesn't matter how we sort them, as long as both arrays are
|
---|
1356 | # sorted with the same algorithm.
|
---|
1357 | #
|
---|
1358 | # Ensure that references are not accidentally treated the same as a
|
---|
1359 | # string containing the reference.
|
---|
1360 | #
|
---|
1361 | # Have to inline the sort routine due to a threading/sort bug.
|
---|
1362 | # See [rt.cpan.org 6782]
|
---|
1363 | #
|
---|
1364 | # I don't know how references would be sorted so we just don't sort
|
---|
1365 | # them. This means eq_set doesn't really work with refs.
|
---|
1366 | return eq_array(
|
---|
1367 | [grep(ref, @$a1), sort( grep(!ref, @$a1) )],
|
---|
1368 | [grep(ref, @$a2), sort( grep(!ref, @$a2) )],
|
---|
1369 | );
|
---|
1370 | }
|
---|
1371 |
|
---|
1372 | =back
|
---|
1373 |
|
---|
1374 |
|
---|
1375 | =head2 Extending and Embedding Test::More
|
---|
1376 |
|
---|
1377 | Sometimes the Test::More interface isn't quite enough. Fortunately,
|
---|
1378 | Test::More is built on top of Test::Builder which provides a single,
|
---|
1379 | unified backend for any test library to use. This means two test
|
---|
1380 | libraries which both use Test::Builder B<can be used together in the
|
---|
1381 | same program>.
|
---|
1382 |
|
---|
1383 | If you simply want to do a little tweaking of how the tests behave,
|
---|
1384 | you can access the underlying Test::Builder object like so:
|
---|
1385 |
|
---|
1386 | =over 4
|
---|
1387 |
|
---|
1388 | =item B<builder>
|
---|
1389 |
|
---|
1390 | my $test_builder = Test::More->builder;
|
---|
1391 |
|
---|
1392 | Returns the Test::Builder object underlying Test::More for you to play
|
---|
1393 | with.
|
---|
1394 |
|
---|
1395 |
|
---|
1396 | =back
|
---|
1397 |
|
---|
1398 |
|
---|
1399 | =head1 EXIT CODES
|
---|
1400 |
|
---|
1401 | If all your tests passed, Test::Builder will exit with zero (which is
|
---|
1402 | normal). If anything failed it will exit with how many failed. If
|
---|
1403 | you run less (or more) tests than you planned, the missing (or extras)
|
---|
1404 | will be considered failures. If no tests were ever run Test::Builder
|
---|
1405 | will throw a warning and exit with 255. If the test died, even after
|
---|
1406 | having successfully completed all its tests, it will still be
|
---|
1407 | considered a failure and will exit with 255.
|
---|
1408 |
|
---|
1409 | So the exit codes are...
|
---|
1410 |
|
---|
1411 | 0 all tests successful
|
---|
1412 | 255 test died or all passed but wrong # of tests run
|
---|
1413 | any other number how many failed (including missing or extras)
|
---|
1414 |
|
---|
1415 | If you fail more than 254 tests, it will be reported as 254.
|
---|
1416 |
|
---|
1417 | B<NOTE> This behavior may go away in future versions.
|
---|
1418 |
|
---|
1419 |
|
---|
1420 | =head1 CAVEATS and NOTES
|
---|
1421 |
|
---|
1422 | =over 4
|
---|
1423 |
|
---|
1424 | =item Backwards compatibility
|
---|
1425 |
|
---|
1426 | Test::More works with Perls as old as 5.004_05.
|
---|
1427 |
|
---|
1428 |
|
---|
1429 | =item Overloaded objects
|
---|
1430 |
|
---|
1431 | String overloaded objects are compared B<as strings> (or in cmp_ok()'s
|
---|
1432 | case, strings or numbers as appropriate to the comparison op). This
|
---|
1433 | prevents Test::More from piercing an object's interface allowing
|
---|
1434 | better blackbox testing. So if a function starts returning overloaded
|
---|
1435 | objects instead of bare strings your tests won't notice the
|
---|
1436 | difference. This is good.
|
---|
1437 |
|
---|
1438 | However, it does mean that functions like is_deeply() cannot be used to
|
---|
1439 | test the internals of string overloaded objects. In this case I would
|
---|
1440 | suggest Test::Deep which contains more flexible testing functions for
|
---|
1441 | complex data structures.
|
---|
1442 |
|
---|
1443 |
|
---|
1444 | =item Threads
|
---|
1445 |
|
---|
1446 | Test::More will only be aware of threads if "use threads" has been done
|
---|
1447 | I<before> Test::More is loaded. This is ok:
|
---|
1448 |
|
---|
1449 | use threads;
|
---|
1450 | use Test::More;
|
---|
1451 |
|
---|
1452 | This may cause problems:
|
---|
1453 |
|
---|
1454 | use Test::More
|
---|
1455 | use threads;
|
---|
1456 |
|
---|
1457 |
|
---|
1458 | =item Test::Harness upgrade
|
---|
1459 |
|
---|
1460 | no_plan and todo depend on new Test::Harness features and fixes. If
|
---|
1461 | you're going to distribute tests that use no_plan or todo your
|
---|
1462 | end-users will have to upgrade Test::Harness to the latest one on
|
---|
1463 | CPAN. If you avoid no_plan and TODO tests, the stock Test::Harness
|
---|
1464 | will work fine.
|
---|
1465 |
|
---|
1466 | Installing Test::More should also upgrade Test::Harness.
|
---|
1467 |
|
---|
1468 | =back
|
---|
1469 |
|
---|
1470 |
|
---|
1471 | =head1 HISTORY
|
---|
1472 |
|
---|
1473 | This is a case of convergent evolution with Joshua Pritikin's Test
|
---|
1474 | module. I was largely unaware of its existence when I'd first
|
---|
1475 | written my own ok() routines. This module exists because I can't
|
---|
1476 | figure out how to easily wedge test names into Test's interface (along
|
---|
1477 | with a few other problems).
|
---|
1478 |
|
---|
1479 | The goal here is to have a testing utility that's simple to learn,
|
---|
1480 | quick to use and difficult to trip yourself up with while still
|
---|
1481 | providing more flexibility than the existing Test.pm. As such, the
|
---|
1482 | names of the most common routines are kept tiny, special cases and
|
---|
1483 | magic side-effects are kept to a minimum. WYSIWYG.
|
---|
1484 |
|
---|
1485 |
|
---|
1486 | =head1 SEE ALSO
|
---|
1487 |
|
---|
1488 | L<Test::Simple> if all this confuses you and you just want to write
|
---|
1489 | some tests. You can upgrade to Test::More later (it's forward
|
---|
1490 | compatible).
|
---|
1491 |
|
---|
1492 | L<Test> is the old testing module. Its main benefit is that it has
|
---|
1493 | been distributed with Perl since 5.004_05.
|
---|
1494 |
|
---|
1495 | L<Test::Harness> for details on how your test results are interpreted
|
---|
1496 | by Perl.
|
---|
1497 |
|
---|
1498 | L<Test::Differences> for more ways to test complex data structures.
|
---|
1499 | And it plays well with Test::More.
|
---|
1500 |
|
---|
1501 | L<Test::Class> is like XUnit but more perlish.
|
---|
1502 |
|
---|
1503 | L<Test::Deep> gives you more powerful complex data structure testing.
|
---|
1504 |
|
---|
1505 | L<Test::Unit> is XUnit style testing.
|
---|
1506 |
|
---|
1507 | L<Test::Inline> shows the idea of embedded testing.
|
---|
1508 |
|
---|
1509 | L<Bundle::Test> installs a whole bunch of useful test modules.
|
---|
1510 |
|
---|
1511 |
|
---|
1512 | =head1 AUTHORS
|
---|
1513 |
|
---|
1514 | Michael G Schwern E<lt>[email protected]<gt> with much inspiration
|
---|
1515 | from Joshua Pritikin's Test module and lots of help from Barrie
|
---|
1516 | Slaymaker, Tony Bowden, blackstar.co.uk, chromatic, Fergal Daly and
|
---|
1517 | the perl-qa gang.
|
---|
1518 |
|
---|
1519 |
|
---|
1520 | =head1 BUGS
|
---|
1521 |
|
---|
1522 | See F<http://rt.cpan.org> to report and view bugs.
|
---|
1523 |
|
---|
1524 |
|
---|
1525 | =head1 COPYRIGHT
|
---|
1526 |
|
---|
1527 | Copyright 2001, 2002, 2004 by Michael G Schwern E<lt>[email protected]<gt>.
|
---|
1528 |
|
---|
1529 | This program is free software; you can redistribute it and/or
|
---|
1530 | modify it under the same terms as Perl itself.
|
---|
1531 |
|
---|
1532 | See F<http://www.perl.com/perl/misc/Artistic.html>
|
---|
1533 |
|
---|
1534 | =cut
|
---|
1535 |
|
---|
1536 | 1;
|
---|