Commit | Line | Data |
---|---|---|
920dae64 AT |
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>schwern@pobox.comE<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>schwern@pobox.comE<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; |