This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
d0b379aba41df6128e30f7365af53ea6c3ca6019
[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.33_02';
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     if( $self->{Have_Plan} ) {
251         $self->croak("You tried to plan twice");
252     }
253
254     if( $cmd eq 'no_plan' ) {
255         $self->no_plan;
256     }
257     elsif( $cmd eq 'skip_all' ) {
258         return $self->skip_all($arg);
259     }
260     elsif( $cmd eq 'tests' ) {
261         if( $arg ) {
262             local $Level = $Level + 1;
263             return $self->expected_tests($arg);
264         }
265         elsif( !defined $arg ) {
266             $self->croak("Got an undefined number of tests");
267         }
268         elsif( !$arg ) {
269             $self->croak("You said to run 0 tests");
270         }
271     }
272     else {
273         my @args = grep { defined } ($cmd, $arg);
274         $self->croak("plan() doesn't understand @args");
275     }
276
277     return 1;
278 }
279
280 =item B<expected_tests>
281
282     my $max = $Test->expected_tests;
283     $Test->expected_tests($max);
284
285 Gets/sets the # of tests we expect this test to run and prints out
286 the appropriate headers.
287
288 =cut
289
290 sub expected_tests {
291     my $self = shift;
292     my($max) = @_;
293
294     if( @_ ) {
295         $self->croak("Number of tests must be a positive integer.  You gave it '$max'")
296           unless $max =~ /^\+?\d+$/ and $max > 0;
297
298         $self->{Expected_Tests} = $max;
299         $self->{Have_Plan}      = 1;
300
301         $self->_print("1..$max\n") unless $self->no_header;
302     }
303     return $self->{Expected_Tests};
304 }
305
306
307 =item B<no_plan>
308
309   $Test->no_plan;
310
311 Declares that this test will run an indeterminate # of tests.
312
313 =cut
314
315 sub no_plan {
316     my $self = shift;
317
318     $self->{No_Plan}   = 1;
319     $self->{Have_Plan} = 1;
320 }
321
322 =item B<has_plan>
323
324   $plan = $Test->has_plan
325
326 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).
327
328 =cut
329
330 sub has_plan {
331     my $self = shift;
332
333     return($self->{Expected_Tests}) if $self->{Expected_Tests};
334     return('no_plan') if $self->{No_Plan};
335     return(undef);
336 };
337
338
339 =item B<skip_all>
340
341   $Test->skip_all;
342   $Test->skip_all($reason);
343
344 Skips all the tests, using the given $reason.  Exits immediately with 0.
345
346 =cut
347
348 sub skip_all {
349     my($self, $reason) = @_;
350
351     my $out = "1..0";
352     $out .= " # Skip $reason" if $reason;
353     $out .= "\n";
354
355     $self->{Skip_All} = 1;
356
357     $self->_print($out) unless $self->no_header;
358     exit(0);
359 }
360
361 =back
362
363 =head2 Running tests
364
365 These actually run the tests, analogous to the functions in
366 Test::More.
367
368 $name is always optional.
369
370 =over 4
371
372 =item B<ok>
373
374   $Test->ok($test, $name);
375
376 Your basic test.  Pass if $test is true, fail if $test is false.  Just
377 like Test::Simple's ok().
378
379 =cut
380
381 sub ok {
382     my($self, $test, $name) = @_;
383
384     # $test might contain an object which we don't want to accidentally
385     # store, so we turn it into a boolean.
386     $test = $test ? 1 : 0;
387
388     $self->_plan_check;
389
390     lock $self->{Curr_Test};
391     $self->{Curr_Test}++;
392
393     # In case $name is a string overloaded object, force it to stringify.
394     $self->_unoverload_str(\$name);
395
396     $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
397     You named your test '$name'.  You shouldn't use numbers for your test names.
398     Very confusing.
399 ERR
400
401     my($pack, $file, $line) = $self->caller;
402
403     my $todo = $self->todo($pack);
404     $self->_unoverload_str(\$todo);
405
406     my $out;
407     my $result = &share({});
408
409     unless( $test ) {
410         $out .= "not ";
411         @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
412     }
413     else {
414         @$result{ 'ok', 'actual_ok' } = ( 1, $test );
415     }
416
417     $out .= "ok";
418     $out .= " $self->{Curr_Test}" if $self->use_numbers;
419
420     if( defined $name ) {
421         $name =~ s|#|\\#|g;     # # in a name can confuse Test::Harness.
422         $out   .= " - $name";
423         $result->{name} = $name;
424     }
425     else {
426         $result->{name} = '';
427     }
428
429     if( $todo ) {
430         $out   .= " # TODO $todo";
431         $result->{reason} = $todo;
432         $result->{type}   = 'todo';
433     }
434     else {
435         $result->{reason} = '';
436         $result->{type}   = '';
437     }
438
439     $self->{Test_Results}[$self->{Curr_Test}-1] = $result;
440     $out .= "\n";
441
442     $self->_print($out);
443
444     unless( $test ) {
445         my $msg = $todo ? "Failed (TODO)" : "Failed";
446         $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
447
448         if( defined $name ) {
449             $self->diag(qq[  $msg test '$name'\n]);
450             $self->diag(qq[  at $file line $line.\n]);
451         }
452         else {
453             $self->diag(qq[  $msg test at $file line $line.\n]);
454         }
455     } 
456
457     return $test ? 1 : 0;
458 }
459
460
461 sub _unoverload {
462     my $self  = shift;
463     my $type  = shift;
464
465     local($@,$!);
466
467     eval { require overload } || return;
468
469     foreach my $thing (@_) {
470         eval { 
471             if( _is_object($$thing) ) {
472                 if( my $string_meth = overload::Method($$thing, $type) ) {
473                     $$thing = $$thing->$string_meth();
474                 }
475             }
476         };
477     }
478 }
479
480
481 sub _is_object {
482     my $thing = shift;
483
484     return eval { ref $thing && $thing->isa('UNIVERSAL') } ? 1 : 0;
485 }
486
487
488 sub _unoverload_str {
489     my $self = shift;
490
491     $self->_unoverload(q[""], @_);
492 }    
493
494 sub _unoverload_num {
495     my $self = shift;
496
497     $self->_unoverload('0+', @_);
498
499     for my $val (@_) {
500         next unless $self->_is_dualvar($$val);
501         $$val = $$val+0;
502     }
503 }
504
505
506 # This is a hack to detect a dualvar such as $!
507 sub _is_dualvar {
508     my($self, $val) = @_;
509
510     local $^W = 0;
511     my $numval = $val+0;
512     return 1 if $numval != 0 and $numval ne $val;
513 }
514
515
516
517 =item B<is_eq>
518
519   $Test->is_eq($got, $expected, $name);
520
521 Like Test::More's is().  Checks if $got eq $expected.  This is the
522 string version.
523
524 =item B<is_num>
525
526   $Test->is_num($got, $expected, $name);
527
528 Like Test::More's is().  Checks if $got == $expected.  This is the
529 numeric version.
530
531 =cut
532
533 sub is_eq {
534     my($self, $got, $expect, $name) = @_;
535     local $Level = $Level + 1;
536
537     $self->_unoverload_str(\$got, \$expect);
538
539     if( !defined $got || !defined $expect ) {
540         # undef only matches undef and nothing else
541         my $test = !defined $got && !defined $expect;
542
543         $self->ok($test, $name);
544         $self->_is_diag($got, 'eq', $expect) unless $test;
545         return $test;
546     }
547
548     return $self->cmp_ok($got, 'eq', $expect, $name);
549 }
550
551 sub is_num {
552     my($self, $got, $expect, $name) = @_;
553     local $Level = $Level + 1;
554
555     $self->_unoverload_num(\$got, \$expect);
556
557     if( !defined $got || !defined $expect ) {
558         # undef only matches undef and nothing else
559         my $test = !defined $got && !defined $expect;
560
561         $self->ok($test, $name);
562         $self->_is_diag($got, '==', $expect) unless $test;
563         return $test;
564     }
565
566     return $self->cmp_ok($got, '==', $expect, $name);
567 }
568
569 sub _is_diag {
570     my($self, $got, $type, $expect) = @_;
571
572     foreach my $val (\$got, \$expect) {
573         if( defined $$val ) {
574             if( $type eq 'eq' ) {
575                 # quote and force string context
576                 $$val = "'$$val'"
577             }
578             else {
579                 # force numeric context
580                 $self->_unoverload_num($val);
581             }
582         }
583         else {
584             $$val = 'undef';
585         }
586     }
587
588     return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
589          got: %s
590     expected: %s
591 DIAGNOSTIC
592
593 }    
594
595 =item B<isnt_eq>
596
597   $Test->isnt_eq($got, $dont_expect, $name);
598
599 Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
600 the string version.
601
602 =item B<isnt_num>
603
604   $Test->isnt_num($got, $dont_expect, $name);
605
606 Like Test::More's isnt().  Checks if $got ne $dont_expect.  This is
607 the numeric version.
608
609 =cut
610
611 sub isnt_eq {
612     my($self, $got, $dont_expect, $name) = @_;
613     local $Level = $Level + 1;
614
615     if( !defined $got || !defined $dont_expect ) {
616         # undef only matches undef and nothing else
617         my $test = defined $got || defined $dont_expect;
618
619         $self->ok($test, $name);
620         $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
621         return $test;
622     }
623
624     return $self->cmp_ok($got, 'ne', $dont_expect, $name);
625 }
626
627 sub isnt_num {
628     my($self, $got, $dont_expect, $name) = @_;
629     local $Level = $Level + 1;
630
631     if( !defined $got || !defined $dont_expect ) {
632         # undef only matches undef and nothing else
633         my $test = defined $got || defined $dont_expect;
634
635         $self->ok($test, $name);
636         $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
637         return $test;
638     }
639
640     return $self->cmp_ok($got, '!=', $dont_expect, $name);
641 }
642
643
644 =item B<like>
645
646   $Test->like($this, qr/$regex/, $name);
647   $Test->like($this, '/$regex/', $name);
648
649 Like Test::More's like().  Checks if $this matches the given $regex.
650
651 You'll want to avoid qr// if you want your tests to work before 5.005.
652
653 =item B<unlike>
654
655   $Test->unlike($this, qr/$regex/, $name);
656   $Test->unlike($this, '/$regex/', $name);
657
658 Like Test::More's unlike().  Checks if $this B<does not match> the
659 given $regex.
660
661 =cut
662
663 sub like {
664     my($self, $this, $regex, $name) = @_;
665
666     local $Level = $Level + 1;
667     $self->_regex_ok($this, $regex, '=~', $name);
668 }
669
670 sub unlike {
671     my($self, $this, $regex, $name) = @_;
672
673     local $Level = $Level + 1;
674     $self->_regex_ok($this, $regex, '!~', $name);
675 }
676
677 =item B<maybe_regex>
678
679   $Test->maybe_regex(qr/$regex/);
680   $Test->maybe_regex('/$regex/');
681
682 Convenience method for building testing functions that take regular
683 expressions as arguments, but need to work before perl 5.005.
684
685 Takes a quoted regular expression produced by qr//, or a string
686 representing a regular expression.
687
688 Returns a Perl value which may be used instead of the corresponding
689 regular expression, or undef if it's argument is not recognised.
690
691 For example, a version of like(), sans the useful diagnostic messages,
692 could be written as:
693
694   sub laconic_like {
695       my ($self, $this, $regex, $name) = @_;
696       my $usable_regex = $self->maybe_regex($regex);
697       die "expecting regex, found '$regex'\n"
698           unless $usable_regex;
699       $self->ok($this =~ m/$usable_regex/, $name);
700   }
701
702 =cut
703
704
705 sub maybe_regex {
706     my ($self, $regex) = @_;
707     my $usable_regex = undef;
708
709     return $usable_regex unless defined $regex;
710
711     my($re, $opts);
712
713     # Check for qr/foo/
714     if( ref $regex eq 'Regexp' ) {
715         $usable_regex = $regex;
716     }
717     # Check for '/foo/' or 'm,foo,'
718     elsif( ($re, $opts)        = $regex =~ m{^ /(.*)/ (\w*) $ }sx           or
719            (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
720          )
721     {
722         $usable_regex = length $opts ? "(?$opts)$re" : $re;
723     }
724
725     return $usable_regex;
726 };
727
728 sub _regex_ok {
729     my($self, $this, $regex, $cmp, $name) = @_;
730
731     my $ok = 0;
732     my $usable_regex = $self->maybe_regex($regex);
733     unless (defined $usable_regex) {
734         $ok = $self->ok( 0, $name );
735         $self->diag("    '$regex' doesn't look much like a regex to me.");
736         return $ok;
737     }
738
739     {
740         my $test;
741         my $code = $self->_caller_context;
742
743         local($@, $!);
744
745         # Yes, it has to look like this or 5.4.5 won't see the #line directive.
746         # Don't ask me, man, I just work here.
747         $test = eval "
748 $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
749
750         $test = !$test if $cmp eq '!~';
751
752         local $Level = $Level + 1;
753         $ok = $self->ok( $test, $name );
754     }
755
756     unless( $ok ) {
757         $this = defined $this ? "'$this'" : 'undef';
758         my $match = $cmp eq '=~' ? "doesn't match" : "matches";
759         $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
760                   %s
761     %13s '%s'
762 DIAGNOSTIC
763
764     }
765
766     return $ok;
767 }
768
769 =item B<cmp_ok>
770
771   $Test->cmp_ok($this, $type, $that, $name);
772
773 Works just like Test::More's cmp_ok().
774
775     $Test->cmp_ok($big_num, '!=', $other_big_num);
776
777 =cut
778
779
780 my %numeric_cmps = map { ($_, 1) } 
781                        ("<",  "<=", ">",  ">=", "==", "!=", "<=>");
782
783 sub cmp_ok {
784     my($self, $got, $type, $expect, $name) = @_;
785
786     # Treat overloaded objects as numbers if we're asked to do a
787     # numeric comparison.
788     my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
789                                           : '_unoverload_str';
790
791     $self->$unoverload(\$got, \$expect);
792
793
794     my $test;
795     {
796         local($@,$!);   # don't interfere with $@
797                         # eval() sometimes resets $!
798
799         my $code = $self->_caller_context;
800
801         # Yes, it has to look like this or 5.4.5 won't see the #line directive.
802         # Don't ask me, man, I just work here.
803         $test = eval "
804 $code" . "\$got $type \$expect;";
805
806     }
807     local $Level = $Level + 1;
808     my $ok = $self->ok($test, $name);
809
810     unless( $ok ) {
811         if( $type =~ /^(eq|==)$/ ) {
812             $self->_is_diag($got, $type, $expect);
813         }
814         else {
815             $self->_cmp_diag($got, $type, $expect);
816         }
817     }
818     return $ok;
819 }
820
821 sub _cmp_diag {
822     my($self, $got, $type, $expect) = @_;
823     
824     $got    = defined $got    ? "'$got'"    : 'undef';
825     $expect = defined $expect ? "'$expect'" : 'undef';
826     return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
827     %s
828         %s
829     %s
830 DIAGNOSTIC
831 }
832
833
834 sub _caller_context {
835     my $self = shift;
836
837     my($pack, $file, $line) = $self->caller(1);
838
839     my $code = '';
840     $code .= "#line $line $file\n" if defined $file and defined $line;
841
842     return $code;
843 }
844
845
846 =item B<BAIL_OUT>
847
848     $Test->BAIL_OUT($reason);
849
850 Indicates to the Test::Harness that things are going so badly all
851 testing should terminate.  This includes running any additional test
852 scripts.
853
854 It will exit with 255.
855
856 =cut
857
858 sub BAIL_OUT {
859     my($self, $reason) = @_;
860
861     $self->{Bailed_Out} = 1;
862     $self->_print("Bail out!  $reason");
863     exit 255;
864 }
865
866 =for deprecated
867 BAIL_OUT() used to be BAILOUT()
868
869 =cut
870
871 *BAILOUT = \&BAIL_OUT;
872
873
874 =item B<skip>
875
876     $Test->skip;
877     $Test->skip($why);
878
879 Skips the current test, reporting $why.
880
881 =cut
882
883 sub skip {
884     my($self, $why) = @_;
885     $why ||= '';
886     $self->_unoverload_str(\$why);
887
888     $self->_plan_check;
889
890     lock($self->{Curr_Test});
891     $self->{Curr_Test}++;
892
893     $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
894         'ok'      => 1,
895         actual_ok => 1,
896         name      => '',
897         type      => 'skip',
898         reason    => $why,
899     });
900
901     my $out = "ok";
902     $out   .= " $self->{Curr_Test}" if $self->use_numbers;
903     $out   .= " # skip";
904     $out   .= " $why"       if length $why;
905     $out   .= "\n";
906
907     $self->_print($out);
908
909     return 1;
910 }
911
912
913 =item B<todo_skip>
914
915   $Test->todo_skip;
916   $Test->todo_skip($why);
917
918 Like skip(), only it will declare the test as failing and TODO.  Similar
919 to
920
921     print "not ok $tnum # TODO $why\n";
922
923 =cut
924
925 sub todo_skip {
926     my($self, $why) = @_;
927     $why ||= '';
928
929     $self->_plan_check;
930
931     lock($self->{Curr_Test});
932     $self->{Curr_Test}++;
933
934     $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
935         'ok'      => 1,
936         actual_ok => 0,
937         name      => '',
938         type      => 'todo_skip',
939         reason    => $why,
940     });
941
942     my $out = "not ok";
943     $out   .= " $self->{Curr_Test}" if $self->use_numbers;
944     $out   .= " # TODO & SKIP $why\n";
945
946     $self->_print($out);
947
948     return 1;
949 }
950
951
952 =begin _unimplemented
953
954 =item B<skip_rest>
955
956   $Test->skip_rest;
957   $Test->skip_rest($reason);
958
959 Like skip(), only it skips all the rest of the tests you plan to run
960 and terminates the test.
961
962 If you're running under no_plan, it skips once and terminates the
963 test.
964
965 =end _unimplemented
966
967 =back
968
969
970 =head2 Test style
971
972 =over 4
973
974 =item B<level>
975
976     $Test->level($how_high);
977
978 How far up the call stack should $Test look when reporting where the
979 test failed.
980
981 Defaults to 1.
982
983 Setting $Test::Builder::Level overrides.  This is typically useful
984 localized:
985
986     {
987         local $Test::Builder::Level = 2;
988         $Test->ok($test);
989     }
990
991 =cut
992
993 sub level {
994     my($self, $level) = @_;
995
996     if( defined $level ) {
997         $Level = $level;
998     }
999     return $Level;
1000 }
1001
1002
1003 =item B<use_numbers>
1004
1005     $Test->use_numbers($on_or_off);
1006
1007 Whether or not the test should output numbers.  That is, this if true:
1008
1009   ok 1
1010   ok 2
1011   ok 3
1012
1013 or this if false
1014
1015   ok
1016   ok
1017   ok
1018
1019 Most useful when you can't depend on the test output order, such as
1020 when threads or forking is involved.
1021
1022 Test::Harness will accept either, but avoid mixing the two styles.
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 + 2;
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 + 1;
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;