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