[Merge] minitest fixes
[perl.git] / lib / sort.t
1 #!./perl
2
3 # This tests the behavior of sort() under the different 'use sort' forms.
4 # Algorithm by John P. Linderman.
5
6 my ($BigWidth, $BigEnough, $RootWidth, $ItemFormat, @TestSizes, $WellSoaked);
7
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)) {
21         push(@TestSizes, int($ts));             # about 3 per decade
22     }
23 }
24
25 use strict;
26 use warnings;
27
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"
33
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.
40
41 sub genarray {
42     my $size = int(shift);              # fractions not welcome
43     my ($items, $i);
44     my @a;
45
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 }
55
56
57 # Check for correct order (including stability)
58
59 sub checkorder {
60     my $aref = shift;
61     my $status = '';                    # so far, so good
62     my ($i, $disorder);
63
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 }
77
78
79 # Verify that the two array refs reference identical arrays
80
81 sub checkequal {
82     my ($aref, $bref) = @_;
83     my $status = '';
84     my $i;
85
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 }
97
98
99 # Test sort on arrays of various sizes (set up in @TestSizes)
100
101 sub main {
102     my ($dothesort, $expect_unstable) = @_;
103     my ($ts, $unsorted, @sorted, $status);
104     my $unstable_num = 0;
105
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 }
134
135 # Test with no pragma still loaded -- stability expected (this is a mergesort)
136 main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);
137
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 {&{$_[0]}} @{$_[1]} }, 1);
143 }
144
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]}} @{$_[1]} }, 0);
150 }
151
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]}} @{$_[1]} }, 0);
157 }
158
159 # Tests added to check "defaults" subpragma, and "no sort"
160
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]}} @{$_[1]} }, 0);
167 }
168
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 }
175
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]}} @{$_[1]} }, 0);
181 }