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