1#line 1
2package Test::Builder;
3
4use 5.004;
5
6# $^C was only introduced in 5.005-ish.  We do this to prevent
7# use of uninitialized value warnings in older perls.
8$^C ||= 0;
9
10use strict;
11use vars qw($VERSION);
12$VERSION = '0.74';
13$VERSION = eval $VERSION;    # make the alpha version come out as a number
14
15# Make Test::Builder thread-safe for ithreads.
16BEGIN {
17    use Config;
18    # Load threads::shared when threads are turned on.
19    # 5.8.0's threads are so busted we no longer support them.
20    if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) {
21        require threads::shared;
22
23        # Hack around YET ANOTHER threads::shared bug.  It would
24        # occassionally forget the contents of the variable when sharing it.
25        # So we first copy the data, then share, then put our copy back.
26        *share = sub (\[$@%]) {
27            my $type = ref $_[0];
28            my $data;
29
30            if( $type eq 'HASH' ) {
31                %$data = %{$_[0]};
32            }
33            elsif( $type eq 'ARRAY' ) {
34                @$data = @{$_[0]};
35            }
36            elsif( $type eq 'SCALAR' ) {
37                $$data = ${$_[0]};
38            }
39            else {
40                die("Unknown type: ".$type);
41            }
42
43            $_[0] = &threads::shared::share($_[0]);
44
45            if( $type eq 'HASH' ) {
46                %{$_[0]} = %$data;
47            }
48            elsif( $type eq 'ARRAY' ) {
49                @{$_[0]} = @$data;
50            }
51            elsif( $type eq 'SCALAR' ) {
52                ${$_[0]} = $$data;
53            }
54            else {
55                die("Unknown type: ".$type);
56            }
57
58            return $_[0];
59        };
60    }
61    # 5.8.0's threads::shared is busted when threads are off
62    # and earlier Perls just don't have that module at all.
63    else {
64        *share = sub { return $_[0] };
65        *lock  = sub { 0 };
66    }
67}
68
69
70#line 128
71
72my $Test = Test::Builder->new;
73sub new {
74    my($class) = shift;
75    $Test ||= $class->create;
76    return $Test;
77}
78
79
80#line 150
81
82sub create {
83    my $class = shift;
84
85    my $self = bless {}, $class;
86    $self->reset;
87
88    return $self;
89}
90
91#line 169
92
93use vars qw($Level);
94
95sub reset {
96    my ($self) = @_;
97
98    # We leave this a global because it has to be localized and localizing
99    # hash keys is just asking for pain.  Also, it was documented.
100    $Level = 1;
101
102    $self->{Test_Died}    = 0;
103    $self->{Have_Plan}    = 0;
104    $self->{No_Plan}      = 0;
105    $self->{Original_Pid} = $$;
106
107    share($self->{Curr_Test});
108    $self->{Curr_Test}    = 0;
109    $self->{Test_Results} = &share([]);
110
111    $self->{Exported_To}    = undef;
112    $self->{Expected_Tests} = 0;
113
114    $self->{Skip_All}   = 0;
115
116    $self->{Use_Nums}   = 1;
117
118    $self->{No_Header}  = 0;
119    $self->{No_Ending}  = 0;
120
121    $self->_dup_stdhandles unless $^C;
122
123    return undef;
124}
125
126#line 221
127
128sub exported_to {
129    my($self, $pack) = @_;
130
131    if( defined $pack ) {
132        $self->{Exported_To} = $pack;
133    }
134    return $self->{Exported_To};
135}
136
137#line 243
138
139sub plan {
140    my($self, $cmd, $arg) = @_;
141
142    return unless $cmd;
143
144    local $Level = $Level + 1;
145
146    if( $self->{Have_Plan} ) {
147        $self->croak("You tried to plan twice");
148    }
149
150    if( $cmd eq 'no_plan' ) {
151        $self->no_plan;
152    }
153    elsif( $cmd eq 'skip_all' ) {
154        return $self->skip_all($arg);
155    }
156    elsif( $cmd eq 'tests' ) {
157        if( $arg ) {
158            local $Level = $Level + 1;
159            return $self->expected_tests($arg);
160        }
161        elsif( !defined $arg ) {
162            $self->croak("Got an undefined number of tests");
163        }
164        elsif( !$arg ) {
165            $self->croak("You said to run 0 tests");
166        }
167    }
168    else {
169        my @args = grep { defined } ($cmd, $arg);
170        $self->croak("plan() doesn't understand @args");
171    }
172
173    return 1;
174}
175
176#line 290
177
178sub expected_tests {
179    my $self = shift;
180    my($max) = @_;
181
182    if( @_ ) {
183        $self->croak("Number of tests must be a positive integer.  You gave it '$max'")
184          unless $max =~ /^\+?\d+$/ and $max > 0;
185
186        $self->{Expected_Tests} = $max;
187        $self->{Have_Plan}      = 1;
188
189        $self->_print("1..$max\n") unless $self->no_header;
190    }
191    return $self->{Expected_Tests};
192}
193
194
195#line 315
196
197sub no_plan {
198    my $self = shift;
199
200    $self->{No_Plan}   = 1;
201    $self->{Have_Plan} = 1;
202}
203
204#line 330
205
206sub has_plan {
207    my $self = shift;
208
209    return($self->{Expected_Tests}) if $self->{Expected_Tests};
210    return('no_plan') if $self->{No_Plan};
211    return(undef);
212};
213
214
215#line 348
216
217sub skip_all {
218    my($self, $reason) = @_;
219
220    my $out = "1..0";
221    $out .= " # Skip $reason" if $reason;
222    $out .= "\n";
223
224    $self->{Skip_All} = 1;
225
226    $self->_print($out) unless $self->no_header;
227    exit(0);
228}
229
230#line 382
231
232sub ok {
233    my($self, $test, $name) = @_;
234
235    # $test might contain an object which we don't want to accidentally
236    # store, so we turn it into a boolean.
237    $test = $test ? 1 : 0;
238
239    $self->_plan_check;
240
241    lock $self->{Curr_Test};
242    $self->{Curr_Test}++;
243
244    # In case $name is a string overloaded object, force it to stringify.
245    $self->_unoverload_str(\$name);
246
247    $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/;
248    You named your test '$name'.  You shouldn't use numbers for your test names.
249    Very confusing.
250ERR
251
252    my($pack, $file, $line) = $self->caller;
253
254    my $todo = $self->todo($pack);
255    $self->_unoverload_str(\$todo);
256
257    my $out;
258    my $result = &share({});
259
260    unless( $test ) {
261        $out .= "not ";
262        @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
263    }
264    else {
265        @$result{ 'ok', 'actual_ok' } = ( 1, $test );
266    }
267
268    $out .= "ok";
269    $out .= " $self->{Curr_Test}" if $self->use_numbers;
270
271    if( defined $name ) {
272        $name =~ s|#|\\#|g;     # # in a name can confuse Test::Harness.
273        $out   .= " - $name";
274        $result->{name} = $name;
275    }
276    else {
277        $result->{name} = '';
278    }
279
280    if( $todo ) {
281        $out   .= " # TODO $todo";
282        $result->{reason} = $todo;
283        $result->{type}   = 'todo';
284    }
285    else {
286        $result->{reason} = '';
287        $result->{type}   = '';
288    }
289
290    $self->{Test_Results}[$self->{Curr_Test}-1] = $result;
291    $out .= "\n";
292
293    $self->_print($out);
294
295    unless( $test ) {
296        my $msg = $todo ? "Failed (TODO)" : "Failed";
297        $self->_print_diag("\n") if $ENV{HARNESS_ACTIVE};
298
299	if( defined $name ) {
300	    $self->diag(qq[  $msg test '$name'\n]);
301	    $self->diag(qq[  at $file line $line.\n]);
302	}
303	else {
304	    $self->diag(qq[  $msg test at $file line $line.\n]);
305	}
306    }
307
308    return $test ? 1 : 0;
309}
310
311
312sub _unoverload {
313    my $self  = shift;
314    my $type  = shift;
315
316    $self->_try(sub { require overload } ) || return;
317
318    foreach my $thing (@_) {
319        if( $self->_is_object($$thing) ) {
320            if( my $string_meth = overload::Method($$thing, $type) ) {
321                $$thing = $$thing->$string_meth();
322            }
323        }
324    }
325}
326
327
328sub _is_object {
329    my($self, $thing) = @_;
330
331    return $self->_try(sub { ref $thing && $thing->isa('UNIVERSAL') }) ? 1 : 0;
332}
333
334
335sub _unoverload_str {
336    my $self = shift;
337
338    $self->_unoverload(q[""], @_);
339}
340
341sub _unoverload_num {
342    my $self = shift;
343
344    $self->_unoverload('0+', @_);
345
346    for my $val (@_) {
347        next unless $self->_is_dualvar($$val);
348        $$val = $$val+0;
349    }
350}
351
352
353# This is a hack to detect a dualvar such as $!
354sub _is_dualvar {
355    my($self, $val) = @_;
356
357    local $^W = 0;
358    my $numval = $val+0;
359    return 1 if $numval != 0 and $numval ne $val;
360}
361
362
363
364#line 530
365
366sub is_eq {
367    my($self, $got, $expect, $name) = @_;
368    local $Level = $Level + 1;
369
370    $self->_unoverload_str(\$got, \$expect);
371
372    if( !defined $got || !defined $expect ) {
373        # undef only matches undef and nothing else
374        my $test = !defined $got && !defined $expect;
375
376        $self->ok($test, $name);
377        $self->_is_diag($got, 'eq', $expect) unless $test;
378        return $test;
379    }
380
381    return $self->cmp_ok($got, 'eq', $expect, $name);
382}
383
384sub is_num {
385    my($self, $got, $expect, $name) = @_;
386    local $Level = $Level + 1;
387
388    $self->_unoverload_num(\$got, \$expect);
389
390    if( !defined $got || !defined $expect ) {
391        # undef only matches undef and nothing else
392        my $test = !defined $got && !defined $expect;
393
394        $self->ok($test, $name);
395        $self->_is_diag($got, '==', $expect) unless $test;
396        return $test;
397    }
398
399    return $self->cmp_ok($got, '==', $expect, $name);
400}
401
402sub _is_diag {
403    my($self, $got, $type, $expect) = @_;
404
405    foreach my $val (\$got, \$expect) {
406        if( defined $$val ) {
407            if( $type eq 'eq' ) {
408                # quote and force string context
409                $$val = "'$$val'"
410            }
411            else {
412                # force numeric context
413                $self->_unoverload_num($val);
414            }
415        }
416        else {
417            $$val = 'undef';
418        }
419    }
420
421    return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
422         got: %s
423    expected: %s
424DIAGNOSTIC
425
426}
427
428#line 608
429
430sub isnt_eq {
431    my($self, $got, $dont_expect, $name) = @_;
432    local $Level = $Level + 1;
433
434    if( !defined $got || !defined $dont_expect ) {
435        # undef only matches undef and nothing else
436        my $test = defined $got || defined $dont_expect;
437
438        $self->ok($test, $name);
439        $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
440        return $test;
441    }
442
443    return $self->cmp_ok($got, 'ne', $dont_expect, $name);
444}
445
446sub isnt_num {
447    my($self, $got, $dont_expect, $name) = @_;
448    local $Level = $Level + 1;
449
450    if( !defined $got || !defined $dont_expect ) {
451        # undef only matches undef and nothing else
452        my $test = defined $got || defined $dont_expect;
453
454        $self->ok($test, $name);
455        $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
456        return $test;
457    }
458
459    return $self->cmp_ok($got, '!=', $dont_expect, $name);
460}
461
462
463#line 660
464
465sub like {
466    my($self, $this, $regex, $name) = @_;
467
468    local $Level = $Level + 1;
469    $self->_regex_ok($this, $regex, '=~', $name);
470}
471
472sub unlike {
473    my($self, $this, $regex, $name) = @_;
474
475    local $Level = $Level + 1;
476    $self->_regex_ok($this, $regex, '!~', $name);
477}
478
479
480#line 685
481
482
483my %numeric_cmps = map { ($_, 1) }
484                       ("<",  "<=", ">",  ">=", "==", "!=", "<=>");
485
486sub cmp_ok {
487    my($self, $got, $type, $expect, $name) = @_;
488
489    # Treat overloaded objects as numbers if we're asked to do a
490    # numeric comparison.
491    my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
492                                          : '_unoverload_str';
493
494    $self->$unoverload(\$got, \$expect);
495
496
497    my $test;
498    {
499        local($@,$!,$SIG{__DIE__});  # isolate eval
500
501        my $code = $self->_caller_context;
502
503        # Yes, it has to look like this or 5.4.5 won't see the #line directive.
504        # Don't ask me, man, I just work here.
505        $test = eval "
506$code" . "\$got $type \$expect;";
507
508    }
509    local $Level = $Level + 1;
510    my $ok = $self->ok($test, $name);
511
512    unless( $ok ) {
513        if( $type =~ /^(eq|==)$/ ) {
514            $self->_is_diag($got, $type, $expect);
515        }
516        else {
517            $self->_cmp_diag($got, $type, $expect);
518        }
519    }
520    return $ok;
521}
522
523sub _cmp_diag {
524    my($self, $got, $type, $expect) = @_;
525
526    $got    = defined $got    ? "'$got'"    : 'undef';
527    $expect = defined $expect ? "'$expect'" : 'undef';
528    return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
529    %s
530        %s
531    %s
532DIAGNOSTIC
533}
534
535
536sub _caller_context {
537    my $self = shift;
538
539    my($pack, $file, $line) = $self->caller(1);
540
541    my $code = '';
542    $code .= "#line $line $file\n" if defined $file and defined $line;
543
544    return $code;
545}
546
547#line 771
548
549sub BAIL_OUT {
550    my($self, $reason) = @_;
551
552    $self->{Bailed_Out} = 1;
553    $self->_print("Bail out!  $reason");
554    exit 255;
555}
556
557#line 784
558
559*BAILOUT = \&BAIL_OUT;
560
561
562#line 796
563
564sub skip {
565    my($self, $why) = @_;
566    $why ||= '';
567    $self->_unoverload_str(\$why);
568
569    $self->_plan_check;
570
571    lock($self->{Curr_Test});
572    $self->{Curr_Test}++;
573
574    $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
575        'ok'      => 1,
576        actual_ok => 1,
577        name      => '',
578        type      => 'skip',
579        reason    => $why,
580    });
581
582    my $out = "ok";
583    $out   .= " $self->{Curr_Test}" if $self->use_numbers;
584    $out   .= " # skip";
585    $out   .= " $why"       if length $why;
586    $out   .= "\n";
587
588    $self->_print($out);
589
590    return 1;
591}
592
593
594#line 838
595
596sub todo_skip {
597    my($self, $why) = @_;
598    $why ||= '';
599
600    $self->_plan_check;
601
602    lock($self->{Curr_Test});
603    $self->{Curr_Test}++;
604
605    $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
606        'ok'      => 1,
607        actual_ok => 0,
608        name      => '',
609        type      => 'todo_skip',
610        reason    => $why,
611    });
612
613    my $out = "not ok";
614    $out   .= " $self->{Curr_Test}" if $self->use_numbers;
615    $out   .= " # TODO & SKIP $why\n";
616
617    $self->_print($out);
618
619    return 1;
620}
621
622
623#line 916
624
625
626sub maybe_regex {
627    my ($self, $regex) = @_;
628    my $usable_regex = undef;
629
630    return $usable_regex unless defined $regex;
631
632    my($re, $opts);
633
634    # Check for qr/foo/
635    if( ref $regex eq 'Regexp' ) {
636        $usable_regex = $regex;
637    }
638    # Check for '/foo/' or 'm,foo,'
639    elsif( ($re, $opts)        = $regex =~ m{^ /(.*)/ (\w*) $ }sx           or
640           (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
641         )
642    {
643        $usable_regex = length $opts ? "(?$opts)$re" : $re;
644    }
645
646    return $usable_regex;
647};
648
649sub _regex_ok {
650    my($self, $this, $regex, $cmp, $name) = @_;
651
652    my $ok = 0;
653    my $usable_regex = $self->maybe_regex($regex);
654    unless (defined $usable_regex) {
655        $ok = $self->ok( 0, $name );
656        $self->diag("    '$regex' doesn't look much like a regex to me.");
657        return $ok;
658    }
659
660    {
661        my $test;
662        my $code = $self->_caller_context;
663
664        local($@, $!, $SIG{__DIE__}); # isolate eval
665
666        # Yes, it has to look like this or 5.4.5 won't see the #line directive.
667        # Don't ask me, man, I just work here.
668        $test = eval "
669$code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
670
671        $test = !$test if $cmp eq '!~';
672
673        local $Level = $Level + 1;
674        $ok = $self->ok( $test, $name );
675    }
676
677    unless( $ok ) {
678        $this = defined $this ? "'$this'" : 'undef';
679        my $match = $cmp eq '=~' ? "doesn't match" : "matches";
680        $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
681                  %s
682    %13s '%s'
683DIAGNOSTIC
684
685    }
686
687    return $ok;
688}
689
690
691# I'm not ready to publish this.  It doesn't deal with array return
692# values from the code or context.
693
694#line 1000
695
696sub _try {
697    my($self, $code) = @_;
698
699    local $!;               # eval can mess up $!
700    local $@;               # don't set $@ in the test
701    local $SIG{__DIE__};    # don't trip an outside DIE handler.
702    my $return = eval { $code->() };
703
704    return wantarray ? ($return, $@) : $return;
705}
706
707#line 1022
708
709sub is_fh {
710    my $self = shift;
711    my $maybe_fh = shift;
712    return 0 unless defined $maybe_fh;
713
714    return 1 if ref $maybe_fh  eq 'GLOB'; # its a glob ref
715    return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
716
717    return eval { $maybe_fh->isa("IO::Handle") } ||
718           # 5.5.4's tied() and can() doesn't like getting undef
719           eval { (tied($maybe_fh) || '')->can('TIEHANDLE') };
720}
721
722
723#line 1067
724
725sub level {
726    my($self, $level) = @_;
727
728    if( defined $level ) {
729        $Level = $level;
730    }
731    return $Level;
732}
733
734
735#line 1100
736
737sub use_numbers {
738    my($self, $use_nums) = @_;
739
740    if( defined $use_nums ) {
741        $self->{Use_Nums} = $use_nums;
742    }
743    return $self->{Use_Nums};
744}
745
746
747#line 1134
748
749foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
750    my $method = lc $attribute;
751
752    my $code = sub {
753        my($self, $no) = @_;
754
755        if( defined $no ) {
756            $self->{$attribute} = $no;
757        }
758        return $self->{$attribute};
759    };
760
761    no strict 'refs';
762    *{__PACKAGE__.'::'.$method} = $code;
763}
764
765
766#line 1188
767
768sub diag {
769    my($self, @msgs) = @_;
770
771    return if $self->no_diag;
772    return unless @msgs;
773
774    # Prevent printing headers when compiling (i.e. -c)
775    return if $^C;
776
777    # Smash args together like print does.
778    # Convert undef to 'undef' so its readable.
779    my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
780
781    # Escape each line with a #.
782    $msg =~ s/^/# /gm;
783
784    # Stick a newline on the end if it needs it.
785    $msg .= "\n" unless $msg =~ /\n\Z/;
786
787    local $Level = $Level + 1;
788    $self->_print_diag($msg);
789
790    return 0;
791}
792
793#line 1225
794
795sub _print {
796    my($self, @msgs) = @_;
797
798    # Prevent printing headers when only compiling.  Mostly for when
799    # tests are deparsed with B::Deparse
800    return if $^C;
801
802    my $msg = join '', @msgs;
803
804    local($\, $", $,) = (undef, ' ', '');
805    my $fh = $self->output;
806
807    # Escape each line after the first with a # so we don't
808    # confuse Test::Harness.
809    $msg =~ s/\n(.)/\n# $1/sg;
810
811    # Stick a newline on the end if it needs it.
812    $msg .= "\n" unless $msg =~ /\n\Z/;
813
814    print $fh $msg;
815}
816
817#line 1259
818
819sub _print_diag {
820    my $self = shift;
821
822    local($\, $", $,) = (undef, ' ', '');
823    my $fh = $self->todo ? $self->todo_output : $self->failure_output;
824    print $fh @_;
825}
826
827#line 1296
828
829sub output {
830    my($self, $fh) = @_;
831
832    if( defined $fh ) {
833        $self->{Out_FH} = $self->_new_fh($fh);
834    }
835    return $self->{Out_FH};
836}
837
838sub failure_output {
839    my($self, $fh) = @_;
840
841    if( defined $fh ) {
842        $self->{Fail_FH} = $self->_new_fh($fh);
843    }
844    return $self->{Fail_FH};
845}
846
847sub todo_output {
848    my($self, $fh) = @_;
849
850    if( defined $fh ) {
851        $self->{Todo_FH} = $self->_new_fh($fh);
852    }
853    return $self->{Todo_FH};
854}
855
856
857sub _new_fh {
858    my $self = shift;
859    my($file_or_fh) = shift;
860
861    my $fh;
862    if( $self->is_fh($file_or_fh) ) {
863        $fh = $file_or_fh;
864    }
865    else {
866        $fh = do { local *FH };
867        open $fh, ">$file_or_fh" or
868            $self->croak("Can't open test output log $file_or_fh: $!");
869	_autoflush($fh);
870    }
871
872    return $fh;
873}
874
875
876sub _autoflush {
877    my($fh) = shift;
878    my $old_fh = select $fh;
879    $| = 1;
880    select $old_fh;
881}
882
883
884sub _dup_stdhandles {
885    my $self = shift;
886
887    $self->_open_testhandles;
888
889    # Set everything to unbuffered else plain prints to STDOUT will
890    # come out in the wrong order from our own prints.
891    _autoflush(\*TESTOUT);
892    _autoflush(\*STDOUT);
893    _autoflush(\*TESTERR);
894    _autoflush(\*STDERR);
895
896    $self->output(\*TESTOUT);
897    $self->failure_output(\*TESTERR);
898    $self->todo_output(\*TESTOUT);
899}
900
901
902my $Opened_Testhandles = 0;
903sub _open_testhandles {
904    return if $Opened_Testhandles;
905    # We dup STDOUT and STDERR so people can change them in their
906    # test suites while still getting normal test output.
907    open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT:  $!";
908    open(TESTERR, ">&STDERR") or die "Can't dup STDERR:  $!";
909    $Opened_Testhandles = 1;
910}
911
912
913#line 1396
914
915sub _message_at_caller {
916    my $self = shift;
917
918    local $Level = $Level + 1;
919    my($pack, $file, $line) = $self->caller;
920    return join("", @_) . " at $file line $line.\n";
921}
922
923sub carp {
924    my $self = shift;
925    warn $self->_message_at_caller(@_);
926}
927
928sub croak {
929    my $self = shift;
930    die $self->_message_at_caller(@_);
931}
932
933sub _plan_check {
934    my $self = shift;
935
936    unless( $self->{Have_Plan} ) {
937        local $Level = $Level + 2;
938        $self->croak("You tried to run a test without a plan");
939    }
940}
941
942#line 1444
943
944sub current_test {
945    my($self, $num) = @_;
946
947    lock($self->{Curr_Test});
948    if( defined $num ) {
949        unless( $self->{Have_Plan} ) {
950            $self->croak("Can't change the current test number without a plan!");
951        }
952
953        $self->{Curr_Test} = $num;
954
955        # If the test counter is being pushed forward fill in the details.
956        my $test_results = $self->{Test_Results};
957        if( $num > @$test_results ) {
958            my $start = @$test_results ? @$test_results : 0;
959            for ($start..$num-1) {
960                $test_results->[$_] = &share({
961                    'ok'      => 1,
962                    actual_ok => undef,
963                    reason    => 'incrementing test number',
964                    type      => 'unknown',
965                    name      => undef
966                });
967            }
968        }
969        # If backward, wipe history.  Its their funeral.
970        elsif( $num < @$test_results ) {
971            $#{$test_results} = $num - 1;
972        }
973    }
974    return $self->{Curr_Test};
975}
976
977
978#line 1489
979
980sub summary {
981    my($self) = shift;
982
983    return map { $_->{'ok'} } @{ $self->{Test_Results} };
984}
985
986#line 1544
987
988sub details {
989    my $self = shift;
990    return @{ $self->{Test_Results} };
991}
992
993#line 1569
994
995sub todo {
996    my($self, $pack) = @_;
997
998    $pack = $pack || $self->exported_to || $self->caller($Level);
999    return 0 unless $pack;
1000
1001    no strict 'refs';
1002    return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
1003                                     : 0;
1004}
1005
1006#line 1590
1007
1008sub caller {
1009    my($self, $height) = @_;
1010    $height ||= 0;
1011
1012    my @caller = CORE::caller($self->level + $height + 1);
1013    return wantarray ? @caller : $caller[0];
1014}
1015
1016#line 1602
1017
1018#line 1616
1019
1020#'#
1021sub _sanity_check {
1022    my $self = shift;
1023
1024    $self->_whoa($self->{Curr_Test} < 0,  'Says here you ran a negative number of tests!');
1025    $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
1026          'Somehow your tests ran without a plan!');
1027    $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
1028          'Somehow you got a different number of results than tests ran!');
1029}
1030
1031#line 1637
1032
1033sub _whoa {
1034    my($self, $check, $desc) = @_;
1035    if( $check ) {
1036        local $Level = $Level + 1;
1037        $self->croak(<<"WHOA");
1038WHOA!  $desc
1039This should never happen!  Please contact the author immediately!
1040WHOA
1041    }
1042}
1043
1044#line 1659
1045
1046sub _my_exit {
1047    $? = $_[0];
1048
1049    return 1;
1050}
1051
1052
1053#line 1672
1054
1055$SIG{__DIE__} = sub {
1056    # We don't want to muck with death in an eval, but $^S isn't
1057    # totally reliable.  5.005_03 and 5.6.1 both do the wrong thing
1058    # with it.  Instead, we use caller.  This also means it runs under
1059    # 5.004!
1060    my $in_eval = 0;
1061    for( my $stack = 1;  my $sub = (CORE::caller($stack))[3];  $stack++ ) {
1062        $in_eval = 1 if $sub =~ /^\(eval\)/;
1063    }
1064    $Test->{Test_Died} = 1 unless $in_eval;
1065};
1066
1067sub _ending {
1068    my $self = shift;
1069
1070    $self->_sanity_check();
1071
1072    # Don't bother with an ending if this is a forked copy.  Only the parent
1073    # should do the ending.
1074    # Exit if plan() was never called.  This is so "require Test::Simple"
1075    # doesn't puke.
1076    # Don't do an ending if we bailed out.
1077    if( ($self->{Original_Pid} != $$) 			or
1078	(!$self->{Have_Plan} && !$self->{Test_Died}) 	or
1079	$self->{Bailed_Out}
1080      )
1081    {
1082	_my_exit($?);
1083	return;
1084    }
1085
1086    # Figure out if we passed or failed and print helpful messages.
1087    my $test_results = $self->{Test_Results};
1088    if( @$test_results ) {
1089        # The plan?  We have no plan.
1090        if( $self->{No_Plan} ) {
1091            $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1092            $self->{Expected_Tests} = $self->{Curr_Test};
1093        }
1094
1095        # Auto-extended arrays and elements which aren't explicitly
1096        # filled in with a shared reference will puke under 5.8.0
1097        # ithreads.  So we have to fill them in by hand. :(
1098        my $empty_result = &share({});
1099        for my $idx ( 0..$self->{Expected_Tests}-1 ) {
1100            $test_results->[$idx] = $empty_result
1101              unless defined $test_results->[$idx];
1102        }
1103
1104        my $num_failed = grep !$_->{'ok'},
1105                              @{$test_results}[0..$self->{Curr_Test}-1];
1106
1107        my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1108
1109        if( $num_extra < 0 ) {
1110            my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1111            $self->diag(<<"FAIL");
1112Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
1113FAIL
1114        }
1115        elsif( $num_extra > 0 ) {
1116            my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1117            $self->diag(<<"FAIL");
1118Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
1119FAIL
1120        }
1121
1122        if ( $num_failed ) {
1123            my $num_tests = $self->{Curr_Test};
1124            my $s = $num_failed == 1 ? '' : 's';
1125
1126            my $qualifier = $num_extra == 0 ? '' : ' run';
1127
1128            $self->diag(<<"FAIL");
1129Looks like you failed $num_failed test$s of $num_tests$qualifier.
1130FAIL
1131        }
1132
1133        if( $self->{Test_Died} ) {
1134            $self->diag(<<"FAIL");
1135Looks like your test died just after $self->{Curr_Test}.
1136FAIL
1137
1138            _my_exit( 255 ) && return;
1139        }
1140
1141        my $exit_code;
1142        if( $num_failed ) {
1143            $exit_code = $num_failed <= 254 ? $num_failed : 254;
1144        }
1145        elsif( $num_extra != 0 ) {
1146            $exit_code = 255;
1147        }
1148        else {
1149            $exit_code = 0;
1150        }
1151
1152        _my_exit( $exit_code ) && return;
1153    }
1154    elsif ( $self->{Skip_All} ) {
1155        _my_exit( 0 ) && return;
1156    }
1157    elsif ( $self->{Test_Died} ) {
1158        $self->diag(<<'FAIL');
1159Looks like your test died before it could output anything.
1160FAIL
1161        _my_exit( 255 ) && return;
1162    }
1163    else {
1164        $self->diag("No tests run!\n");
1165        _my_exit( 255 ) && return;
1166    }
1167}
1168
1169END {
1170    $Test->_ending if defined $Test and !$Test->no_ending;
1171}
1172
1173#line 1847
1174
11751;
1176