This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Upgrade to Test-Simple-0.65.
[perl5.git] / lib / Test / Builder.pm
1 package Test::Builder;
2
3 use 5.004;
4
5 # $^C was only introduced in 5.005-ish.  We do this to prevent
6 # use of uninitialized value warnings in older perls.
7 $^C ||= 0;
8
9 use strict;
10 use vars qw($VERSION);
11 $VERSION = '0.34';
12 $VERSION = eval $VERSION;    # make the alpha version come out as a number
13
14 # Make Test::Builder thread-safe for ithreads.
15 BEGIN {
16     use Config;
17     # Load threads::shared when threads are turned on.
18     # 5.8.0's threads are so busted we no longer support them.
19     if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) {
20         require threads::shared;
21
22         # Hack around YET ANOTHER threads::shared bug.  It would 
23         # occassionally forget the contents of the variable when sharing it.
24         # So we first copy the data, then share, then put our copy back.
25         *share = sub (\[$@%]) {
26             my $type = ref $_[0];
27             my $data;
28
29             if( $type eq 'HASH' ) {
30                 %$data = %{$_[0]};
31             }
32             elsif( $type eq 'ARRAY' ) {
33                 @$data = @{$_[0]};
34             }
35             elsif( $type eq 'SCALAR' ) {
36                 $$data = ${$_[0]};
37             }
38             else {
39                 die("Unknown type: ".$type);
40             }
41
42             $_[0] = &threads::shared::share($_[0]);
43
44             if( $type eq 'HASH' ) {
45                 %{$_[0]} = %$data;
46             }
47             elsif( $type eq 'ARRAY' ) {
48                 @{$_[0]} = @$data;
49             }
50             elsif( $type eq 'SCALAR' ) {
51                 ${$_[0]} = $$data;
52             }
53             else {
54                 die("Unknown type: ".$type);
55             }
56
57             return $_[0];
58         };
59     }
60     # 5.8.0's threads::shared is busted when threads are off
61     # and earlier Perls just don't have that module at all.
62     else {
63         *share = sub { return $_[0] };
64         *lock  = sub { 0 };
65     }
66 }
67
68
69 =head1 NAME
70
71 Test::Builder - Backend for building test libraries
72
73 =head1 SYNOPSIS
74
75   package My::Test::Module;
76   use Test::Builder;
77   require Exporter;
78   @ISA = qw(Exporter);
79   @EXPORT = qw(ok);
80
81   my $Test = Test::Builder->new;
82   $Test->output('my_logfile');
83
84   sub import {
85       my($self) = shift;
86       my $pack = caller;
87
88       $Test->exported_to($pack);
89       $Test->plan(@_);
90
91       $self->export_to_level(1, $self, 'ok');
92   }
93
94   sub ok {
95       my($test, $name) = @_;
96
97       $Test->ok($test, $name);
98   }
99
100
101 =head1 DESCRIPTION
102
103 Test::Simple and Test::More have proven to be popular testing modules,
104 but they're not always flexible enough.  Test::Builder provides the a
105 building block upon which to write your own test libraries I<which can
106 work together>.
107
108 =head2 Construction
109
110 =over 4
111
112 =item B<new>
113
114   my $Test = Test::Builder->new;
115
116 Returns a Test::Builder object representing the current state of the
117 test.
118
119 Since you only run one test per program C<new> always returns the same
120 Test::Builder object.  No matter how many times you call new(), you're
121 getting the same object.  This is called a singleton.  This is done so that
122 multiple modules share such global information as the test counter and
123 where test output is going.
124
125 If you want a completely new Test::Builder object different from the
126 singleton, use C<create>.
127
128 =cut
129
130 my $Test = Test::Builder->new;
131 sub new {
132     my($class) = shift;
133     $Test ||= $class->create;
134     return $Test;
135 }
136
137
138 =item B<create>
139
140   my $Test = Test::Builder->create;
141
142 Ok, so there can be more than one Test::Builder object and this is how
143 you get it.  You might use this instead of C<new()> if you're testing
144 a Test::Builder based module, but otherwise you probably want C<new>.
145
146 B<NOTE>: the implementation is not complete.  C<level>, for example, is
147 still shared amongst B<all> Test::Builder objects, even ones created using
148 this method.  Also, the method name may change in the future.
149
150 =cut
151
152 sub create {
153     my $class = shift;
154
155     my $self = bless {}, $class;
156     $self->reset;
157
158     return $self;
159 }
160
161 =item B<reset>
162
163   $Test->reset;
164
165 Reinitializes the Test::Builder singleton to its original state.
166 Mostly useful for tests run in persistent environments where the same
167 test might be run multiple times in the same process.
168
169 =cut
170
171 use vars qw($Level);
172
173 sub reset {
174     my ($self) = @_;
175
176     # We leave this a global because it has to be localized and localizing
177     # hash keys is just asking for pain.  Also, it was documented.
178     $Level = 1;
179
180     $self->{Test_Died}    = 0;
181     $self->{Have_Plan}    = 0;
182     $self->{No_Plan}      = 0;
183     $self->{Original_Pid} = $$;
184
185     share($self->{Curr_Test});
186     $self->{Curr_Test}    = 0;
187     $self->{Test_Results} = &share([]);
188
189     $self->{Exported_To}    = undef;
190     $self->{Expected_Tests} = 0;
191
192     $self->{Skip_All}   = 0;
193
194     $self->{Use_Nums}   = 1;
195
196     $self->{No_Header}  = 0;
197     $self->{No_Ending}  = 0;
198
199     $self->_dup_stdhandles unless $^C;
200
201     return undef;
202 }
203
204 =back
205
206 =head2 Setting up tests
207
208 These methods are for setting up tests and declaring how many there
209 are.  You usually only want to call one of these methods.
210
211 =over 4
212
213 =item B<exported_to>
214
215   my $pack = $Test->exported_to;
216   $Test->exported_to($pack);
217
218 Tells Test::Builder what package you exported your functions to.
219 This is important for getting TODO tests right.
220
221 =cut
222
223 sub exported_to {
224     my($self, $pack) = @_;
225
226     if( defined $pack ) {
227         $self->{Exported_To} = $pack;
228     }
229     return $self->{Exported_To};
230 }
231
232 =item B<plan>
233
234   $Test->plan('no_plan');
235   $Test->plan( skip_all => $reason );
236   $Test->plan( tests => $num_tests );
237
238 A convenient way to set up your tests.  Call this and Test::Builder
239 will print the appropriate headers and take the appropriate actions.
240
241 If you call plan(), don't call any of the other methods below.
242
243 =cut
244
245 sub plan {
246     my($self, $cmd, $arg) = @_;
247
248     return unless $cmd;
249
250     local $Level = $Level + 1;
251
252     if( $self->{Have_Plan} ) {
253         $self->croak("You tried to plan twice");
254     }
255
256     if( $cmd eq 'no_plan' ) {
257         $self->no_plan;
258     }
259     elsif( $cmd eq 'skip_all' ) {
260         return $self->skip_all($arg);
261     }
262     elsif( $cmd eq 'tests' ) {
263         if( $arg ) {
264             local $Level = $Level + 1;
265             return $self->expected_tests($arg);
266         }
267         elsif( !defined $arg ) {
268             $self->croak("Got an undefined number of tests");
269         }
270         elsif( !$arg ) {
271             $self->croak("You said to run 0 tests");
272         }
273     }
274     else {
275         my @args = grep { defined } ($cmd, $arg);
276         $self->croak("plan() doesn't understand @args");
277     }
278
279     return 1;
280 }
281
282 =item B<expected_tests>
283
284     my $max = $Test->expected_tests;
285     $Test->expected_tests($max);
286
287 Gets/sets the # of tests we expect this test to run and prints out
288 the appropriate headers.
289
290 =cut
291
292 sub expected_tests {
293     my $self = shift;
294     my($max) = @_;
295
296     if( @_ ) {
297         $self->croak("Number of tests must be a positive integer.  You gave it '$max'")
298           unless $max =~ /^\+?\d+$/ and $max > 0;
299
300         $self->{Expected_Tests} = $max;
301         $self->{Have_Plan}      = 1;
302
303         $self->_print("1..$max\n") unless $self->no_header;
304     }
305     return $self->{Expected_Tests};
306 }
307
308
309 =item B<no_plan>
310
311   $Test->no_plan;
312
313 Declares that this test will run an indeterminate # of tests.
314
315 =cut
316
317 sub no_plan {
318     my $self = shift;
319
320     $self->{No_Plan}   = 1;
321     $self->{Have_Plan} = 1;
322 }
323
324 =item B<has_plan>
325
326   $plan = $Test->has_plan
327
328 Find out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests).
329
330 =cut
331
332 sub has_plan {
333     my $self = shift;
334
335     return($self->{Expected_Tests}) if $self->{Expected_Tests};
336     return('no_plan') if $self->{No_Plan};
337     return(undef);
338 };
339
340
341 =item B<skip_all>
342
343   $Test->skip_all;
344   $Test->skip_all($reason);
345
346 Skips all the tests, using the given $reason.  Exits immediately with 0.
347
348 =cut
349
350 sub skip_all {
351     my($self, $reason) = @_;
352
353     my $out = "1..0";
354     $out .= " # Skip $reason" if $reason;
355     $out .= "\n";
356
357     $self->{Skip_All} = 1;
358
359     $self->_print($out) unless $self->no_header;
360     exit(0);
361 }
362
363 =back
364
365 =head2 Running tests
366
367 These actually run the tests, analogous to the functions in
368 Test::More.
369
370 $name is always optional.
371
372 =over 4
373
374 =item B<ok>
375
376   $Test->ok($test, $name);
377
378 Your basic test.  Pass if $test is true, fail if $test is false.  Just
379 like Test::Simple's ok().
380
381 =cut
382
383 sub ok {
384     my($self, $test, $name) = @_;
385
386     # $test might contain an object which we don't want to accidentally
387     # store, so we turn it into a boolean.
388     $test = $test ? 1 : 0;
389
390     $self->_plan_check;
391
392     lock $self->{Curr_Test};
393     $self->{Curr_Test}++;
394
395     # In case $name is a string overloaded object, force it to stringify.
396     $self->_unoverload_str(\$name);
397
398     $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
399     You named your test '$name'.  You shouldn't use numbers for your test names.
400     Very confusing.
401 ERR
402
403     my($pack, $file, $line) = $self->caller;
404
405     my $todo = $self->todo($pack);
406     $self->_unoverload_str(\$todo);
407
408     my $out;
409     my $result = &share({});
410
411     unless( $test ) {
412         $out .= "not ";
413         @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
414     }
415     else {
416         @$result{ 'ok', 'actual_ok' } = ( 1, $test );
417     }
418
419     $out .= "ok";
420     $out .= " $self->{Curr_Test}" if $self->use_numbers;
421
422     if( defined $name ) {
423         $name =~ s|#|\\#|g;     # # in a name can confuse Test::Harness.
424         $out   .= " - $name";
425         $result->{name} = $name;
426     }
427     else {
428         $result->{name} = '';
429     }
430
431     if( $todo ) {
432         $out   .= " # TODO $todo";
433         $result->{reason} = $todo;
434         $result->{type}   = 'todo';
435     }
436     else {
437         $result->{reason} = '';
438         $result->{type}   = '';
439     }
440
441     $self->{Test_Results}[$self->{Curr_Test}-1] = $result;
442     $out .= "\n";
443
444     $self->_print($out);
445
446     unless( $test ) {
447         my $msg = $todo ? "Failed (TODO)" : "Failed";
448         $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
449
450         if( defined $name ) {
451             $self->diag(qq[  $msg test '$name'\n]);
452             $self->diag(qq[  at $file line $line.\n]);
453         }
454         else {
455             $self->diag(qq[  $msg test at $file line $line.\n]);
456         }
457     } 
458
459     return $test ? 1 : 0;
460 }
461
462
463 sub _unoverload {
464     my $self  = shift;
465     my $type  = shift;
466
467     local($@,$!);
468
469     eval { require overload } || return;
470
471     foreach my $thing (@_) {
472         eval { 
473             if( _is_object($$thing) ) {
474                 if( my $string_meth = overload::Method($$thing, $type) ) {
475                     $$thing = $$thing->$string_meth();
476                 }
477             }
478         };
479     }
480 }
481
482
483 sub _is_object {
484     my $thing = shift;
485
486     return eval { ref $thing && $thing->isa('UNIVERSAL') } ? 1 : 0;
487 }
488
489
490 sub _unoverload_str {
491     my $self = shift;
492
493     $self->_unoverload(q[""], @_);
494 }    
495
496 sub _unoverload_num {
497     my $self = shift;
498
499     $self->_unoverload('0+', @_);
500
501     for my $val (@_) {
502         next unless $self->_is_dualvar($$val);
503         $$val = $$val+0;
504     }
505 }
506
507
508 # This is a hack to detect a dualvar such as $!
509 sub _is_dualvar {
510     my($self, $val) = @_;
511
512     local $^W = 0;
513     my $numval = $val+0;
514     return 1 if $numval != 0 and $numval ne $val;
515 }
516
517
518
519 =item B<is_eq>
520
521   $Test->is_eq($got, $expected, $name);
522
523 Like Test::More's is().  Checks if $got eq $expected.  This is the
524 string version.
525
526 =item B<is_num>
527
528   $Test->is_num($got, $expected, $name);
529
530 Like Test::More's is().  Checks if $got == $expected.  This is the
531 numeric version.
532
533 =cut
534
535 sub is_eq {
536     my($self, $got, $expect, $name) = @_;
537     local $Level = $Level + 1;
538
539     $self->_unoverload_str(\$got, \$expect);
540
541     if( !defined $got || !defined $expect ) {
542         # undef only matches undef and nothing else
543         my $test = !defined $got && !defined $expect;
544
545         $self->ok($test, $name);
546         $self->_is_diag($got, 'eq', $expect) unless $test;
547         return $test;
548     }
549
550     return $self->cmp_ok($got, 'eq', $expect, $name);
551 }
552
553 sub is_num {
554     my($self, $got, $expect, $name) = @_;
555     local $Level = $Level + 1;
556
557     $self->_unoverload_num(\$got, \$expect);
558
559     if( !defined $got || !defined $expect ) {
560         # undef only matches undef and nothing else
561         my $test = !defined $got && !defined $expect;
562
563         $self->ok($test, $name);
564         $self->_is_diag($got, '==', $expect) unless $test;
565         return $test;
566     }
567
568     return $self->cmp_ok($got, '==', $expect, $name);
569 }
570
571 sub _is_diag {
572     my($self, $got, $type, $expect) = @_;
573
574     foreach my $val (\$got, \$expect) {
575         if( defined $$val ) {
576             if( $type eq 'eq' ) {
577                 # quote and force string context
578                 $$val = "'$$val'"
579             }
580             else {
581                 # force numeric context
582                 $self->_unoverload_num($val);
583             }
584         }
585         else {
586             $$val = 'undef';
587         }
588     }
589
590     return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
591          got: %s
592     expected: %s
593 DIAGNOSTIC
594
595 }    
596
597 =item B<isnt_eq>
598
599   $Test->isnt_eq($got, $dont_expect, $name);
600
601 Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
602 the string version.
603
604 =item B<isnt_num>
605
606   $Test->isnt_num($got, $dont_expect, $name);
607
608 Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
609 the numeric version.
610
611 =cut
612
613 sub isnt_eq {
614     my($self, $got, $dont_expect, $name) = @_;
615     local $Level = $Level + 1;
616
617     if( !defined $got || !defined $dont_expect ) {
618         # undef only matches undef and nothing else
619         my $test = defined $got || defined $dont_expect;
620
621         $self->ok($test, $name);
622         $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
623         return $test;
624     }
625
626     return $self->cmp_ok($got, 'ne', $dont_expect, $name);
627 }
628
629 sub isnt_num {
630     my($self, $got, $dont_expect, $name) = @_;
631     local $Level = $Level + 1;
632
633     if( !defined $got || !defined $dont_expect ) {
634         # undef only matches undef and nothing else
635         my $test = defined $got || defined $dont_expect;
636
637         $self->ok($test, $name);
638         $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
639         return $test;
640     }
641
642     return $self->cmp_ok($got, '!=', $dont_expect, $name);
643 }
644
645
646 =item B<like>
647
648   $Test->like($this, qr/$regex/, $name);
649   $Test->like($this, '/$regex/', $name);
650
651 Like Test::More's like().  Checks if $this matches the given $regex.
652
653 You'll want to avoid qr// if you want your tests to work before 5.005.
654
655 =item B<unlike>
656
657   $Test->unlike($this, qr/$regex/, $name);
658   $Test->unlike($this, '/$regex/', $name);
659
660 Like Test::More's unlike().  Checks if $this B<does not match> the
661 given $regex.
662
663 =cut
664
665 sub like {
666     my($self, $this, $regex, $name) = @_;
667
668     local $Level = $Level + 1;
669     $self->_regex_ok($this, $regex, '=~', $name);
670 }
671
672 sub unlike {
673     my($self, $this, $regex, $name) = @_;
674
675     local $Level = $Level + 1;
676     $self->_regex_ok($this, $regex, '!~', $name);
677 }
678
679 =item B<maybe_regex>
680
681   $Test->maybe_regex(qr/$regex/);
682   $Test->maybe_regex('/$regex/');
683
684 Convenience method for building testing functions that take regular
685 expressions as arguments, but need to work before perl 5.005.
686
687 Takes a quoted regular expression produced by qr//, or a string
688 representing a regular expression.
689
690 Returns a Perl value which may be used instead of the corresponding
691 regular expression, or undef if it's argument is not recognised.
692
693 For example, a version of like(), sans the useful diagnostic messages,
694 could be written as:
695
696   sub laconic_like {
697       my ($self, $this, $regex, $name) = @_;
698       my $usable_regex = $self->maybe_regex($regex);
699       die "expecting regex, found '$regex'\n"
700           unless $usable_regex;
701       $self->ok($this =~ m/$usable_regex/, $name);
702   }
703
704 =cut
705
706
707 sub maybe_regex {
708     my ($self, $regex) = @_;
709     my $usable_regex = undef;
710
711     return $usable_regex unless defined $regex;
712
713     my($re, $opts);
714
715     # Check for qr/foo/
716     if( ref $regex eq 'Regexp' ) {
717         $usable_regex = $regex;
718     }
719     # Check for '/foo/' or 'm,foo,'
720     elsif( ($re, $opts)        = $regex =~ m{^ /(.*)/ (\w*) $ }sx           or
721            (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
722          )
723     {
724         $usable_regex = length $opts ? "(?$opts)$re" : $re;
725     }
726
727     return $usable_regex;
728 };
729
730 sub _regex_ok {
731     my($self, $this, $regex, $cmp, $name) = @_;
732
733     my $ok = 0;
734     my $usable_regex = $self->maybe_regex($regex);
735     unless (defined $usable_regex) {
736         $ok = $self->ok( 0, $name );
737         $self->diag("    '$regex' doesn't look much like a regex to me.");
738         return $ok;
739     }
740
741     {
742         my $test;
743         my $code = $self->_caller_context;
744
745         local($@, $!);
746
747         # Yes, it has to look like this or 5.4.5 won't see the #line directive.
748         # Don't ask me, man, I just work here.
749         $test = eval "
750 $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
751
752         $test = !$test if $cmp eq '!~';
753
754         local $Level = $Level + 1;
755         $ok = $self->ok( $test, $name );
756     }
757
758     unless( $ok ) {
759         $this = defined $this ? "'$this'" : 'undef';
760         my $match = $cmp eq '=~' ? "doesn't match" : "matches";
761         $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
762                   %s
763     %13s '%s'
764 DIAGNOSTIC
765
766     }
767
768     return $ok;
769 }
770
771 =item B<cmp_ok>
772
773   $Test->cmp_ok($this, $type, $that, $name);
774
775 Works just like Test::More's cmp_ok().
776
777     $Test->cmp_ok($big_num, '!=', $other_big_num);
778
779 =cut
780
781
782 my %numeric_cmps = map { ($_, 1) } 
783                        ("<",  "<=", ">",  ">=", "==", "!=", "<=>");
784
785 sub cmp_ok {
786     my($self, $got, $type, $expect, $name) = @_;
787
788     # Treat overloaded objects as numbers if we're asked to do a
789     # numeric comparison.
790     my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
791                                           : '_unoverload_str';
792
793     $self->$unoverload(\$got, \$expect);
794
795
796     my $test;
797     {
798         local($@,$!);   # don't interfere with $@
799                         # eval() sometimes resets $!
800
801         my $code = $self->_caller_context;
802
803         # Yes, it has to look like this or 5.4.5 won't see the #line directive.
804         # Don't ask me, man, I just work here.
805         $test = eval "
806 $code" . "\$got $type \$expect;";
807
808     }
809     local $Level = $Level + 1;
810     my $ok = $self->ok($test, $name);
811
812     unless( $ok ) {
813         if( $type =~ /^(eq|==)$/ ) {
814             $self->_is_diag($got, $type, $expect);
815         }
816         else {
817             $self->_cmp_diag($got, $type, $expect);
818         }
819     }
820     return $ok;
821 }
822
823 sub _cmp_diag {
824     my($self, $got, $type, $expect) = @_;
825     
826     $got    = defined $got    ? "'$got'"    : 'undef';
827     $expect = defined $expect ? "'$expect'" : 'undef';
828     return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
829     %s
830         %s
831     %s
832 DIAGNOSTIC
833 }
834
835
836 sub _caller_context {
837     my $self = shift;
838
839     my($pack, $file, $line) = $self->caller(1);
840
841     my $code = '';
842     $code .= "#line $line $file\n" if defined $file and defined $line;
843
844     return $code;
845 }
846
847
848 =item B<BAIL_OUT>
849
850     $Test->BAIL_OUT($reason);
851
852 Indicates to the Test::Harness that things are going so badly all
853 testing should terminate.  This includes running any additional test
854 scripts.
855
856 It will exit with 255.
857
858 =cut
859
860 sub BAIL_OUT {
861     my($self, $reason) = @_;
862
863     $self->{Bailed_Out} = 1;
864     $self->_print("Bail out!  $reason");
865     exit 255;
866 }
867
868 =for deprecated
869 BAIL_OUT() used to be BAILOUT()
870
871 =cut
872
873 *BAILOUT = \&BAIL_OUT;
874
875
876 =item B<skip>
877
878     $Test->skip;
879     $Test->skip($why);
880
881 Skips the current test, reporting $why.
882
883 =cut
884
885 sub skip {
886     my($self, $why) = @_;
887     $why ||= '';
888     $self->_unoverload_str(\$why);
889
890     $self->_plan_check;
891
892     lock($self->{Curr_Test});
893     $self->{Curr_Test}++;
894
895     $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
896         'ok'      => 1,
897         actual_ok => 1,
898         name      => '',
899         type      => 'skip',
900         reason    => $why,
901     });
902
903     my $out = "ok";
904     $out   .= " $self->{Curr_Test}" if $self->use_numbers;
905     $out   .= " # skip";
906     $out   .= " $why"       if length $why;
907     $out   .= "\n";
908
909     $self->_print($out);
910
911     return 1;
912 }
913
914
915 =item B<todo_skip>
916
917   $Test->todo_skip;
918   $Test->todo_skip($why);
919
920 Like skip(), only it will declare the test as failing and TODO.  Similar
921 to
922
923     print "not ok $tnum # TODO $why\n";
924
925 =cut
926
927 sub todo_skip {
928     my($self, $why) = @_;
929     $why ||= '';
930
931     $self->_plan_check;
932
933     lock($self->{Curr_Test});
934     $self->{Curr_Test}++;
935
936     $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
937         'ok'      => 1,
938         actual_ok => 0,
939         name      => '',
940         type      => 'todo_skip',
941         reason    => $why,
942     });
943
944     my $out = "not ok";
945     $out   .= " $self->{Curr_Test}" if $self->use_numbers;
946     $out   .= " # TODO & SKIP $why\n";
947
948     $self->_print($out);
949
950     return 1;
951 }
952
953
954 =begin _unimplemented
955
956 =item B<skip_rest>
957
958   $Test->skip_rest;
959   $Test->skip_rest($reason);
960
961 Like skip(), only it skips all the rest of the tests you plan to run
962 and terminates the test.
963
964 If you're running under no_plan, it skips once and terminates the
965 test.
966
967 =end _unimplemented
968
969 =back
970
971
972 =head2 Test style
973
974 =over 4
975
976 =item B<level>
977
978     $Test->level($how_high);
979
980 How far up the call stack should $Test look when reporting where the
981 test failed.
982
983 Defaults to 1.
984
985 Setting $Test::Builder::Level overrides.  This is typically useful
986 localized:
987
988     {
989         local $Test::Builder::Level = 2;
990         $Test->ok($test);
991     }
992
993 =cut
994
995 sub level {
996     my($self, $level) = @_;
997
998     if( defined $level ) {
999         $Level = $level;
1000     }
1001     return $Level;
1002 }
1003
1004
1005 =item B<use_numbers>
1006
1007     $Test->use_numbers($on_or_off);
1008
1009 Whether or not the test should output numbers.  That is, this if true:
1010
1011   ok 1
1012   ok 2
1013   ok 3
1014
1015 or this if false
1016
1017   ok
1018   ok
1019   ok
1020
1021 Most useful when you can't depend on the test output order, such as
1022 when threads or forking is involved.
1023
1024 Defaults to on.
1025
1026 =cut
1027
1028 sub use_numbers {
1029     my($self, $use_nums) = @_;
1030
1031     if( defined $use_nums ) {
1032         $self->{Use_Nums} = $use_nums;
1033     }
1034     return $self->{Use_Nums};
1035 }
1036
1037
1038 =item B<no_diag>
1039
1040     $Test->no_diag($no_diag);
1041
1042 If set true no diagnostics will be printed.  This includes calls to
1043 diag().
1044
1045 =item B<no_ending>
1046
1047     $Test->no_ending($no_ending);
1048
1049 Normally, Test::Builder does some extra diagnostics when the test
1050 ends.  It also changes the exit code as described below.
1051
1052 If this is true, none of that will be done.
1053
1054 =item B<no_header>
1055
1056     $Test->no_header($no_header);
1057
1058 If set to true, no "1..N" header will be printed.
1059
1060 =cut
1061
1062 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
1063     my $method = lc $attribute;
1064
1065     my $code = sub {
1066         my($self, $no) = @_;
1067
1068         if( defined $no ) {
1069             $self->{$attribute} = $no;
1070         }
1071         return $self->{$attribute};
1072     };
1073
1074     no strict 'refs';
1075     *{__PACKAGE__.'::'.$method} = $code;
1076 }
1077
1078
1079 =back
1080
1081 =head2 Output
1082
1083 Controlling where the test output goes.
1084
1085 It's ok for your test to change where STDOUT and STDERR point to,
1086 Test::Builder's default output settings will not be affected.
1087
1088 =over 4
1089
1090 =item B<diag>
1091
1092     $Test->diag(@msgs);
1093
1094 Prints out the given @msgs.  Like C<print>, arguments are simply
1095 appended together.
1096
1097 Normally, it uses the failure_output() handle, but if this is for a
1098 TODO test, the todo_output() handle is used.
1099
1100 Output will be indented and marked with a # so as not to interfere
1101 with test output.  A newline will be put on the end if there isn't one
1102 already.
1103
1104 We encourage using this rather than calling print directly.
1105
1106 Returns false.  Why?  Because diag() is often used in conjunction with
1107 a failing test (C<ok() || diag()>) it "passes through" the failure.
1108
1109     return ok(...) || diag(...);
1110
1111 =for blame transfer
1112 Mark Fowler <mark@twoshortplanks.com>
1113
1114 =cut
1115
1116 sub diag {
1117     my($self, @msgs) = @_;
1118
1119     return if $self->no_diag;
1120     return unless @msgs;
1121
1122     # Prevent printing headers when compiling (i.e. -c)
1123     return if $^C;
1124
1125     # Smash args together like print does.
1126     # Convert undef to 'undef' so its readable.
1127     my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
1128
1129     # Escape each line with a #.
1130     $msg =~ s/^/# /gm;
1131
1132     # Stick a newline on the end if it needs it.
1133     $msg .= "\n" unless $msg =~ /\n\Z/;
1134
1135     local $Level = $Level + 1;
1136     $self->_print_diag($msg);
1137
1138     return 0;
1139 }
1140
1141 =begin _private
1142
1143 =item B<_print>
1144
1145     $Test->_print(@msgs);
1146
1147 Prints to the output() filehandle.
1148
1149 =end _private
1150
1151 =cut
1152
1153 sub _print {
1154     my($self, @msgs) = @_;
1155
1156     # Prevent printing headers when only compiling.  Mostly for when
1157     # tests are deparsed with B::Deparse
1158     return if $^C;
1159
1160     my $msg = join '', @msgs;
1161
1162     local($\, $", $,) = (undef, ' ', '');
1163     my $fh = $self->output;
1164
1165     # Escape each line after the first with a # so we don't
1166     # confuse Test::Harness.
1167     $msg =~ s/\n(.)/\n# $1/sg;
1168
1169     # Stick a newline on the end if it needs it.
1170     $msg .= "\n" unless $msg =~ /\n\Z/;
1171
1172     print $fh $msg;
1173 }
1174
1175 =begin private
1176
1177 =item B<_print_diag>
1178
1179     $Test->_print_diag(@msg);
1180
1181 Like _print, but prints to the current diagnostic filehandle.
1182
1183 =end private
1184
1185 =cut
1186
1187 sub _print_diag {
1188     my $self = shift;
1189
1190     local($\, $", $,) = (undef, ' ', '');
1191     my $fh = $self->todo ? $self->todo_output : $self->failure_output;
1192     print $fh @_;
1193 }    
1194
1195 =item B<output>
1196
1197     $Test->output($fh);
1198     $Test->output($file);
1199
1200 Where normal "ok/not ok" test output should go.
1201
1202 Defaults to STDOUT.
1203
1204 =item B<failure_output>
1205
1206     $Test->failure_output($fh);
1207     $Test->failure_output($file);
1208
1209 Where diagnostic output on test failures and diag() should go.
1210
1211 Defaults to STDERR.
1212
1213 =item B<todo_output>
1214
1215     $Test->todo_output($fh);
1216     $Test->todo_output($file);
1217
1218 Where diagnostics about todo test failures and diag() should go.
1219
1220 Defaults to STDOUT.
1221
1222 =cut
1223
1224 sub output {
1225     my($self, $fh) = @_;
1226
1227     if( defined $fh ) {
1228         $self->{Out_FH} = $self->_new_fh($fh);
1229     }
1230     return $self->{Out_FH};
1231 }
1232
1233 sub failure_output {
1234     my($self, $fh) = @_;
1235
1236     if( defined $fh ) {
1237         $self->{Fail_FH} = $self->_new_fh($fh);
1238     }
1239     return $self->{Fail_FH};
1240 }
1241
1242 sub todo_output {
1243     my($self, $fh) = @_;
1244
1245     if( defined $fh ) {
1246         $self->{Todo_FH} = $self->_new_fh($fh);
1247     }
1248     return $self->{Todo_FH};
1249 }
1250
1251
1252 sub _new_fh {
1253     my $self = shift;
1254     my($file_or_fh) = shift;
1255
1256     my $fh;
1257     if( $self->_is_fh($file_or_fh) ) {
1258         $fh = $file_or_fh;
1259     }
1260     else {
1261         $fh = do { local *FH };
1262         open $fh, ">$file_or_fh" or
1263             $self->croak("Can't open test output log $file_or_fh: $!");
1264         _autoflush($fh);
1265     }
1266
1267     return $fh;
1268 }
1269
1270
1271 sub _is_fh {
1272     my $self = shift;
1273     my $maybe_fh = shift;
1274     return 0 unless defined $maybe_fh;
1275
1276     return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
1277
1278     return UNIVERSAL::isa($maybe_fh,               'GLOB')       ||
1279            UNIVERSAL::isa($maybe_fh,               'IO::Handle') ||
1280
1281            # 5.5.4's tied() and can() doesn't like getting undef
1282            UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE');
1283 }
1284
1285
1286 sub _autoflush {
1287     my($fh) = shift;
1288     my $old_fh = select $fh;
1289     $| = 1;
1290     select $old_fh;
1291 }
1292
1293
1294 sub _dup_stdhandles {
1295     my $self = shift;
1296
1297     $self->_open_testhandles;
1298
1299     # Set everything to unbuffered else plain prints to STDOUT will
1300     # come out in the wrong order from our own prints.
1301     _autoflush(\*TESTOUT);
1302     _autoflush(\*STDOUT);
1303     _autoflush(\*TESTERR);
1304     _autoflush(\*STDERR);
1305
1306     $self->output(\*TESTOUT);
1307     $self->failure_output(\*TESTERR);
1308     $self->todo_output(\*TESTOUT);
1309 }
1310
1311
1312 my $Opened_Testhandles = 0;
1313 sub _open_testhandles {
1314     return if $Opened_Testhandles;
1315     # We dup STDOUT and STDERR so people can change them in their
1316     # test suites while still getting normal test output.
1317     open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT:  $!";
1318     open(TESTERR, ">&STDERR") or die "Can't dup STDERR:  $!";
1319     $Opened_Testhandles = 1;
1320 }
1321
1322
1323 =item carp
1324
1325   $tb->carp(@message);
1326
1327 Warns with C<@message> but the message will appear to come from the
1328 point where the original test function was called (C<$tb->caller>).
1329
1330 =item croak
1331
1332   $tb->croak(@message);
1333
1334 Dies with C<@message> but the message will appear to come from the
1335 point where the original test function was called (C<$tb->caller>).
1336
1337 =cut
1338
1339 sub _message_at_caller {
1340     my $self = shift;
1341
1342     local $Level = $Level + 1;
1343     my($pack, $file, $line) = $self->caller;
1344     return join("", @_) . " at $file line $line.\n";
1345 }
1346
1347 sub carp {
1348     my $self = shift;
1349     warn $self->_message_at_caller(@_);
1350 }
1351
1352 sub croak {
1353     my $self = shift;
1354     die $self->_message_at_caller(@_);
1355 }
1356
1357 sub _plan_check {
1358     my $self = shift;
1359
1360     unless( $self->{Have_Plan} ) {
1361         local $Level = $Level + 2;
1362         $self->croak("You tried to run a test without a plan");
1363     }
1364 }
1365
1366 =back
1367
1368
1369 =head2 Test Status and Info
1370
1371 =over 4
1372
1373 =item B<current_test>
1374
1375     my $curr_test = $Test->current_test;
1376     $Test->current_test($num);
1377
1378 Gets/sets the current test number we're on.  You usually shouldn't
1379 have to set this.
1380
1381 If set forward, the details of the missing tests are filled in as 'unknown'.
1382 if set backward, the details of the intervening tests are deleted.  You
1383 can erase history if you really want to.
1384
1385 =cut
1386
1387 sub current_test {
1388     my($self, $num) = @_;
1389
1390     lock($self->{Curr_Test});
1391     if( defined $num ) {
1392         unless( $self->{Have_Plan} ) {
1393             $self->croak("Can't change the current test number without a plan!");
1394         }
1395
1396         $self->{Curr_Test} = $num;
1397
1398         # If the test counter is being pushed forward fill in the details.
1399         my $test_results = $self->{Test_Results};
1400         if( $num > @$test_results ) {
1401             my $start = @$test_results ? @$test_results : 0;
1402             for ($start..$num-1) {
1403                 $test_results->[$_] = &share({
1404                     'ok'      => 1, 
1405                     actual_ok => undef, 
1406                     reason    => 'incrementing test number', 
1407                     type      => 'unknown', 
1408                     name      => undef 
1409                 });
1410             }
1411         }
1412         # If backward, wipe history.  Its their funeral.
1413         elsif( $num < @$test_results ) {
1414             $#{$test_results} = $num - 1;
1415         }
1416     }
1417     return $self->{Curr_Test};
1418 }
1419
1420
1421 =item B<summary>
1422
1423     my @tests = $Test->summary;
1424
1425 A simple summary of the tests so far.  True for pass, false for fail.
1426 This is a logical pass/fail, so todos are passes.
1427
1428 Of course, test #1 is $tests[0], etc...
1429
1430 =cut
1431
1432 sub summary {
1433     my($self) = shift;
1434
1435     return map { $_->{'ok'} } @{ $self->{Test_Results} };
1436 }
1437
1438 =item B<details>
1439
1440     my @tests = $Test->details;
1441
1442 Like summary(), but with a lot more detail.
1443
1444     $tests[$test_num - 1] = 
1445             { 'ok'       => is the test considered a pass?
1446               actual_ok  => did it literally say 'ok'?
1447               name       => name of the test (if any)
1448               type       => type of test (if any, see below).
1449               reason     => reason for the above (if any)
1450             };
1451
1452 'ok' is true if Test::Harness will consider the test to be a pass.
1453
1454 'actual_ok' is a reflection of whether or not the test literally
1455 printed 'ok' or 'not ok'.  This is for examining the result of 'todo'
1456 tests.  
1457
1458 'name' is the name of the test.
1459
1460 'type' indicates if it was a special test.  Normal tests have a type
1461 of ''.  Type can be one of the following:
1462
1463     skip        see skip()
1464     todo        see todo()
1465     todo_skip   see todo_skip()
1466     unknown     see below
1467
1468 Sometimes the Test::Builder test counter is incremented without it
1469 printing any test output, for example, when current_test() is changed.
1470 In these cases, Test::Builder doesn't know the result of the test, so
1471 it's type is 'unkown'.  These details for these tests are filled in.
1472 They are considered ok, but the name and actual_ok is left undef.
1473
1474 For example "not ok 23 - hole count # TODO insufficient donuts" would
1475 result in this structure:
1476
1477     $tests[22] =    # 23 - 1, since arrays start from 0.
1478       { ok        => 1,   # logically, the test passed since it's todo
1479         actual_ok => 0,   # in absolute terms, it failed
1480         name      => 'hole count',
1481         type      => 'todo',
1482         reason    => 'insufficient donuts'
1483       };
1484
1485 =cut
1486
1487 sub details {
1488     my $self = shift;
1489     return @{ $self->{Test_Results} };
1490 }
1491
1492 =item B<todo>
1493
1494     my $todo_reason = $Test->todo;
1495     my $todo_reason = $Test->todo($pack);
1496
1497 todo() looks for a $TODO variable in your tests.  If set, all tests
1498 will be considered 'todo' (see Test::More and Test::Harness for
1499 details).  Returns the reason (ie. the value of $TODO) if running as
1500 todo tests, false otherwise.
1501
1502 todo() is about finding the right package to look for $TODO in.  It
1503 uses the exported_to() package to find it.  If that's not set, it's
1504 pretty good at guessing the right package to look at based on $Level.
1505
1506 Sometimes there is some confusion about where todo() should be looking
1507 for the $TODO variable.  If you want to be sure, tell it explicitly
1508 what $pack to use.
1509
1510 =cut
1511
1512 sub todo {
1513     my($self, $pack) = @_;
1514
1515     $pack = $pack || $self->exported_to || $self->caller($Level);
1516     return 0 unless $pack;
1517
1518     no strict 'refs';
1519     return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1520                                      : 0;
1521 }
1522
1523 =item B<caller>
1524
1525     my $package = $Test->caller;
1526     my($pack, $file, $line) = $Test->caller;
1527     my($pack, $file, $line) = $Test->caller($height);
1528
1529 Like the normal caller(), except it reports according to your level().
1530
1531 =cut
1532
1533 sub caller {
1534     my($self, $height) = @_;
1535     $height ||= 0;
1536
1537     my @caller = CORE::caller($self->level + $height + 1);
1538     return wantarray ? @caller : $caller[0];
1539 }
1540
1541 =back
1542
1543 =cut
1544
1545 =begin _private
1546
1547 =over 4
1548
1549 =item B<_sanity_check>
1550
1551   $self->_sanity_check();
1552
1553 Runs a bunch of end of test sanity checks to make sure reality came
1554 through ok.  If anything is wrong it will die with a fairly friendly
1555 error message.
1556
1557 =cut
1558
1559 #'#
1560 sub _sanity_check {
1561     my $self = shift;
1562
1563     $self->_whoa($self->{Curr_Test} < 0,  'Says here you ran a negative number of tests!');
1564     $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test}, 
1565           'Somehow your tests ran without a plan!');
1566     $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
1567           'Somehow you got a different number of results than tests ran!');
1568 }
1569
1570 =item B<_whoa>
1571
1572   $self->_whoa($check, $description);
1573
1574 A sanity check, similar to assert().  If the $check is true, something
1575 has gone horribly wrong.  It will die with the given $description and
1576 a note to contact the author.
1577
1578 =cut
1579
1580 sub _whoa {
1581     my($self, $check, $desc) = @_;
1582     if( $check ) {
1583         local $Level = $Level + 1;
1584         $self->croak(<<"WHOA");
1585 WHOA!  $desc
1586 This should never happen!  Please contact the author immediately!
1587 WHOA
1588     }
1589 }
1590
1591 =item B<_my_exit>
1592
1593   _my_exit($exit_num);
1594
1595 Perl seems to have some trouble with exiting inside an END block.  5.005_03
1596 and 5.6.1 both seem to do odd things.  Instead, this function edits $?
1597 directly.  It should ONLY be called from inside an END block.  It
1598 doesn't actually exit, that's your job.
1599
1600 =cut
1601
1602 sub _my_exit {
1603     $? = $_[0];
1604
1605     return 1;
1606 }
1607
1608
1609 =back
1610
1611 =end _private
1612
1613 =cut
1614
1615 $SIG{__DIE__} = sub {
1616     # We don't want to muck with death in an eval, but $^S isn't
1617     # totally reliable.  5.005_03 and 5.6.1 both do the wrong thing
1618     # with it.  Instead, we use caller.  This also means it runs under
1619     # 5.004!
1620     my $in_eval = 0;
1621     for( my $stack = 1;  my $sub = (CORE::caller($stack))[3];  $stack++ ) {
1622         $in_eval = 1 if $sub =~ /^\(eval\)/;
1623     }
1624     $Test->{Test_Died} = 1 unless $in_eval;
1625 };
1626
1627 sub _ending {
1628     my $self = shift;
1629
1630     $self->_sanity_check();
1631
1632     # Don't bother with an ending if this is a forked copy.  Only the parent
1633     # should do the ending.
1634     # Exit if plan() was never called.  This is so "require Test::Simple" 
1635     # doesn't puke.
1636     # Don't do an ending if we bailed out.
1637     if( ($self->{Original_Pid} != $$)                   or
1638         (!$self->{Have_Plan} && !$self->{Test_Died})    or
1639         $self->{Bailed_Out}
1640       )
1641     {
1642         _my_exit($?);
1643         return;
1644     }
1645
1646     # Figure out if we passed or failed and print helpful messages.
1647     my $test_results = $self->{Test_Results};
1648     if( @$test_results ) {
1649         # The plan?  We have no plan.
1650         if( $self->{No_Plan} ) {
1651             $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1652             $self->{Expected_Tests} = $self->{Curr_Test};
1653         }
1654
1655         # Auto-extended arrays and elements which aren't explicitly
1656         # filled in with a shared reference will puke under 5.8.0
1657         # ithreads.  So we have to fill them in by hand. :(
1658         my $empty_result = &share({});
1659         for my $idx ( 0..$self->{Expected_Tests}-1 ) {
1660             $test_results->[$idx] = $empty_result
1661               unless defined $test_results->[$idx];
1662         }
1663
1664         my $num_failed = grep !$_->{'ok'}, 
1665                               @{$test_results}[0..$self->{Curr_Test}-1];
1666
1667         my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1668
1669         if( $num_extra < 0 ) {
1670             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1671             $self->diag(<<"FAIL");
1672 Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
1673 FAIL
1674         }
1675         elsif( $num_extra > 0 ) {
1676             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1677             $self->diag(<<"FAIL");
1678 Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
1679 FAIL
1680         }
1681
1682         if ( $num_failed ) {
1683             my $num_tests = $self->{Curr_Test};
1684             my $s = $num_failed == 1 ? '' : 's';
1685
1686             my $qualifier = $num_extra == 0 ? '' : ' run';
1687
1688             $self->diag(<<"FAIL");
1689 Looks like you failed $num_failed test$s of $num_tests$qualifier.
1690 FAIL
1691         }
1692
1693         if( $self->{Test_Died} ) {
1694             $self->diag(<<"FAIL");
1695 Looks like your test died just after $self->{Curr_Test}.
1696 FAIL
1697
1698             _my_exit( 255 ) && return;
1699         }
1700
1701         my $exit_code;
1702         if( $num_failed ) {
1703             $exit_code = $num_failed <= 254 ? $num_failed : 254;
1704         }
1705         elsif( $num_extra != 0 ) {
1706             $exit_code = 255;
1707         }
1708         else {
1709             $exit_code = 0;
1710         }
1711
1712         _my_exit( $exit_code ) && return;
1713     }
1714     elsif ( $self->{Skip_All} ) {
1715         _my_exit( 0 ) && return;
1716     }
1717     elsif ( $self->{Test_Died} ) {
1718         $self->diag(<<'FAIL');
1719 Looks like your test died before it could output anything.
1720 FAIL
1721         _my_exit( 255 ) && return;
1722     }
1723     else {
1724         $self->diag("No tests run!\n");
1725         _my_exit( 255 ) && return;
1726     }
1727 }
1728
1729 END {
1730     $Test->_ending if defined $Test and !$Test->no_ending;
1731 }
1732
1733 =head1 EXIT CODES
1734
1735 If all your tests passed, Test::Builder will exit with zero (which is
1736 normal).  If anything failed it will exit with how many failed.  If
1737 you run less (or more) tests than you planned, the missing (or extras)
1738 will be considered failures.  If no tests were ever run Test::Builder
1739 will throw a warning and exit with 255.  If the test died, even after
1740 having successfully completed all its tests, it will still be
1741 considered a failure and will exit with 255.
1742
1743 So the exit codes are...
1744
1745     0                   all tests successful
1746     255                 test died or all passed but wrong # of tests run
1747     any other number    how many failed (including missing or extras)
1748
1749 If you fail more than 254 tests, it will be reported as 254.
1750
1751
1752 =head1 THREADS
1753
1754 In perl 5.8.1 and later, Test::Builder is thread-safe.  The test
1755 number is shared amongst all threads.  This means if one thread sets
1756 the test number using current_test() they will all be effected.
1757
1758 While versions earlier than 5.8.1 had threads they contain too many
1759 bugs to support.
1760
1761 Test::Builder is only thread-aware if threads.pm is loaded I<before>
1762 Test::Builder.
1763
1764 =head1 EXAMPLES
1765
1766 CPAN can provide the best examples.  Test::Simple, Test::More,
1767 Test::Exception and Test::Differences all use Test::Builder.
1768
1769 =head1 SEE ALSO
1770
1771 Test::Simple, Test::More, Test::Harness
1772
1773 =head1 AUTHORS
1774
1775 Original code by chromatic, maintained by Michael G Schwern
1776 E<lt>schwern@pobox.comE<gt>
1777
1778 =head1 COPYRIGHT
1779
1780 Copyright 2002, 2004 by chromatic E<lt>chromatic@wgz.orgE<gt> and
1781                         Michael G Schwern E<lt>schwern@pobox.comE<gt>.
1782
1783 This program is free software; you can redistribute it and/or 
1784 modify it under the same terms as Perl itself.
1785
1786 See F<http://www.perl.com/perl/misc/Artistic.html>
1787
1788 =cut
1789
1790 1;