inc/Test/More.pm

#line 1
package Test::More;

use 5.004;

use strict;


# Can't use Carp because it might cause use_ok() to accidentally succeed
# even though the module being used forgot to use Carp.  Yes, this
# actually happened.
sub _carp {
    my($file, $line) = (caller(1))[1,2];
    warn @_, " at $file line $line\n";
}


use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
$VERSION = '0.62';
$VERSION = eval $VERSION;    # make the alpha version come out as a number

use Test::Builder::Module;
@ISA    = qw(Test::Builder::Module);
@EXPORT = qw(ok use_ok require_ok
             is isnt like unlike is_deeply
             cmp_ok
             skip todo todo_skip
             pass fail
             eq_array eq_hash eq_set
             $TODO
             plan
             can_ok  isa_ok
             diag
             BAIL_OUT
            );


#line 157

sub plan {
    my $tb = Test::More->builder;

    $tb->plan(@_);
}


# This implements "use Test::More 'no_diag'" but the behavior is
# deprecated.
sub import_extra {
    my $class = shift;
    my $list  = shift;

    my @other = ();
    my $idx = 0;
    while( $idx <= $#{$list} ) {
        my $item = $list->[$idx];

        if( defined $item and $item eq 'no_diag' ) {
            $class->builder->no_diag(1);
        }
        else {
            push @other, $item;
        }

        $idx++;
    }

    @$list = @other;
}


#line 257

sub ok ($;$) {
    my($test, $name) = @_;
    my $tb = Test::More->builder;

    $tb->ok($test, $name);
}

#line 324

sub is ($$;$) {
    my $tb = Test::More->builder;

    $tb->is_eq(@_);
}

sub isnt ($$;$) {
    my $tb = Test::More->builder;

    $tb->isnt_eq(@_);
}

*isn't = \&isnt;


#line 369

sub like ($$;$) {
    my $tb = Test::More->builder;

    $tb->like(@_);
}


#line 385

sub unlike ($$;$) {
    my $tb = Test::More->builder;

    $tb->unlike(@_);
}


#line 425

sub cmp_ok($$$;$) {
    my $tb = Test::More->builder;

    $tb->cmp_ok(@_);
}


#line 461

sub can_ok ($@) {
    my($proto, @methods) = @_;
    my $class = ref $proto || $proto;
    my $tb = Test::More->builder;

    unless( @methods ) {
        my $ok = $tb->ok( 0, "$class->can(...)" );
        $tb->diag('    can_ok() called with no methods');
        return $ok;
    }

    my @nok = ();
    foreach my $method (@methods) {
        local($!, $@);  # don't interfere with caller's $@
                        # eval sometimes resets $!
        eval { $proto->can($method) } || push @nok, $method;
    }

    my $name;
    $name = @methods == 1 ? "$class->can('$methods[0]')" 
                          : "$class->can(...)";
    
    my $ok = $tb->ok( !@nok, $name );

    $tb->diag(map "    $class->can('$_') failed\n", @nok);

    return $ok;
}

#line 519

sub isa_ok ($$;$) {
    my($object, $class, $obj_name) = @_;
    my $tb = Test::More->builder;

    my $diag;
    $obj_name = 'The object' unless defined $obj_name;
    my $name = "$obj_name isa $class";
    if( !defined $object ) {
        $diag = "$obj_name isn't defined";
    }
    elsif( !ref $object ) {
        $diag = "$obj_name isn't a reference";
    }
    else {
        # We can't use UNIVERSAL::isa because we want to honor isa() overrides
        local($@, $!);  # eval sometimes resets $!
        my $rslt = eval { $object->isa($class) };
        if( $@ ) {
            if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
                if( !UNIVERSAL::isa($object, $class) ) {
                    my $ref = ref $object;
                    $diag = "$obj_name isn't a '$class' it's a '$ref'";
                }
            } else {
                die <<WHOA;
WHOA! I tried to call ->isa on your object and got some weird error.
This should never happen.  Please contact the author immediately.
Here's the error.
$@
WHOA
            }
        }
        elsif( !$rslt ) {
            my $ref = ref $object;
            $diag = "$obj_name isn't a '$class' it's a '$ref'";
        }
    }
            
      
    my $ok;
    if( $diag ) {
        $ok = $tb->ok( 0, $name );
        $tb->diag("    $diag\n");
    }
    else {
        $ok = $tb->ok( 1, $name );
    }

    return $ok;
}


#line 589

sub pass (;$) {
    my $tb = Test::More->builder;
    $tb->ok(1, @_);
}

sub fail (;$) {
    my $tb = Test::More->builder;
    $tb->ok(0, @_);
}

#line 650

