1 #!./perl
3 # This tests the behavior of sort() under the different 'use sort' forms.
4 # Algorithm by John P. Linderman.
6 my (\$BigWidth, \$BigEnough, \$RootWidth, \$ItemFormat, @TestSizes, \$WellSoaked);
8 BEGIN {
9     chdir 't' if -d 't';
10     @INC = qw(../lib);
11     \$BigWidth  = 6;                             # Digits in \$BigEnough-1
12     \$BigEnough = 10**\$BigWidth;                 # Largest array we'll attempt
13     \$RootWidth = int((\$BigWidth+1)/2);          # Digits in sqrt(\$BigEnough-1)
14     \$ItemFormat = "%0\${RootWidth}d%0\${BigWidth}d";      # Array item format
15     @TestSizes = (0, 1, 2);                     # Small special cases
16     # Testing all the way up to \$BigEnough takes too long
17     # for casual testing.  There are some cutoffs (~256)
18     # in pp_sort that should be tested, but 10_000 is ample.
19     \$WellSoaked = 10_000;                       # <= \$BigEnough
20     for (my \$ts = 3; \$ts < \$WellSoaked; \$ts *= 10**(1/3)) {
22     }
23 }
25 use strict;
26 use warnings;
28 use Test::More tests => @TestSizes * 2  # sort() tests
29                         * 6             # number of pragmas to test
30                         + 1             # extra test for qsort instability
31                         + 3             # tests for sort::current
32                         + 3;            # tests for "defaults" and "no sort"
34 # Generate array of specified size for testing sort.
35 #
36 # We ensure repeated items, where possible, by drawing the \$size items
37 # from a pool of size sqrt(\$size).  Each randomly chosen item is
38 # tagged with the item index, so we can detect original input order,
39 # and reconstruct the original array order.
41 sub genarray {
42     my \$size = int(shift);              # fractions not welcome
43     my (\$items, \$i);
44     my @a;
46     if    (\$size < 0) { \$size = 0; }    # avoid complexity with sqrt
47     elsif (\$size > \$BigEnough) { \$size = \$BigEnough; }
48     \$#a = \$size - 1;                    # preallocate array
49     \$items = int(sqrt(\$size));          # number of distinct items
50     for (\$i = 0; \$i < \$size; ++\$i) {
51         \$a[\$i] = sprintf(\$ItemFormat, int(\$items * rand()), \$i);
52     }
53     return \@a;
54 }
57 # Check for correct order (including stability)
59 sub checkorder {
60     my \$aref = shift;
61     my \$status = '';                    # so far, so good
62     my (\$i, \$disorder);
64     for (\$i = 0; \$i < \$#\$aref; ++\$i) {
65         # Equality shouldn't happen, but catch it in the contents check
66         next if (\$aref->[\$i] le \$aref->[\$i+1]);
67         \$disorder = (substr(\$aref->[\$i],   0, \$RootWidth) eq
68                      substr(\$aref->[\$i+1], 0, \$RootWidth)) ?
69                      "Instability" : "Disorder";
70         # Keep checking if merely unstable... disorder is much worse.
71         \$status =
72             "\$disorder at element \$i between \$aref->[\$i] and \$aref->[\$i+1]";
73         last unless (\$disorder eq "Instability");
74     }
75     return \$status;
76 }
79 # Verify that the two array refs reference identical arrays
81 sub checkequal {
82     my (\$aref, \$bref) = @_;
83     my \$status = '';
84     my \$i;
86     if (@\$aref != @\$bref) {
87         \$status = "Sizes differ: " . @\$aref . " vs " . @\$bref;
88     } else {
89         for (\$i = 0; \$i < @\$aref; ++\$i) {
90             next if (\$aref->[\$i] eq \$bref->[\$i]);
91             \$status = "Element \$i differs: \$aref->[\$i] vs \$bref->[\$i]";
92             last;
93         }
94     }
95     return \$status;
96 }
99 # Test sort on arrays of various sizes (set up in @TestSizes)
101 sub main {
102     my (\$dothesort, \$expect_unstable) = @_;
103     my (\$ts, \$unsorted, @sorted, \$status);
104     my \$unstable_num = 0;
106     foreach \$ts (@TestSizes) {
107         \$unsorted = genarray(\$ts);
108         # Sort only on item portion of each element.
109         # There will typically be many repeated items,
110         # and their order had better be preserved.
111         @sorted = \$dothesort->(sub { substr(\$a, 0, \$RootWidth)
112                                     cmp
113                          substr(\$b, 0, \$RootWidth) }, \$unsorted);
114         \$status = checkorder(\@sorted);
115         # Put the items back into the original order.
116         # The contents of the arrays had better be identical.
117         if (\$expect_unstable && \$status =~ /^Instability/) {
118             \$status = '';
119             ++\$unstable_num;
120         }
121         is(\$status, '', "order ok for size \$ts");
122         @sorted = \$dothesort->(sub { substr(\$a, \$RootWidth)
123                                     cmp
124                             substr(\$b, \$RootWidth) }, \@sorted);
125         \$status = checkequal(\@sorted, \$unsorted);
126         is(\$status, '', "contents ok for size \$ts");
127     }
128     # If the following test (#58) fails, see the comments in pp_sort.c
129     # for Perl_sortsv().
130     if (\$expect_unstable) {
131         ok(\$unstable_num > 0, 'Instability ok');
132     }
133 }
135 # Test with no pragma still loaded -- stability expected (this is a mergesort)
136 main(sub { sort {&{\$_}} @{\$_} }, 0);
138 {
139     use sort qw(_qsort);
140     my \$sort_current; BEGIN { \$sort_current = sort::current(); }
141     is(\$sort_current, 'quicksort', 'sort::current for _qsort');
142     main(sub { sort {&{\$_}} @{\$_} }, 1);
143 }
145 {
146     use sort qw(_mergesort);
147     my \$sort_current; BEGIN { \$sort_current = sort::current(); }
148     is(\$sort_current, 'mergesort', 'sort::current for _mergesort');
149     main(sub { sort {&{\$_}} @{\$_} }, 0);
150 }
152 {
153     use sort qw(_qsort stable);
154     my \$sort_current; BEGIN { \$sort_current = sort::current(); }
155     is(\$sort_current, 'quicksort stable', 'sort::current for _qsort stable');
156     main(sub { sort {&{\$_}} @{\$_} }, 0);
157 }
159 # Tests added to check "defaults" subpragma, and "no sort"
161 {
162     use sort qw(_qsort stable);
163     no sort qw(_qsort);
164     my \$sort_current; BEGIN { \$sort_current = sort::current(); }
165     is(\$sort_current, 'stable', 'sort::current after no _qsort');
166     main(sub { sort {&{\$_}} @{\$_} }, 0);
167 }
169 {
170     use sort qw(defaults _qsort);
171     my \$sort_current; BEGIN { \$sort_current = sort::current(); }
172     is(\$sort_current, 'quicksort', 'sort::current after defaults _qsort');
173     # Not expected to be stable, so don't test for stability here
174 }
176 {
177     use sort qw(defaults stable);
178     my \$sort_current; BEGIN { \$sort_current = sort::current(); }
179     is(\$sort_current, 'stable', 'sort::current after defaults stable');
180     main(sub { sort {&{\$_}} @{\$_} }, 0);
181 } 