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