sub use_ok ($;@) {
    my($module, @imports) = @_;
    @imports = () unless @imports;
    my $tb = Test::More->builder;

    my($pack,$filename,$line) = caller;

    local($@,$!);   # eval sometimes interferes with $!

    if( @imports == 1 and $imports[0] =~ /^\d+(?:\.\d+)?$/ ) {
        # probably a version check.  Perl needs to see the bare number
        # for it to work with non-Exporter based modules.
        eval <<USE;
package $pack;
use $module $imports[0];
USE
    }
    else {
        eval <<USE;
package $pack;
use $module \@imports;
USE
    }

    my $ok = $tb->ok( !$@, "use $module;" );

    unless( $ok ) {
        chomp $@;
        $@ =~ s{^BEGIN failed--compilation aborted at .*$}
                {BEGIN failed--compilation aborted at $filename line $line.}m;
        $tb->diag(<<DIAGNOSTIC);
    Tried to use '$module'.
    Error:  $@
DIAGNOSTIC

    }

    return $ok;
}

#line 699

sub require_ok ($) {
    my($module) = shift;
    my $tb = Test::More->builder;

    my $pack = caller;

    # Try to deterine if we've been given a module name or file.
    # Module names must be barewords, files not.
    $module = qq['$module'] unless _is_module_name($module);

    local($!, $@); # eval sometimes interferes with $!
    eval <<REQUIRE;
package $pack;
require $module;
REQUIRE

    my $ok = $tb->ok( !$@, "require $module;" );

    unless( $ok ) {
        chomp $@;
        $tb->diag(<<DIAGNOSTIC);
    Tried to require '$module'.
    Error:  $@
DIAGNOSTIC

    }

    return $ok;
}


sub _is_module_name {
    my $module = shift;

    # Module names start with a letter.
    # End with an alphanumeric.
    # The rest is an alphanumeric or ::
    $module =~ s/\b::\b//g;
    $module =~ /^[a-zA-Z]\w*$/;
}

#line 775

use vars qw(@Data_Stack %Refs_Seen);
my $DNE = bless [], 'Does::Not::Exist';
sub is_deeply {
    my $tb = Test::More->builder;

    unless( @_ == 2 or @_ == 3 ) {
        my $msg = <<WARNING;
is_deeply() takes two or three args, you gave %d.
This usually means you passed an array or hash instead 
of a reference to it
WARNING
        chop $msg;   # clip off newline so carp() will put in line/file

        _carp sprintf $msg, scalar @_;

        return $tb->ok(0);
    }

    my($this, $that, $name) = @_;

    $tb->_unoverload_str(\$that, \$this);

    my $ok;
    if( !ref $this and !ref $that ) {           # neither is a reference
        $ok = $tb->is_eq($this, $that, $name);
    }
    elsif( !ref $this xor !ref $that ) {        # one's a reference, one isn't
        $ok = $tb->ok(0, $name);
        $tb->diag( _format_stack({ vals => [ $this, $that ] }) );
    }
    else {                                      # both references
        local @Data_Stack = ();
        if( _deep_check($this, $that) ) {
            $ok = $tb->ok(1, $name);
        }
        else {
            $ok = $tb->ok(0, $name);
            $tb->diag(_format_stack(@Data_Stack));
        }
    }

    return $ok;
}

sub _format_stack {
    my(@Stack) = @_;

    my $var = '$FOO';
    my $did_arrow = 0;
    foreach my $entry (@Stack) {
        my $type = $entry->{type} || '';
        my $idx  = $entry->{'idx'};
        if( $type eq 'HASH' ) {
            $var .= "->" unless $did_arrow++;
            $var .= "{$idx}";
        }
        elsif( $type eq 'ARRAY' ) {
            $var .= "->" unless $did_arrow++;
            $var .= "[$idx]";
        }
        elsif( $type eq 'REF' ) {
            $var = "\${$var}";
        }
    }

    my @vals = @{$Stack[-1]{vals}}[0,1];
    my @vars = ();
    ($vars[0] = $var) =~ s/\$FOO/     \$got/;
    ($vars[1] = $var) =~ s/\$FOO/\$expected/;

    my $out = "Structures begin differing at:\n";
    foreach my $idx (0..$#vals) {
        my $val = $vals[$idx];
        $vals[$idx] = !defined $val ? 'undef'          :
                      $val eq $DNE  ? "Does not exist" :
                      ref $val      ? "$val"           :
                                      "'$val'";
    }

    $out .= "$vars[0] = $vals[0]\n";
    $out .= "$vars[1] = $vals[1]\n";

    $out =~ s/^/    /msg;
    return $out;
}


sub _type {
    my $thing = shift;

    return '' if !ref $thing;

    for my $type (qw(ARRAY HASH REF SCALAR GLOB CODE Regexp)) {
        return $type if UNIVERSAL::isa($thing, $type);
    }

    return '';
}

#line 915

sub diag {
    my $tb = Test::More->builder;

    $tb->diag(@_);
}


#line 984

#'#
sub skip {
    my($why, $how_many) = @_;
    my $tb = Test::More->builder;

    unless( defined $how_many ) {
        # $how_many can only be avoided when no_plan is in use.
        _carp "skip() needs to know \$how_many tests are in the block"
          unless $tb->has_plan eq 'no_plan';
        $how_many = 1;
    }

    for( 1..$how_many ) {
        $tb->skip($why);
    }

    local $^W = 0;
    last SKIP;
}


#line 1066

