mktables: Use already set variable

[perl5.git] / lib / sort.t

diff --git a/lib/sort.t b/lib/sort.t
index dbbf82e..e0ef9d3 100644 (file)
--- a/lib/sort.t
+++ b/lib/sort.t
@@ -3,9 +3,6 @@
 # This tests the behavior of sort() under the different 'use sort' forms.
 # Algorithm by John P. Linderman.
 
-use strict;
-use warnings;
-
 my ($BigWidth, $BigEnough, $RootWidth, $ItemFormat, @TestSizes, $WellSoaked);
 
 BEGIN {
@@ -25,10 +22,12 @@ BEGIN {
     }
 }
 
+use strict;
+use warnings;
+
 use Test::More tests => @TestSizes * 2 # sort() tests
-                       * 4             # number of pragmas to test
-                       + 1             # extra test for qsort instability
-                       + 3;            # tests for sort::current
+                       * 3             # number of pragmas to test
+                       + 2;            # tests for sort::current
 
 # Generate array of specified size for testing sort.
 #
@@ -58,15 +57,18 @@ sub genarray {
 sub checkorder {
     my $aref = shift;
     my $status = '';                   # so far, so good
-    my $i;
+    my ($i, $disorder);
 
     for ($i = 0; $i < $#$aref; ++$i) {
-       next if ($aref->[$i] lt $aref->[$i+1]);
-       $status = (substr($aref->[$i], 0, $RootWidth) eq
-                  substr($aref->[$i+1], 0, $RootWidth)) ?
-                 "Instability" : "Disorder";
-       $status .= " at element $i between $aref->[$i] and $aref->[$i+1]";
-       last;
+       # Equality shouldn't happen, but catch it in the contents check
+       next if ($aref->[$i] le $aref->[$i+1]);
+       $disorder = (substr($aref->[$i],   0, $RootWidth) eq
+                    substr($aref->[$i+1], 0, $RootWidth)) ?
+                    "Instability" : "Disorder";
+       # Keep checking if merely unstable... disorder is much worse.
+       $status =
+           "$disorder at element $i between $aref->[$i] and $aref->[$i+1]";
+       last unless ($disorder eq "Instability");       
     }
     return $status;
 }
@@ -95,7 +97,7 @@ sub checkequal {
 # Test sort on arrays of various sizes (set up in @TestSizes)
 
 sub main {
-    my ($expect_unstable) = @_;
+    my ($dothesort, $expect_unstable) = @_;
     my ($ts, $unsorted, @sorted, $status);
     my $unstable_num = 0;
 
@@ -104,9 +106,9 @@ sub main {
        # Sort only on item portion of each element.
        # There will typically be many repeated items,
        # and their order had better be preserved.
-       @sorted = sort { substr($a, 0, $RootWidth)
+       @sorted = $dothesort->(sub { substr($a, 0, $RootWidth)
                                    cmp
-                        substr($b, 0, $RootWidth) } @$unsorted;
+                        substr($b, 0, $RootWidth) }, $unsorted);
        $status = checkorder(\@sorted);
        # Put the items back into the original order.
        # The contents of the arrays had better be identical.
@@ -115,9 +117,9 @@ sub main {
            ++$unstable_num;
        }
        is($status, '', "order ok for size $ts");
-       @sorted = sort { substr($a, $RootWidth)
+       @sorted = $dothesort->(sub { substr($a, $RootWidth)
                                    cmp
-                        substr($b, $RootWidth) } @sorted;
+                           substr($b, $RootWidth) }, \@sorted);
        $status = checkequal(\@sorted, $unsorted);
        is($status, '', "contents ok for size $ts");
     }
@@ -126,33 +128,36 @@ sub main {
     }
 }
 
-# Test with no pragma still loaded -- stability expected (this is a mergesort)
-main(0);
-
-# XXX We're using this eval "..." trick to force recompilation,
-# to ensure that the correct pragma is enabled when main() is run.
-# Currently 'use sort' modifies $^H{SORT} at compile-time, but
-# pp_sort() fetches its value at run-time : thus the lexical scoping
-# of %^H is of no utility.
-# The order of those evals is important.
-
-eval q{
-    use sort qw(_qsort);
-    is(sort::current(), 'quicksort', 'sort::current for _qsort');
-    main(1);
-};
-die $@ if $@;
-
-eval q{
-    use sort qw(_mergesort);
-    is(sort::current(), 'mergesort', 'sort::current for _mergesort');
-    main(0);
-};
-die $@ if $@;
-
-eval q{
-    use sort qw(_qsort stable);
-    is(sort::current(), 'quicksort stable', 'sort::current for _qsort stable');
-    main(0);
-};
-die $@ if $@;
+# Test with no pragma yet loaded. Stability is expected from default sort.
+main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);
+
+# Verify that we have eliminated the segfault that could be triggered
+# by invoking a sort as part of a comparison routine.
+# No need for an explicit test. If we don't segfault, we're good.
+
+{
+    sub dumbsort {
+       my ($a, $b) = @_;
+       use sort qw( defaults stable );
+       my @ignore = sort (5,4,3,2,1);
+       return $a <=> $b;
+    }
+    use sort qw( defaults stable );
+    my @nested = sort { dumbsort($a,$b) } (3,2,2,1);
+}
+
+{
+    use sort qw(stable);
+    my $sort_current; BEGIN { $sort_current = sort::current(); }
+    is($sort_current, 'stable', 'sort::current for stable');
+    main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);
+}
+
+# Tests added to check "defaults" subpragma, and "no sort"
+
+{
+    use sort qw(defaults stable);
+    my $sort_current; BEGIN { $sort_current = sort::current(); }
+    is($sort_current, 'stable', 'sort::current after defaults stable');
+    main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);
+}