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