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