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.64';
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        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
165sub 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;
190WHOA! I tried to call ->isa on your object and got some weird error.
191This should never happen.  Please contact the author immediately.
192Here's the error.
193$@
194WHOA
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
220sub pass (;$) {
221    my $tb = Test::More->builder;
222    $tb->ok(1, @_);
223}
224
225sub fail (;$) {
226    my $tb = Test::More->builder;
227    $tb->ok(0, @_);
228}
229
230#line 656
231
232sub 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;
245package $pack;
246use $module $imports[0];
247USE
248    }
249    else {
250        eval <<USE;
251package $pack;
252use $module \@imports;
253USE
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:  $@
265DIAGNOSTIC
266
267    }
268
269    return $ok;
270}
271
272#line 705
273
274sub 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;
286package $pack;
287require $module;
288REQUIRE
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:  $@
297DIAGNOSTIC
298
299    }
300
301    return $ok;
302}
303
304
305sub _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
317use vars qw(@Data_Stack %Refs_Seen);
318my $DNE = bless [], 'Does::Not::Exist';
319sub is_deeply {
320    my $tb = Test::More->builder;
321
322    unless( @_ == 2 or @_ == 3 ) {
323        my $msg = <<WARNING;
324is_deeply() takes two or three args, you gave %d.
325This usually means you passed an array or hash instead
326of a reference to it
327WARNING
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($this, $that, $name) = @_;
336
337    $tb->_unoverload_str(\$that, \$this);
338
339    my $ok;
340    if( !ref $this and !ref $that ) {  		# neither is a reference
341        $ok = $tb->is_eq($this, $that, $name);
342    }
343    elsif( !ref $this xor !ref $that ) {  	# one's a reference, one isn't
344        $ok = $tb->ok(0, $name);
345	$tb->diag( _format_stack({ vals => [ $this, $that ] }) );
346    }
347    else {			       		# both references
348        local @Data_Stack = ();
349        if( _deep_check($this, $that) ) {
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
361sub _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
404sub _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
418sub diag {
419    my $tb = Test::More->builder;
420
421    $tb->diag(@_);
422}
423
424
425#line 990
426
427#'#
428sub 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
455sub 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
476sub 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#'#
486sub eq_array {
487    local @Data_Stack;
488    _deep_check(@_);
489}
490
491sub _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
517sub _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
596sub _whoa {
597    my($check, $desc) = @_;
598    if( $check ) {
599        die <<WHOA;
600WHOA!  $desc
601This should never happen!  Please contact the author immediately!
602WHOA
603    }
604}
605
606
607#line 1300
608
609sub eq_hash {
610    local @Data_Stack;
611    return _deep_check(@_);
612}
613
614sub _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
642sub 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 1545
667
6681;
669