This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Test::Builder: Fix "return $a or $b" precedence issue
[perl5.git] / cpan / Test-Simple / lib / Test / Builder.pm
1 package Test::Builder;
2
3 use 5.006;
4 use strict;
5 use warnings;
6
7 our $VERSION = '0.98';
8 $VERSION = eval $VERSION;    ## no critic (BuiltinFunctions::ProhibitStringyEval)
9
10 BEGIN {
11     if( $] < 5.008 ) {
12         require Test::Builder::IO::Scalar;
13     }
14 }
15
16
17 # Make Test::Builder thread-safe for ithreads.
18 BEGIN {
19     use Config;
20     # Load threads::shared when threads are turned on.
21     # 5.8.0's threads are so busted we no longer support them.
22     if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
23         require threads::shared;
24
25         # Hack around YET ANOTHER threads::shared bug.  It would
26         # occasionally forget the contents of the variable when sharing it.
27         # So we first copy the data, then share, then put our copy back.
28         *share = sub (\[$@%]) {
29             my $type = ref $_[0];
30             my $data;
31
32             if( $type eq 'HASH' ) {
33                 %$data = %{ $_[0] };
34             }
35             elsif( $type eq 'ARRAY' ) {
36                 @$data = @{ $_[0] };
37             }
38             elsif( $type eq 'SCALAR' ) {
39                 $$data = ${ $_[0] };
40             }
41             else {
42                 die( "Unknown type: " . $type );
43             }
44
45             $_[0] = &threads::shared::share( $_[0] );
46
47             if( $type eq 'HASH' ) {
48                 %{ $_[0] } = %$data;
49             }
50             elsif( $type eq 'ARRAY' ) {
51                 @{ $_[0] } = @$data;
52             }
53             elsif( $type eq 'SCALAR' ) {
54                 ${ $_[0] } = $$data;
55             }
56             else {
57                 die( "Unknown type: " . $type );
58             }
59
60             return $_[0];
61         };
62     }
63     # 5.8.0's threads::shared is busted when threads are off
64     # and earlier Perls just don't have that module at all.
65     else {
66         *share = sub { return $_[0] };
67         *lock  = sub { 0 };
68     }
69 }
70
71 =head1 NAME
72
73 Test::Builder - Backend for building test libraries
74
75 =head1 SYNOPSIS
76
77   package My::Test::Module;
78   use base 'Test::Builder::Module';
79
80   my $CLASS = __PACKAGE__;
81
82   sub ok {
83       my($test, $name) = @_;
84       my $tb = $CLASS->builder;
85
86       $tb->ok($test, $name);
87   }
88
89
90 =head1 DESCRIPTION
91
92 Test::Simple and Test::More have proven to be popular testing modules,
93 but they're not always flexible enough.  Test::Builder provides a
94 building block upon which to write your own test libraries I<which can
95 work together>.
96
97 =head2 Construction
98
99 =over 4
100
101 =item B<new>
102
103   my $Test = Test::Builder->new;
104
105 Returns a Test::Builder object representing the current state of the
106 test.
107
108 Since you only run one test per program C<new> always returns the same
109 Test::Builder object.  No matter how many times you call C<new()>, you're
110 getting the same object.  This is called a singleton.  This is done so that
111 multiple modules share such global information as the test counter and
112 where test output is going.
113
114 If you want a completely new Test::Builder object different from the
115 singleton, use C<create>.
116
117 =cut
118
119 our $Test = Test::Builder->new;
120
121 sub new {
122     my($class) = shift;
123     $Test ||= $class->create;
124     return $Test;
125 }
126
127 =item B<create>
128
129   my $Test = Test::Builder->create;
130
131 Ok, so there can be more than one Test::Builder object and this is how
132 you get it.  You might use this instead of C<new()> if you're testing
133 a Test::Builder based module, but otherwise you probably want C<new>.
134
135 B<NOTE>: the implementation is not complete.  C<level>, for example, is
136 still shared amongst B<all> Test::Builder objects, even ones created using
137 this method.  Also, the method name may change in the future.
138
139 =cut
140
141 sub create {
142     my $class = shift;
143
144     my $self = bless {}, $class;
145     $self->reset;
146
147     return $self;
148 }
149
150 =item B<child>
151
152   my $child = $builder->child($name_of_child);
153   $child->plan( tests => 4 );
154   $child->ok(some_code());
155   ...
156   $child->finalize;
157
158 Returns a new instance of C<Test::Builder>.  Any output from this child will
159 be indented four spaces more than the parent's indentation.  When done, the
160 C<finalize> method I<must> be called explicitly.
161
162 Trying to create a new child with a previous child still active (i.e.,
163 C<finalize> not called) will C<croak>.
164
165 Trying to run a test when you have an open child will also C<croak> and cause
166 the test suite to fail.
167
168 =cut
169
170 sub child {
171     my( $self, $name ) = @_;
172
173     if( $self->{Child_Name} ) {
174         $self->croak("You already have a child named ($self->{Child_Name}) running");
175     }
176
177     my $parent_in_todo = $self->in_todo;
178
179     # Clear $TODO for the child.
180     my $orig_TODO = $self->find_TODO(undef, 1, undef);
181
182     my $child = bless {}, ref $self;
183     $child->reset;
184
185     # Add to our indentation
186     $child->_indent( $self->_indent . '    ' );
187     
188     $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};
189     if ($parent_in_todo) {
190         $child->{Fail_FH} = $self->{Todo_FH};
191     }
192
193     # This will be reset in finalize. We do this here lest one child failure
194     # cause all children to fail.
195     $child->{Child_Error} = $?;
196     $?                    = 0;
197     $child->{Parent}      = $self;
198     $child->{Parent_TODO} = $orig_TODO;
199     $child->{Name}        = $name || "Child of " . $self->name;
200     $self->{Child_Name}   = $child->name;
201     return $child;
202 }
203
204
205 =item B<subtest>
206
207     $builder->subtest($name, \&subtests);
208
209 See documentation of C<subtest> in Test::More.
210
211 =cut
212
213 sub subtest {
214     my $self = shift;
215     my($name, $subtests) = @_;
216
217     if ('CODE' ne ref $subtests) {
218         $self->croak("subtest()'s second argument must be a code ref");
219     }
220
221     # Turn the child into the parent so anyone who has stored a copy of
222     # the Test::Builder singleton will get the child.
223     my($error, $child, %parent);
224     {
225         # child() calls reset() which sets $Level to 1, so we localize
226         # $Level first to limit the scope of the reset to the subtest.
227         local $Test::Builder::Level = $Test::Builder::Level + 1;
228
229         $child  = $self->child($name);
230         %parent = %$self;
231         %$self  = %$child;
232
233         my $run_the_subtests = sub {
234             $subtests->();
235             $self->done_testing unless $self->_plan_handled;
236             1;
237         };
238
239         if( !eval { $run_the_subtests->() } ) {
240             $error = $@;
241         }
242     }
243
244     # Restore the parent and the copied child.
245     %$child = %$self;
246     %$self = %parent;
247
248     # Restore the parent's $TODO
249     $self->find_TODO(undef, 1, $child->{Parent_TODO});
250
251     # Die *after* we restore the parent.
252     die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
253
254     local $Test::Builder::Level = $Test::Builder::Level + 1;
255     return $child->finalize;
256 }
257
258 =begin _private
259
260 =item B<_plan_handled>
261
262     if ( $Test->_plan_handled ) { ... }
263
264 Returns true if the developer has explicitly handled the plan via:
265
266 =over 4
267
268 =item * Explicitly setting the number of tests
269
270 =item * Setting 'no_plan'
271
272 =item * Set 'skip_all'.
273
274 =back
275
276 This is currently used in subtests when we implicitly call C<< $Test->done_testing >>
277 if the developer has not set a plan.
278
279 =end _private
280
281 =cut
282
283 sub _plan_handled {
284     my $self = shift;
285     return $self->{Have_Plan} || $self->{No_Plan} || $self->{Skip_All};
286 }
287
288
289 =item B<finalize>
290
291   my $ok = $child->finalize;
292
293 When your child is done running tests, you must call C<finalize> to clean up
294 and tell the parent your pass/fail status.
295
296 Calling finalize on a child with open children will C<croak>.
297
298 If the child falls out of scope before C<finalize> is called, a failure
299 diagnostic will be issued and the child is considered to have failed.
300
301 No attempt to call methods on a child after C<finalize> is called is
302 guaranteed to succeed.
303
304 Calling this on the root builder is a no-op.
305
306 =cut
307
308 sub finalize {
309     my $self = shift;
310
311     return unless $self->parent;
312     if( $self->{Child_Name} ) {
313         $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
314     }
315
316     local $? = 0;     # don't fail if $subtests happened to set $? nonzero
317     $self->_ending;
318
319     # XXX This will only be necessary for TAP envelopes (we think)
320     #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
321
322     local $Test::Builder::Level = $Test::Builder::Level + 1;
323     my $ok = 1;
324     $self->parent->{Child_Name} = undef;
325     if ( $self->{Skip_All} ) {
326         $self->parent->skip($self->{Skip_All});
327     }
328     elsif ( not @{ $self->{Test_Results} } ) {
329         $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
330     }
331     else {
332         $self->parent->ok( $self->is_passing, $self->name );
333     }
334     $? = $self->{Child_Error};
335     delete $self->{Parent};
336
337     return $self->is_passing;
338 }
339
340 sub _indent      {
341     my $self = shift;
342
343     if( @_ ) {
344         $self->{Indent} = shift;
345     }
346
347     return $self->{Indent};
348 }
349
350 =item B<parent>
351
352  if ( my $parent = $builder->parent ) {
353      ...
354  }
355
356 Returns the parent C<Test::Builder> instance, if any.  Only used with child
357 builders for nested TAP.
358
359 =cut
360
361 sub parent { shift->{Parent} }
362
363 =item B<name>
364
365  diag $builder->name;
366
367 Returns the name of the current builder.  Top level builders default to C<$0>
368 (the name of the executable).  Child builders are named via the C<child>
369 method.  If no name is supplied, will be named "Child of $parent->name".
370
371 =cut
372
373 sub name { shift->{Name} }
374
375 sub DESTROY {
376     my $self = shift;
377     if ( $self->parent and $$ == $self->{Original_Pid} ) {
378         my $name = $self->name;
379         $self->diag(<<"FAIL");
380 Child ($name) exited without calling finalize()
381 FAIL
382         $self->parent->{In_Destroy} = 1;
383         $self->parent->ok(0, $name);
384     }
385 }
386
387 =item B<reset>
388
389   $Test->reset;
390
391 Reinitializes the Test::Builder singleton to its original state.
392 Mostly useful for tests run in persistent environments where the same
393 test might be run multiple times in the same process.
394
395 =cut
396
397 our $Level;
398
399 sub reset {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
400     my($self) = @_;
401
402     # We leave this a global because it has to be localized and localizing
403     # hash keys is just asking for pain.  Also, it was documented.
404     $Level = 1;
405
406     $self->{Name}         = $0;
407     $self->is_passing(1);
408     $self->{Ending}       = 0;
409     $self->{Have_Plan}    = 0;
410     $self->{No_Plan}      = 0;
411     $self->{Have_Output_Plan} = 0;
412     $self->{Done_Testing} = 0;
413
414     $self->{Original_Pid} = $$;
415     $self->{Child_Name}   = undef;
416     $self->{Indent}     ||= '';
417
418     share( $self->{Curr_Test} );
419     $self->{Curr_Test} = 0;
420     $self->{Test_Results} = &share( [] );
421
422     $self->{Exported_To}    = undef;
423     $self->{Expected_Tests} = 0;
424
425     $self->{Skip_All} = 0;
426
427     $self->{Use_Nums} = 1;
428
429     $self->{No_Header} = 0;
430     $self->{No_Ending} = 0;
431
432     $self->{Todo}       = undef;
433     $self->{Todo_Stack} = [];
434     $self->{Start_Todo} = 0;
435     $self->{Opened_Testhandles} = 0;
436
437     $self->_dup_stdhandles;
438
439     return;
440 }
441
442 =back
443
444 =head2 Setting up tests
445
446 These methods are for setting up tests and declaring how many there
447 are.  You usually only want to call one of these methods.
448
449 =over 4
450
451 =item B<plan>
452
453   $Test->plan('no_plan');
454   $Test->plan( skip_all => $reason );
455   $Test->plan( tests => $num_tests );
456
457 A convenient way to set up your tests.  Call this and Test::Builder
458 will print the appropriate headers and take the appropriate actions.
459
460 If you call C<plan()>, don't call any of the other methods below.
461
462 If a child calls "skip_all" in the plan, a C<Test::Builder::Exception> is
463 thrown.  Trap this error, call C<finalize()> and don't run any more tests on
464 the child.
465
466  my $child = $Test->child('some child');
467  eval { $child->plan( $condition ? ( skip_all => $reason ) : ( tests => 3 )  ) };
468  if ( eval { $@->isa('Test::Builder::Exception') } ) {
469     $child->finalize;
470     return;
471  }
472  # run your tests
473
474 =cut
475
476 my %plan_cmds = (
477     no_plan     => \&no_plan,
478     skip_all    => \&skip_all,
479     tests       => \&_plan_tests,
480 );
481
482 sub plan {
483     my( $self, $cmd, $arg ) = @_;
484
485     return unless $cmd;
486
487     local $Level = $Level + 1;
488
489     $self->croak("You tried to plan twice") if $self->{Have_Plan};
490
491     if( my $method = $plan_cmds{$cmd} ) {
492         local $Level = $Level + 1;
493         $self->$method($arg);
494     }
495     else {
496         my @args = grep { defined } ( $cmd, $arg );
497         $self->croak("plan() doesn't understand @args");
498     }
499
500     return 1;
501 }
502
503
504 sub _plan_tests {
505     my($self, $arg) = @_;
506
507     if($arg) {
508         local $Level = $Level + 1;
509         return $self->expected_tests($arg);
510     }
511     elsif( !defined $arg ) {
512         $self->croak("Got an undefined number of tests");
513     }
514     else {
515         $self->croak("You said to run 0 tests");
516     }
517
518     return;
519 }
520
521 =item B<expected_tests>
522
523     my $max = $Test->expected_tests;
524     $Test->expected_tests($max);
525
526 Gets/sets the number of tests we expect this test to run and prints out
527 the appropriate headers.
528
529 =cut
530
531 sub expected_tests {
532     my $self = shift;
533     my($max) = @_;
534
535     if(@_) {
536         $self->croak("Number of tests must be a positive integer.  You gave it '$max'")
537           unless $max =~ /^\+?\d+$/;
538
539         $self->{Expected_Tests} = $max;
540         $self->{Have_Plan}      = 1;
541
542         $self->_output_plan($max) unless $self->no_header;
543     }
544     return $self->{Expected_Tests};
545 }
546
547 =item B<no_plan>
548
549   $Test->no_plan;
550
551 Declares that this test will run an indeterminate number of tests.
552
553 =cut
554
555 sub no_plan {
556     my($self, $arg) = @_;
557
558     $self->carp("no_plan takes no arguments") if $arg;
559
560     $self->{No_Plan}   = 1;
561     $self->{Have_Plan} = 1;
562
563     return 1;
564 }
565
566 =begin private
567
568 =item B<_output_plan>
569
570   $tb->_output_plan($max);
571   $tb->_output_plan($max, $directive);
572   $tb->_output_plan($max, $directive => $reason);
573
574 Handles displaying the test plan.
575
576 If a C<$directive> and/or C<$reason> are given they will be output with the
577 plan.  So here's what skipping all tests looks like:
578
579     $tb->_output_plan(0, "SKIP", "Because I said so");
580
581 It sets C<< $tb->{Have_Output_Plan} >> and will croak if the plan was already
582 output.
583
584 =end private
585
586 =cut
587
588 sub _output_plan {
589     my($self, $max, $directive, $reason) = @_;
590
591     $self->carp("The plan was already output") if $self->{Have_Output_Plan};
592
593     my $plan = "1..$max";
594     $plan .= " # $directive" if defined $directive;
595     $plan .= " $reason"      if defined $reason;
596
597     $self->_print("$plan\n");
598
599     $self->{Have_Output_Plan} = 1;
600
601     return;
602 }
603
604
605 =item B<done_testing>
606
607   $Test->done_testing();
608   $Test->done_testing($num_tests);
609
610 Declares that you are done testing, no more tests will be run after this point.
611
612 If a plan has not yet been output, it will do so.
613
614 $num_tests is the number of tests you planned to run.  If a numbered
615 plan was already declared, and if this contradicts, a failing test
616 will be run to reflect the planning mistake.  If C<no_plan> was declared,
617 this will override.
618
619 If C<done_testing()> is called twice, the second call will issue a
620 failing test.
621
622 If C<$num_tests> is omitted, the number of tests run will be used, like
623 no_plan.
624
625 C<done_testing()> is, in effect, used when you'd want to use C<no_plan>, but
626 safer. You'd use it like so:
627
628     $Test->ok($a == $b);
629     $Test->done_testing();
630
631 Or to plan a variable number of tests:
632
633     for my $test (@tests) {
634         $Test->ok($test);
635     }
636     $Test->done_testing(@tests);
637
638 =cut
639
640 sub done_testing {
641     my($self, $num_tests) = @_;
642
643     # If done_testing() specified the number of tests, shut off no_plan.
644     if( defined $num_tests ) {
645         $self->{No_Plan} = 0;
646     }
647     else {
648         $num_tests = $self->current_test;
649     }
650
651     if( $self->{Done_Testing} ) {
652         my($file, $line) = @{$self->{Done_Testing}}[1,2];
653         $self->ok(0, "done_testing() was already called at $file line $line");
654         return;
655     }
656
657     $self->{Done_Testing} = [caller];
658
659     if( $self->expected_tests && $num_tests != $self->expected_tests ) {
660         $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
661                      "but done_testing() expects $num_tests");
662     }
663     else {
664         $self->{Expected_Tests} = $num_tests;
665     }
666
667     $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
668
669     $self->{Have_Plan} = 1;
670
671     # The wrong number of tests were run
672     $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
673
674     # No tests were run
675     $self->is_passing(0) if $self->{Curr_Test} == 0;
676
677     return 1;
678 }
679
680
681 =item B<has_plan>
682
683   $plan = $Test->has_plan
684
685 Find out whether a plan has been defined. C<$plan> is either C<undef> (no plan
686 has been set), C<no_plan> (indeterminate # of tests) or an integer (the number
687 of expected tests).
688
689 =cut
690
691 sub has_plan {
692     my $self = shift;
693
694     return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
695     return('no_plan') if $self->{No_Plan};
696     return(undef);
697 }
698
699 =item B<skip_all>
700
701   $Test->skip_all;
702   $Test->skip_all($reason);
703
704 Skips all the tests, using the given C<$reason>.  Exits immediately with 0.
705
706 =cut
707
708 sub skip_all {
709     my( $self, $reason ) = @_;
710
711     $self->{Skip_All} = $self->parent ? $reason : 1;
712
713     $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
714     if ( $self->parent ) {
715         die bless {} => 'Test::Builder::Exception';
716     }
717     exit(0);
718 }
719
720 =item B<exported_to>
721
722   my $pack = $Test->exported_to;
723   $Test->exported_to($pack);
724
725 Tells Test::Builder what package you exported your functions to.
726
727 This method isn't terribly useful since modules which share the same
728 Test::Builder object might get exported to different packages and only
729 the last one will be honored.
730
731 =cut
732
733 sub exported_to {
734     my( $self, $pack ) = @_;
735
736     if( defined $pack ) {
737         $self->{Exported_To} = $pack;
738     }
739     return $self->{Exported_To};
740 }
741
742 =back
743
744 =head2 Running tests
745
746 These actually run the tests, analogous to the functions in Test::More.
747
748 They all return true if the test passed, false if the test failed.
749
750 C<$name> is always optional.
751
752 =over 4
753
754 =item B<ok>
755
756   $Test->ok($test, $name);
757
758 Your basic test.  Pass if C<$test> is true, fail if $test is false.  Just
759 like Test::Simple's C<ok()>.
760
761 =cut
762
763 sub ok {
764     my( $self, $test, $name ) = @_;
765
766     if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
767         $name = 'unnamed test' unless defined $name;
768         $self->is_passing(0);
769         $self->croak("Cannot run test ($name) with active children");
770     }
771     # $test might contain an object which we don't want to accidentally
772     # store, so we turn it into a boolean.
773     $test = $test ? 1 : 0;
774
775     lock $self->{Curr_Test};
776     $self->{Curr_Test}++;
777
778     # In case $name is a string overloaded object, force it to stringify.
779     $self->_unoverload_str( \$name );
780
781     $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
782     You named your test '$name'.  You shouldn't use numbers for your test names.
783     Very confusing.
784 ERR
785
786     # Capture the value of $TODO for the rest of this ok() call
787     # so it can more easily be found by other routines.
788     my $todo    = $self->todo();
789     my $in_todo = $self->in_todo;
790     local $self->{Todo} = $todo if $in_todo;
791
792     $self->_unoverload_str( \$todo );
793
794     my $out;
795     my $result = &share( {} );
796
797     unless($test) {
798         $out .= "not ";
799         @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
800     }
801     else {
802         @$result{ 'ok', 'actual_ok' } = ( 1, $test );
803     }
804
805     $out .= "ok";
806     $out .= " $self->{Curr_Test}" if $self->use_numbers;
807
808     if( defined $name ) {
809         $name =~ s|#|\\#|g;    # # in a name can confuse Test::Harness.
810         $out .= " - $name";
811         $result->{name} = $name;
812     }
813     else {
814         $result->{name} = '';
815     }
816
817     if( $self->in_todo ) {
818         $out .= " # TODO $todo";
819         $result->{reason} = $todo;
820         $result->{type}   = 'todo';
821     }
822     else {
823         $result->{reason} = '';
824         $result->{type}   = '';
825     }
826
827     $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
828     $out .= "\n";
829
830     $self->_print($out);
831
832     unless($test) {
833         my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
834         $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
835
836         my( undef, $file, $line ) = $self->caller;
837         if( defined $name ) {
838             $self->diag(qq[  $msg test '$name'\n]);
839             $self->diag(qq[  at $file line $line.\n]);
840         }
841         else {
842             $self->diag(qq[  $msg test at $file line $line.\n]);
843         }
844     }
845
846     $self->is_passing(0) unless $test || $self->in_todo;
847
848     # Check that we haven't violated the plan
849     $self->_check_is_passing_plan();
850
851     return $test ? 1 : 0;
852 }
853
854
855 # Check that we haven't yet violated the plan and set
856 # is_passing() accordingly
857 sub _check_is_passing_plan {
858     my $self = shift;
859
860     my $plan = $self->has_plan;
861     return unless defined $plan;        # no plan yet defined
862     return unless $plan !~ /\D/;        # no numeric plan
863     $self->is_passing(0) if $plan < $self->{Curr_Test};
864 }
865
866
867 sub _unoverload {
868     my $self = shift;
869     my $type = shift;
870
871     $self->_try(sub { require overload; }, die_on_fail => 1);
872
873     foreach my $thing (@_) {
874         if( $self->_is_object($$thing) ) {
875             if( my $string_meth = overload::Method( $$thing, $type ) ) {
876                 $$thing = $$thing->$string_meth();
877             }
878         }
879     }
880
881     return;
882 }
883
884 sub _is_object {
885     my( $self, $thing ) = @_;
886
887     return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
888 }
889
890 sub _unoverload_str {
891     my $self = shift;
892
893     return $self->_unoverload( q[""], @_ );
894 }
895
896 sub _unoverload_num {
897     my $self = shift;
898
899     $self->_unoverload( '0+', @_ );
900
901     for my $val (@_) {
902         next unless $self->_is_dualvar($$val);
903         $$val = $$val + 0;
904     }
905
906     return;
907 }
908
909 # This is a hack to detect a dualvar such as $!
910 sub _is_dualvar {
911     my( $self, $val ) = @_;
912
913     # Objects are not dualvars.
914     return 0 if ref $val;
915
916     no warnings 'numeric';
917     my $numval = $val + 0;
918     return ($numval != 0 and $numval ne $val ? 1 : 0);
919 }
920
921 =item B<is_eq>
922
923   $Test->is_eq($got, $expected, $name);
924
925 Like Test::More's C<is()>.  Checks if C<$got eq $expected>.  This is the
926 string version.
927
928 C<undef> only ever matches another C<undef>.
929
930 =item B<is_num>
931
932   $Test->is_num($got, $expected, $name);
933
934 Like Test::More's C<is()>.  Checks if C<$got == $expected>.  This is the
935 numeric version.
936
937 C<undef> only ever matches another C<undef>.
938
939 =cut
940
941 sub is_eq {
942     my( $self, $got, $expect, $name ) = @_;
943     local $Level = $Level + 1;
944
945     if( !defined $got || !defined $expect ) {
946         # undef only matches undef and nothing else
947         my $test = !defined $got && !defined $expect;
948
949         $self->ok( $test, $name );
950         $self->_is_diag( $got, 'eq', $expect ) unless $test;
951         return $test;
952     }
953
954     return $self->cmp_ok( $got, 'eq', $expect, $name );
955 }
956
957 sub is_num {
958     my( $self, $got, $expect, $name ) = @_;
959     local $Level = $Level + 1;
960
961     if( !defined $got || !defined $expect ) {
962         # undef only matches undef and nothing else
963         my $test = !defined $got && !defined $expect;
964
965         $self->ok( $test, $name );
966         $self->_is_diag( $got, '==', $expect ) unless $test;
967         return $test;
968     }
969
970     return $self->cmp_ok( $got, '==', $expect, $name );
971 }
972
973 sub _diag_fmt {
974     my( $self, $type, $val ) = @_;
975
976     if( defined $$val ) {
977         if( $type eq 'eq' or $type eq 'ne' ) {
978             # quote and force string context
979             $$val = "'$$val'";
980         }
981         else {
982             # force numeric context
983             $self->_unoverload_num($val);
984         }
985     }
986     else {
987         $$val = 'undef';
988     }
989
990     return;
991 }
992
993 sub _is_diag {
994     my( $self, $got, $type, $expect ) = @_;
995
996     $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
997
998     local $Level = $Level + 1;
999     return $self->diag(<<"DIAGNOSTIC");
1000          got: $got
1001     expected: $expect
1002 DIAGNOSTIC
1003
1004 }
1005
1006 sub _isnt_diag {
1007     my( $self, $got, $type ) = @_;
1008
1009     $self->_diag_fmt( $type, \$got );
1010
1011     local $Level = $Level + 1;
1012     return $self->diag(<<"DIAGNOSTIC");
1013          got: $got
1014     expected: anything else
1015 DIAGNOSTIC
1016 }
1017
1018 =item B<isnt_eq>
1019
1020   $Test->isnt_eq($got, $dont_expect, $name);
1021
1022 Like Test::More's C<isnt()>.  Checks if C<$got ne $dont_expect>.  This is
1023 the string version.
1024
1025 =item B<isnt_num>
1026
1027   $Test->isnt_num($got, $dont_expect, $name);
1028
1029 Like Test::More's C<isnt()>.  Checks if C<$got ne $dont_expect>.  This is
1030 the numeric version.
1031
1032 =cut
1033
1034 sub isnt_eq {
1035     my( $self, $got, $dont_expect, $name ) = @_;
1036     local $Level = $Level + 1;
1037
1038     if( !defined $got || !defined $dont_expect ) {
1039         # undef only matches undef and nothing else
1040         my $test = defined $got || defined $dont_expect;
1041
1042         $self->ok( $test, $name );
1043         $self->_isnt_diag( $got, 'ne' ) unless $test;
1044         return $test;
1045     }
1046
1047     return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
1048 }
1049
1050 sub isnt_num {
1051     my( $self, $got, $dont_expect, $name ) = @_;
1052     local $Level = $Level + 1;
1053
1054     if( !defined $got || !defined $dont_expect ) {
1055         # undef only matches undef and nothing else
1056         my $test = defined $got || defined $dont_expect;
1057
1058         $self->ok( $test, $name );
1059         $self->_isnt_diag( $got, '!=' ) unless $test;
1060         return $test;
1061     }
1062
1063     return $self->cmp_ok( $got, '!=', $dont_expect, $name );
1064 }
1065
1066 =item B<like>
1067
1068   $Test->like($this, qr/$regex/, $name);
1069   $Test->like($this, '/$regex/', $name);
1070
1071 Like Test::More's C<like()>.  Checks if $this matches the given C<$regex>.
1072
1073 =item B<unlike>
1074
1075   $Test->unlike($this, qr/$regex/, $name);
1076   $Test->unlike($this, '/$regex/', $name);
1077
1078 Like Test::More's C<unlike()>.  Checks if $this B<does not match> the
1079 given C<$regex>.
1080
1081 =cut
1082
1083 sub like {
1084     my( $self, $this, $regex, $name ) = @_;
1085
1086     local $Level = $Level + 1;
1087     return $self->_regex_ok( $this, $regex, '=~', $name );
1088 }
1089
1090 sub unlike {
1091     my( $self, $this, $regex, $name ) = @_;
1092
1093     local $Level = $Level + 1;
1094     return $self->_regex_ok( $this, $regex, '!~', $name );
1095 }
1096
1097 =item B<cmp_ok>
1098
1099   $Test->cmp_ok($this, $type, $that, $name);
1100
1101 Works just like Test::More's C<cmp_ok()>.
1102
1103     $Test->cmp_ok($big_num, '!=', $other_big_num);
1104
1105 =cut
1106
1107 my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
1108
1109 sub cmp_ok {
1110     my( $self, $got, $type, $expect, $name ) = @_;
1111
1112     my $test;
1113     my $error;
1114     {
1115         ## no critic (BuiltinFunctions::ProhibitStringyEval)
1116
1117         local( $@, $!, $SIG{__DIE__} );    # isolate eval
1118
1119         my($pack, $file, $line) = $self->caller();
1120
1121         # This is so that warnings come out at the caller's level
1122         $test = eval qq[
1123 #line $line "(eval in cmp_ok) $file"
1124 \$got $type \$expect;
1125 ];
1126         $error = $@;
1127     }
1128     local $Level = $Level + 1;
1129     my $ok = $self->ok( $test, $name );
1130
1131     # Treat overloaded objects as numbers if we're asked to do a
1132     # numeric comparison.
1133     my $unoverload
1134       = $numeric_cmps{$type}
1135       ? '_unoverload_num'
1136       : '_unoverload_str';
1137
1138     $self->diag(<<"END") if $error;
1139 An error occurred while using $type:
1140 ------------------------------------
1141 $error
1142 ------------------------------------
1143 END
1144
1145     unless($ok) {
1146         $self->$unoverload( \$got, \$expect );
1147
1148         if( $type =~ /^(eq|==)$/ ) {
1149             $self->_is_diag( $got, $type, $expect );
1150         }
1151         elsif( $type =~ /^(ne|!=)$/ ) {
1152             $self->_isnt_diag( $got, $type );
1153         }
1154         else {
1155             $self->_cmp_diag( $got, $type, $expect );
1156         }
1157     }
1158     return $ok;
1159 }
1160
1161 sub _cmp_diag {
1162     my( $self, $got, $type, $expect ) = @_;
1163
1164     $got    = defined $got    ? "'$got'"    : 'undef';
1165     $expect = defined $expect ? "'$expect'" : 'undef';
1166
1167     local $Level = $Level + 1;
1168     return $self->diag(<<"DIAGNOSTIC");
1169     $got
1170         $type
1171     $expect
1172 DIAGNOSTIC
1173 }
1174
1175 sub _caller_context {
1176     my $self = shift;
1177
1178     my( $pack, $file, $line ) = $self->caller(1);
1179
1180     my $code = '';
1181     $code .= "#line $line $file\n" if defined $file and defined $line;
1182
1183     return $code;
1184 }
1185
1186 =back
1187
1188
1189 =head2 Other Testing Methods
1190
1191 These are methods which are used in the course of writing a test but are not themselves tests.
1192
1193 =over 4
1194
1195 =item B<BAIL_OUT>
1196
1197     $Test->BAIL_OUT($reason);
1198
1199 Indicates to the Test::Harness that things are going so badly all
1200 testing should terminate.  This includes running any additional test
1201 scripts.
1202
1203 It will exit with 255.
1204
1205 =cut
1206
1207 sub BAIL_OUT {
1208     my( $self, $reason ) = @_;
1209
1210     $self->{Bailed_Out} = 1;
1211     $self->_print("Bail out!  $reason");
1212     exit 255;
1213 }
1214
1215 =for deprecated
1216 BAIL_OUT() used to be BAILOUT()
1217
1218 =cut
1219
1220 {
1221     no warnings 'once';
1222     *BAILOUT = \&BAIL_OUT;
1223 }
1224
1225 =item B<skip>
1226
1227     $Test->skip;
1228     $Test->skip($why);
1229
1230 Skips the current test, reporting C<$why>.
1231
1232 =cut
1233
1234 sub skip {
1235     my( $self, $why ) = @_;
1236     $why ||= '';
1237     $self->_unoverload_str( \$why );
1238
1239     lock( $self->{Curr_Test} );
1240     $self->{Curr_Test}++;
1241
1242     $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
1243         {
1244             'ok'      => 1,
1245             actual_ok => 1,
1246             name      => '',
1247             type      => 'skip',
1248             reason    => $why,
1249         }
1250     );
1251
1252     my $out = "ok";
1253     $out .= " $self->{Curr_Test}" if $self->use_numbers;
1254     $out .= " # skip";
1255     $out .= " $why"               if length $why;
1256     $out .= "\n";
1257
1258     $self->_print($out);
1259
1260     return 1;
1261 }
1262
1263 =item B<todo_skip>
1264
1265   $Test->todo_skip;
1266   $Test->todo_skip($why);
1267
1268 Like C<skip()>, only it will declare the test as failing and TODO.  Similar
1269 to
1270
1271     print "not ok $tnum # TODO $why\n";
1272
1273 =cut
1274
1275 sub todo_skip {
1276     my( $self, $why ) = @_;
1277     $why ||= '';
1278
1279     lock( $self->{Curr_Test} );
1280     $self->{Curr_Test}++;
1281
1282     $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
1283         {
1284             'ok'      => 1,
1285             actual_ok => 0,
1286             name      => '',
1287             type      => 'todo_skip',
1288             reason    => $why,
1289         }
1290     );
1291
1292     my $out = "not ok";
1293     $out .= " $self->{Curr_Test}" if $self->use_numbers;
1294     $out .= " # TODO & SKIP $why\n";
1295
1296     $self->_print($out);
1297
1298     return 1;
1299 }
1300
1301 =begin _unimplemented
1302
1303 =item B<skip_rest>
1304
1305   $Test->skip_rest;
1306   $Test->skip_rest($reason);
1307
1308 Like C<skip()>, only it skips all the rest of the tests you plan to run
1309 and terminates the test.
1310
1311 If you're running under C<no_plan>, it skips once and terminates the
1312 test.
1313
1314 =end _unimplemented
1315
1316 =back
1317
1318
1319 =head2 Test building utility methods
1320
1321 These methods are useful when writing your own test methods.
1322
1323 =over 4
1324
1325 =item B<maybe_regex>
1326
1327   $Test->maybe_regex(qr/$regex/);
1328   $Test->maybe_regex('/$regex/');
1329
1330 This method used to be useful back when Test::Builder worked on Perls
1331 before 5.6 which didn't have qr//.  Now its pretty useless.
1332
1333 Convenience method for building testing functions that take regular
1334 expressions as arguments.
1335
1336 Takes a quoted regular expression produced by C<qr//>, or a string
1337 representing a regular expression.
1338
1339 Returns a Perl value which may be used instead of the corresponding
1340 regular expression, or C<undef> if its argument is not recognised.
1341
1342 For example, a version of C<like()>, sans the useful diagnostic messages,
1343 could be written as:
1344
1345   sub laconic_like {
1346       my ($self, $this, $regex, $name) = @_;
1347       my $usable_regex = $self->maybe_regex($regex);
1348       die "expecting regex, found '$regex'\n"
1349           unless $usable_regex;
1350       $self->ok($this =~ m/$usable_regex/, $name);
1351   }
1352
1353 =cut
1354
1355 sub maybe_regex {
1356     my( $self, $regex ) = @_;
1357     my $usable_regex = undef;
1358
1359     return $usable_regex unless defined $regex;
1360
1361     my( $re, $opts );
1362
1363     # Check for qr/foo/
1364     if( _is_qr($regex) ) {
1365         $usable_regex = $regex;
1366     }
1367     # Check for '/foo/' or 'm,foo,'
1368     elsif(( $re, $opts )        = $regex =~ m{^ /(.*)/ (\w*) $ }sx              or
1369           ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
1370     )
1371     {
1372         $usable_regex = length $opts ? "(?$opts)$re" : $re;
1373     }
1374
1375     return $usable_regex;
1376 }
1377
1378 sub _is_qr {
1379     my $regex = shift;
1380
1381     # is_regexp() checks for regexes in a robust manner, say if they're
1382     # blessed.
1383     return re::is_regexp($regex) if defined &re::is_regexp;
1384     return ref $regex eq 'Regexp';
1385 }
1386
1387 sub _regex_ok {
1388     my( $self, $this, $regex, $cmp, $name ) = @_;
1389
1390     my $ok           = 0;
1391     my $usable_regex = $self->maybe_regex($regex);
1392     unless( defined $usable_regex ) {
1393         local $Level = $Level + 1;
1394         $ok = $self->ok( 0, $name );
1395         $self->diag("    '$regex' doesn't look much like a regex to me.");
1396         return $ok;
1397     }
1398
1399     {
1400         ## no critic (BuiltinFunctions::ProhibitStringyEval)
1401
1402         my $test;
1403         my $context = $self->_caller_context;
1404
1405         local( $@, $!, $SIG{__DIE__} );    # isolate eval
1406
1407         $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
1408
1409         $test = !$test if $cmp eq '!~';
1410
1411         local $Level = $Level + 1;
1412         $ok = $self->ok( $test, $name );
1413     }
1414
1415     unless($ok) {
1416         $this = defined $this ? "'$this'" : 'undef';
1417         my $match = $cmp eq '=~' ? "doesn't match" : "matches";
1418
1419         local $Level = $Level + 1;
1420         $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
1421                   %s
1422     %13s '%s'
1423 DIAGNOSTIC
1424
1425     }
1426
1427     return $ok;
1428 }
1429
1430 # I'm not ready to publish this.  It doesn't deal with array return
1431 # values from the code or context.
1432
1433 =begin private
1434
1435 =item B<_try>
1436
1437     my $return_from_code          = $Test->try(sub { code });
1438     my($return_from_code, $error) = $Test->try(sub { code });
1439
1440 Works like eval BLOCK except it ensures it has no effect on the rest
1441 of the test (ie. C<$@> is not set) nor is effected by outside
1442 interference (ie. C<$SIG{__DIE__}>) and works around some quirks in older
1443 Perls.
1444
1445 C<$error> is what would normally be in C<$@>.
1446
1447 It is suggested you use this in place of eval BLOCK.
1448
1449 =cut
1450
1451 sub _try {
1452     my( $self, $code, %opts ) = @_;
1453
1454     my $error;
1455     my $return;
1456     {
1457         local $!;               # eval can mess up $!
1458         local $@;               # don't set $@ in the test
1459         local $SIG{__DIE__};    # don't trip an outside DIE handler.
1460         $return = eval { $code->() };
1461         $error = $@;
1462     }
1463
1464     die $error if $error and $opts{die_on_fail};
1465
1466     return wantarray ? ( $return, $error ) : $return;
1467 }
1468
1469 =end private
1470
1471
1472 =item B<is_fh>
1473
1474     my $is_fh = $Test->is_fh($thing);
1475
1476 Determines if the given C<$thing> can be used as a filehandle.
1477
1478 =cut
1479
1480 sub is_fh {
1481     my $self     = shift;
1482     my $maybe_fh = shift;
1483     return 0 unless defined $maybe_fh;
1484
1485     return 1 if ref $maybe_fh  eq 'GLOB';    # its a glob ref
1486     return 1 if ref \$maybe_fh eq 'GLOB';    # its a glob
1487
1488     return eval { $maybe_fh->isa("IO::Handle") } ||
1489            eval { tied($maybe_fh)->can('TIEHANDLE') };
1490 }
1491
1492 =back
1493
1494
1495 =head2 Test style
1496
1497
1498 =over 4
1499
1500 =item B<level>
1501
1502     $Test->level($how_high);
1503
1504 How far up the call stack should C<$Test> look when reporting where the
1505 test failed.
1506
1507 Defaults to 1.
1508
1509 Setting L<$Test::Builder::Level> overrides.  This is typically useful
1510 localized:
1511
1512     sub my_ok {
1513         my $test = shift;
1514
1515         local $Test::Builder::Level = $Test::Builder::Level + 1;
1516         $TB->ok($test);
1517     }
1518
1519 To be polite to other functions wrapping your own you usually want to increment C<$Level> rather than set it to a constant.
1520
1521 =cut
1522
1523 sub level {
1524     my( $self, $level ) = @_;
1525
1526     if( defined $level ) {
1527         $Level = $level;
1528     }
1529     return $Level;
1530 }
1531
1532 =item B<use_numbers>
1533
1534     $Test->use_numbers($on_or_off);
1535
1536 Whether or not the test should output numbers.  That is, this if true:
1537
1538   ok 1
1539   ok 2
1540   ok 3
1541
1542 or this if false
1543
1544   ok
1545   ok
1546   ok
1547
1548 Most useful when you can't depend on the test output order, such as
1549 when threads or forking is involved.
1550
1551 Defaults to on.
1552
1553 =cut
1554
1555 sub use_numbers {
1556     my( $self, $use_nums ) = @_;
1557
1558     if( defined $use_nums ) {
1559         $self->{Use_Nums} = $use_nums;
1560     }
1561     return $self->{Use_Nums};
1562 }
1563
1564 =item B<no_diag>
1565
1566     $Test->no_diag($no_diag);
1567
1568 If set true no diagnostics will be printed.  This includes calls to
1569 C<diag()>.
1570
1571 =item B<no_ending>
1572
1573     $Test->no_ending($no_ending);
1574
1575 Normally, Test::Builder does some extra diagnostics when the test
1576 ends.  It also changes the exit code as described below.
1577
1578 If this is true, none of that will be done.
1579
1580 =item B<no_header>
1581
1582     $Test->no_header($no_header);
1583
1584 If set to true, no "1..N" header will be printed.
1585
1586 =cut
1587
1588 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1589     my $method = lc $attribute;
1590
1591     my $code = sub {
1592         my( $self, $no ) = @_;
1593
1594         if( defined $no ) {
1595             $self->{$attribute} = $no;
1596         }
1597         return $self->{$attribute};
1598     };
1599
1600     no strict 'refs';    ## no critic
1601     *{ __PACKAGE__ . '::' . $method } = $code;
1602 }
1603
1604 =back
1605
1606 =head2 Output
1607
1608 Controlling where the test output goes.
1609
1610 It's ok for your test to change where STDOUT and STDERR point to,
1611 Test::Builder's default output settings will not be affected.
1612
1613 =over 4
1614
1615 =item B<diag>
1616
1617     $Test->diag(@msgs);
1618
1619 Prints out the given C<@msgs>.  Like C<print>, arguments are simply
1620 appended together.
1621
1622 Normally, it uses the C<failure_output()> handle, but if this is for a
1623 TODO test, the C<todo_output()> handle is used.
1624
1625 Output will be indented and marked with a # so as not to interfere
1626 with test output.  A newline will be put on the end if there isn't one
1627 already.
1628
1629 We encourage using this rather than calling print directly.
1630
1631 Returns false.  Why?  Because C<diag()> is often used in conjunction with
1632 a failing test (C<ok() || diag()>) it "passes through" the failure.
1633
1634     return ok(...) || diag(...);
1635
1636 =for blame transfer
1637 Mark Fowler <mark@twoshortplanks.com>
1638
1639 =cut
1640
1641 sub diag {
1642     my $self = shift;
1643
1644     $self->_print_comment( $self->_diag_fh, @_ );
1645 }
1646
1647 =item B<note>
1648
1649     $Test->note(@msgs);
1650
1651 Like C<diag()>, but it prints to the C<output()> handle so it will not
1652 normally be seen by the user except in verbose mode.
1653
1654 =cut
1655
1656 sub note {
1657     my $self = shift;
1658
1659     $self->_print_comment( $self->output, @_ );
1660 }
1661
1662 sub _diag_fh {
1663     my $self = shift;
1664
1665     local $Level = $Level + 1;
1666     return $self->in_todo ? $self->todo_output : $self->failure_output;
1667 }
1668
1669 sub _print_comment {
1670     my( $self, $fh, @msgs ) = @_;
1671
1672     return if $self->no_diag;
1673     return unless @msgs;
1674
1675     # Prevent printing headers when compiling (i.e. -c)
1676     return if $^C;
1677
1678     # Smash args together like print does.
1679     # Convert undef to 'undef' so its readable.
1680     my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1681
1682     # Escape the beginning, _print will take care of the rest.
1683     $msg =~ s/^/# /;
1684
1685     local $Level = $Level + 1;
1686     $self->_print_to_fh( $fh, $msg );
1687
1688     return 0;
1689 }
1690
1691 =item B<explain>
1692
1693     my @dump = $Test->explain(@msgs);
1694
1695 Will dump the contents of any references in a human readable format.
1696 Handy for things like...
1697
1698     is_deeply($have, $want) || diag explain $have;
1699
1700 or
1701
1702     is_deeply($have, $want) || note explain $have;
1703
1704 =cut
1705
1706 sub explain {
1707     my $self = shift;
1708
1709     return map {
1710         ref $_
1711           ? do {
1712             $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
1713
1714             my $dumper = Data::Dumper->new( [$_] );
1715             $dumper->Indent(1)->Terse(1);
1716             $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
1717             $dumper->Dump;
1718           }
1719           : $_
1720     } @_;
1721 }
1722
1723 =begin _private
1724
1725 =item B<_print>
1726
1727     $Test->_print(@msgs);
1728
1729 Prints to the C<output()> filehandle.
1730
1731 =end _private
1732
1733 =cut
1734
1735 sub _print {
1736     my $self = shift;
1737     return $self->_print_to_fh( $self->output, @_ );
1738 }
1739
1740 sub _print_to_fh {
1741     my( $self, $fh, @msgs ) = @_;
1742
1743     # Prevent printing headers when only compiling.  Mostly for when
1744     # tests are deparsed with B::Deparse
1745     return if $^C;
1746
1747     my $msg = join '', @msgs;
1748     my $indent = $self->_indent;
1749
1750     local( $\, $", $, ) = ( undef, ' ', '' );
1751
1752     # Escape each line after the first with a # so we don't
1753     # confuse Test::Harness.
1754     $msg =~ s{\n(?!\z)}{\n$indent# }sg;
1755
1756     # Stick a newline on the end if it needs it.
1757     $msg .= "\n" unless $msg =~ /\n\z/;
1758
1759     return print $fh $indent, $msg;
1760 }
1761
1762 =item B<output>
1763
1764 =item B<failure_output>
1765
1766 =item B<todo_output>
1767
1768     my $filehandle = $Test->output;
1769     $Test->output($filehandle);
1770     $Test->output($filename);
1771     $Test->output(\$scalar);
1772
1773 These methods control where Test::Builder will print its output.
1774 They take either an open C<$filehandle>, a C<$filename> to open and write to
1775 or a C<$scalar> reference to append to.  It will always return a C<$filehandle>.
1776
1777 B<output> is where normal "ok/not ok" test output goes.
1778
1779 Defaults to STDOUT.
1780
1781 B<failure_output> is where diagnostic output on test failures and
1782 C<diag()> goes.  It is normally not read by Test::Harness and instead is
1783 displayed to the user.
1784
1785 Defaults to STDERR.
1786
1787 C<todo_output> is used instead of C<failure_output()> for the
1788 diagnostics of a failing TODO test.  These will not be seen by the
1789 user.
1790
1791 Defaults to STDOUT.
1792
1793 =cut
1794
1795 sub output {
1796     my( $self, $fh ) = @_;
1797
1798     if( defined $fh ) {
1799         $self->{Out_FH} = $self->_new_fh($fh);
1800     }
1801     return $self->{Out_FH};
1802 }
1803
1804 sub failure_output {
1805     my( $self, $fh ) = @_;
1806
1807     if( defined $fh ) {
1808         $self->{Fail_FH} = $self->_new_fh($fh);
1809     }
1810     return $self->{Fail_FH};
1811 }
1812
1813 sub todo_output {
1814     my( $self, $fh ) = @_;
1815
1816     if( defined $fh ) {
1817         $self->{Todo_FH} = $self->_new_fh($fh);
1818     }
1819     return $self->{Todo_FH};
1820 }
1821
1822 sub _new_fh {
1823     my $self = shift;
1824     my($file_or_fh) = shift;
1825
1826     my $fh;
1827     if( $self->is_fh($file_or_fh) ) {
1828         $fh = $file_or_fh;
1829     }
1830     elsif( ref $file_or_fh eq 'SCALAR' ) {
1831         # Scalar refs as filehandles was added in 5.8.
1832         if( $] >= 5.008 ) {
1833             open $fh, ">>", $file_or_fh
1834               or $self->croak("Can't open scalar ref $file_or_fh: $!");
1835         }
1836         # Emulate scalar ref filehandles with a tie.
1837         else {
1838             $fh = Test::Builder::IO::Scalar->new($file_or_fh)
1839               or $self->croak("Can't tie scalar ref $file_or_fh");
1840         }
1841     }
1842     else {
1843         open $fh, ">", $file_or_fh
1844           or $self->croak("Can't open test output log $file_or_fh: $!");
1845         _autoflush($fh);
1846     }
1847
1848     return $fh;
1849 }
1850
1851 sub _autoflush {
1852     my($fh) = shift;
1853     my $old_fh = select $fh;
1854     $| = 1;
1855     select $old_fh;
1856
1857     return;
1858 }
1859
1860 my( $Testout, $Testerr );
1861
1862 sub _dup_stdhandles {
1863     my $self = shift;
1864
1865     $self->_open_testhandles;
1866
1867     # Set everything to unbuffered else plain prints to STDOUT will
1868     # come out in the wrong order from our own prints.
1869     _autoflush($Testout);
1870     _autoflush( \*STDOUT );
1871     _autoflush($Testerr);
1872     _autoflush( \*STDERR );
1873
1874     $self->reset_outputs;
1875
1876     return;
1877 }
1878
1879 sub _open_testhandles {
1880     my $self = shift;
1881
1882     return if $self->{Opened_Testhandles};
1883
1884     # We dup STDOUT and STDERR so people can change them in their
1885     # test suites while still getting normal test output.
1886     open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT:  $!";
1887     open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR:  $!";
1888
1889     $self->_copy_io_layers( \*STDOUT, $Testout );
1890     $self->_copy_io_layers( \*STDERR, $Testerr );
1891
1892     $self->{Opened_Testhandles} = 1;
1893
1894     return;
1895 }
1896
1897 sub _copy_io_layers {
1898     my( $self, $src, $dst ) = @_;
1899
1900     $self->_try(
1901         sub {
1902             require PerlIO;
1903             my @src_layers = PerlIO::get_layers($src);
1904
1905             _apply_layers($dst, @src_layers) if @src_layers;
1906         }
1907     );
1908
1909     return;
1910 }
1911
1912 sub _apply_layers {
1913     my ($fh, @layers) = @_;
1914     my %seen;
1915     my @unique = grep { $_ ne 'unix' and !$seen{$_}++ } @layers;
1916     binmode($fh, join(":", "", "raw", @unique));
1917 }
1918
1919
1920 =item reset_outputs
1921
1922   $tb->reset_outputs;
1923
1924 Resets all the output filehandles back to their defaults.
1925
1926 =cut
1927
1928 sub reset_outputs {
1929     my $self = shift;
1930
1931     $self->output        ($Testout);
1932     $self->failure_output($Testerr);
1933     $self->todo_output   ($Testout);
1934
1935     return;
1936 }
1937
1938 =item carp
1939
1940   $tb->carp(@message);
1941
1942 Warns with C<@message> but the message will appear to come from the
1943 point where the original test function was called (C<< $tb->caller >>).
1944
1945 =item croak
1946
1947   $tb->croak(@message);
1948
1949 Dies with C<@message> but the message will appear to come from the
1950 point where the original test function was called (C<< $tb->caller >>).
1951
1952 =cut
1953
1954 sub _message_at_caller {
1955     my $self = shift;
1956
1957     local $Level = $Level + 1;
1958     my( $pack, $file, $line ) = $self->caller;
1959     return join( "", @_ ) . " at $file line $line.\n";
1960 }
1961
1962 sub carp {
1963     my $self = shift;
1964     return warn $self->_message_at_caller(@_);
1965 }
1966
1967 sub croak {
1968     my $self = shift;
1969     return die $self->_message_at_caller(@_);
1970 }
1971
1972
1973 =back
1974
1975
1976 =head2 Test Status and Info
1977
1978 =over 4
1979
1980 =item B<current_test>
1981
1982     my $curr_test = $Test->current_test;
1983     $Test->current_test($num);
1984
1985 Gets/sets the current test number we're on.  You usually shouldn't
1986 have to set this.
1987
1988 If set forward, the details of the missing tests are filled in as 'unknown'.
1989 if set backward, the details of the intervening tests are deleted.  You
1990 can erase history if you really want to.
1991
1992 =cut
1993
1994 sub current_test {
1995     my( $self, $num ) = @_;
1996
1997     lock( $self->{Curr_Test} );
1998     if( defined $num ) {
1999         $self->{Curr_Test} = $num;
2000
2001         # If the test counter is being pushed forward fill in the details.
2002         my $test_results = $self->{Test_Results};
2003         if( $num > @$test_results ) {
2004             my $start = @$test_results ? @$test_results : 0;
2005             for( $start .. $num - 1 ) {
2006                 $test_results->[$_] = &share(
2007                     {
2008                         'ok'      => 1,
2009                         actual_ok => undef,
2010                         reason    => 'incrementing test number',
2011                         type      => 'unknown',
2012                         name      => undef
2013                     }
2014                 );
2015             }
2016         }
2017         # If backward, wipe history.  Its their funeral.
2018         elsif( $num < @$test_results ) {
2019             $#{$test_results} = $num - 1;
2020         }
2021     }
2022     return $self->{Curr_Test};
2023 }
2024
2025 =item B<is_passing>
2026
2027    my $ok = $builder->is_passing;
2028
2029 Indicates if the test suite is currently passing.
2030
2031 More formally, it will be false if anything has happened which makes
2032 it impossible for the test suite to pass.  True otherwise.
2033
2034 For example, if no tests have run C<is_passing()> will be true because
2035 even though a suite with no tests is a failure you can add a passing
2036 test to it and start passing.
2037
2038 Don't think about it too much.
2039
2040 =cut
2041
2042 sub is_passing {
2043     my $self = shift;
2044
2045     if( @_ ) {
2046         $self->{Is_Passing} = shift;
2047     }
2048
2049     return $self->{Is_Passing};
2050 }
2051
2052
2053 =item B<summary>
2054
2055     my @tests = $Test->summary;
2056
2057 A simple summary of the tests so far.  True for pass, false for fail.
2058 This is a logical pass/fail, so todos are passes.
2059
2060 Of course, test #1 is $tests[0], etc...
2061
2062 =cut
2063
2064 sub summary {
2065     my($self) = shift;
2066
2067     return map { $_->{'ok'} } @{ $self->{Test_Results} };
2068 }
2069
2070 =item B<details>
2071
2072     my @tests = $Test->details;
2073
2074 Like C<summary()>, but with a lot more detail.
2075
2076     $tests[$test_num - 1] = 
2077             { 'ok'       => is the test considered a pass?
2078               actual_ok  => did it literally say 'ok'?
2079               name       => name of the test (if any)
2080               type       => type of test (if any, see below).
2081               reason     => reason for the above (if any)
2082             };
2083
2084 'ok' is true if Test::Harness will consider the test to be a pass.
2085
2086 'actual_ok' is a reflection of whether or not the test literally
2087 printed 'ok' or 'not ok'.  This is for examining the result of 'todo'
2088 tests.
2089
2090 'name' is the name of the test.
2091
2092 'type' indicates if it was a special test.  Normal tests have a type
2093 of ''.  Type can be one of the following:
2094
2095     skip        see skip()
2096     todo        see todo()
2097     todo_skip   see todo_skip()
2098     unknown     see below
2099
2100 Sometimes the Test::Builder test counter is incremented without it
2101 printing any test output, for example, when C<current_test()> is changed.
2102 In these cases, Test::Builder doesn't know the result of the test, so
2103 its type is 'unknown'.  These details for these tests are filled in.
2104 They are considered ok, but the name and actual_ok is left C<undef>.
2105
2106 For example "not ok 23 - hole count # TODO insufficient donuts" would
2107 result in this structure:
2108
2109     $tests[22] =    # 23 - 1, since arrays start from 0.
2110       { ok        => 1,   # logically, the test passed since its todo
2111         actual_ok => 0,   # in absolute terms, it failed
2112         name      => 'hole count',
2113         type      => 'todo',
2114         reason    => 'insufficient donuts'
2115       };
2116
2117 =cut
2118
2119 sub details {
2120     my $self = shift;
2121     return @{ $self->{Test_Results} };
2122 }
2123
2124 =item B<todo>
2125
2126     my $todo_reason = $Test->todo;
2127     my $todo_reason = $Test->todo($pack);
2128
2129 If the current tests are considered "TODO" it will return the reason,
2130 if any.  This reason can come from a C<$TODO> variable or the last call
2131 to C<todo_start()>.
2132
2133 Since a TODO test does not need a reason, this function can return an
2134 empty string even when inside a TODO block.  Use C<< $Test->in_todo >>
2135 to determine if you are currently inside a TODO block.
2136
2137 C<todo()> is about finding the right package to look for C<$TODO> in.  It's
2138 pretty good at guessing the right package to look at.  It first looks for
2139 the caller based on C<$Level + 1>, since C<todo()> is usually called inside
2140 a test function.  As a last resort it will use C<exported_to()>.
2141
2142 Sometimes there is some confusion about where todo() should be looking
2143 for the C<$TODO> variable.  If you want to be sure, tell it explicitly
2144 what $pack to use.
2145
2146 =cut
2147
2148 sub todo {
2149     my( $self, $pack ) = @_;
2150
2151     return $self->{Todo} if defined $self->{Todo};
2152
2153     local $Level = $Level + 1;
2154     my $todo = $self->find_TODO($pack);
2155     return $todo if defined $todo;
2156
2157     return '';
2158 }
2159
2160 =item B<find_TODO>
2161
2162     my $todo_reason = $Test->find_TODO();
2163     my $todo_reason = $Test->find_TODO($pack);
2164
2165 Like C<todo()> but only returns the value of C<$TODO> ignoring
2166 C<todo_start()>.
2167
2168 Can also be used to set C<$TODO> to a new value while returning the
2169 old value:
2170
2171     my $old_reason = $Test->find_TODO($pack, 1, $new_reason);
2172
2173 =cut
2174
2175 sub find_TODO {
2176     my( $self, $pack, $set, $new_value ) = @_;
2177
2178     $pack = $pack || $self->caller(1) || $self->exported_to;
2179     return unless $pack;
2180
2181     no strict 'refs';    ## no critic
2182     my $old_value = ${ $pack . '::TODO' };
2183     $set and ${ $pack . '::TODO' } = $new_value;
2184     return $old_value;
2185 }
2186
2187 =item B<in_todo>
2188
2189     my $in_todo = $Test->in_todo;
2190
2191 Returns true if the test is currently inside a TODO block.
2192
2193 =cut
2194
2195 sub in_todo {
2196     my $self = shift;
2197
2198     local $Level = $Level + 1;
2199     return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
2200 }
2201
2202 =item B<todo_start>
2203
2204     $Test->todo_start();
2205     $Test->todo_start($message);
2206
2207 This method allows you declare all subsequent tests as TODO tests, up until
2208 the C<todo_end> method has been called.
2209
2210 The C<TODO:> and C<$TODO> syntax is generally pretty good about figuring out
2211 whether or not we're in a TODO test.  However, often we find that this is not
2212 possible to determine (such as when we want to use C<$TODO> but
2213 the tests are being executed in other packages which can't be inferred
2214 beforehand).
2215
2216 Note that you can use this to nest "todo" tests
2217
2218  $Test->todo_start('working on this');
2219  # lots of code
2220  $Test->todo_start('working on that');
2221  # more code
2222  $Test->todo_end;
2223  $Test->todo_end;
2224
2225 This is generally not recommended, but large testing systems often have weird
2226 internal needs.
2227
2228 We've tried to make this also work with the TODO: syntax, but it's not
2229 guaranteed and its use is also discouraged:
2230
2231  TODO: {
2232      local $TODO = 'We have work to do!';
2233      $Test->todo_start('working on this');
2234      # lots of code
2235      $Test->todo_start('working on that');
2236      # more code
2237      $Test->todo_end;
2238      $Test->todo_end;
2239  }
2240
2241 Pick one style or another of "TODO" to be on the safe side.
2242
2243 =cut
2244
2245 sub todo_start {
2246     my $self = shift;
2247     my $message = @_ ? shift : '';
2248
2249     $self->{Start_Todo}++;
2250     if( $self->in_todo ) {
2251         push @{ $self->{Todo_Stack} } => $self->todo;
2252     }
2253     $self->{Todo} = $message;
2254
2255     return;
2256 }
2257
2258 =item C<todo_end>
2259
2260  $Test->todo_end;
2261
2262 Stops running tests as "TODO" tests.  This method is fatal if called without a
2263 preceding C<todo_start> method call.
2264
2265 =cut
2266
2267 sub todo_end {
2268     my $self = shift;
2269
2270     if( !$self->{Start_Todo} ) {
2271         $self->croak('todo_end() called without todo_start()');
2272     }
2273
2274     $self->{Start_Todo}--;
2275
2276     if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
2277         $self->{Todo} = pop @{ $self->{Todo_Stack} };
2278     }
2279     else {
2280         delete $self->{Todo};
2281     }
2282
2283     return;
2284 }
2285
2286 =item B<caller>
2287
2288     my $package = $Test->caller;
2289     my($pack, $file, $line) = $Test->caller;
2290     my($pack, $file, $line) = $Test->caller($height);
2291
2292 Like the normal C<caller()>, except it reports according to your C<level()>.
2293
2294 C<$height> will be added to the C<level()>.
2295
2296 If C<caller()> winds up off the top of the stack it report the highest context.
2297
2298 =cut
2299
2300 sub caller {    ## no critic (Subroutines::ProhibitBuiltinHomonyms)
2301     my( $self, $height ) = @_;
2302     $height ||= 0;
2303
2304     my $level = $self->level + $height + 1;
2305     my @caller;
2306     do {
2307         @caller = CORE::caller( $level );
2308         $level--;
2309     } until @caller;
2310     return wantarray ? @caller : $caller[0];
2311 }
2312
2313 =back
2314
2315 =cut
2316
2317 =begin _private
2318
2319 =over 4
2320
2321 =item B<_sanity_check>
2322
2323   $self->_sanity_check();
2324
2325 Runs a bunch of end of test sanity checks to make sure reality came
2326 through ok.  If anything is wrong it will die with a fairly friendly
2327 error message.
2328
2329 =cut
2330
2331 #'#
2332 sub _sanity_check {
2333     my $self = shift;
2334
2335     $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
2336     $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
2337         'Somehow you got a different number of results than tests ran!' );
2338
2339     return;
2340 }
2341
2342 =item B<_whoa>
2343
2344   $self->_whoa($check, $description);
2345
2346 A sanity check, similar to C<assert()>.  If the C<$check> is true, something
2347 has gone horribly wrong.  It will die with the given C<$description> and
2348 a note to contact the author.
2349
2350 =cut
2351
2352 sub _whoa {
2353     my( $self, $check, $desc ) = @_;
2354     if($check) {
2355         local $Level = $Level + 1;
2356         $self->croak(<<"WHOA");
2357 WHOA!  $desc
2358 This should never happen!  Please contact the author immediately!
2359 WHOA
2360     }
2361
2362     return;
2363 }
2364
2365 =item B<_my_exit>
2366
2367   _my_exit($exit_num);
2368
2369 Perl seems to have some trouble with exiting inside an C<END> block.
2370 5.6.1 does some odd things.  Instead, this function edits C<$?>
2371 directly.  It should B<only> be called from inside an C<END> block.
2372 It doesn't actually exit, that's your job.
2373
2374 =cut
2375
2376 sub _my_exit {
2377     $? = $_[0];    ## no critic (Variables::RequireLocalizedPunctuationVars)
2378
2379     return 1;
2380 }
2381
2382 =back
2383
2384 =end _private
2385
2386 =cut
2387
2388 sub _ending {
2389     my $self = shift;
2390     return if $self->no_ending;
2391     return if $self->{Ending}++;
2392
2393     my $real_exit_code = $?;
2394
2395     # Don't bother with an ending if this is a forked copy.  Only the parent
2396     # should do the ending.
2397     if( $self->{Original_Pid} != $$ ) {
2398         return;
2399     }
2400
2401     # Ran tests but never declared a plan or hit done_testing
2402     if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
2403         $self->is_passing(0);
2404         $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
2405     }
2406
2407     # Exit if plan() was never called.  This is so "require Test::Simple"
2408     # doesn't puke.
2409     if( !$self->{Have_Plan} ) {
2410         return;
2411     }
2412
2413     # Don't do an ending if we bailed out.
2414     if( $self->{Bailed_Out} ) {
2415         $self->is_passing(0);
2416         return;
2417     }
2418     # Figure out if we passed or failed and print helpful messages.
2419     my $test_results = $self->{Test_Results};
2420     if(@$test_results) {
2421         # The plan?  We have no plan.
2422         if( $self->{No_Plan} ) {
2423             $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
2424             $self->{Expected_Tests} = $self->{Curr_Test};
2425         }
2426
2427         # Auto-extended arrays and elements which aren't explicitly
2428         # filled in with a shared reference will puke under 5.8.0
2429         # ithreads.  So we have to fill them in by hand. :(
2430         my $empty_result = &share( {} );
2431         for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
2432             $test_results->[$idx] = $empty_result
2433               unless defined $test_results->[$idx];
2434         }
2435
2436         my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
2437
2438         my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
2439
2440         if( $num_extra != 0 ) {
2441             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
2442             $self->diag(<<"FAIL");
2443 Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
2444 FAIL
2445             $self->is_passing(0);
2446         }
2447
2448         if($num_failed) {
2449             my $num_tests = $self->{Curr_Test};
2450             my $s = $num_failed == 1 ? '' : 's';
2451
2452             my $qualifier = $num_extra == 0 ? '' : ' run';
2453
2454             $self->diag(<<"FAIL");
2455 Looks like you failed $num_failed test$s of $num_tests$qualifier.
2456 FAIL
2457             $self->is_passing(0);
2458         }
2459
2460         if($real_exit_code) {
2461             $self->diag(<<"FAIL");
2462 Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
2463 FAIL
2464             $self->is_passing(0);
2465             _my_exit($real_exit_code) && return;
2466         }
2467
2468         my $exit_code;
2469         if($num_failed) {
2470             $exit_code = $num_failed <= 254 ? $num_failed : 254;
2471         }
2472         elsif( $num_extra != 0 ) {
2473             $exit_code = 255;
2474         }
2475         else {
2476             $exit_code = 0;
2477         }
2478
2479         _my_exit($exit_code) && return;
2480     }
2481     elsif( $self->{Skip_All} ) {
2482         _my_exit(0) && return;
2483     }
2484     elsif($real_exit_code) {
2485         $self->diag(<<"FAIL");
2486 Looks like your test exited with $real_exit_code before it could output anything.
2487 FAIL
2488         $self->is_passing(0);
2489         _my_exit($real_exit_code) && return;
2490     }
2491     else {
2492         $self->diag("No tests run!\n");
2493         $self->is_passing(0);
2494         _my_exit(255) && return;
2495     }
2496
2497     $self->is_passing(0);
2498     $self->_whoa( 1, "We fell off the end of _ending()" );
2499 }
2500
2501 END {
2502     $Test->_ending if defined $Test;
2503 }
2504
2505 =head1 EXIT CODES
2506
2507 If all your tests passed, Test::Builder will exit with zero (which is
2508 normal).  If anything failed it will exit with how many failed.  If
2509 you run less (or more) tests than you planned, the missing (or extras)
2510 will be considered failures.  If no tests were ever run Test::Builder
2511 will throw a warning and exit with 255.  If the test died, even after
2512 having successfully completed all its tests, it will still be
2513 considered a failure and will exit with 255.
2514
2515 So the exit codes are...
2516
2517     0                   all tests successful
2518     255                 test died or all passed but wrong # of tests run
2519     any other number    how many failed (including missing or extras)
2520
2521 If you fail more than 254 tests, it will be reported as 254.
2522
2523 =head1 THREADS
2524
2525 In perl 5.8.1 and later, Test::Builder is thread-safe.  The test
2526 number is shared amongst all threads.  This means if one thread sets
2527 the test number using C<current_test()> they will all be effected.
2528
2529 While versions earlier than 5.8.1 had threads they contain too many
2530 bugs to support.
2531
2532 Test::Builder is only thread-aware if threads.pm is loaded I<before>
2533 Test::Builder.
2534
2535 =head1 MEMORY
2536
2537 An informative hash, accessible via C<<details()>>, is stored for each
2538 test you perform.  So memory usage will scale linearly with each test
2539 run. Although this is not a problem for most test suites, it can
2540 become an issue if you do large (hundred thousands to million)
2541 combinatorics tests in the same run.
2542
2543 In such cases, you are advised to either split the test file into smaller
2544 ones, or use a reverse approach, doing "normal" (code) compares and
2545 triggering fail() should anything go unexpected.
2546
2547 Future versions of Test::Builder will have a way to turn history off.
2548
2549
2550 =head1 EXAMPLES
2551
2552 CPAN can provide the best examples.  Test::Simple, Test::More,
2553 Test::Exception and Test::Differences all use Test::Builder.
2554
2555 =head1 SEE ALSO
2556
2557 Test::Simple, Test::More, Test::Harness
2558
2559 =head1 AUTHORS
2560
2561 Original code by chromatic, maintained by Michael G Schwern
2562 E<lt>schwern@pobox.comE<gt>
2563
2564 =head1 COPYRIGHT
2565
2566 Copyright 2002-2008 by chromatic E<lt>chromatic@wgz.orgE<gt> and
2567                        Michael G Schwern E<lt>schwern@pobox.comE<gt>.
2568
2569 This program is free software; you can redistribute it and/or
2570 modify it under the same terms as Perl itself.
2571
2572 See F<http://www.perl.com/perl/misc/Artistic.html>
2573
2574 =cut
2575
2576 1;
2577