root/Encode-DoubleEncodedUTF8/trunk/inc/Test/Builder.pm

Revision 2162 (checked in by miyagawa, 13 years ago)

import

Line 
1 #line 1
2 package Test::Builder;
3
4 use 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
10 use strict;
11 use vars qw($VERSION);
12 $VERSION = '0.34';
13 $VERSION = eval $VERSION;    # make the alpha version come out as a number
14
15 # Make Test::Builder thread-safe for ithreads.
16 BEGIN {
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
72 my $Test = Test::Builder->new;
73 sub new {
74     my($class) = shift;
75     $Test ||= $class->create;
76     return $Test;
77 }
78
79
80 #line 150
81
82 sub create {
83     my $class = shift;
84
85     my $self = bless {}, $class;
86     $self->reset;
87
88     return $self;
89 }
90
91 #line 169
92
93 use vars qw($Level);
94
95 sub 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
128 sub 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
139 sub 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
178 sub 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
197 sub no_plan {
198     my $self = shift;
199
200     $self->{No_Plan}   = 1;
201     $self->{Have_Plan} = 1;
202 }
203
204 #line 330
205
206 sub 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
217 sub 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 381
231
232 sub 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.
250 ERR
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
312 sub _unoverload {
313     my $self  = shift;
314     my $type  = shift;
315
316     local($@,$!);
317
318     eval { require overload } || return;
319
320     foreach my $thing (@_) {
321         eval {
322             if( _is_object($$thing) ) {
323                 if( my $string_meth = overload::Method($$thing, $type) ) {
324                     $$thing = $$thing->$string_meth();
325                 }
326             }
327         };
328     }
329 }
330
331
332 sub _is_object {
333     my $thing = shift;
334
335     return eval { ref $thing && $thing->isa('UNIVERSAL') } ? 1 : 0;
336 }
337
338
339 sub _unoverload_str {
340     my $self = shift;
341
342     $self->_unoverload(q[""], @_);
343 }   
344
345 sub _unoverload_num {
346     my $self = shift;
347
348     $self->_unoverload('0+', @_);
349
350     for my $val (@_) {
351         next unless $self->_is_dualvar($$val);
352         $$val = $$val+0;
353     }
354 }
355
356
357 # This is a hack to detect a dualvar such as $!
358 sub _is_dualvar {
359     my($self, $val) = @_;
360
361     local $^W = 0;
362     my $numval = $val+0;
363     return 1 if $numval != 0 and $numval ne $val;
364 }
365
366
367
368 #line 533
369
370 sub is_eq {
371     my($self, $got, $expect, $name) = @_;
372     local $Level = $Level + 1;
373
374     $self->_unoverload_str(\$got, \$expect);
375
376     if( !defined $got || !defined $expect ) {
377         # undef only matches undef and nothing else
378         my $test = !defined $got && !defined $expect;
379
380         $self->ok($test, $name);
381         $self->_is_diag($got, 'eq', $expect) unless $test;
382         return $test;
383     }
384
385     return $self->cmp_ok($got, 'eq', $expect, $name);
386 }
387
388 sub is_num {
389     my($self, $got, $expect, $name) = @_;
390     local $Level = $Level + 1;
391
392     $self->_unoverload_num(\$got, \$expect);
393
394     if( !defined $got || !defined $expect ) {
395         # undef only matches undef and nothing else
396         my $test = !defined $got && !defined $expect;
397
398         $self->ok($test, $name);
399         $self->_is_diag($got, '==', $expect) unless $test;
400         return $test;
401     }
402
403     return $self->cmp_ok($got, '==', $expect, $name);
404 }
405
406 sub _is_diag {
407     my($self, $got, $type, $expect) = @_;
408
409     foreach my $val (\$got, \$expect) {
410         if( defined $$val ) {
411             if( $type eq 'eq' ) {
412                 # quote and force string context
413                 $$val = "'$$val'"
414             }
415             else {
416                 # force numeric context
417                 $self->_unoverload_num($val);
418             }
419         }
420         else {
421             $$val = 'undef';
422         }
423     }
424
425     return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect);
426          got: %s
427     expected: %s
428 DIAGNOSTIC
429
430 }   
431
432 #line 611
433
434 sub isnt_eq {
435     my($self, $got, $dont_expect, $name) = @_;
436     local $Level = $Level + 1;
437
438     if( !defined $got || !defined $dont_expect ) {
439         # undef only matches undef and nothing else
440         my $test = defined $got || defined $dont_expect;
441
442         $self->ok($test, $name);
443         $self->_cmp_diag($got, 'ne', $dont_expect) unless $test;
444         return $test;
445     }
446
447     return $self->cmp_ok($got, 'ne', $dont_expect, $name);
448 }
449
450 sub isnt_num {
451     my($self, $got, $dont_expect, $name) = @_;
452     local $Level = $Level + 1;
453
454     if( !defined $got || !defined $dont_expect ) {
455         # undef only matches undef and nothing else
456         my $test = defined $got || defined $dont_expect;
457
458         $self->ok($test, $name);
459         $self->_cmp_diag($got, '!=', $dont_expect) unless $test;
460         return $test;
461     }
462
463     return $self->cmp_ok($got, '!=', $dont_expect, $name);
464 }
465
466
467 #line 663
468
469 sub like {
470     my($self, $this, $regex, $name) = @_;
471
472     local $Level = $Level + 1;
473     $self->_regex_ok($this, $regex, '=~', $name);
474 }
475
476 sub unlike {
477     my($self, $this, $regex, $name) = @_;
478
479     local $Level = $Level + 1;
480     $self->_regex_ok($this, $regex, '!~', $name);
481 }
482
483 #line 704
484
485
486 sub maybe_regex {
487     my ($self, $regex) = @_;
488     my $usable_regex = undef;
489
490     return $usable_regex unless defined $regex;
491
492     my($re, $opts);
493
494     # Check for qr/foo/
495     if( ref $regex eq 'Regexp' ) {
496         $usable_regex = $regex;
497     }
498     # Check for '/foo/' or 'm,foo,'
499     elsif( ($re, $opts)        = $regex =~ m{^ /(.*)/ (\w*) $ }sx           or
500            (undef, $re, $opts) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
501          )
502     {
503         $usable_regex = length $opts ? "(?$opts)$re" : $re;
504     }
505
506     return $usable_regex;
507 };
508
509 sub _regex_ok {
510     my($self, $this, $regex, $cmp, $name) = @_;
511
512     my $ok = 0;
513     my $usable_regex = $self->maybe_regex($regex);
514     unless (defined $usable_regex) {
515         $ok = $self->ok( 0, $name );
516         $self->diag("    '$regex' doesn't look much like a regex to me.");
517         return $ok;
518     }
519
520     {
521         my $test;
522         my $code = $self->_caller_context;
523
524         local($@, $!);
525
526         # Yes, it has to look like this or 5.4.5 won't see the #line directive.
527         # Don't ask me, man, I just work here.
528         $test = eval "
529 $code" . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
530
531         $test = !$test if $cmp eq '!~';
532
533         local $Level = $Level + 1;
534         $ok = $self->ok( $test, $name );
535     }
536
537     unless( $ok ) {
538         $this = defined $this ? "'$this'" : 'undef';
539         my $match = $cmp eq '=~' ? "doesn't match" : "matches";
540         $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex);
541                   %s
542     %13s '%s'
543 DIAGNOSTIC
544
545     }
546
547     return $ok;
548 }
549
550 #line 779
551
552
553 my %numeric_cmps = map { ($_, 1) }
554                        ("<",  "<=", ">",  ">=", "==", "!=", "<=>");
555
556 sub cmp_ok {
557     my($self, $got, $type, $expect, $name) = @_;
558
559     # Treat overloaded objects as numbers if we're asked to do a
560     # numeric comparison.
561     my $unoverload = $numeric_cmps{$type} ? '_unoverload_num'
562                                           : '_unoverload_str';
563
564     $self->$unoverload(\$got, \$expect);
565
566
567     my $test;
568     {
569         local($@,$!);   # don't interfere with $@
570                         # eval() sometimes resets $!
571
572         my $code = $self->_caller_context;
573
574         # Yes, it has to look like this or 5.4.5 won't see the #line directive.
575         # Don't ask me, man, I just work here.
576         $test = eval "
577 $code" . "\$got $type \$expect;";
578
579     }
580     local $Level = $Level + 1;
581     my $ok = $self->ok($test, $name);
582
583     unless( $ok ) {
584         if( $type =~ /^(eq|==)$/ ) {
585             $self->_is_diag($got, $type, $expect);
586         }
587         else {
588             $self->_cmp_diag($got, $type, $expect);
589         }
590     }
591     return $ok;
592 }
593
594 sub _cmp_diag {
595     my($self, $got, $type, $expect) = @_;
596    
597     $got    = defined $got    ? "'$got'"    : 'undef';
598     $expect = defined $expect ? "'$expect'" : 'undef';
599     return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect);
600     %s
601         %s
602     %s
603 DIAGNOSTIC
604 }
605
606
607 sub _caller_context {
608     my $self = shift;
609
610     my($pack, $file, $line) = $self->caller(1);
611
612     my $code = '';
613     $code .= "#line $line $file\n" if defined $file and defined $line;
614
615     return $code;
616 }
617
618
619 #line 858
620
621 sub BAIL_OUT {
622     my($self, $reason) = @_;
623
624     $self->{Bailed_Out} = 1;
625     $self->_print("Bail out!  $reason");
626     exit 255;
627 }
628
629 #line 871
630
631 *BAILOUT = \&BAIL_OUT;
632
633
634 #line 883
635
636 sub skip {
637     my($self, $why) = @_;
638     $why ||= '';
639     $self->_unoverload_str(\$why);
640
641     $self->_plan_check;
642
643     lock($self->{Curr_Test});
644     $self->{Curr_Test}++;
645
646     $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
647         'ok'      => 1,
648         actual_ok => 1,
649         name      => '',
650         type      => 'skip',
651         reason    => $why,
652     });
653
654     my $out = "ok";
655     $out   .= " $self->{Curr_Test}" if $self->use_numbers;
656     $out   .= " # skip";
657     $out   .= " $why"       if length $why;
658     $out   .= "\n";
659
660     $self->_print($out);
661
662     return 1;
663 }
664
665
666 #line 925
667
668 sub todo_skip {
669     my($self, $why) = @_;
670     $why ||= '';
671
672     $self->_plan_check;
673
674     lock($self->{Curr_Test});
675     $self->{Curr_Test}++;
676
677     $self->{Test_Results}[$self->{Curr_Test}-1] = &share({
678         'ok'      => 1,
679         actual_ok => 0,
680         name      => '',
681         type      => 'todo_skip',
682         reason    => $why,
683     });
684
685     my $out = "not ok";
686     $out   .= " $self->{Curr_Test}" if $self->use_numbers;
687     $out   .= " # TODO & SKIP $why\n";
688
689     $self->_print($out);
690
691     return 1;
692 }
693
694
695 #line 993
696
697 sub level {
698     my($self, $level) = @_;
699
700     if( defined $level ) {
701         $Level = $level;
702     }
703     return $Level;
704 }
705
706
707 #line 1026
708
709 sub use_numbers {
710     my($self, $use_nums) = @_;
711
712     if( defined $use_nums ) {
713         $self->{Use_Nums} = $use_nums;
714     }
715     return $self->{Use_Nums};
716 }
717
718
719 #line 1060
720
721 foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
722     my $method = lc $attribute;
723
724     my $code = sub {
725         my($self, $no) = @_;
726
727         if( defined $no ) {
728             $self->{$attribute} = $no;
729         }
730         return $self->{$attribute};
731     };
732
733     no strict 'refs';
734     *{__PACKAGE__.'::'.$method} = $code;
735 }
736
737
738 #line 1114
739
740 sub diag {
741     my($self, @msgs) = @_;
742
743     return if $self->no_diag;
744     return unless @msgs;
745
746     # Prevent printing headers when compiling (i.e. -c)
747     return if $^C;
748
749     # Smash args together like print does.
750     # Convert undef to 'undef' so its readable.
751     my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
752
753     # Escape each line with a #.
754     $msg =~ s/^/# /gm;
755
756     # Stick a newline on the end if it needs it.
757     $msg .= "\n" unless $msg =~ /\n\Z/;
758
759     local $Level = $Level + 1;
760     $self->_print_diag($msg);
761
762     return 0;
763 }
764
765 #line 1151
766
767 sub _print {
768     my($self, @msgs) = @_;
769
770     # Prevent printing headers when only compiling.  Mostly for when
771     # tests are deparsed with B::Deparse
772     return if $^C;
773
774     my $msg = join '', @msgs;
775
776     local($\, $", $,) = (undef, ' ', '');
777     my $fh = $self->output;
778
779     # Escape each line after the first with a # so we don't
780     # confuse Test::Harness.
781     $msg =~ s/\n(.)/\n# $1/sg;
782
783     # Stick a newline on the end if it needs it.
784     $msg .= "\n" unless $msg =~ /\n\Z/;
785
786     print $fh $msg;
787 }
788
789 #line 1185
790
791 sub _print_diag {
792     my $self = shift;
793
794     local($\, $", $,) = (undef, ' ', '');
795     my $fh = $self->todo ? $self->todo_output : $self->failure_output;
796     print $fh @_;
797 }   
798
799 #line 1222
800
801 sub output {
802     my($self, $fh) = @_;
803
804     if( defined $fh ) {
805         $self->{Out_FH} = $self->_new_fh($fh);
806     }
807     return $self->{Out_FH};
808 }
809
810 sub failure_output {
811     my($self, $fh) = @_;
812
813     if( defined $fh ) {
814         $self->{Fail_FH} = $self->_new_fh($fh);
815     }
816     return $self->{Fail_FH};
817 }
818
819 sub todo_output {
820     my($self, $fh) = @_;
821
822     if( defined $fh ) {
823         $self->{Todo_FH} = $self->_new_fh($fh);
824     }
825     return $self->{Todo_FH};
826 }
827
828
829 sub _new_fh {
830     my $self = shift;
831     my($file_or_fh) = shift;
832
833     my $fh;
834     if( $self->_is_fh($file_or_fh) ) {
835         $fh = $file_or_fh;
836     }
837     else {
838         $fh = do { local *FH };
839         open $fh, ">$file_or_fh" or
840             $self->croak("Can't open test output log $file_or_fh: $!");
841         _autoflush($fh);
842     }
843
844     return $fh;
845 }
846
847
848 sub _is_fh {
849     my $self = shift;
850     my $maybe_fh = shift;
851     return 0 unless defined $maybe_fh;
852
853     return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
854
855     return UNIVERSAL::isa($maybe_fh,               'GLOB')       ||
856            UNIVERSAL::isa($maybe_fh,               'IO::Handle') ||
857
858            # 5.5.4's tied() and can() doesn't like getting undef
859            UNIVERSAL::can((tied($maybe_fh) || ''), 'TIEHANDLE');
860 }
861
862
863 sub _autoflush {
864     my($fh) = shift;
865     my $old_fh = select $fh;
866     $| = 1;
867     select $old_fh;
868 }
869
870
871 sub _dup_stdhandles {
872     my $self = shift;
873
874     $self->_open_testhandles;
875
876     # Set everything to unbuffered else plain prints to STDOUT will
877     # come out in the wrong order from our own prints.
878     _autoflush(\*TESTOUT);
879     _autoflush(\*STDOUT);
880     _autoflush(\*TESTERR);
881     _autoflush(\*STDERR);
882
883     $self->output(\*TESTOUT);
884     $self->failure_output(\*TESTERR);
885     $self->todo_output(\*TESTOUT);
886 }
887
888
889 my $Opened_Testhandles = 0;
890 sub _open_testhandles {
891     return if $Opened_Testhandles;
892     # We dup STDOUT and STDERR so people can change them in their
893     # test suites while still getting normal test output.
894     open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT:  $!";
895     open(TESTERR, ">&STDERR") or die "Can't dup STDERR:  $!";
896     $Opened_Testhandles = 1;
897 }
898
899
900 #line 1337
901
902 sub _message_at_caller {
903     my $self = shift;
904
905     local $Level = $Level + 1;
906     my($pack, $file, $line) = $self->caller;
907     return join("", @_) . " at $file line $line.\n";
908 }
909
910 sub carp {
911     my $self = shift;
912     warn $self->_message_at_caller(@_);
913 }
914
915 sub croak {
916     my $self = shift;
917     die $self->_message_at_caller(@_);
918 }
919
920 sub _plan_check {
921     my $self = shift;
922
923     unless( $self->{Have_Plan} ) {
924         local $Level = $Level + 2;
925         $self->croak("You tried to run a test without a plan");
926     }
927 }
928
929 #line 1385
930
931 sub current_test {
932     my($self, $num) = @_;
933
934     lock($self->{Curr_Test});
935     if( defined $num ) {
936         unless( $self->{Have_Plan} ) {
937             $self->croak("Can't change the current test number without a plan!");
938         }
939
940         $self->{Curr_Test} = $num;
941
942         # If the test counter is being pushed forward fill in the details.
943         my $test_results = $self->{Test_Results};
944         if( $num > @$test_results ) {
945             my $start = @$test_results ? @$test_results : 0;
946             for ($start..$num-1) {
947                 $test_results->[$_] = &share({
948                     'ok'      => 1,
949                     actual_ok => undef,
950                     reason    => 'incrementing test number',
951                     type      => 'unknown',
952                     name      => undef
953                 });
954             }
955         }
956         # If backward, wipe history.  Its their funeral.
957         elsif( $num < @$test_results ) {
958             $#{$test_results} = $num - 1;
959         }
960     }
961     return $self->{Curr_Test};
962 }
963
964
965 #line 1430
966
967 sub summary {
968     my($self) = shift;
969
970     return map { $_->{'ok'} } @{ $self->{Test_Results} };
971 }
972
973 #line 1485
974
975 sub details {
976     my $self = shift;
977     return @{ $self->{Test_Results} };
978 }
979
980 #line 1510
981
982 sub todo {
983     my($self, $pack) = @_;
984
985     $pack = $pack || $self->exported_to || $self->caller($Level);
986     return 0 unless $pack;
987
988     no strict 'refs';
989     return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'}
990                                      : 0;
991 }
992
993 #line 1531
994
995 sub caller {
996     my($self, $height) = @_;
997     $height ||= 0;
998
999     my @caller = CORE::caller($self->level + $height + 1);
1000     return wantarray ? @caller : $caller[0];
1001 }
1002
1003 #line 1543
1004
1005 #line 1557
1006
1007 #'#
1008 sub _sanity_check {
1009     my $self = shift;
1010
1011     $self->_whoa($self->{Curr_Test} < 0,  'Says here you ran a negative number of tests!');
1012     $self->_whoa(!$self->{Have_Plan} and $self->{Curr_Test},
1013           'Somehow your tests ran without a plan!');
1014     $self->_whoa($self->{Curr_Test} != @{ $self->{Test_Results} },
1015           'Somehow you got a different number of results than tests ran!');
1016 }
1017
1018 #line 1578
1019
1020 sub _whoa {
1021     my($self, $check, $desc) = @_;
1022     if( $check ) {
1023         local $Level = $Level + 1;
1024         $self->croak(<<"WHOA");
1025 WHOA!  $desc
1026 This should never happen!  Please contact the author immediately!
1027 WHOA
1028     }
1029 }
1030
1031 #line 1600
1032
1033 sub _my_exit {
1034     $? = $_[0];
1035
1036     return 1;
1037 }
1038
1039
1040 #line 1613
1041
1042 $SIG{__DIE__} = sub {
1043     # We don't want to muck with death in an eval, but $^S isn't
1044     # totally reliable.  5.005_03 and 5.6.1 both do the wrong thing
1045     # with it.  Instead, we use caller.  This also means it runs under
1046     # 5.004!
1047     my $in_eval = 0;
1048     for( my $stack = 1;  my $sub = (CORE::caller($stack))[3];  $stack++ ) {
1049         $in_eval = 1 if $sub =~ /^\(eval\)/;
1050     }
1051     $Test->{Test_Died} = 1 unless $in_eval;
1052 };
1053
1054 sub _ending {
1055     my $self = shift;
1056
1057     $self->_sanity_check();
1058
1059     # Don't bother with an ending if this is a forked copy.  Only the parent
1060     # should do the ending.
1061     # Exit if plan() was never called.  This is so "require Test::Simple"
1062     # doesn't puke.
1063     # Don't do an ending if we bailed out.
1064     if( ($self->{Original_Pid} != $$)                   or
1065         (!$self->{Have_Plan} && !$self->{Test_Died})    or
1066         $self->{Bailed_Out}
1067       )
1068     {
1069         _my_exit($?);
1070         return;
1071     }
1072
1073     # Figure out if we passed or failed and print helpful messages.
1074     my $test_results = $self->{Test_Results};
1075     if( @$test_results ) {
1076         # The plan?  We have no plan.
1077         if( $self->{No_Plan} ) {
1078             $self->_print("1..$self->{Curr_Test}\n") unless $self->no_header;
1079             $self->{Expected_Tests} = $self->{Curr_Test};
1080         }
1081
1082         # Auto-extended arrays and elements which aren't explicitly
1083         # filled in with a shared reference will puke under 5.8.0
1084         # ithreads.  So we have to fill them in by hand. :(
1085         my $empty_result = &share({});
1086         for my $idx ( 0..$self->{Expected_Tests}-1 ) {
1087             $test_results->[$idx] = $empty_result
1088               unless defined $test_results->[$idx];
1089         }
1090
1091         my $num_failed = grep !$_->{'ok'},
1092                               @{$test_results}[0..$self->{Curr_Test}-1];
1093
1094         my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
1095
1096         if( $num_extra < 0 ) {
1097             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1098             $self->diag(<<"FAIL");
1099 Looks like you planned $self->{Expected_Tests} test$s but only ran $self->{Curr_Test}.
1100 FAIL
1101         }
1102         elsif( $num_extra > 0 ) {
1103             my $s = $self->{Expected_Tests} == 1 ? '' : 's';
1104             $self->diag(<<"FAIL");
1105 Looks like you planned $self->{Expected_Tests} test$s but ran $num_extra extra.
1106 FAIL
1107         }
1108
1109         if ( $num_failed ) {
1110             my $num_tests = $self->{Curr_Test};
1111             my $s = $num_failed == 1 ? '' : 's';
1112
1113             my $qualifier = $num_extra == 0 ? '' : ' run';
1114
1115             $self->diag(<<"FAIL");
1116 Looks like you failed $num_failed test$s of $num_tests$qualifier.
1117 FAIL
1118         }
1119
1120         if( $self->{Test_Died} ) {
1121             $self->diag(<<"FAIL");
1122 Looks like your test died just after $self->{Curr_Test}.
1123 FAIL
1124
1125             _my_exit( 255 ) && return;
1126         }
1127
1128         my $exit_code;
1129         if( $num_failed ) {
1130             $exit_code = $num_failed <= 254 ? $num_failed : 254;
1131         }
1132         elsif( $num_extra != 0 ) {
1133             $exit_code = 255;
1134         }
1135         else {
1136             $exit_code = 0;
1137         }
1138
1139         _my_exit( $exit_code ) && return;
1140     }
1141     elsif ( $self->{Skip_All} ) {
1142         _my_exit( 0 ) && return;
1143     }
1144     elsif ( $self->{Test_Died} ) {
1145         $self->diag(<<'FAIL');
1146 Looks like your test died before it could output anything.
1147 FAIL
1148         _my_exit( 255 ) && return;
1149     }
1150     else {
1151         $self->diag("No tests run!\n");
1152         _my_exit( 255 ) && return;
1153     }
1154 }
1155
1156 END {
1157     $Test->_ending if defined $Test and !$Test->no_ending;
1158 }
1159
1160 #line 1788
1161
1162 1;
Note: See TracBrowser for help on using the browser.