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