sub todo_skip {
    my($why, $how_many) = @_;
    my $tb = Test::More->builder;

    unless( defined $how_many ) {
        # $how_many can only be avoided when no_plan is in use.
        _carp "todo_skip() needs to know \$how_many tests are in the block"
          unless $tb->has_plan eq 'no_plan';
        $how_many = 1;
    }

    for( 1..$how_many ) {
        $tb->todo_skip($why);
    }

    local $^W = 0;
    last TODO;
}

#line 1119

sub BAIL_OUT {
    my $reason = shift;
    my $tb = Test::More->builder;

    $tb->BAIL_OUT($reason);
}

#line 1158

#'#
sub eq_array {
    local @Data_Stack;
    _deep_check(@_);
}

sub _eq_array  {
    my($a1, $a2) = @_;

    if( grep !_type($_) eq 'ARRAY', $a1, $a2 ) {
        warn "eq_array passed a non-array ref";
        return 0;
    }

    return 1 if $a1 eq $a2;

    my $ok = 1;
    my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
    for (0..$max) {
        my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
        my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];

        push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
        $ok = _deep_check($e1,$e2);
        pop @Data_Stack if $ok;

        last unless $ok;
    }

    return $ok;
}

sub _deep_check {
    my($e1, $e2) = @_;
    my $tb = Test::More->builder;

    my $ok = 0;

    # Effectively turn %Refs_Seen into a stack.  This avoids picking up
    # the same referenced used twice (such as [\$a, \$a]) to be considered
    # circular.
    local %Refs_Seen = %Refs_Seen;

    {
        # Quiet uninitialized value warnings when comparing undefs.
        local $^W = 0; 

        $tb->_unoverload_str(\$e1, \$e2);

        # Either they're both references or both not.
        my $same_ref = !(!ref $e1 xor !ref $e2);
        my $not_ref  = (!ref $e1 and !ref $e2);

        if( defined $e1 xor defined $e2 ) {
            $ok = 0;
        }
        elsif ( $e1 == $DNE xor $e2 == $DNE ) {
            $ok = 0;
        }
        elsif ( $same_ref and ($e1 eq $e2) ) {
            $ok = 1;
        }
        elsif ( $not_ref ) {
            push @Data_Stack, { type => '', vals => [$e1, $e2] };
            $ok = 0;
        }
        else {
            if( $Refs_Seen{$e1} ) {
                return $Refs_Seen{$e1} eq $e2;
            }
            else {
                $Refs_Seen{$e1} = "$e2";
            }

            my $type = _type($e1);
            $type = 'DIFFERENT' unless _type($e2) eq $type;

            if( $type eq 'DIFFERENT' ) {
                push @Data_Stack, { type => $type, vals => [$e1, $e2] };
                $ok = 0;
            }
            elsif( $type eq 'ARRAY' ) {
                $ok = _eq_array($e1, $e2);
            }
            elsif( $type eq 'HASH' ) {
                $ok = _eq_hash($e1, $e2);
            }
            elsif( $type eq 'REF' ) {
                push @Data_Stack, { type => $type, vals => [$e1, $e2] };
                $ok = _deep_check($$e1, $$e2);
                pop @Data_Stack if $ok;
            }
            elsif( $type eq 'SCALAR' ) {
                push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
                $ok = _deep_check($$e1, $$e2);
                pop @Data_Stack if $ok;
            }
            elsif( $type ) {
                push @Data_Stack, { type => $type, vals => [$e1, $e2] };
                $ok = 0;
            }
            else {
                _whoa(1, "No type in _deep_check");
            }
        }
    }

    return $ok;
}


sub _whoa {
    my($check, $desc) = @_;
    if( $check ) {
        die <<WHOA;
WHOA!  $desc
This should never happen!  Please contact the author immediately!
WHOA
    }
}


#line 1289

sub eq_hash {
    local @Data_Stack;
    return _deep_check(@_);
}

sub _eq_hash {
    my($a1, $a2) = @_;

    if( grep !_type($_) eq 'HASH', $a1, $a2 ) {
        warn "eq_hash passed a non-hash ref";
        return 0;
    }

    return 1 if $a1 eq $a2;

    my $ok = 1;
    my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
    foreach my $k (keys %$bigger) {
        my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
        my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;

        push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
        $ok = _deep_check($e1, $e2);
        pop @Data_Stack if $ok;

        last unless $ok;
    }

    return $ok;
}

#line 1346

sub eq_set  {
    my($a1, $a2) = @_;
    return 0 unless @$a1 == @$a2;

    # There's faster ways to do this, but this is easiest.
    local $^W = 0;

    # It really doesn't matter how we sort them, as long as both arrays are 
    # sorted with the same algorithm.
    #
    # Ensure that references are not accidentally treated the same as a
    # string containing the reference.
    #
    # Have to inline the sort routine due to a threading/sort bug.
    # See [rt.cpan.org 6782]
    #
    # I don't know how references would be sorted so we just don't sort
    # them.  This means eq_set doesn't really work with refs.
    return eq_array(
           [grep(ref, @$a1), sort( grep(!ref, @$a1) )],
           [grep(ref, @$a2), sort( grep(!ref, @$a2) )],
    );
}

#line 1534

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