File Coverage

support/Test.pm
Criterion Covered Total %
statement 85 211 40.3
branch 27 104 26.0
condition 9 41 22.0
subroutine 9 20 45.0
pod 3 3 100.0
total 133 379 35.1


line stmt bran cond sub pod time code
1              
2             require 5.004;
3             package Test;
4             # Time-stamp: "2004-04-28 21:46:51 ADT"
5              
6 46     46   616 use strict;
  46         558  
  46         2149  
7              
8 46     46   830 use Carp;
  46         437  
  46         917  
9 46         693 use vars (qw($VERSION @ISA @EXPORT @EXPORT_OK $ntest $TestLevel), #public-ish
10                       qw($TESTOUT $TESTERR %Program_Lines $told_about_diff
11             $ONFAIL %todo %history $planned @FAILDETAIL) #private-ish
12 46     46   845          );
  46         445  
13              
14             # In case a test is run in a persistent environment.
15             sub _reset_globals {
16 46     46   1398     %todo = ();
17 46         555     %history = ();
18 46         492     @FAILDETAIL = ();
19 46         460     $ntest = 1;
20 46         439     $TestLevel = 0; # how many extra stack frames to skip
21 46         448     $planned = 0;
22             }
23              
24             $VERSION = '1.25';
25             require Exporter;
26             @ISA=('Exporter');
27              
28             @EXPORT    = qw(&plan &ok &skip);
29             @EXPORT_OK = qw($ntest $TESTOUT $TESTERR);
30              
31             $|=1;
32             $TESTOUT = *STDOUT{IO};
33             $TESTERR = *STDERR{IO};
34              
35             # Use of this variable is strongly discouraged. It is set mainly to
36             # help test coverage analyzers know which test is running.
37             $ENV{REGRESSION_TEST} = $0;
38              
39              
40             =head1 NAME
41            
42             Test - provides a simple framework for writing test scripts
43            
44             =head1 SYNOPSIS
45            
46             use strict;
47             use Test;
48            
49             # use a BEGIN block so we print our plan before MyModule is loaded
50             BEGIN { plan tests => 14, todo => [3,4] }
51            
52             # load your module...
53             use MyModule;
54            
55             # Helpful notes. All note-lines must start with a "#".
56             print "# I'm testing MyModule version $MyModule::VERSION\n";
57            
58             ok(0); # failure
59             ok(1); # success
60            
61             ok(0); # ok, expected failure (see todo list, above)
62             ok(1); # surprise success!
63            
64             ok(0,1); # failure: '0' ne '1'
65             ok('broke','fixed'); # failure: 'broke' ne 'fixed'
66             ok('fixed','fixed'); # success: 'fixed' eq 'fixed'
67             ok('fixed',qr/x/); # success: 'fixed' =~ qr/x/
68            
69             ok(sub { 1+1 }, 2); # success: '2' eq '2'
70             ok(sub { 1+1 }, 3); # failure: '2' ne '3'
71            
72             my @list = (0,0);
73             ok @list, 3, "\@list=".join(',',@list); #extra notes
74             ok 'segmentation fault', '/(?i)success/'; #regex match
75            
76             skip(
77             $^O =~ m/MSWin/ ? "Skip if MSWin" : 0, # whether to skip
78             $foo, $bar # arguments just like for ok(...)
79             );
80             skip(
81             $^O =~ m/MSWin/ ? 0 : "Skip unless MSWin", # whether to skip
82             $foo, $bar # arguments just like for ok(...)
83             );
84            
85             =head1 DESCRIPTION
86            
87             This module simplifies the task of writing test files for Perl modules,
88             such that their output is in the format that
89             L<Test::Harness|Test::Harness> expects to see.
90            
91             =head1 QUICK START GUIDE
92            
93             To write a test for your new (and probably not even done) module, create
94             a new file called F<t/test.t> (in a new F<t> directory). If you have
95             multiple test files, to test the "foo", "bar", and "baz" feature sets,
96             then feel free to call your files F<t/foo.t>, F<t/bar.t>, and
97             F<t/baz.t>
98            
99             =head2 Functions
100            
101             This module defines three public functions, C<plan(...)>, C<ok(...)>,
102             and C<skip(...)>. By default, all three are exported by
103             the C<use Test;> statement.
104            
105             =over 4
106            
107             =item C<plan(...)>
108            
109             BEGIN { plan %theplan; }
110            
111             This should be the first thing you call in your test script. It
112             declares your testing plan, how many there will be, if any of them
113             should be allowed to fail, and so on.
114            
115             Typical usage is just:
116            
117             use Test;
118             BEGIN { plan tests => 23 }
119            
120             These are the things that you can put in the parameters to plan:
121            
122             =over
123            
124             =item C<tests =E<gt> I<number>>
125            
126             The number of tests in your script.
127             This means all ok() and skip() calls.
128            
129             =item C<todo =E<gt> [I<1,5,14>]>
130            
131             A reference to a list of tests which are allowed to fail.
132             See L</TODO TESTS>.
133            
134             =item C<onfail =E<gt> sub { ... }>
135            
136             =item C<onfail =E<gt> \&some_sub>
137            
138             A subroutine reference to be run at the end of the test script, if
139             any of the tests fail. See L</ONFAIL>.
140            
141             =back
142            
143             You must call C<plan(...)> once and only once. You should call it
144             in a C<BEGIN {...}> block, like so:
145            
146             BEGIN { plan tests => 23 }
147            
148             =cut
149              
150             sub plan {
151 46 50   46 1 581     croak "Test::plan(%args): odd number of arguments" if @_ & 1;
152 46 50       538     croak "Test::plan(): should not be called more than once" if $planned;
153              
154 46         579     local($\, $,); # guard against -l and other things that screw with
155             # print
156              
157 46         3789     _reset_globals();
158              
159 46         737     _read_program( (caller)[1] );
160              
161 46         488     my $max=0;
162 46         1106     while (@_) {
163 46         564 my ($k,$v) = splice(@_, 0, 2);
164 46 50 0     998 if ($k =~ /^test(s)?$/) { $max = $v; }
  46 0       722  
    0          
165             elsif ($k eq 'todo' or
166 0         0 $k eq 'failok') { for (@$v) { $todo{$_}=1; }; }
  0         0  
167             elsif ($k eq 'onfail') {
168 0 0       0 ref $v eq 'CODE' or croak "Test::plan(onfail => $v): must be CODE";
169 0         0 $ONFAIL = $v;
170             }
171 0         0 else { carp "Test::plan(): skipping unrecognized directive '$k'" }
172                 }
173 46         631     my @todo = sort { $a <=> $b } keys %todo;
  0         0  
174 46 50       632     if (@todo) {
175 0         0 print $TESTOUT "1..$max todo ".join(' ', @todo).";\n";
176                 } else {
177 46         57563 print $TESTOUT "1..$max\n";
178                 }
179 46         894     ++$planned;
180 46         22193     print $TESTOUT "# Running under perl version $] for $^O",
181                   (chr(65) eq 'A') ? "\n" : " in a non-ASCII world\n";
182              
183 46 50 33     1192     print $TESTOUT "# Win32::BuildNumber ", &Win32::BuildNumber(), "\n"
184                   if defined(&Win32::BuildNumber) and defined &Win32::BuildNumber();
185              
186 46 50       933     print $TESTOUT "# MacPerl version $MacPerl::Version\n"
187                   if defined $MacPerl::Version;
188              
189 46         77607     printf $TESTOUT
190                   "# Current time local: %s\n# Current time GMT: %s\n",
191                   scalar(localtime($^T)), scalar(gmtime($^T));
192              
193 46         14611     print $TESTOUT "# Using Test.pm version $VERSION\n";
194              
195             # Retval never used:
196 46         7010     return undef;
197             }
198              
199             sub _read_program {
200 46     46   535   my($file) = shift;
201 46 50 33     5493   return unless defined $file and length $file
      33        
      33        
      33        
202                 and -e $file and -f _ and -r _;
203 46 50       6089   open(SOURCEFILE, "<$file") || return;
204 46         7388715   $Program_Lines{$file} = [<SOURCEFILE>];
205 46         27970   close(SOURCEFILE);
206              
207 46         643   foreach my $x (@{$Program_Lines{$file}})
  46         676  
208 155593         6596396    { $x =~ tr/\cm\cj\n\r//d }
209              
210 46         562   unshift @{$Program_Lines{$file}}, '';
  46         1026638  
211 46         758   return 1;
212             }
213              
214             =begin _private
215            
216             =item B<_to_value>
217            
218             my $value = _to_value($input);
219            
220             Converts an C<ok> parameter to its value. Typically this just means
221             running it, if it's a code reference. You should run all inputted
222             values through this.
223            
224             =cut
225              
226             sub _to_value {
227 89045     89045   1930284     my ($v) = @_;
228 89045 100       3139574     return ref $v eq 'CODE' ? $v->() : $v;
229             }
230              
231             sub _quote {
232 0     0   0     my $str = $_[0];
233 0 0       0     return "<UNDEF>" unless defined $str;
234 0         0     $str =~ s/\\/\\\\/g;
235 0         0     $str =~ s/"/\\"/g;
236 0         0     $str =~ s/\a/\\a/g;
237 0         0     $str =~ s/[\b]/\\b/g;
238 0         0     $str =~ s/\e/\\e/g;
239 0         0     $str =~ s/\f/\\f/g;
240 0         0     $str =~ s/\n/\\n/g;
241 0         0     $str =~ s/\r/\\r/g;
242 0         0     $str =~ s/\t/\\t/g;
243 0         0     $str =~ s/([\0-\037])(?!\d)/sprintf('\\%o',ord($1))/eg;
  0         0  
244 0         0     $str =~ s/([\0-\037\177-\377])/sprintf('\\x%02X',ord($1))/eg;
  0         0  
245 0         0     $str =~ s/([^\0-\176])/sprintf('\\x{%X}',ord($1))/eg;
  0         0  
246             #if( $_[1] ) {
247             # substr( $str , 218-3 ) = "..."
248             # if length($str) >= 218 and !$ENV{PERL_TEST_NO_TRUNC};
249             #}
250 0         0     return qq("$str");
251             }
252              
253              
254             =end _private
255            
256             =item C<ok(...)>
257            
258             ok(1 + 1 == 2);
259             ok($have, $expect);
260             ok($have, $expect, $diagnostics);
261            
262             This function is the reason for C<Test>'s existence. It's
263             the basic function that
264             handles printing "C<ok>" or "C<not ok>", along with the
265             current test number. (That's what C<Test::Harness> wants to see.)
266            
267             In its most basic usage, C<ok(...)> simply takes a single scalar
268             expression. If its value is true, the test passes; if false,
269             the test fails. Examples:
270            
271             # Examples of ok(scalar)
272            
273             ok( 1 + 1 == 2 ); # ok if 1 + 1 == 2
274             ok( $foo =~ /bar/ ); # ok if $foo contains 'bar'
275             ok( baz($x + $y) eq 'Armondo' ); # ok if baz($x + $y) returns
276             # 'Armondo'
277             ok( @a == @b ); # ok if @a and @b are the same length
278            
279             The expression is evaluated in scalar context. So the following will
280             work:
281            
282             ok( @stuff ); # ok if @stuff has any elements
283             ok( !grep !defined $_, @stuff ); # ok if everything in @stuff is
284             # defined.
285            
286             A special case is if the expression is a subroutine reference (in either
287             C<sub {...}> syntax or C<\&foo> syntax). In
288             that case, it is executed and its value (true or false) determines if
289             the test passes or fails. For example,
290            
291             ok( sub { # See whether sleep works at least passably
292             my $start_time = time;
293             sleep 5;
294             time() - $start_time >= 4
295             });
296            
297             In its two-argument form, C<ok(I<arg1>, I<arg2>)> compares the two
298             scalar values to see if they match. They match if both are undefined,
299             or if I<arg2> is a regex that matches I<arg1>, or if they compare equal
300             with C<eq>.
301            
302             # Example of ok(scalar, scalar)
303            
304             ok( "this", "that" ); # not ok, 'this' ne 'that'
305             ok( "", undef ); # not ok, "" is defined
306            
307             The second argument is considered a regex if it is either a regex
308             object or a string that looks like a regex. Regex objects are
309             constructed with the qr// operator in recent versions of perl. A
310             string is considered to look like a regex if its first and last
311             characters are "/", or if the first character is "m"
312             and its second and last characters are both the
313             same non-alphanumeric non-whitespace character. These regexp
314            
315             Regex examples:
316            
317             ok( 'JaffO', '/Jaff/' ); # ok, 'JaffO' =~ /Jaff/
318             ok( 'JaffO', 'm|Jaff|' ); # ok, 'JaffO' =~ m|Jaff|
319             ok( 'JaffO', qr/Jaff/ ); # ok, 'JaffO' =~ qr/Jaff/;
320             ok( 'JaffO', '/(?i)jaff/ ); # ok, 'JaffO' =~ /jaff/i;
321            
322             If either (or both!) is a subroutine reference, it is run and used
323             as the value for comparing. For example:
324            
325             ok sub {
326             open(OUT, ">x.dat") || die $!;
327             print OUT "\x{e000}";
328             close OUT;
329             my $bytecount = -s 'x.dat';
330             unlink 'x.dat' or warn "Can't unlink : $!";
331             return $bytecount;
332             },
333             4
334             ;
335            
336             The above test passes two values to C<ok(arg1, arg2)> -- the first
337             a coderef, and the second is the number 4. Before C<ok> compares them,
338             it calls the coderef, and uses its return value as the real value of
339             this parameter. Assuming that C<$bytecount> returns 4, C<ok> ends up
340             testing C<4 eq 4>. Since that's true, this test passes.
341            
342             Finally, you can append an optional third argument, in
343             C<ok(I<arg1>,I<arg2>, I<note>)>, where I<note> is a string value that
344             will be printed if the test fails. This should be some useful
345             information about the test, pertaining to why it failed, and/or
346             a description of the test. For example:
347            
348             ok( grep($_ eq 'something unique', @stuff), 1,
349             "Something that should be unique isn't!\n".
350             '@stuff = '.join ', ', @stuff
351             );
352            
353             Unfortunately, a note cannot be used with the single argument
354             style of C<ok()>. That is, if you try C<ok(I<arg1>, I<note>)>, then
355             C<Test> will interpret this as C<ok(I<arg1>, I<arg2>)>, and probably
356             end up testing C<I<arg1> eq I<arg2>> -- and that's not what you want!
357            
358             All of the above special cases can occasionally cause some
359             problems. See L</BUGS and CAVEATS>.
360            
361             =cut
362              
363             # A past maintainer of this module said:
364             # <<ok(...)'s special handling of subroutine references is an unfortunate
365             # "feature" that can't be removed due to compatibility.>>
366             #
367              
368             sub ok ($;$$) {
369 47410 50   47410 1 153040804     croak "ok: plan before you test!" if !$planned;
370              
371 47410         2039494     local($\,$,); # guard against -l and other things that screw with
372             # print
373              
374 47410         3168802     my ($pkg,$file,$line) = caller($TestLevel);
375 47410         1810624     my $repetition = ++$history{"$file:$line"};
376 47410 100       1958820     my $context = ("$file at line $line".
377             ($repetition > 1 ? " fail \#$repetition" : ''));
378              
379             # Are we comparing two values?
380 47410         929454     my $compare = 0;
381              
382 47410         805300     my $ok=0;
383 47410         1254826     my $result = _to_value(shift);
384 47410         1140454     my ($expected, $isregex, $regex);
385 47410 100       1430090     if (@_ == 0) {
386 8287         137057 $ok = $result;
387                 } else {
388 39123         1046995         $compare = 1;
389 39123         1514134 $expected = _to_value(shift);
390 39123 50 33     2441730 if (!defined $expected) {
    50          
    100          
    50          
391 0         0 $ok = !defined $result;
392             } elsif (!defined $result) {
393 0         0 $ok = 0;
394             } elsif (ref($expected) eq 'Regexp') {
395 2520         44480 $ok = $result =~ /$expected/;
396 2520         30036             $regex = $expected;
397             } elsif (($regex) = ($expected =~ m,^ / (.+) / $,sx) or
398             (undef, $regex) = ($expected =~ m,^ m([^\w\s]) (.+) \1 $,sx)) {
399 0         0 $ok = $result =~ /$regex/;
400             } else {
401 36603         1083213 $ok = $result eq $expected;
402             }
403                 }
404 47410         1236000     my $todo = $todo{$ntest};
405 47410 50 33     1431795     if ($todo and $ok) {
406 0 0       0 $context .= ' TODO?!' if $todo;
407 0         0 print $TESTOUT "ok $ntest # ($context)\n";
408                 } else {
409             # Issuing two seperate prints() causes problems on VMS.
410 47410 50       1688933         if (!$ok) {
411 0         0             print $TESTOUT "not ok $ntest\n";
412                     }
413             else {
414 47410         6310892             print $TESTOUT "ok $ntest\n";
415                     }
416              
417 47410 0       1531844         $ok or _complain($result, $expected,
    50          
418                     {
419                       'repetition' => $repetition, 'package' => $pkg,
420                       'result' => $result, 'todo' => $todo,
421                       'file' => $file, 'line' => $line,
422                       'context' => $context, 'compare' => $compare,
423                       @_ ? ('diagnostic' => _to_value(shift)) : (),
424                     });
425              
426                 }
427 47410         1139226     ++ $ntest;
428 47410         1640880     $ok;
429             }
430              
431              
432             sub _complain {
433 0     0   0     my($result, $expected, $detail) = @_;
434 0 0       0     $$detail{expected} = $expected if defined $expected;
435              
436             # Get the user's diagnostic, protecting against multi-line
437             # diagnostics.
438 0         0     my $diag = $$detail{diagnostic};
439 0 0       0     $diag =~ s/\n/\n#/g if defined $diag;
440              
441 0 0       0     $$detail{context} .= ' *TODO*' if $$detail{todo};
442 0 0       0     if (!$$detail{compare}) {
443 0 0       0         if (!$diag) {
444 0         0             print $TESTERR "# Failed test $ntest in $$detail{context}\n";
445                     } else {
446 0         0             print $TESTERR "# Failed test $ntest in $$detail{context}: $diag\n";
447                     }
448                 } else {
449 0         0         my $prefix = "Test $ntest";
450              
451 0         0         print $TESTERR "# $prefix got: " . _quote($result) .
452                                    " ($$detail{context})\n";
453 0         0         $prefix = ' ' x (length($prefix) - 5);
454 0 0       0         my $expected_quoted = (defined $$detail{regex})
455                      ? 'qr{'.($$detail{regex}).'}' : _quote($expected);
456              
457 0 0       0         print $TESTERR "# $prefix Expected: $expected_quoted",
458                        $diag ? " ($diag)" : (), "\n";
459              
460 0 0 0     0         _diff_complain( $result, $expected, $detail, $prefix )
461                       if defined($expected) and 2 < ($expected =~ tr/\n//);
462                 }
463              
464 0 0       0     if(defined $Program_Lines{ $$detail{file} }[ $$detail{line} ]) {
465 0 0       0         print $TESTERR
466                       "# $$detail{file} line $$detail{line} is: $Program_Lines{ $$detail{file} }[ $$detail{line} ]\n"
467                      if $Program_Lines{ $$detail{file} }[ $$detail{line} ]
468                       =~ m/[^\s\#\(\)\{\}\[\]\;]/; # Otherwise it's uninformative
469              
470 0         0         undef $Program_Lines{ $$detail{file} }[ $$detail{line} ];
471             # So we won't repeat it.
472                 }
473              
474 0         0     push @FAILDETAIL, $detail;
475 0         0     return;
476             }
477              
478              
479              
480             sub _diff_complain {
481 0     0   0     my($result, $expected, $detail, $prefix) = @_;
482 0 0       0     return _diff_complain_external(@_) if $ENV{PERL_TEST_DIFF};
483                 return _diff_complain_algdiff(@_)
484 0 0       0      if eval { require Algorithm::Diff; Algorithm::Diff->VERSION(1.15); 1; };
  0         0  
  0         0  
  0         0  
485              
486 0 0       0     $told_about_diff++ or print $TESTERR <<"EOT";
487             # $prefix (Install the Algorithm::Diff module to have differences in multiline
488             # $prefix output explained. You might also set the PERL_TEST_DIFF environment
489             # $prefix variable to run a diff program on the output.)
490             EOT
491                 ;
492 0         0     return;
493             }
494              
495              
496              
497             sub _diff_complain_external {
498 0     0   0     my($result, $expected, $detail, $prefix) = @_;
499 0   0     0     my $diff = $ENV{PERL_TEST_DIFF} || die "WHAAAA?";
500              
501 0         0     require File::Temp;
502 0         0     my($got_fh, $got_filename) = File::Temp::tempfile("test-got-XXXXX");
503 0         0     my($exp_fh, $exp_filename) = File::Temp::tempfile("test-exp-XXXXX");
504 0 0 0     0     unless ($got_fh && $exp_fh) {
505 0         0       warn "Can't get tempfiles";
506 0         0       return;
507                 }
508              
509 0         0     print $got_fh $result;
510 0         0     print $exp_fh $expected;
511 0 0 0     0     if (close($got_fh) && close($exp_fh)) {
512 0         0         my $diff_cmd = "$diff $exp_filename $got_filename";
513 0         0         print $TESTERR "#\n# $prefix $diff_cmd\n";
514 0 0       0         if (open(DIFF, "$diff_cmd |")) {
515 0         0             local $_;
516 0         0             while (<DIFF>) {
517 0         0                 print $TESTERR "# $prefix $_";
518                         }
519 0         0             close(DIFF);
520                     }
521                     else {
522 0         0             warn "Can't run diff: $!";
523                     }
524                 } else {
525 0         0         warn "Can't write to tempfiles: $!";
526                 }
527 0         0     unlink($got_filename);
528 0         0     unlink($exp_filename);
529 0         0     return;
530             }
531              
532              
533              
534             sub _diff_complain_algdiff {
535 0     0   0     my($result, $expected, $detail, $prefix) = @_;
536              
537 0         0     my @got = split(/^/, $result);
538 0         0     my @exp = split(/^/, $expected);
539              
540 0         0     my $diff_kind;
541 0         0     my @diff_lines;
542              
543                 my $diff_flush = sub {
544 0 0   0   0         return unless $diff_kind;
545              
546 0         0         my $count_lines = @diff_lines;
547 0 0       0         my $s = $count_lines == 1 ? "" : "s";
548 0         0         my $first_line = $diff_lines[0][0] + 1;
549              
550 0         0         print $TESTERR "# $prefix ";
551 0 0       0         if ($diff_kind eq "GOT") {
    0          
    0          
552 0         0             print $TESTERR "Got $count_lines extra line$s at line $first_line:\n";
553 0         0             for my $i (@diff_lines) {
554 0         0                 print $TESTERR "# $prefix + " . _quote($got[$i->[0]]) . "\n";
555                         }
556                     } elsif ($diff_kind eq "EXP") {
557 0 0       0             if ($count_lines > 1) {
558 0         0                 my $last_line = $diff_lines[-1][0] + 1;
559 0         0                 print $TESTERR "Lines $first_line-$last_line are";
560                         }
561                         else {
562 0         0                 print $TESTERR "Line $first_line is";
563                         }
564 0         0             print $TESTERR " missing:\n";
565 0         0             for my $i (@diff_lines) {
566 0         0                 print $TESTERR "# $prefix - " . _quote($exp[$i->[1]]) . "\n";
567                         }
568                     } elsif ($diff_kind eq "CH") {
569 0 0       0             if ($count_lines > 1) {
570 0         0                 my $last_line = $diff_lines[-1][0] + 1;
571 0         0                 print $TESTERR "Lines $first_line-$last_line are";
572                         }
573                         else {
574 0         0                 print $TESTERR "Line $first_line is";
575                         }
576 0         0             print $TESTERR " changed:\n";
577 0         0             for my $i (@diff_lines) {
578 0         0                 print $TESTERR "# $prefix - " . _quote($exp[$i->[1]]) . "\n";
579 0         0                 print $TESTERR "# $prefix + " . _quote($got[$i->[0]]) . "\n";
580                         }
581                     }
582              
583             # reset
584 0         0         $diff_kind = undef;
585 0         0         @diff_lines = ();
586 0         0     };
587              
588                 my $diff_collect = sub {
589 0     0   0         my $kind = shift;
590 0 0 0     0         &$diff_flush() if $diff_kind && $diff_kind ne $kind;
591 0         0         $diff_kind = $kind;
592 0         0         push(@diff_lines, [@_]);
593 0         0     };
594              
595              
596                 Algorithm::Diff::traverse_balanced(
597                     \@got, \@exp,
598                     {
599 0     0   0             DISCARD_A => sub { &$diff_collect("GOT", @_) },
600 0     0   0             DISCARD_B => sub { &$diff_collect("EXP", @_) },
601 0     0   0             CHANGE => sub { &$diff_collect("CH", @_) },
602 0     0   0             MATCH => sub { &$diff_flush() },
603                     },
604 0         0     );
605 0         0     &$diff_flush();
606              
607 0         0     return;
608             }
609              
610              
611              
612              
613             #~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~`~
614              
615              
616             =item C<skip(I<skip_if_true>, I<args...>)>
617            
618             This is used for tests that under some conditions can be skipped. It's
619             basically equivalent to:
620            
621             if( $skip_if_true ) {
622             ok(1);
623             } else {
624             ok( args... );
625             }
626            
627             ...except that the C<ok(1)> emits not just "C<ok I<testnum>>" but
628             actually "C<ok I<testnum> # I<skip_if_true_value>>".
629            
630             The arguments after the I<skip_if_true> are what is fed to C<ok(...)> if
631             this test isn't skipped.
632            
633             Example usage:
634            
635             my $if_MSWin =
636             $^O =~ m/MSWin/ ? 'Skip if under MSWin' : '';
637            
638             # A test to be skipped if under MSWin (i.e., run except under MSWin)
639             skip($if_MSWin, thing($foo), thing($bar) );
640            
641             Or, going the other way:
642            
643             my $unless_MSWin =
644             $^O =~ m/MSWin/ ? '' : 'Skip unless under MSWin';
645            
646             # A test to be skipped unless under MSWin (i.e., run only under MSWin)
647             skip($unless_MSWin, thing($foo), thing($bar) );
648            
649             The tricky thing to remember is that the first parameter is true if
650             you want to I<skip> the test, not I<run> it; and it also doubles as a
651             note about why it's being skipped. So in the first codeblock above, read
652             the code as "skip if MSWin -- (otherwise) test whether C<thing($foo)> is
653             C<thing($bar)>" or for the second case, "skip unless MSWin...".
654            
655             Also, when your I<skip_if_reason> string is true, it really should (for
656             backwards compatibility with older Test.pm versions) start with the
657             string "Skip", as shown in the above examples.
658            
659             Note that in the above cases, C<thing($foo)> and C<thing($bar)>
660             I<are> evaluated -- but as long as the C<skip_if_true> is true,
661             then we C<skip(...)> just tosses out their value (i.e., not
662             bothering to treat them like values to C<ok(...)>. But if
663             you need to I<not> eval the arguments when skipping the
664             test, use
665             this format:
666            
667             skip( $unless_MSWin,
668             sub {
669             # This code returns true if the test passes.
670             # (But it doesn't even get called if the test is skipped.)
671             thing($foo) eq thing($bar)
672             }
673             );
674            
675             or even this, which is basically equivalent:
676            
677             skip( $unless_MSWin,
678             sub { thing($foo) }, sub { thing($bar) }
679             );
680            
681             That is, both are like this:
682            
683             if( $unless_MSWin ) {
684             ok(1); # but it actually appends "# $unless_MSWin"
685             # so that Test::Harness can tell it's a skip
686             } else {
687             # Not skipping, so actually call and evaluate...
688             ok( sub { thing($foo) }, sub { thing($bar) } );
689             }
690            
691             =cut
692              
693             sub skip ($;$$$) {
694 2512     2512 1 219916     local($\, $,); # guard against -l and other things that screw with
695             # print
696              
697 2512         137003     my $whyskip = _to_value(shift);
698 2512 100 66     43287     if (!@_ or $whyskip) {
699 556 50       8246 $whyskip = '' if $whyskip =~ m/^\d+$/;
700 556         5805         $whyskip =~ s/^[Ss]kip(?:\s+|$)//; # backwards compatibility, old
701             # versions required the reason
702             # to start with 'skip'
703             # We print in one shot for VMSy reasons.
704 556         6143         my $ok = "ok $ntest # skip";
705 556 50       8094         $ok .= " $whyskip" if length $whyskip;
706 556         4946         $ok .= "\n";
707 556         131062         print $TESTOUT $ok;
708 556         5948         ++ $ntest;
709 556         45837         return 1;
710                 } else {
711             # backwards compatiblity (I think). skip() used to be
712             # called like ok(), which is weird. I haven't decided what to do with
713             # this yet.
714             # warn <<WARN if $^W;
715             #This looks like a skip() using the very old interface. Please upgrade to
716             #the documented interface as this has been deprecated.
717             #WARN
718              
719 1956         32659 local($TestLevel) = $TestLevel+1; #to ignore this stack frame
720 1956         21577         return &ok(@_);
721                 }
722             }
723              
724             =back
725            
726             =cut
727              
728             END {
729                 $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
730             }
731              
732             1;
733             __END__
734            
735             =head1 TEST TYPES
736            
737             =over 4
738            
739             =item * NORMAL TESTS
740            
741             These tests are expected to succeed. Usually, most or all of your tests
742             are in this category. If a normal test doesn't succeed, then that
743             means that something is I<wrong>.
744            
745             =item * SKIPPED TESTS
746            
747             The C<skip(...)> function is for tests that might or might not be
748             possible to run, depending
749             on the availability of platform-specific features. The first argument
750             should evaluate to true (think "yes, please skip") if the required
751             feature is I<not> available. After the first argument, C<skip(...)> works
752             exactly the same way as C<ok(...)> does.
753            
754             =item * TODO TESTS
755            
756             TODO tests are designed for maintaining an B<executable TODO list>.
757             These tests are I<expected to fail.> If a TODO test does succeed,
758             then the feature in question shouldn't be on the TODO list, now
759             should it?
760            
761             Packages should NOT be released with succeeding TODO tests. As soon
762             as a TODO test starts working, it should be promoted to a normal test,
763             and the newly working feature should be documented in the release
764             notes or in the change log.
765            
766             =back
767            
768             =head1 ONFAIL
769            
770             BEGIN { plan test => 4, onfail => sub { warn "CALL 911!" } }
771            
772             Although test failures should be enough, extra diagnostics can be
773             triggered at the end of a test run. C<onfail> is passed an array ref
774             of hash refs that describe each test failure. Each hash will contain
775             at least the following fields: C<package>, C<repetition>, and
776             C<result>. (You shouldn't rely on any other fields being present.) If the test
777             had an expected value or a diagnostic (or "note") string, these will also be
778             included.
779            
780             The I<optional> C<onfail> hook might be used simply to print out the
781             version of your package and/or how to report problems. It might also
782             be used to generate extremely sophisticated diagnostics for a
783             particularly bizarre test failure. However it's not a panacea. Core
784             dumps or other unrecoverable errors prevent the C<onfail> hook from
785             running. (It is run inside an C<END> block.) Besides, C<onfail> is
786             probably over-kill in most cases. (Your test code should be simpler
787             than the code it is testing, yes?)
788            
789            
790             =head1 BUGS and CAVEATS
791            
792             =over
793            
794             =item *
795            
796             C<ok(...)>'s special handing of strings which look like they might be
797             regexes can also cause unexpected behavior. An innocent:
798            
799             ok( $fileglob, '/path/to/some/*stuff/' );
800            
801             will fail, since Test.pm considers the second argument to be a regex!
802             The best bet is to use the one-argument form:
803            
804             ok( $fileglob eq '/path/to/some/*stuff/' );
805            
806             =item *
807            
808             C<ok(...)>'s use of string C<eq> can sometimes cause odd problems
809             when comparing
810             numbers, especially if you're casting a string to a number:
811            
812             $foo = "1.0";
813             ok( $foo, 1 ); # not ok, "1.0" ne 1
814            
815             Your best bet is to use the single argument form:
816            
817             ok( $foo == 1 ); # ok "1.0" == 1
818            
819             =item *
820            
821             As you may have inferred from the above documentation and examples,
822             C<ok>'s prototype is C<($;$$)> (and, incidentally, C<skip>'s is
823             C<($;$$$)>). This means, for example, that you can do C<ok @foo, @bar>
824             to compare the I<size> of the two arrays. But don't be fooled into
825             thinking that C<ok @foo, @bar> means a comparison of the contents of two
826             arrays -- you're comparing I<just> the number of elements of each. It's
827             so easy to make that mistake in reading C<ok @foo, @bar> that you might
828             want to be very explicit about it, and instead write C<ok scalar(@foo),
829             scalar(@bar)>.
830            
831             =item *
832            
833             This almost definitely doesn't do what you expect:
834            
835             ok $thingy->can('some_method');
836            
837             Why? Because C<can> returns a coderef to mean "yes it can (and the
838             method is this...)", and then C<ok> sees a coderef and thinks you're
839             passing a function that you want it to call and consider the truth of
840             the result of! I.e., just like:
841            
842             ok $thingy->can('some_method')->();
843            
844             What you probably want instead is this:
845            
846             ok $thingy->can('some_method') && 1;
847            
848             If the C<can> returns false, then that is passed to C<ok>. If it
849             returns true, then the larger expression S<< C<<
850             $thingy->can('some_method') && 1 >> >> returns 1, which C<ok> sees as
851             a simple signal of success, as you would expect.
852            
853            
854             =item *
855            
856             The syntax for C<skip> is about the only way it can be, but it's still
857             quite confusing. Just start with the above examples and you'll
858             be okay.
859            
860             Moreover, users may expect this:
861            
862             skip $unless_mswin, foo($bar), baz($quux);
863            
864             to not evaluate C<foo($bar)> and C<baz($quux)> when the test is being
865             skipped. But in reality, they I<are> evaluated, but C<skip> just won't
866             bother comparing them if C<$unless_mswin> is true.
867            
868             You could do this:
869            
870             skip $unless_mswin, sub{foo($bar)}, sub{baz($quux)};
871            
872             But that's not terribly pretty. You may find it simpler or clearer in
873             the long run to just do things like this:
874            
875             if( $^O =~ m/MSWin/ ) {
876             print "# Yay, we're under $^O\n";
877             ok foo($bar), baz($quux);
878             ok thing($whatever), baz($stuff);
879             ok blorp($quux, $whatever);
880             ok foo($barzbarz), thang($quux);
881             } else {
882             print "# Feh, we're under $^O. Watch me skip some tests...\n";
883             for(1 .. 4) { skip "Skip unless under MSWin" }
884             }
885            
886             But be quite sure that C<ok> is called exactly as many times in the
887             first block as C<skip> is called in the second block.
888            
889             =back
890            
891            
892             =head1 ENVIRONMENT
893            
894             If C<PERL_TEST_DIFF> environment variable is set, it will be used as a
895             command for comparing unexpected multiline results. If you have GNU
896             diff installed, you might want to set C<PERL_TEST_DIFF> to C<diff -u>.
897             If you don't have a suitable program, you might install the
898             C<Text::Diff> module and then set C<PERL_TEST_DIFF> to be C<perl
899             -MText::Diff -e 'print diff(@ARGV)'>. If C<PERL_TEST_DIFF> isn't set
900             but the C<Algorithm::Diff> module is available, then it will be used
901             to show the differences in multiline results.
902            
903             =for comment
904             If C<PERL_TEST_NO_TRUNC> is set, then the initial "Got 'something' but
905             expected 'something_else'" readings for long multiline output values aren't
906             truncated at about the 230th column, as they normally could be in some
907             cases. Normally you won't need to use this, unless you were carefully
908             parsing the output of your test programs.
909            
910            
911             =head1 NOTE
912            
913             A past developer of this module once said that it was no longer being
914             actively developed. However, rumors of its demise were greatly
915             exaggerated. Feedback and suggestions are quite welcome.
916            
917             Be aware that the main value of this module is its simplicity. Note
918             that there are already more ambitious modules out there, such as
919             L<Test::More> and L<Test::Unit>.
920            
921             Some earlier versions of this module had docs with some confusing
922             typoes in the description of C<skip(...)>.
923            
924            
925             =head1 SEE ALSO
926            
927             L<Test::Harness>
928            
929             L<Test::Simple>, L<Test::More>, L<Devel::Cover>
930            
931             L<Test::Builder> for building your own testing library.
932            
933             L<Test::Unit> is an interesting XUnit-style testing library.
934            
935             L<Test::Inline> and L<SelfTest> let you embed tests in code.
936            
937            
938             =head1 AUTHOR
939            
940             Copyright (c) 1998-2000 Joshua Nathaniel Pritikin. All rights reserved.
941            
942             Copyright (c) 2001-2002 Michael G. Schwern.
943            
944             Copyright (c) 2002-2004 and counting Sean M. Burke.
945            
946             Current maintainer: Sean M. Burke. E<lt>sburke@cpan.orgE<gt>
947            
948             This package is free software and is provided "as is" without express
949             or implied warranty. It may be used, redistributed and/or modified
950             under the same terms as Perl itself.
951            
952             =cut
953            
954             # "Your mistake was a hidden intention."
955             # -- /Oblique Strategies/, Brian Eno and Peter Schmidt
956