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