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