``````#!./perl

# This tests the behavior of sort() under the different 'use sort' forms.
# Algorithm by John P. Linderman.

my (\$BigWidth, \$BigEnough, \$RootWidth, \$ItemFormat, @TestSizes, \$WellSoaked);

BEGIN {
chdir 't' if -d 't';
@INC = qw(../lib);
\$BigWidth  = 6;				# Digits in \$BigEnough-1
\$BigEnough = 10**\$BigWidth;			# Largest array we'll attempt
\$RootWidth = int((\$BigWidth+1)/2);		# Digits in sqrt(\$BigEnough-1)
\$ItemFormat = "%0\${RootWidth}d%0\${BigWidth}d";	# Array item format
@TestSizes = (0, 1, 2);			# Small special cases
# Testing all the way up to \$BigEnough takes too long
# for casual testing.  There are some cutoffs (~256)
# in pp_sort that should be tested, but 10_000 is ample.
\$WellSoaked = 10_000;			# <= \$BigEnough
for (my \$ts = 3; \$ts < \$WellSoaked; \$ts *= 10**(1/3)) {
}
}

use strict;
use warnings;

use Test::More tests => @TestSizes * 2	# sort() tests
* 3		# number of pragmas to test
+ 2;		# tests for sort::current

# Generate array of specified size for testing sort.
#
# We ensure repeated items, where possible, by drawing the \$size items
# from a pool of size sqrt(\$size).  Each randomly chosen item is
# tagged with the item index, so we can detect original input order,
# and reconstruct the original array order.

sub genarray {
my \$size = int(shift);		# fractions not welcome
my (\$items, \$i);
my @a;

if    (\$size < 0) { \$size = 0; }	# avoid complexity with sqrt
elsif (\$size > \$BigEnough) { \$size = \$BigEnough; }
\$#a = \$size - 1;			# preallocate array
\$items = int(sqrt(\$size));		# number of distinct items
for (\$i = 0; \$i < \$size; ++\$i) {
\$a[\$i] = sprintf(\$ItemFormat, int(\$items * rand()), \$i);
}
return \@a;
}

# Check for correct order (including stability)

sub checkorder {
my \$aref = shift;
my \$status = '';			# so far, so good
my (\$i, \$disorder);

for (\$i = 0; \$i < \$#\$aref; ++\$i) {
# 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;
}

# Verify that the two array refs reference identical arrays

sub checkequal {
my (\$aref, \$bref) = @_;
my \$status = '';
my \$i;

if (@\$aref != @\$bref) {
\$status = "Sizes differ: " . @\$aref . " vs " . @\$bref;
} else {
for (\$i = 0; \$i < @\$aref; ++\$i) {
next if (\$aref->[\$i] eq \$bref->[\$i]);
\$status = "Element \$i differs: \$aref->[\$i] vs \$bref->[\$i]";
last;
}
}
return \$status;
}

# Test sort on arrays of various sizes (set up in @TestSizes)

sub main {
my (\$dothesort, \$expect_unstable) = @_;
my (\$ts, \$unsorted, @sorted, \$status);
my \$unstable_num = 0;

foreach \$ts (@TestSizes) {
\$unsorted = genarray(\$ts);
# Sort only on item portion of each element.
# There will typically be many repeated items,
# and their order had better be preserved.
@sorted = \$dothesort->(sub { substr(\$a, 0, \$RootWidth)
cmp
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.
if (\$expect_unstable && \$status =~ /^Instability/) {
\$status = '';
++\$unstable_num;
}
is(\$status, '', "order ok for size \$ts");
@sorted = \$dothesort->(sub { substr(\$a, \$RootWidth)
cmp
substr(\$b, \$RootWidth) }, \@sorted);
\$status = checkequal(\@sorted, \$unsorted);
is(\$status, '', "contents ok for size \$ts");
}
if (\$expect_unstable) {
ok(\$unstable_num > 0, 'Instability ok');
}
}

# Test with no pragma yet loaded. Stability is expected from default sort.
main(sub { sort {&{\$_}} @{\$_} }, 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);
}

# 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);
}
``````