1#!./perl
2
3# This tests the behavior of sort() under the different 'use sort' forms.
4# Algorithm by John P. Linderman.
5
6my ($BigWidth, $BigEnough, $RootWidth, $ItemFormat, @TestSizes, $WellSoaked);
7
8BEGIN {
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
25use strict;
26use warnings;
27
28use Test::More tests => @TestSizes * 2	# sort() tests
29			* 3		# number of pragmas to test
30			+ 10;		# tests for sort::current
31
32# Generate array of specified size for testing sort.
33#
34# We ensure repeated items, where possible, by drawing the $size items
35# from a pool of size sqrt($size).  Each randomly chosen item is
36# tagged with the item index, so we can detect original input order,
37# and reconstruct the original array order.
38
39sub genarray {
40    my $size = int(shift);		# fractions not welcome
41    my ($items, $i);
42    my @a;
43
44    if    ($size < 0) { $size = 0; }	# avoid complexity with sqrt
45    elsif ($size > $BigEnough) { $size = $BigEnough; }
46    $#a = $size - 1;			# preallocate array
47    $items = int(sqrt($size));		# number of distinct items
48    for ($i = 0; $i < $size; ++$i) {
49	$a[$i] = sprintf($ItemFormat, int($items * rand()), $i);
50    }
51    return \@a;
52}
53
54
55# Check for correct order (including stability)
56
57sub checkorder {
58    my $aref = shift;
59    my $status = '';			# so far, so good
60    my ($i, $disorder);
61
62    for ($i = 0; $i < $#$aref; ++$i) {
63	# Equality shouldn't happen, but catch it in the contents check
64	next if ($aref->[$i] le $aref->[$i+1]);
65	$disorder = (substr($aref->[$i],   0, $RootWidth) eq
66		     substr($aref->[$i+1], 0, $RootWidth)) ?
67		     "Instability" : "Disorder";
68	# Keep checking if merely unstable... disorder is much worse.
69	$status =
70	    "$disorder at element $i between $aref->[$i] and $aref->[$i+1]";
71	last unless ($disorder eq "Instability");
72    }
73    return $status;
74}
75
76
77# Verify that the two array refs reference identical arrays
78
79sub checkequal {
80    my ($aref, $bref) = @_;
81    my $status = '';
82    my $i;
83
84    if (@$aref != @$bref) {
85	$status = "Sizes differ: " . @$aref . " vs " . @$bref;
86    } else {
87	for ($i = 0; $i < @$aref; ++$i) {
88	    next if ($aref->[$i] eq $bref->[$i]);
89	    $status = "Element $i differs: $aref->[$i] vs $bref->[$i]";
90	    last;
91	}
92    }
93    return $status;
94}
95
96
97# Test sort on arrays of various sizes (set up in @TestSizes)
98
99sub main {
100    my ($dothesort, $expect_unstable) = @_;
101    my ($ts, $unsorted, @sorted, $status);
102    my $unstable_num = 0;
103
104    foreach $ts (@TestSizes) {
105	$unsorted = genarray($ts);
106	# Sort only on item portion of each element.
107	# There will typically be many repeated items,
108	# and their order had better be preserved.
109	@sorted = $dothesort->(sub { substr($a, 0, $RootWidth)
110				    cmp
111	                 substr($b, 0, $RootWidth) }, $unsorted);
112	$status = checkorder(\@sorted);
113	# Put the items back into the original order.
114	# The contents of the arrays had better be identical.
115	if ($expect_unstable && $status =~ /^Instability/) {
116	    $status = '';
117	    ++$unstable_num;
118	}
119	is($status, '', "order ok for size $ts");
120	@sorted = $dothesort->(sub { substr($a, $RootWidth)
121				    cmp
122			    substr($b, $RootWidth) }, \@sorted);
123	$status = checkequal(\@sorted, $unsorted);
124	is($status, '', "contents ok for size $ts");
125    }
126    if ($expect_unstable) {
127	ok($unstable_num > 0, 'Instability ok');
128    }
129}
130
131# Test with no pragma yet loaded. Stability is expected from default sort.
132main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);
133
134# Verify that we have eliminated the segfault that could be triggered
135# by invoking a sort as part of a comparison routine.
136# No need for an explicit test. If we don't segfault, we're good.
137
138{
139    sub dumbsort {
140	my ($a, $b) = @_;
141	use sort qw( defaults stable );
142	my @ignore = sort (5,4,3,2,1);
143	return $a <=> $b;
144    }
145    use sort qw( defaults stable );
146    my @nested = sort { dumbsort($a,$b) } (3,2,2,1);
147}
148
149{
150    use sort qw(stable);
151    my $sort_current;
152    BEGIN {
153        my $a = "" ;
154        local $SIG{__WARN__} = sub {$a = $_[0]};
155        $sort_current = sort::current();
156        like($a, qr/\Asort::current is deprecated\b/, "sort::current warns");
157    }
158    is($sort_current, 'stable', 'sort::current for stable');
159    main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);
160}
161
162# Tests added to check "defaults" subpragma, and "no sort"
163
164{
165    use sort qw(defaults stable);
166    my $sort_current;
167    BEGIN {
168        my $a = "" ;
169        local $SIG{__WARN__} = sub {$a = $_[0]};
170        $sort_current = sort::current();
171        like($a, qr/\Asort::current is deprecated\b/, "sort::current warns");
172    }
173    is($sort_current, 'stable', 'sort::current after defaults stable');
174    main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);
175}
176
177# Tests added to check how sort::current is deprecated
178
179{
180    no sort qw(stable);
181    my $sort_current;
182    BEGIN {
183        my $a = "" ;
184        local $SIG{__WARN__} = sub {$a = $_[0]};
185        $sort_current = sort::current();
186        like($a, qr/\Asort::current is deprecated\b/, "sort::current warns");
187    }
188    is($sort_current, 'stable', 'sort::current *always* stable');
189}
190
191{
192    use sort qw(defaults);
193    my $sort_current;
194    BEGIN {
195        no warnings qw(deprecated);
196        my $a = "" ;
197        local $SIG{__WARN__} = sub {$a = $_[0]};
198        $sort_current = sort::current();
199        is($a, "", "sort::current warning can be disabled");
200    }
201    is($sort_current, 'stable', 'sort::current *always* stable');
202}
203
204{
205    use sort qw(stable);
206    my $sort_current;
207    BEGIN {
208        no warnings qw(deprecated);
209        my $a = "" ;
210        local $SIG{__WARN__} = sub {$a = $_[0]};
211        $sort_current = sort::current();
212        is($a, "", "sort::current warning can be disabled");
213    }
214    is($sort_current, 'stable', 'sort::current for stable');
215}
216