File Coverage

inc/Test/More.pm
Criterion Covered Total %
statement 83 351 23.6
branch 14 178 7.8
condition 11 67 16.4
subroutine 16 50 32.0
pod 26 27 96.3
total 150 673 22.2


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