File Coverage

support/Test.pm
Criterion Covered Total %
statement 86 211 40.7
branch 27 106 25.4
condition 10 44 22.7
subroutine 10 21 47.6
pod 3 3 100.0
total 136 385 35.3


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 43     43   28639 use strict;
  43         300  
  43         1251  
7              
8 43     43   212 use Carp;
  43         81  
  43         4843  
9 43         143168 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 43     43   305 );
  43         83  
13              
14             # In case a test is run in a persistent environment.
15             sub _reset_globals {
16 43     43   110 %todo = ();
17 43         77 %history = ();
18 43         88 @FAILDETAIL = ();
19 43         98 $ntest = 1;
20 43         67 $TestLevel = 0; # how many extra stack frames to skip
21 43         88 $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 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 (in a new F 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, F, and
97             F
98              
99             =head2 Functions
100              
101             This module defines three public functions, C, C,
102             and C. By default, all three are exported by
103             the C statement.
104              
105             =over 4
106              
107             =item C
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 I>
125              
126             The number of tests in your script.
127             This means all ok() and skip() calls.
128              
129             =item C [I<1,5,14>]>
130              
131             A reference to a list of tests which are allowed to fail.
132             See L.
133              
134             =item C sub { ... }>
135              
136             =item C \&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.
140              
141             =back
142              
143             You must call C once and only once. You should call it
144             in a C block, like so:
145              
146             BEGIN { plan tests => 23 }
147              
148             =cut
149              
150             sub plan {
151 43 50   43 1 4597 croak "Test::plan(%args): odd number of arguments" if @_ & 1;
152 43 50       220 croak "Test::plan(): should not be called more than once" if $planned;
153              
154 43         343 local($\, $,); # guard against -l and other things that screw with
155             # print
156              
157 43         173 _reset_globals();
158              
159 43         191 _read_program( (caller)[1] );
160              
161 43         81 my $max=0;
162 43         145 while (@_) {
163 43         161 my ($k,$v) = splice(@_, 0, 2);
164 43 50 0     329 if ($k =~ /^test(s)?$/) { $max = $v; }
  43 0       140  
    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 43         186 my @todo = sort { $a <=> $b } keys %todo;
  0         0  
174 43 50       121 if (@todo) {
175 0         0 print $TESTOUT "1..$max todo ".join(' ', @todo).";\n";
176             } else {
177 43         23233 print $TESTOUT "1..$max\n";
178             }
179 43         259 ++$planned;
180 43         797 print $TESTOUT "# Running under perl version $] for $^O",
181             (chr(65) eq 'A') ? "\n" : " in a non-ASCII world\n";
182              
183 43 50 33     345 print $TESTOUT "# Win32::BuildNumber ", &Win32::BuildNumber(), "\n"
184             if defined(&Win32::BuildNumber) and defined &Win32::BuildNumber();
185              
186 43 50       125 print $TESTOUT "# MacPerl version $MacPerl::Version\n"
187             if defined $MacPerl::Version;
188              
189 43         3888 printf $TESTOUT
190             "# Current time local: %s\n# Current time GMT: %s\n",
191             scalar(localtime($^T)), scalar(gmtime($^T));
192              
193 43         813 print $TESTOUT "# Using Test.pm version $VERSION\n";
194              
195             # Retval never used:
196 43         103919 return undef;
197             }
198              
199             sub _read_program {
200 43     43   99 my($file) = shift;
201 43 50 33     1511 return unless defined $file and length $file
      33        
      33        
      33        
202             and -e $file and -f _ and -r _;
203 43 50       1325 open(SOURCEFILE, "<$file") || return;
204 43         7273 $Program_Lines{$file} = [];
205 43         817 close(SOURCEFILE);
206              
207 43         159 foreach my $x (@{$Program_Lines{$file}})
  43         174  
208 8698         11018 { $x =~ tr/\cm\cj\n\r//d }
209              
210 43         85 unshift @{$Program_Lines{$file}}, '';
  43         419  
211 43         131 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 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 26781     26781   39748 my ($v) = @_;
228 26781 100       56123 return ref $v eq 'CODE' ? $v->() : $v;
229             }
230              
231             sub _quote {
232 0     0   0 my $str = $_[0];
233 0 0       0 return "" 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
257              
258             ok(1 + 1 == 2);
259             ok($have, $expect);
260             ok($have, $expect, $diagnostics);
261              
262             This function is the reason for C's existence. It's
263             the basic function that
264             handles printing "C" or "C", along with the
265             current test number. (That's what C wants to see.)
266              
267             In its most basic usage, C 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 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, I)> compares the two
298             scalar values to see if they match. They match if both are undefined,
299             or if I is a regex that matches I, or if they compare equal
300             with C.
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 -- the first
337             a coderef, and the second is the number 4. Before C 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 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,I, I)>, where I 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. That is, if you try C, I)>, then
355             C will interpret this as C, I)>, and probably
356             end up testing C eq I> -- and that's not what you want!
357              
358             All of the above special cases can occasionally cause some
359             problems. See L.
360              
361             =cut
362              
363             # A past maintainer of this module said:
364             # <
365             # "feature" that can't be removed due to compatibility.>>
366             #
367              
368             sub ok ($;$$) {
369 12566 50   12566 1 8717297 croak "ok: plan before you test!" if !$planned;
370              
371 12566         34345 local($\,$,); # guard against -l and other things that screw with
372             # print
373              
374 12566         69886 my ($pkg,$file,$line) = caller($TestLevel);
375 12566         35474 my $repetition = ++$history{"$file:$line"};
376 12566 100       32447 my $context = ("$file at line $line".
377             ($repetition > 1 ? " fail \#$repetition" : ''));
378              
379             # Are we comparing two values?
380 12566         15922 my $compare = 0;
381              
382 12566         16092 my $ok=0;
383 12566         22216 my $result = _to_value(shift);
384 12566         19585 my ($expected, $isregex, $regex);
385 12566 100       21513 if (@_ == 0) {
386 787         1091 $ok = $result;
387             } else {
388 11779         15253 $compare = 1;
389 11779         17050 $expected = _to_value(shift);
390 11779 50 33     54017 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 2544         16147 $ok = $result =~ /$expected/;
396 2544         3982 $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 9235         15965 $ok = $result eq $expected;
402             }
403             }
404 12566         19859 my $todo = $todo{$ntest};
405 12566 50 33     25555 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 12566 50       18982 if (!$ok) {
411 0         0 print $TESTOUT "not ok $ntest\n";
412             }
413             else {
414 12566         144001 print $TESTOUT "ok $ntest\n";
415             }
416              
417 12566 0       50965 $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 12566         16847 ++ $ntest;
428 12566         52858 $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             my $expected_quoted = (defined $$detail{regex})
455 0 0       0 ? '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             print $TESTERR
466             "# $$detail{file} line $$detail{line} is: $Program_Lines{ $$detail{file} }[ $$detail{line} ]\n"
467 0 0       0 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 () {
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             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, I)>
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 emits not just "C>" but
628             actually "C # I>".
629              
630             The arguments after the I are what is fed to C 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 the test, not I 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 is
653             C" or for the second case, "skip unless MSWin...".
654              
655             Also, when your I 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 and C
660             I evaluated -- but as long as the C is true,
661             then we C just tosses out their value (i.e., not
662             bothering to treat them like values to C. But if
663             you need to I 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 2436     2436 1 51094 local($\, $,); # guard against -l and other things that screw with
695             # print
696              
697 2436         4580 my $whyskip = _to_value(shift);
698 2436 100 66     8240 if (!@_ or $whyskip) {
699 480 50       1188 $whyskip = '' if $whyskip =~ m/^\d+$/;
700 480         685 $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 480         827 my $ok = "ok $ntest # skip";
705 480 50       885 $ok .= " $whyskip" if length $whyskip;
706 480         573 $ok .= "\n";
707 480         3302 print $TESTOUT $ok;
708 480         1526 ++ $ntest;
709 480         1795 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 <
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         3103 local($TestLevel) = $TestLevel+1; #to ignore this stack frame
720 1956         3150 return &ok(@_);
721             }
722             }
723              
724             =back
725              
726             =cut
727              
728             END {
729 43 0 33 43   0 $ONFAIL->(\@FAILDETAIL) if @FAILDETAIL && $ONFAIL;
730             }
731              
732             1;
733             __END__