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

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

import

Line 
1 #line 1
2 package Test::More;
3
4 use 5.004;
5
6 use strict;
7
8
9 # Can't use Carp because it might cause use_ok() to accidentally succeed
10 # even though the module being used forgot to use Carp.  Yes, this
11 # actually happened.
12 sub _carp {
13     my($file, $line) = (caller(1))[1,2];
14     warn @_, " at $file line $line\n";
15 }
16
17
18
19 use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
20 $VERSION = '0.65';
21 $VERSION = eval $VERSION;    # make the alpha version come out as a number
22
23 use Test::Builder::Module;
24 @ISA    = qw(Test::Builder::Module);
25 @EXPORT = qw(ok use_ok require_ok
26              is isnt like unlike is_deeply
27              cmp_ok
28              skip todo todo_skip
29              pass fail
30              eq_array eq_hash eq_set
31              $TODO
32              plan
33              can_ok  isa_ok
34              diag
35              BAIL_OUT
36             );
37
38
39 #line 157
40
41 sub plan {
42     my $tb = Test::More->builder;
43
44     $tb->plan(@_);
45 }
46
47
48 # This implements "use Test::More 'no_diag'" but the behavior is
49 # deprecated.
50 sub import_extra {
51     my $class = shift;
52     my $list  = shift;
53
54     my @other = ();
55     my $idx = 0;
56     while( $idx <= $#{$list} ) {
57         my $item = $list->[$idx];
58
59         if( defined $item and $item eq 'no_diag' ) {
60             $class->builder->no_diag(1);
61         }
62         else {
63             push @other, $item;
64         }
65
66         $idx++;
67     }
68
69     @$list = @other;
70 }
71
72
73 #line 257
74
75 sub ok ($;$) {
76     my($test, $name) = @_;
77     my $tb = Test::More->builder;
78
79     $tb->ok($test, $name);
80 }
81
82 #line 324
83
84 sub is ($$;$) {
85     my $tb = Test::More->builder;
86
87     $tb->is_eq(@_);
88 }
89
90 sub isnt ($$;$) {
91     my $tb = Test::More->builder;
92
93     $tb->isnt_eq(@_);
94 }
95
96 *isn't = \&isnt;
97
98
99 #line 369
100
101 sub like ($$;$) {
102     my $tb = Test::More->builder;
103
104     $tb->like(@_);
105 }
106
107
108 #line 385
109
110 sub unlike ($$;$) {
111     my $tb = Test::More->builder;
112
113     $tb->unlike(@_);
114 }
115
116
117 #line 425
118
119 sub cmp_ok($$$;$) {
120     my $tb = Test::More->builder;
121
122     $tb->cmp_ok(@_);
123 }
124
125
126 #line 461
127
128 sub can_ok ($@) {
129     my($proto, @methods) = @_;
130     my $class = ref $proto || $proto;
131     my $tb = Test::More->builder;
132
133     unless( $class ) {
134         my $ok = $tb->ok( 0, "->can(...)" );
135         $tb->diag('    can_ok() called with empty class or reference');
136         return $ok;
137     }
138
139     unless( @methods ) {
140         my $ok = $tb->ok( 0, "$class->can(...)" );
141         $tb->diag('    can_ok() called with no methods');
142         return $ok;
143     }
144
145     my @nok = ();
146     foreach my $method (@methods) {
147         local($!, $@);  # don't interfere with caller's $@
148                         # eval sometimes resets $!
149         eval { $proto->can($method) } || push @nok, $method;
150     }
151
152     my $name;
153     $name = @methods == 1 ? "$class->can('$methods[0]')"
154                           : "$class->can(...)";
155
156     my $ok = $tb->ok( !@nok, $name );
157
158     $tb->diag(map "    $class->can('$_') failed\n", @nok);
159
160     return $ok;
161 }
162
163 #line 525
164
165 sub isa_ok ($$;$) {
166     my($object, $class, $obj_name) = @_;
167     my $tb = Test::More->builder;
168
169     my $diag;
170     $obj_name = 'The object' unless defined $obj_name;
171     my $name = "$obj_name isa $class";
172     if( !defined $object ) {
173         $diag = "$obj_name isn't defined";
174     }
175     elsif( !ref $object ) {
176         $diag = "$obj_name isn't a reference";
177     }
178     else {
179         # We can't use UNIVERSAL::isa because we want to honor isa() overrides
180         local($@, $!);  # eval sometimes resets $!
181         my $rslt = eval { $object->isa($class) };
182         if( $@ ) {
183             if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
184                 if( !UNIVERSAL::isa($object, $class) ) {
185                     my $ref = ref $object;
186                     $diag = "$obj_name isn't a '$class' it's a '$ref'";
187                 }
188             } else {
189                 die <<WHOA;
190 WHOA! I tried to call ->isa on your object and got some weird error.
191 This should never happen.  Please contact the author immediately.
192 Here's the error.
193 $@
194 WHOA
195             }
196         }
197         elsif( !$rslt ) {
198             my $ref = ref $object;
199             $diag = "$obj_name isn't a '$class' it's a '$ref'";
200         }
201     }
202            
203      
204
205     my $ok;
206     if( $diag ) {
207         $ok = $tb->ok( 0, $name );
208         $tb->diag("    $diag\n");
209     }
210     else {
211         $ok = $tb->ok( 1, $name );
212     }
213
214     return $ok;
215 }
216
217
218 #line 595
219
220 sub pass (;$) {
221     my $tb = Test::More->builder;
222     $tb->ok(1, @_);
223 }
224
225 sub fail (;$) {
226     my $tb = Test::More->builder;
227     $tb->ok(0, @_);
228 }
229
230 #line 656
231
232 sub use_ok ($;@) {
233     my($module, @imports) = @_;
234     @imports = () unless @imports;
235     my $tb = Test::More->builder;
236
237     my($pack,$filename,$line) = caller;
238
239     local($@,$!);   # eval sometimes interferes with $!
240
241     if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
242         # probably a version check.  Perl needs to see the bare number
243         # for it to work with non-Exporter based modules.
244         eval <<USE;
245 package $pack;
246 use $module $imports[0];
247 USE
248     }
249     else {
250         eval <<USE;
251 package $pack;
252 use $module \@imports;
253 USE
254     }
255
256     my $ok = $tb->ok( !$@, "use $module;" );
257
258     unless( $ok ) {
259         chomp $@;
260         $@ =~ s{^BEGIN failed--compilation aborted at .*$}
261                 {BEGIN failed--compilation aborted at $filename line $line.}m;
262         $tb->diag(<<DIAGNOSTIC);
263     Tried to use '$module'.
264     Error:  $@
265 DIAGNOSTIC
266
267     }
268
269     return $ok;
270 }
271
272 #line 705
273
274 sub require_ok ($) {
275     my($module) = shift;
276     my $tb = Test::More->builder;
277
278     my $pack = caller;
279
280     # Try to deterine if we've been given a module name or file.
281     # Module names must be barewords, files not.
282     $module = qq['$module'] unless _is_module_name($module);
283
284     local($!, $@); # eval sometimes interferes with $!
285     eval <<REQUIRE;
286 package $pack;
287 require $module;
288 REQUIRE
289
290     my $ok = $tb->ok( !$@, "require $module;" );
291
292     unless( $ok ) {
293         chomp $@;
294         $tb->diag(<<DIAGNOSTIC);
295     Tried to require '$module'.
296     Error:  $@
297 DIAGNOSTIC
298
299     }
300
301     return $ok;
302 }
303
304
305 sub _is_module_name {
306     my $module = shift;
307
308     # Module names start with a letter.
309     # End with an alphanumeric.
310     # The rest is an alphanumeric or ::
311     $module =~ s/\b::\b//g;
312     $module =~ /^[a-zA-Z]\w*$/;
313 }
314
315 #line 781
316
317 use vars qw(@Data_Stack %Refs_Seen);
318 my $DNE = bless [], 'Does::Not::Exist';
319 sub is_deeply {
320     my $tb = Test::More->builder;
321
322     unless( @_ == 2 or @_ == 3 ) {
323         my $msg = <<WARNING;
324 is_deeply() takes two or three args, you gave %d.
325 This usually means you passed an array or hash instead
326 of a reference to it
327 WARNING
328         chop $msg;   # clip off newline so carp() will put in line/file
329
330         _carp sprintf $msg, scalar @_;
331
332         return $tb->ok(0);
333     }
334
335     my($got, $expected, $name) = @_;
336
337     $tb->_unoverload_str(\$expected, \$got);
338
339     my $ok;
340     if( !ref $got and !ref $expected ) {                # neither is a reference
341         $ok = $tb->is_eq($got, $expected, $name);
342     }
343     elsif( !ref $got xor !ref $expected ) {     # one's a reference, one isn't
344         $ok = $tb->ok(0, $name);
345         $tb->diag( _format_stack({ vals => [ $got, $expected ] }) );
346     }
347     else {                                      # both references
348         local @Data_Stack = ();
349         if( _deep_check($got, $expected) ) {
350             $ok = $tb->ok(1, $name);
351         }
352         else {
353             $ok = $tb->ok(0, $name);
354             $tb->diag(_format_stack(@Data_Stack));
355         }
356     }
357
358     return $ok;
359 }
360
361 sub _format_stack {
362     my(@Stack) = @_;
363
364     my $var = '$FOO';
365     my $did_arrow = 0;
366     foreach my $entry (@Stack) {
367         my $type = $entry->{type} || '';
368         my $idx  = $entry->{'idx'};
369         if( $type eq 'HASH' ) {
370             $var .= "->" unless $did_arrow++;
371             $var .= "{$idx}";
372         }
373         elsif( $type eq 'ARRAY' ) {
374             $var .= "->" unless $did_arrow++;
375             $var .= "[$idx]";
376         }
377         elsif( $type eq 'REF' ) {
378             $var = "\${$var}";
379         }
380     }
381
382     my @vals = @{$Stack[-1]{vals}}[0,1];
383     my @vars = ();
384     ($vars[0] = $var) =~ s/\$FOO/     \$got/;
385     ($vars[1] = $var) =~ s/\$FOO/\$expected/;
386
387     my $out = "Structures begin differing at:\n";
388     foreach my $idx (0..$#vals) {
389         my $val = $vals[$idx];
390         $vals[$idx] = !defined $val ? 'undef'          :
391                       $val eq $DNE  ? "Does not exist" :
392                       ref $val      ? "$val"           :
393                                       "'$val'";
394     }
395
396     $out .= "$vars[0] = $vals[0]\n";
397     $out .= "$vars[1] = $vals[1]\n";
398
399     $out =~ s/^/    /msg;
400     return $out;
401 }
402
403
404 sub _type {
405     my $thing = shift;
406
407     return '' if !ref $thing;
408
409     for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
410         return $type if UNIVERSAL::isa($thing, $type);
411     }
412
413     return '';
414 }
415
416 #line 921
417
418 sub diag {
419     my $tb = Test::More->builder;
420
421     $tb->diag(@_);
422 }
423
424
425 #line 990
426
427 #'#
428 sub skip {
429     my($why, $how_many) = @_;
430     my $tb = Test::More->builder;
431
432     unless( defined $how_many ) {
433         # $how_many can only be avoided when no_plan is in use.
434         _carp "skip() needs to know \$how_many tests are in the block"
435           unless $tb->has_plan eq 'no_plan';
436         $how_many = 1;
437     }
438
439     if( defined $how_many and $how_many =~ /\D/ ) {
440         _carp "skip() was passed a non-numeric number of tests.  Did you get the arguments backwards?";
441         $how_many = 1;
442     }
443
444     for( 1..$how_many ) {
445         $tb->skip($why);
446     }
447
448     local $^W = 0;
449     last SKIP;
450 }
451
452
453 #line 1077
454
455 sub todo_skip {
456     my($why, $how_many) = @_;
457     my $tb = Test::More->builder;
458
459     unless( defined $how_many ) {
460         # $how_many can only be avoided when no_plan is in use.
461         _carp "todo_skip() needs to know \$how_many tests are in the block"
462           unless $tb->has_plan eq 'no_plan';
463         $how_many = 1;
464     }
465
466     for( 1..$how_many ) {
467         $tb->todo_skip($why);
468     }
469
470     local $^W = 0;
471     last TODO;
472 }
473
474 #line 1130
475
476 sub BAIL_OUT {
477     my $reason = shift;
478     my $tb = Test::More->builder;
479
480     $tb->BAIL_OUT($reason);
481 }
482
483 #line 1169
484
485 #'#
486 sub eq_array {
487     local @Data_Stack;
488     _deep_check(@_);
489 }
490
491 sub _eq_array  {
492     my($a1, $a2) = @_;
493
494     if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
495         warn "eq_array passed a non-array ref";
496         return 0;
497     }
498
499     return 1 if $a1 eq $a2;
500
501     my $ok = 1;
502     my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
503     for (0..$max) {
504         my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
505         my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
506
507         push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
508         $ok = _deep_check($e1,$e2);
509         pop @Data_Stack if $ok;
510
511         last unless $ok;
512     }
513
514     return $ok;
515 }
516
517 sub _deep_check {
518     my($e1, $e2) = @_;
519     my $tb = Test::More->builder;
520
521     my $ok = 0;
522
523     # Effectively turn %Refs_Seen into a stack.  This avoids picking up
524     # the same referenced used twice (such as [\$a, \$a]) to be considered
525     # circular.
526     local %Refs_Seen = %Refs_Seen;
527
528     {
529         # Quiet uninitialized value warnings when comparing undefs.
530         local $^W = 0;
531
532         $tb->_unoverload_str(\$e1, \$e2);
533
534         # Either they're both references or both not.
535         my $same_ref = !(!ref $e1 xor !ref $e2);
536         my $not_ref  = (!ref $e1 and !ref $e2);
537
538         if( defined $e1 xor defined $e2 ) {
539             $ok = 0;
540         }
541         elsif ( $e1 == $DNE xor $e2 == $DNE ) {
542             $ok = 0;
543         }
544         elsif ( $same_ref and ($e1 eq $e2) ) {
545             $ok = 1;
546         }
547         elsif ( $not_ref ) {
548             push @Data_Stack, { type => '', vals => [$e1, $e2] };
549             $ok = 0;
550         }
551         else {
552             if( $Refs_Seen{$e1} ) {
553                 return $Refs_Seen{$e1} eq $e2;
554             }
555             else {
556                 $Refs_Seen{$e1} = "$e2";
557             }
558
559             my $type = _type($e1);
560             $type = 'DIFFERENT' unless _type($e2) eq $type;
561
562             if( $type eq 'DIFFERENT' ) {
563                 push @Data_Stack, { type => $type, vals => [$e1, $e2] };
564                 $ok = 0;
565             }
566             elsif( $type eq 'ARRAY' ) {
567                 $ok = _eq_array($e1, $e2);
568             }
569             elsif( $type eq 'HASH' ) {
570                 $ok = _eq_hash($e1, $e2);
571             }
572             elsif( $type eq 'REF' ) {
573                 push @Data_Stack, { type => $type, vals => [$e1, $e2] };
574                 $ok = _deep_check($$e1, $$e2);
575                 pop @Data_Stack if $ok;
576             }
577             elsif( $type eq 'SCALAR' ) {
578                 push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
579                 $ok = _deep_check($$e1, $$e2);
580                 pop @Data_Stack if $ok;
581             }
582             elsif( $type ) {
583                 push @Data_Stack, { type => $type, vals => [$e1, $e2] };
584                 $ok = 0;
585             }
586             else {
587                 _whoa(1, "No type in _deep_check");
588             }
589         }
590     }
591
592     return $ok;
593 }
594
595
596 sub _whoa {
597     my($check, $desc) = @_;
598     if( $check ) {
599         die <<WHOA;
600 WHOA!  $desc
601 This should never happen!  Please contact the author immediately!
602 WHOA
603     }
604 }
605
606
607 #line 1300
608
609 sub eq_hash {
610     local @Data_Stack;
611     return _deep_check(@_);
612 }
613
614 sub _eq_hash {
615     my($a1, $a2) = @_;
616
617     if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
618         warn "eq_hash passed a non-hash ref";
619         return 0;
620     }
621
622     return 1 if $a1 eq $a2;
623
624     my $ok = 1;
625     my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
626     foreach my $k (keys %$bigger) {
627         my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
628         my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
629
630         push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
631         $ok = _deep_check($e1, $e2);
632         pop @Data_Stack if $ok;
633
634         last unless $ok;
635     }
636
637     return $ok;
638 }
639
640 #line 1357
641
642 sub eq_set  {
643     my($a1, $a2) = @_;
644     return 0 unless @$a1 == @$a2;
645
646     # There's faster ways to do this, but this is easiest.
647     local $^W = 0;
648
649     # It really doesn't matter how we sort them, as long as both arrays are
650     # sorted with the same algorithm.
651     #
652     # Ensure that references are not accidentally treated the same as a
653     # string containing the reference.
654     #
655     # Have to inline the sort routine due to a threading/sort bug.
656     # See [rt.cpan.org 6782]
657     #
658     # I don't know how references would be sorted so we just don't sort
659     # them.  This means eq_set doesn't really work with refs.
660     return eq_array(
661            [grep(ref, @$a1), sort( grep(!ref, @$a1) )],
662            [grep(ref, @$a2), sort( grep(!ref, @$a2) )],
663     );
664 }
665
666 #line 1547
667
668 1;
Note: See TracBrowser for help on using the browser.