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