1#line 1 "inc/Test/More.pm - /usr/local/lib/perl5/site_perl/5.8.4/Test/More.pm"
2package Test::More;
3
4use 5.004;
5
6use strict;
7use Test::Builder;
8
9
10# Can't use Carp because it might cause use_ok() to accidentally succeed
11# even though the module being used forgot to use Carp.  Yes, this
12# actually happened.
13sub _carp {
14    my($file, $line) = (caller(1))[1,2];
15    warn @_, " at $file line $line\n";
16}
17
18
19
20require Exporter;
21use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO);
22$VERSION = '0.47';
23@ISA    = qw(Exporter);
24@EXPORT = qw(ok use_ok require_ok
25             is isnt like unlike is_deeply
26             cmp_ok
27             skip todo todo_skip
28             pass fail
29             eq_array eq_hash eq_set
30             $TODO
31             plan
32             can_ok  isa_ok
33             diag
34            );
35
36my $Test = Test::Builder->new;
37
38
39# 5.004's Exporter doesn't have export_to_level.
40sub _export_to_level
41{
42      my $pkg = shift;
43      my $level = shift;
44      (undef) = shift;                  # redundant arg
45      my $callpkg = caller($level);
46      $pkg->export($callpkg, @_);
47}
48
49
50#line 172
51
52sub plan {
53    my(@plan) = @_;
54
55    my $caller = caller;
56
57    $Test->exported_to($caller);
58
59    my @imports = ();
60    foreach my $idx (0..$#plan) {
61        if( $plan[$idx] eq 'import' ) {
62            my($tag, $imports) = splice @plan, $idx, 2;
63            @imports = @$imports;
64            last;
65        }
66    }
67
68    $Test->plan(@plan);
69
70    __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
71}
72
73sub import {
74    my($class) = shift;
75    goto &plan;
76}
77
78
79#line 266
80
81sub ok ($;$) {
82    my($test, $name) = @_;
83    $Test->ok($test, $name);
84}
85
86#line 330
87
88sub is ($$;$) {
89    $Test->is_eq(@_);
90}
91
92sub isnt ($$;$) {
93    $Test->isnt_eq(@_);
94}
95
96*isn't = \&isnt;
97
98
99#line 371
100
101sub like ($$;$) {
102    $Test->like(@_);
103}
104
105
106#line 385
107
108sub unlike {
109    $Test->unlike(@_);
110}
111
112
113#line 423
114
115sub cmp_ok($$$;$) {
116    $Test->cmp_ok(@_);
117}
118
119
120#line 457
121
122sub can_ok ($@) {
123    my($proto, @methods) = @_;
124    my $class = ref $proto || $proto;
125
126    unless( @methods ) {
127        my $ok = $Test->ok( 0, "$class->can(...)" );
128        $Test->diag('    can_ok() called with no methods');
129        return $ok;
130    }
131
132    my @nok = ();
133    foreach my $method (@methods) {
134        local($!, $@);  # don't interfere with caller's $@
135                        # eval sometimes resets $!
136        eval { $proto->can($method) } || push @nok, $method;
137    }
138
139    my $name;
140    $name = @methods == 1 ? "$class->can('$methods[0]')"
141                          : "$class->can(...)";
142
143    my $ok = $Test->ok( !@nok, $name );
144
145    $Test->diag(map "    $class->can('$_') failed\n", @nok);
146
147    return $ok;
148}
149
150#line 514
151
152sub isa_ok ($$;$) {
153    my($object, $class, $obj_name) = @_;
154
155    my $diag;
156    $obj_name = 'The object' unless defined $obj_name;
157    my $name = "$obj_name isa $class";
158    if( !defined $object ) {
159        $diag = "$obj_name isn't defined";
160    }
161    elsif( !ref $object ) {
162        $diag = "$obj_name isn't a reference";
163    }
164    else {
165        # We can't use UNIVERSAL::isa because we want to honor isa() overrides
166        local($@, $!);  # eval sometimes resets $!
167        my $rslt = eval { $object->isa($class) };
168        if( $@ ) {
169            if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) {
170                if( !UNIVERSAL::isa($object, $class) ) {
171                    my $ref = ref $object;
172                    $diag = "$obj_name isn't a '$class' it's a '$ref'";
173                }
174            } else {
175                die <<WHOA;
176WHOA! I tried to call ->isa on your object and got some weird error.
177This should never happen.  Please contact the author immediately.
178Here's the error.
179$@
180WHOA
181            }
182        }
183        elsif( !$rslt ) {
184            my $ref = ref $object;
185            $diag = "$obj_name isn't a '$class' it's a '$ref'";
186        }
187    }
188
189
190
191    my $ok;
192    if( $diag ) {
193        $ok = $Test->ok( 0, $name );
194        $Test->diag("    $diag\n");
195    }
196    else {
197        $ok = $Test->ok( 1, $name );
198    }
199
200    return $ok;
201}
202
203
204#line 583
205
206sub pass (;$) {
207    $Test->ok(1, @_);
208}
209
210sub fail (;$) {
211    $Test->ok(0, @_);
212}
213
214#line 627
215
216sub diag {
217    $Test->diag(@_);
218}
219
220
221#line 677
222
223sub use_ok ($;@) {
224    my($module, @imports) = @_;
225    @imports = () unless @imports;
226
227    my $pack = caller;
228
229    local($@,$!);   # eval sometimes interferes with $!
230    eval <<USE;
231package $pack;
232require $module;
233'$module'->import(\@imports);
234USE
235
236    my $ok = $Test->ok( !$@, "use $module;" );
237
238    unless( $ok ) {
239        chomp $@;
240        $Test->diag(<<DIAGNOSTIC);
241    Tried to use '$module'.
242    Error:  $@
243DIAGNOSTIC
244
245    }
246
247    return $ok;
248}
249
250#line 712
251
252sub require_ok ($) {
253    my($module) = shift;
254
255    my $pack = caller;
256
257    local($!, $@); # eval sometimes interferes with $!
258    eval <<REQUIRE;
259package $pack;
260require $module;
261REQUIRE
262
263    my $ok = $Test->ok( !$@, "require $module;" );
264
265    unless( $ok ) {
266        chomp $@;
267        $Test->diag(<<DIAGNOSTIC);
268    Tried to require '$module'.
269    Error:  $@
270DIAGNOSTIC
271
272    }
273
274    return $ok;
275}
276
277#line 796
278
279#'#
280sub skip {
281    my($why, $how_many) = @_;
282
283    unless( defined $how_many ) {
284        # $how_many can only be avoided when no_plan is in use.
285        _carp "skip() needs to know \$how_many tests are in the block"
286          unless $Test::Builder::No_Plan;
287        $how_many = 1;
288    }
289
290    for( 1..$how_many ) {
291        $Test->skip($why);
292    }
293
294    local $^W = 0;
295    last SKIP;
296}
297
298
299#line 874
300
301sub todo_skip {
302    my($why, $how_many) = @_;
303
304    unless( defined $how_many ) {
305        # $how_many can only be avoided when no_plan is in use.
306        _carp "todo_skip() needs to know \$how_many tests are in the block"
307          unless $Test::Builder::No_Plan;
308        $how_many = 1;
309    }
310
311    for( 1..$how_many ) {
312        $Test->todo_skip($why);
313    }
314
315    local $^W = 0;
316    last TODO;
317}
318
319#line 933
320
321use vars qw(@Data_Stack);
322my $DNE = bless [], 'Does::Not::Exist';
323sub is_deeply {
324    my($this, $that, $name) = @_;
325
326    my $ok;
327    if( !ref $this || !ref $that ) {
328        $ok = $Test->is_eq($this, $that, $name);
329    }
330    else {
331        local @Data_Stack = ();
332        if( _deep_check($this, $that) ) {
333            $ok = $Test->ok(1, $name);
334        }
335        else {
336            $ok = $Test->ok(0, $name);
337            $ok = $Test->diag(_format_stack(@Data_Stack));
338        }
339    }
340
341    return $ok;
342}
343
344sub _format_stack {
345    my(@Stack) = @_;
346
347    my $var = '$FOO';
348    my $did_arrow = 0;
349    foreach my $entry (@Stack) {
350        my $type = $entry->{type} || '';
351        my $idx  = $entry->{'idx'};
352        if( $type eq 'HASH' ) {
353            $var .= "->" unless $did_arrow++;
354            $var .= "{$idx}";
355        }
356        elsif( $type eq 'ARRAY' ) {
357            $var .= "->" unless $did_arrow++;
358            $var .= "[$idx]";
359        }
360        elsif( $type eq 'REF' ) {
361            $var = "\${$var}";
362        }
363    }
364
365    my @vals = @{$Stack[-1]{vals}}[0,1];
366    my @vars = ();
367    ($vars[0] = $var) =~ s/\$FOO/     \$got/;
368    ($vars[1] = $var) =~ s/\$FOO/\$expected/;
369
370    my $out = "Structures begin differing at:\n";
371    foreach my $idx (0..$#vals) {
372        my $val = $vals[$idx];
373        $vals[$idx] = !defined $val ? 'undef' :
374                      $val eq $DNE  ? "Does not exist"
375                                    : "'$val'";
376    }
377
378    $out .= "$vars[0] = $vals[0]\n";
379    $out .= "$vars[1] = $vals[1]\n";
380
381    $out =~ s/^/    /msg;
382    return $out;
383}
384
385
386#line 1007
387
388#'#
389sub eq_array  {
390    my($a1, $a2) = @_;
391    return 1 if $a1 eq $a2;
392
393    my $ok = 1;
394    my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;
395    for (0..$max) {
396        my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
397        my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];
398
399        push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] };
400        $ok = _deep_check($e1,$e2);
401        pop @Data_Stack if $ok;
402
403        last unless $ok;
404    }
405    return $ok;
406}
407
408sub _deep_check {
409    my($e1, $e2) = @_;
410    my $ok = 0;
411
412    my $eq;
413    {
414        # Quiet uninitialized value warnings when comparing undefs.
415        local $^W = 0;
416
417        if( $e1 eq $e2 ) {
418            $ok = 1;
419        }
420        else {
421            if( UNIVERSAL::isa($e1, 'ARRAY') and
422                UNIVERSAL::isa($e2, 'ARRAY') )
423            {
424                $ok = eq_array($e1, $e2);
425            }
426            elsif( UNIVERSAL::isa($e1, 'HASH') and
427                   UNIVERSAL::isa($e2, 'HASH') )
428            {
429                $ok = eq_hash($e1, $e2);
430            }
431            elsif( UNIVERSAL::isa($e1, 'REF') and
432                   UNIVERSAL::isa($e2, 'REF') )
433            {
434                push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
435                $ok = _deep_check($$e1, $$e2);
436                pop @Data_Stack if $ok;
437            }
438            elsif( UNIVERSAL::isa($e1, 'SCALAR') and
439                   UNIVERSAL::isa($e2, 'SCALAR') )
440            {
441                push @Data_Stack, { type => 'REF', vals => [$e1, $e2] };
442                $ok = _deep_check($$e1, $$e2);
443            }
444            else {
445                push @Data_Stack, { vals => [$e1, $e2] };
446                $ok = 0;
447            }
448        }
449    }
450
451    return $ok;
452}
453
454
455#line 1083
456
457sub eq_hash {
458    my($a1, $a2) = @_;
459    return 1 if $a1 eq $a2;
460
461    my $ok = 1;
462    my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;
463    foreach my $k (keys %$bigger) {
464        my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
465        my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;
466
467        push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] };
468        $ok = _deep_check($e1, $e2);
469        pop @Data_Stack if $ok;
470
471        last unless $ok;
472    }
473
474    return $ok;
475}
476
477#line 1116
478
479# We must make sure that references are treated neutrally.  It really
480# doesn't matter how we sort them, as long as both arrays are sorted
481# with the same algorithm.
482sub _bogus_sort { local $^W = 0;  ref $a ? 0 : $a cmp $b }
483
484sub eq_set  {
485    my($a1, $a2) = @_;
486    return 0 unless @$a1 == @$a2;
487
488    # There's faster ways to do this, but this is easiest.
489    return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] );
490}
491
492#line 1154
493
494sub builder {
495    return Test::Builder->new;
496}
497
498#line 1247
499
5001;
501