Commit | Line | Data |
---|---|---|
3f2ec160 JH |
1 | package Test::More; |
2 | ||
d020a79a | 3 | use 5.004; |
3f2ec160 | 4 | |
d020a79a | 5 | use strict; |
33459055 | 6 | use Test::Builder; |
3f2ec160 | 7 | |
33459055 MS |
8 | |
9 | # Can't use Carp because it might cause use_ok() to accidentally succeed | |
10 | # even though the module being used forgot to use Carp. Yes, this | |
11 | # actually happened. | |
12 | sub _carp { | |
13 | my($file, $line) = (caller(1))[1,2]; | |
14 | warn @_, sprintf " at $file line $line\n"; | |
3f2ec160 JH |
15 | } |
16 | ||
33459055 MS |
17 | |
18 | ||
3f2ec160 | 19 | require Exporter; |
33459055 MS |
20 | use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); |
21 | $VERSION = '0.32'; | |
3f2ec160 JH |
22 | @ISA = qw(Exporter); |
23 | @EXPORT = qw(ok use_ok require_ok | |
33459055 | 24 | is isnt like is_deeply |
3f2ec160 JH |
25 | skip todo |
26 | pass fail | |
27 | eq_array eq_hash eq_set | |
d020a79a JH |
28 | $TODO |
29 | plan | |
30 | can_ok isa_ok | |
3f2ec160 JH |
31 | ); |
32 | ||
33459055 | 33 | my $Test = Test::Builder->new; |
3f2ec160 | 34 | |
3f2ec160 JH |
35 | |
36 | # 5.004's Exporter doesn't have export_to_level. | |
37 | sub _export_to_level | |
38 | { | |
39 | my $pkg = shift; | |
40 | my $level = shift; | |
41 | (undef) = shift; # XXX redundant arg | |
42 | my $callpkg = caller($level); | |
43 | $pkg->export($callpkg, @_); | |
44 | } | |
45 | ||
46 | ||
47 | =head1 NAME | |
48 | ||
49 | Test::More - yet another framework for writing test scripts | |
50 | ||
51 | =head1 SYNOPSIS | |
52 | ||
53 | use Test::More tests => $Num_Tests; | |
54 | # or | |
55 | use Test::More qw(no_plan); | |
56 | # or | |
d020a79a | 57 | use Test::More skip_all => $reason; |
3f2ec160 JH |
58 | |
59 | BEGIN { use_ok( 'Some::Module' ); } | |
60 | require_ok( 'Some::Module' ); | |
61 | ||
62 | # Various ways to say "ok" | |
63 | ok($this eq $that, $test_name); | |
64 | ||
65 | is ($this, $that, $test_name); | |
66 | isnt($this, $that, $test_name); | |
67 | like($this, qr/that/, $test_name); | |
68 | ||
33459055 MS |
69 | is_deeply($complex_structure1, $complex_structure2, $test_name); |
70 | ||
d020a79a JH |
71 | SKIP: { |
72 | skip $why, $how_many unless $have_some_feature; | |
73 | ||
3f2ec160 JH |
74 | ok( foo(), $test_name ); |
75 | is( foo(42), 23, $test_name ); | |
d020a79a JH |
76 | }; |
77 | ||
78 | TODO: { | |
79 | local $TODO = $why; | |
3f2ec160 | 80 | |
3f2ec160 JH |
81 | ok( foo(), $test_name ); |
82 | is( foo(42), 23, $test_name ); | |
d020a79a JH |
83 | }; |
84 | ||
85 | can_ok($module, @methods); | |
86 | isa_ok($object, $class); | |
3f2ec160 JH |
87 | |
88 | pass($test_name); | |
89 | fail($test_name); | |
90 | ||
91 | # Utility comparison functions. | |
92 | eq_array(\@this, \@that); | |
93 | eq_hash(\%this, \%that); | |
94 | eq_set(\@this, \@that); | |
95 | ||
96 | # UNIMPLEMENTED!!! | |
97 | my @status = Test::More::status; | |
98 | ||
d020a79a JH |
99 | # UNIMPLEMENTED!!! |
100 | BAIL_OUT($why); | |
101 | ||
3f2ec160 JH |
102 | |
103 | =head1 DESCRIPTION | |
104 | ||
105 | If you're just getting started writing tests, have a look at | |
d020a79a JH |
106 | Test::Simple first. This is a drop in replacement for Test::Simple |
107 | which you can switch to once you get the hang of basic testing. | |
3f2ec160 JH |
108 | |
109 | This module provides a very wide range of testing utilities. Various | |
110 | ways to say "ok", facilities to skip tests, test future features | |
111 | and compare complicated data structures. | |
112 | ||
113 | ||
114 | =head2 I love it when a plan comes together | |
115 | ||
116 | Before anything else, you need a testing plan. This basically declares | |
117 | how many tests your script is going to run to protect against premature | |
118 | failure. | |
119 | ||
120 | The prefered way to do this is to declare a plan when you C<use Test::More>. | |
121 | ||
122 | use Test::More tests => $Num_Tests; | |
123 | ||
124 | There are rare cases when you will not know beforehand how many tests | |
125 | your script is going to run. In this case, you can declare that you | |
126 | have no plan. (Try to avoid using this as it weakens your test.) | |
127 | ||
128 | use Test::More qw(no_plan); | |
129 | ||
130 | In some cases, you'll want to completely skip an entire testing script. | |
131 | ||
d020a79a | 132 | use Test::More skip_all => $skip_reason; |
3f2ec160 | 133 | |
d020a79a JH |
134 | Your script will declare a skip with the reason why you skipped and |
135 | exit immediately with a zero (success). See L<Test::Harness> for | |
136 | details. | |
3f2ec160 | 137 | |
33459055 MS |
138 | If you want to control what functions Test::More will export, you |
139 | have to use the 'import' option. For example, to import everything | |
140 | but 'fail', you'd do: | |
141 | ||
142 | use Test::More tests => 23, import => ['!fail']; | |
143 | ||
144 | Alternatively, you can use the plan() function. Useful for when you | |
145 | have to calculate the number of tests. | |
146 | ||
147 | use Test::More; | |
148 | plan tests => keys %Stuff * 3; | |
149 | ||
150 | or for deciding between running the tests at all: | |
151 | ||
152 | use Test::More; | |
153 | if( $^O eq 'MacOS' ) { | |
154 | plan skip_all => 'Test irrelevent on MacOS'; | |
155 | } | |
156 | else { | |
157 | plan tests => 42; | |
158 | } | |
159 | ||
160 | =cut | |
161 | ||
162 | sub plan { | |
163 | my(@plan) = @_; | |
164 | ||
165 | my $caller = caller; | |
166 | ||
167 | $Test->exported_to($caller); | |
168 | $Test->plan(@plan); | |
169 | ||
170 | my @imports = (); | |
171 | foreach my $idx (0..$#plan) { | |
172 | if( $plan[$idx] eq 'import' ) { | |
173 | @imports = @{$plan[$idx+1]}; | |
174 | last; | |
175 | } | |
176 | } | |
177 | ||
178 | __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); | |
179 | } | |
180 | ||
181 | sub import { | |
182 | my($class) = shift; | |
183 | goto &plan; | |
184 | } | |
185 | ||
3f2ec160 JH |
186 | |
187 | =head2 Test names | |
188 | ||
189 | By convention, each test is assigned a number in order. This is | |
190 | largely done automatically for you. However, its often very useful to | |
191 | assign a name to each test. Which would you rather see: | |
192 | ||
193 | ok 4 | |
194 | not ok 5 | |
195 | ok 6 | |
196 | ||
197 | or | |
198 | ||
199 | ok 4 - basic multi-variable | |
200 | not ok 5 - simple exponential | |
201 | ok 6 - force == mass * acceleration | |
202 | ||
203 | The later gives you some idea of what failed. It also makes it easier | |
204 | to find the test in your script, simply search for "simple | |
205 | exponential". | |
206 | ||
207 | All test functions take a name argument. Its optional, but highly | |
208 | suggested that you use it. | |
209 | ||
210 | ||
211 | =head2 I'm ok, you're not ok. | |
212 | ||
213 | The basic purpose of this module is to print out either "ok #" or "not | |
214 | ok #" depending on if a given test succeeded or failed. Everything | |
215 | else is just gravy. | |
216 | ||
217 | All of the following print "ok" or "not ok" depending on if the test | |
218 | succeeded or failed. They all also return true or false, | |
219 | respectively. | |
220 | ||
221 | =over 4 | |
222 | ||
223 | =item B<ok> | |
224 | ||
225 | ok($this eq $that, $test_name); | |
226 | ||
227 | This simply evaluates any expression (C<$this eq $that> is just a | |
228 | simple example) and uses that to determine if the test succeeded or | |
229 | failed. A true expression passes, a false one fails. Very simple. | |
230 | ||
231 | For example: | |
232 | ||
233 | ok( $exp{9} == 81, 'simple exponential' ); | |
234 | ok( Film->can('db_Main'), 'set_db()' ); | |
235 | ok( $p->tests == 4, 'saw tests' ); | |
236 | ok( !grep !defined $_, @items, 'items populated' ); | |
237 | ||
238 | (Mnemonic: "This is ok.") | |
239 | ||
240 | $test_name is a very short description of the test that will be printed | |
241 | out. It makes it very easy to find a test in your script when it fails | |
242 | and gives others an idea of your intentions. $test_name is optional, | |
243 | but we B<very> strongly encourage its use. | |
244 | ||
245 | Should an ok() fail, it will produce some diagnostics: | |
246 | ||
247 | not ok 18 - sufficient mucus | |
248 | # Failed test 18 (foo.t at line 42) | |
249 | ||
250 | This is actually Test::Simple's ok() routine. | |
251 | ||
252 | =cut | |
253 | ||
33459055 MS |
254 | sub ok ($;$) { |
255 | my($test, $name) = @_; | |
256 | $Test->ok($test, $name); | |
257 | } | |
3f2ec160 JH |
258 | |
259 | =item B<is> | |
260 | ||
261 | =item B<isnt> | |
262 | ||
263 | is ( $this, $that, $test_name ); | |
264 | isnt( $this, $that, $test_name ); | |
265 | ||
d020a79a JH |
266 | Similar to ok(), is() and isnt() compare their two arguments |
267 | with C<eq> and C<ne> respectively and use the result of that to | |
268 | determine if the test succeeded or failed. So these: | |
3f2ec160 JH |
269 | |
270 | # Is the ultimate answer 42? | |
271 | is( ultimate_answer(), 42, "Meaning of Life" ); | |
272 | ||
273 | # $foo isn't empty | |
274 | isnt( $foo, '', "Got some foo" ); | |
275 | ||
276 | are similar to these: | |
277 | ||
278 | ok( ultimate_answer() eq 42, "Meaning of Life" ); | |
279 | ok( $foo ne '', "Got some foo" ); | |
280 | ||
281 | (Mnemonic: "This is that." "This isn't that.") | |
282 | ||
283 | So why use these? They produce better diagnostics on failure. ok() | |
284 | cannot know what you are testing for (beyond the name), but is() and | |
285 | isnt() know what the test was and why it failed. For example this | |
d020a79a | 286 | test: |
3f2ec160 JH |
287 | |
288 | my $foo = 'waffle'; my $bar = 'yarblokos'; | |
289 | is( $foo, $bar, 'Is foo the same as bar?' ); | |
290 | ||
291 | Will produce something like this: | |
292 | ||
293 | not ok 17 - Is foo the same as bar? | |
294 | # Failed test 1 (foo.t at line 139) | |
295 | # got: 'waffle' | |
296 | # expected: 'yarblokos' | |
297 | ||
298 | So you can figure out what went wrong without rerunning the test. | |
299 | ||
300 | You are encouraged to use is() and isnt() over ok() where possible, | |
301 | however do not be tempted to use them to find out if something is | |
302 | true or false! | |
303 | ||
304 | # XXX BAD! $pope->isa('Catholic') eq 1 | |
305 | is( $pope->isa('Catholic'), 1, 'Is the Pope Catholic?' ); | |
306 | ||
307 | This does not check if C<$pope->isa('Catholic')> is true, it checks if | |
308 | it returns 1. Very different. Similar caveats exist for false and 0. | |
309 | In these cases, use ok(). | |
310 | ||
311 | ok( $pope->isa('Catholic') ), 'Is the Pope Catholic?' ); | |
312 | ||
d020a79a JH |
313 | For those grammatical pedants out there, there's an C<isn't()> |
314 | function which is an alias of isnt(). | |
3f2ec160 JH |
315 | |
316 | =cut | |
317 | ||
318 | sub is ($$;$) { | |
33459055 | 319 | $Test->is_eq(@_); |
3f2ec160 JH |
320 | } |
321 | ||
322 | sub isnt ($$;$) { | |
323 | my($this, $that, $name) = @_; | |
324 | ||
d020a79a JH |
325 | my $test; |
326 | { | |
327 | local $^W = 0; # so isnt(undef, undef) works quietly. | |
328 | $test = $this ne $that; | |
329 | } | |
330 | ||
33459055 | 331 | my $ok = $Test->ok($test, $name); |
3f2ec160 JH |
332 | |
333 | unless( $ok ) { | |
d020a79a JH |
334 | $that = defined $that ? "'$that'" : 'undef'; |
335 | ||
33459055 MS |
336 | $Test->diag(sprintf <<DIAGNOSTIC, $that); |
337 | it should not be %s | |
338 | but it is. | |
3f2ec160 JH |
339 | DIAGNOSTIC |
340 | ||
341 | } | |
342 | ||
343 | return $ok; | |
344 | } | |
345 | ||
346 | *isn't = \&isnt; | |
347 | ||
348 | ||
349 | =item B<like> | |
350 | ||
351 | like( $this, qr/that/, $test_name ); | |
352 | ||
353 | Similar to ok(), like() matches $this against the regex C<qr/that/>. | |
354 | ||
355 | So this: | |
356 | ||
357 | like($this, qr/that/, 'this is like that'); | |
358 | ||
359 | is similar to: | |
360 | ||
361 | ok( $this =~ /that/, 'this is like that'); | |
362 | ||
363 | (Mnemonic "This is like that".) | |
364 | ||
365 | The second argument is a regular expression. It may be given as a | |
d020a79a | 366 | regex reference (ie. C<qr//>) or (for better compatibility with older |
3f2ec160 JH |
367 | perls) as a string that looks like a regex (alternative delimiters are |
368 | currently not supported): | |
369 | ||
370 | like( $this, '/that/', 'this is like that' ); | |
371 | ||
372 | Regex options may be placed on the end (C<'/that/i'>). | |
373 | ||
374 | Its advantages over ok() are similar to that of is() and isnt(). Better | |
375 | diagnostics on failure. | |
376 | ||
377 | =cut | |
378 | ||
379 | sub like ($$;$) { | |
33459055 | 380 | $Test->like(@_); |
3f2ec160 JH |
381 | } |
382 | ||
d020a79a JH |
383 | =item B<can_ok> |
384 | ||
385 | can_ok($module, @methods); | |
386 | can_ok($object, @methods); | |
387 | ||
388 | Checks to make sure the $module or $object can do these @methods | |
389 | (works with functions, too). | |
390 | ||
391 | can_ok('Foo', qw(this that whatever)); | |
392 | ||
393 | is almost exactly like saying: | |
394 | ||
395 | ok( Foo->can('this') && | |
396 | Foo->can('that') && | |
397 | Foo->can('whatever') | |
398 | ); | |
399 | ||
400 | only without all the typing and with a better interface. Handy for | |
401 | quickly testing an interface. | |
402 | ||
403 | =cut | |
404 | ||
405 | sub can_ok ($@) { | |
406 | my($proto, @methods) = @_; | |
407 | my $class= ref $proto || $proto; | |
408 | ||
409 | my @nok = (); | |
410 | foreach my $method (@methods) { | |
33459055 | 411 | my $test = "'$class'->can('$method')"; |
d020a79a JH |
412 | eval $test || push @nok, $method; |
413 | } | |
414 | ||
415 | my $name; | |
416 | $name = @methods == 1 ? "$class->can($methods[0])" | |
417 | : "$class->can(...)"; | |
418 | ||
33459055 | 419 | my $ok = $Test->ok( !@nok, $name ); |
d020a79a | 420 | |
33459055 | 421 | $Test->diag(map "$class->can('$_') failed\n", @nok); |
d020a79a | 422 | |
33459055 | 423 | return $ok; |
d020a79a JH |
424 | } |
425 | ||
426 | =item B<isa_ok> | |
427 | ||
33459055 | 428 | isa_ok($object, $class, $object_name); |
d020a79a JH |
429 | |
430 | Checks to see if the given $object->isa($class). Also checks to make | |
431 | sure the object was defined in the first place. Handy for this sort | |
432 | of thing: | |
433 | ||
434 | my $obj = Some::Module->new; | |
435 | isa_ok( $obj, 'Some::Module' ); | |
436 | ||
437 | where you'd otherwise have to write | |
438 | ||
439 | my $obj = Some::Module->new; | |
440 | ok( defined $obj && $obj->isa('Some::Module') ); | |
441 | ||
442 | to safeguard against your test script blowing up. | |
443 | ||
33459055 MS |
444 | The diagnostics of this test normally just refer to 'the object'. If |
445 | you'd like them to be more specific, you can supply an $object_name | |
446 | (for example 'Test customer'). | |
447 | ||
d020a79a JH |
448 | =cut |
449 | ||
33459055 MS |
450 | sub isa_ok ($$;$) { |
451 | my($object, $class, $obj_name) = @_; | |
d020a79a JH |
452 | |
453 | my $diag; | |
33459055 MS |
454 | $obj_name = 'The object' unless defined $obj_name; |
455 | my $name = "$obj_name isa $class"; | |
d020a79a | 456 | if( !defined $object ) { |
33459055 | 457 | $diag = "$obj_name isn't defined"; |
d020a79a JH |
458 | } |
459 | elsif( !ref $object ) { | |
33459055 | 460 | $diag = "$obj_name isn't a reference"; |
d020a79a JH |
461 | } |
462 | elsif( !$object->isa($class) ) { | |
33459055 | 463 | $diag = "$obj_name isn't a '$class'"; |
d020a79a JH |
464 | } |
465 | ||
33459055 | 466 | my $ok; |
d020a79a | 467 | if( $diag ) { |
33459055 MS |
468 | $ok = $Test->ok( 0, $name ); |
469 | $Test->diag("$diag\n"); | |
d020a79a JH |
470 | } |
471 | else { | |
33459055 | 472 | $ok = $Test->ok( 1, $name ); |
d020a79a | 473 | } |
33459055 MS |
474 | |
475 | return $ok; | |
d020a79a JH |
476 | } |
477 | ||
478 | ||
3f2ec160 JH |
479 | =item B<pass> |
480 | ||
481 | =item B<fail> | |
482 | ||
483 | pass($test_name); | |
484 | fail($test_name); | |
485 | ||
486 | Sometimes you just want to say that the tests have passed. Usually | |
487 | the case is you've got some complicated condition that is difficult to | |
488 | wedge into an ok(). In this case, you can simply use pass() (to | |
489 | declare the test ok) or fail (for not ok). They are synonyms for | |
490 | ok(1) and ok(0). | |
491 | ||
492 | Use these very, very, very sparingly. | |
493 | ||
494 | =cut | |
495 | ||
d020a79a | 496 | sub pass (;$) { |
33459055 | 497 | $Test->ok(1, @_); |
3f2ec160 JH |
498 | } |
499 | ||
d020a79a | 500 | sub fail (;$) { |
33459055 | 501 | $Test->ok(0, @_); |
3f2ec160 JH |
502 | } |
503 | ||
504 | =back | |
505 | ||
506 | =head2 Module tests | |
507 | ||
508 | You usually want to test if the module you're testing loads ok, rather | |
509 | than just vomiting if its load fails. For such purposes we have | |
510 | C<use_ok> and C<require_ok>. | |
511 | ||
512 | =over 4 | |
513 | ||
514 | =item B<use_ok> | |
515 | ||
3f2ec160 | 516 | BEGIN { use_ok($module); } |
d020a79a JH |
517 | BEGIN { use_ok($module, @imports); } |
518 | ||
519 | These simply use the given $module and test to make sure the load | |
520 | happened ok. Its recommended that you run use_ok() inside a BEGIN | |
521 | block so its functions are exported at compile-time and prototypes are | |
522 | properly honored. | |
523 | ||
524 | If @imports are given, they are passed through to the use. So this: | |
525 | ||
526 | BEGIN { use_ok('Some::Module', qw(foo bar)) } | |
527 | ||
528 | is like doing this: | |
529 | ||
530 | use Some::Module qw(foo bar); | |
3f2ec160 | 531 | |
3f2ec160 JH |
532 | |
533 | =cut | |
534 | ||
d020a79a JH |
535 | sub use_ok ($;@) { |
536 | my($module, @imports) = @_; | |
537 | @imports = () unless @imports; | |
3f2ec160 JH |
538 | |
539 | my $pack = caller; | |
540 | ||
541 | eval <<USE; | |
542 | package $pack; | |
543 | require $module; | |
d020a79a | 544 | $module->import(\@imports); |
3f2ec160 JH |
545 | USE |
546 | ||
33459055 | 547 | my $ok = $Test->ok( !$@, "use $module;" ); |
3f2ec160 JH |
548 | |
549 | unless( $ok ) { | |
0cd946aa | 550 | chomp $@; |
33459055 MS |
551 | $Test->diag(<<DIAGNOSTIC); |
552 | Tried to use '$module'. | |
553 | Error: $@ | |
3f2ec160 JH |
554 | DIAGNOSTIC |
555 | ||
556 | } | |
557 | ||
558 | return $ok; | |
559 | } | |
560 | ||
d020a79a JH |
561 | =item B<require_ok> |
562 | ||
563 | require_ok($module); | |
564 | ||
565 | Like use_ok(), except it requires the $module. | |
566 | ||
567 | =cut | |
3f2ec160 JH |
568 | |
569 | sub require_ok ($) { | |
570 | my($module) = shift; | |
571 | ||
572 | my $pack = caller; | |
573 | ||
574 | eval <<REQUIRE; | |
575 | package $pack; | |
576 | require $module; | |
577 | REQUIRE | |
578 | ||
33459055 | 579 | my $ok = $Test->ok( !$@, "require $module;" ); |
3f2ec160 JH |
580 | |
581 | unless( $ok ) { | |
0cd946aa | 582 | chomp $@; |
33459055 | 583 | $Test->diag(<<DIAGNOSTIC); |
3f2ec160 JH |
584 | # Tried to require '$module'. |
585 | # Error: $@ | |
586 | DIAGNOSTIC | |
587 | ||
588 | } | |
589 | ||
590 | return $ok; | |
591 | } | |
592 | ||
d020a79a | 593 | =back |
3f2ec160 JH |
594 | |
595 | =head2 Conditional tests | |
596 | ||
d020a79a JH |
597 | B<WARNING!> The following describes an I<experimental> interface that |
598 | is subject to change B<WITHOUT NOTICE>! Use at your peril. | |
599 | ||
3f2ec160 JH |
600 | Sometimes running a test under certain conditions will cause the |
601 | test script to die. A certain function or method isn't implemented | |
602 | (such as fork() on MacOS), some resource isn't available (like a | |
d020a79a JH |
603 | net connection) or a module isn't available. In these cases it's |
604 | necessary to skip tests, or declare that they are supposed to fail | |
3f2ec160 JH |
605 | but will work in the future (a todo test). |
606 | ||
d020a79a JH |
607 | For more details on skip and todo tests see L<Test::Harness>. |
608 | ||
609 | The way Test::More handles this is with a named block. Basically, a | |
610 | block of tests which can be skipped over or made todo. It's best if I | |
611 | just show you... | |
3f2ec160 JH |
612 | |
613 | =over 4 | |
614 | ||
d020a79a JH |
615 | =item B<SKIP: BLOCK> |
616 | ||
617 | SKIP: { | |
618 | skip $why, $how_many if $condition; | |
3f2ec160 | 619 | |
d020a79a JH |
620 | ...normal testing code goes here... |
621 | } | |
3f2ec160 | 622 | |
d020a79a JH |
623 | This declares a block of tests to skip, $how_many tests there are, |
624 | $why and under what $condition to skip them. An example is the | |
625 | easiest way to illustrate: | |
3f2ec160 | 626 | |
d020a79a JH |
627 | SKIP: { |
628 | skip "Pigs don't fly here", 2 unless Pigs->can('fly'); | |
3f2ec160 | 629 | |
d020a79a JH |
630 | my $pig = Pigs->new; |
631 | $pig->takeoff; | |
632 | ||
633 | ok( $pig->altitude > 0, 'Pig is airborne' ); | |
634 | ok( $pig->airspeed > 0, ' and moving' ); | |
635 | } | |
3f2ec160 | 636 | |
d020a79a JH |
637 | If pigs cannot fly, the whole block of tests will be skipped |
638 | completely. Test::More will output special ok's which Test::Harness | |
639 | interprets as skipped tests. Its important to include $how_many tests | |
640 | are in the block so the total number of tests comes out right (unless | |
33459055 MS |
641 | you're using C<no_plan>, in which case you can leave $how_many off if |
642 | you like). | |
d020a79a JH |
643 | |
644 | You'll typically use this when a feature is missing, like an optional | |
645 | module is not installed or the operating system doesn't have some | |
646 | feature (like fork() or symlinks) or maybe you need an Internet | |
647 | connection and one isn't available. | |
648 | ||
649 | =for _Future | |
650 | See L</Why are skip and todo so weird?> | |
3f2ec160 JH |
651 | |
652 | =cut | |
653 | ||
d020a79a | 654 | #'# |
1af51bd3 | 655 | sub skip { |
d020a79a | 656 | my($why, $how_many) = @_; |
33459055 MS |
657 | |
658 | unless( defined $how_many ) { | |
d020a79a | 659 | # $how_many can only be avoided when no_plan is in use. |
33459055 MS |
660 | _carp "skip() needs to know \$how_many tests are in the block" |
661 | unless $Test::Builder::No_Plan; | |
d020a79a JH |
662 | $how_many = 1; |
663 | } | |
664 | ||
665 | for( 1..$how_many ) { | |
33459055 | 666 | $Test->skip($why); |
d020a79a JH |
667 | } |
668 | ||
669 | local $^W = 0; | |
670 | last SKIP; | |
3f2ec160 JH |
671 | } |
672 | ||
3f2ec160 | 673 | |
d020a79a | 674 | =item B<TODO: BLOCK> |
3f2ec160 | 675 | |
d020a79a JH |
676 | TODO: { |
677 | local $TODO = $why; | |
3f2ec160 | 678 | |
d020a79a JH |
679 | ...normal testing code goes here... |
680 | } | |
3f2ec160 | 681 | |
d020a79a JH |
682 | Declares a block of tests you expect to fail and $why. Perhaps it's |
683 | because you haven't fixed a bug or haven't finished a new feature: | |
3f2ec160 | 684 | |
d020a79a JH |
685 | TODO: { |
686 | local $TODO = "URI::Geller not finished"; | |
3f2ec160 | 687 | |
d020a79a JH |
688 | my $card = "Eight of clubs"; |
689 | is( URI::Geller->your_card, $card, 'Is THIS your card?' ); | |
3f2ec160 | 690 | |
d020a79a JH |
691 | my $spoon; |
692 | URI::Geller->bend_spoon; | |
693 | is( $spoon, 'bent', "Spoon bending, that's original" ); | |
694 | } | |
695 | ||
696 | With a todo block, the tests inside are expected to fail. Test::More | |
697 | will run the tests normally, but print out special flags indicating | |
698 | they are "todo". Test::Harness will interpret failures as being ok. | |
699 | Should anything succeed, it will report it as an unexpected success. | |
700 | ||
701 | The nice part about todo tests, as opposed to simply commenting out a | |
702 | block of tests, is it's like having a programatic todo list. You know | |
703 | how much work is left to be done, you're aware of what bugs there are, | |
704 | and you'll know immediately when they're fixed. | |
705 | ||
706 | Once a todo test starts succeeding, simply move it outside the block. | |
707 | When the block is empty, delete it. | |
708 | ||
709 | ||
710 | =back | |
3f2ec160 JH |
711 | |
712 | =head2 Comparision functions | |
713 | ||
714 | Not everything is a simple eq check or regex. There are times you | |
715 | need to see if two arrays are equivalent, for instance. For these | |
716 | instances, Test::More provides a handful of useful functions. | |
717 | ||
718 | B<NOTE> These are NOT well-tested on circular references. Nor am I | |
719 | quite sure what will happen with filehandles. | |
720 | ||
721 | =over 4 | |
722 | ||
33459055 MS |
723 | =item B<is_deeply> |
724 | ||
725 | is_deeply( $this, $that, $test_name ); | |
726 | ||
727 | Similar to is(), except that if $this and $that are hash or array | |
728 | references, it does a deep comparison walking each data structure to | |
729 | see if they are equivalent. If the two structures are different, it | |
730 | will display the place where they start differing. | |
731 | ||
732 | B<NOTE> Display of scalar refs is not quite 100% | |
733 | ||
734 | =cut | |
735 | ||
736 | use vars qw(@Data_Stack); | |
737 | my $DNE = bless [], 'Does::Not::Exist'; | |
738 | sub is_deeply { | |
739 | my($this, $that, $name) = @_; | |
740 | ||
741 | my $ok; | |
742 | if( !ref $this || !ref $that ) { | |
743 | $ok = $Test->is_eq($this, $that, $name); | |
744 | } | |
745 | else { | |
746 | local @Data_Stack = (); | |
747 | if( _deep_check($this, $that) ) { | |
748 | $ok = $Test->ok(1, $name); | |
749 | } | |
750 | else { | |
751 | $ok = $Test->ok(0, $name); | |
752 | $ok = $Test->diag(_format_stack(@Data_Stack)); | |
753 | } | |
754 | } | |
755 | ||
756 | return $ok; | |
757 | } | |
758 | ||
759 | sub _format_stack { | |
760 | my(@Stack) = @_; | |
761 | ||
762 | my $var = '$FOO'; | |
763 | my $did_arrow = 0; | |
764 | foreach my $entry (@Stack) { | |
765 | my $type = $entry->{type} || ''; | |
766 | my $idx = $entry->{'idx'}; | |
767 | if( $type eq 'HASH' ) { | |
768 | $var .= "->" unless $did_arrow++; | |
769 | $var .= "{$idx}"; | |
770 | } | |
771 | elsif( $type eq 'ARRAY' ) { | |
772 | $var .= "->" unless $did_arrow++; | |
773 | $var .= "[$idx]"; | |
774 | } | |
775 | elsif( $type eq 'REF' ) { | |
776 | $var = "\${$var}"; | |
777 | } | |
778 | } | |
779 | ||
780 | my @vals = @{$Stack[-1]{vals}}[0,1]; | |
781 | my @vars = (); | |
782 | ($vars[0] = $var) =~ s/\$FOO/ \$got/; | |
783 | ($vars[1] = $var) =~ s/\$FOO/\$expected/; | |
784 | ||
785 | my $out = "Structures begin differing at:\n"; | |
786 | foreach my $idx (0..$#vals) { | |
787 | my $val = $vals[$idx]; | |
788 | $vals[$idx] = !defined $val ? 'undef' : | |
789 | $val eq $DNE ? "Does not exist" | |
790 | : "'$val'"; | |
791 | } | |
792 | ||
793 | $out .= "$vars[0] = $vals[0]\n"; | |
794 | $out .= "$vars[1] = $vals[1]\n"; | |
795 | ||
796 | return $out; | |
797 | } | |
798 | ||
799 | ||
3f2ec160 JH |
800 | =item B<eq_array> |
801 | ||
802 | eq_array(\@this, \@that); | |
803 | ||
804 | Checks if two arrays are equivalent. This is a deep check, so | |
805 | multi-level structures are handled correctly. | |
806 | ||
807 | =cut | |
808 | ||
809 | #'# | |
810 | sub eq_array { | |
811 | my($a1, $a2) = @_; | |
3f2ec160 JH |
812 | return 1 if $a1 eq $a2; |
813 | ||
814 | my $ok = 1; | |
33459055 MS |
815 | my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; |
816 | for (0..$max) { | |
817 | my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; | |
818 | my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; | |
819 | ||
820 | push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; | |
3f2ec160 | 821 | $ok = _deep_check($e1,$e2); |
33459055 MS |
822 | pop @Data_Stack if $ok; |
823 | ||
3f2ec160 JH |
824 | last unless $ok; |
825 | } | |
826 | return $ok; | |
827 | } | |
828 | ||
829 | sub _deep_check { | |
830 | my($e1, $e2) = @_; | |
831 | my $ok = 0; | |
832 | ||
d020a79a JH |
833 | my $eq; |
834 | { | |
835 | # Quiet unintialized value warnings when comparing undefs. | |
836 | local $^W = 0; | |
837 | ||
838 | if( $e1 eq $e2 ) { | |
839 | $ok = 1; | |
3f2ec160 JH |
840 | } |
841 | else { | |
d020a79a JH |
842 | if( UNIVERSAL::isa($e1, 'ARRAY') and |
843 | UNIVERSAL::isa($e2, 'ARRAY') ) | |
844 | { | |
845 | $ok = eq_array($e1, $e2); | |
846 | } | |
847 | elsif( UNIVERSAL::isa($e1, 'HASH') and | |
848 | UNIVERSAL::isa($e2, 'HASH') ) | |
849 | { | |
850 | $ok = eq_hash($e1, $e2); | |
851 | } | |
33459055 MS |
852 | elsif( UNIVERSAL::isa($e1, 'REF') and |
853 | UNIVERSAL::isa($e2, 'REF') ) | |
854 | { | |
855 | push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; | |
856 | $ok = _deep_check($$e1, $$e2); | |
857 | pop @Data_Stack if $ok; | |
858 | } | |
859 | elsif( UNIVERSAL::isa($e1, 'SCALAR') and | |
860 | UNIVERSAL::isa($e2, 'SCALAR') ) | |
861 | { | |
862 | push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; | |
863 | $ok = _deep_check($$e1, $$e2); | |
864 | } | |
d020a79a | 865 | else { |
33459055 | 866 | push @Data_Stack, { vals => [$e1, $e2] }; |
d020a79a JH |
867 | $ok = 0; |
868 | } | |
3f2ec160 JH |
869 | } |
870 | } | |
d020a79a | 871 | |
3f2ec160 JH |
872 | return $ok; |
873 | } | |
874 | ||
875 | ||
876 | =item B<eq_hash> | |
877 | ||
878 | eq_hash(\%this, \%that); | |
879 | ||
880 | Determines if the two hashes contain the same keys and values. This | |
881 | is a deep check. | |
882 | ||
883 | =cut | |
884 | ||
885 | sub eq_hash { | |
886 | my($a1, $a2) = @_; | |
3f2ec160 JH |
887 | return 1 if $a1 eq $a2; |
888 | ||
889 | my $ok = 1; | |
33459055 MS |
890 | my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; |
891 | foreach my $k (keys %$bigger) { | |
892 | my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; | |
893 | my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; | |
894 | ||
895 | push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; | |
3f2ec160 | 896 | $ok = _deep_check($e1, $e2); |
33459055 MS |
897 | pop @Data_Stack if $ok; |
898 | ||
3f2ec160 JH |
899 | last unless $ok; |
900 | } | |
901 | ||
902 | return $ok; | |
903 | } | |
904 | ||
905 | =item B<eq_set> | |
906 | ||
907 | eq_set(\@this, \@that); | |
908 | ||
909 | Similar to eq_array(), except the order of the elements is B<not> | |
910 | important. This is a deep check, but the irrelevancy of order only | |
911 | applies to the top level. | |
912 | ||
913 | =cut | |
914 | ||
915 | # We must make sure that references are treated neutrally. It really | |
916 | # doesn't matter how we sort them, as long as both arrays are sorted | |
917 | # with the same algorithm. | |
d020a79a | 918 | sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b } |
3f2ec160 JH |
919 | |
920 | sub eq_set { | |
921 | my($a1, $a2) = @_; | |
922 | return 0 unless @$a1 == @$a2; | |
923 | ||
924 | # There's faster ways to do this, but this is easiest. | |
925 | return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] ); | |
926 | } | |
927 | ||
928 | ||
929 | =back | |
930 | ||
d020a79a JH |
931 | =head1 NOTES |
932 | ||
933 | Test::More is B<explicitly> tested all the way back to perl 5.004. | |
934 | ||
3f2ec160 JH |
935 | =head1 BUGS and CAVEATS |
936 | ||
d020a79a JH |
937 | =over 4 |
938 | ||
939 | =item Making your own ok() | |
940 | ||
941 | This will not do what you mean: | |
942 | ||
943 | sub my_ok { | |
944 | ok( @_ ); | |
945 | } | |
946 | ||
947 | my_ok( 2 + 2 == 5, 'Basic addition' ); | |
948 | ||
949 | since ok() takes it's arguments as scalars, it will see the length of | |
950 | @_ (2) and always pass the test. You want to do this instead: | |
3f2ec160 | 951 | |
d020a79a JH |
952 | sub my_ok { |
953 | ok( $_[0], $_[1] ); | |
954 | } | |
955 | ||
956 | The other functions act similiarly. | |
957 | ||
958 | =item The eq_* family have some caveats. | |
959 | ||
960 | =item Test::Harness upgrades | |
3f2ec160 | 961 | |
d020a79a JH |
962 | no_plan and todo depend on new Test::Harness features and fixes. If |
963 | you're going to distribute tests that use no_plan your end-users will | |
964 | have to upgrade Test::Harness to the latest one on CPAN. | |
965 | ||
966 | If you simply depend on Test::More, it's own dependencies will cause a | |
967 | Test::Harness upgrade. | |
968 | ||
969 | =back | |
3f2ec160 JH |
970 | |
971 | =head1 AUTHOR | |
972 | ||
d020a79a | 973 | Michael G Schwern E<lt>schwern@pobox.comE<gt> with much inspiration from |
3f2ec160 JH |
974 | Joshua Pritikin's Test module and lots of discussion with Barrie |
975 | Slaymaker and the perl-qa gang. | |
976 | ||
977 | ||
978 | =head1 HISTORY | |
979 | ||
980 | This is a case of convergent evolution with Joshua Pritikin's Test | |
d020a79a | 981 | module. I was largely unware of its existence when I'd first |
3f2ec160 JH |
982 | written my own ok() routines. This module exists because I can't |
983 | figure out how to easily wedge test names into Test's interface (along | |
984 | with a few other problems). | |
985 | ||
986 | The goal here is to have a testing utility that's simple to learn, | |
987 | quick to use and difficult to trip yourself up with while still | |
988 | providing more flexibility than the existing Test.pm. As such, the | |
989 | names of the most common routines are kept tiny, special cases and | |
990 | magic side-effects are kept to a minimum. WYSIWYG. | |
991 | ||
992 | ||
993 | =head1 SEE ALSO | |
994 | ||
995 | L<Test::Simple> if all this confuses you and you just want to write | |
996 | some tests. You can upgrade to Test::More later (its forward | |
997 | compatible). | |
998 | ||
999 | L<Test> for a similar testing module. | |
1000 | ||
1001 | L<Test::Harness> for details on how your test results are interpreted | |
1002 | by Perl. | |
1003 | ||
1004 | L<Test::Unit> describes a very featureful unit testing interface. | |
1005 | ||
1006 | L<Pod::Tests> shows the idea of embedded testing. | |
1007 | ||
1008 | L<SelfTest> is another approach to embedded testing. | |
1009 | ||
1010 | =cut | |
1011 | ||
1012 | 1; |