X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2Fsort.t;h=62c5529c21e894d4d53bfcf16207c887ca1c7bde;hb=c69adce39458d65db6bf9adbc7d99cf7524bd8ee;hp=44aaf8ffae28750089b80bfd1dd962434c37efd4;hpb=c53fc8a620e539470713c5fc9ecf3b649176ff4a;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/sort.t b/lib/sort.t
index 44aaf8f..62c5529 100644
--- a/lib/sort.t
+++ b/lib/sort.t
@@ -1,17 +1,178 @@
 #!./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 = '../lib';
+    @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)) {
+	push(@TestSizes, int($ts));		# about 3 per decade
+    }
 }
 
-use Test::More tests => 2;
+use strict;
+use warnings;
 
-BEGIN {
-    require "sort.pm"; # require sort; does not work
-    ok(sort::current() eq 'mergesort');
+use Test::More tests => @TestSizes * 2	# sort() tests
+			* 4		# number of pragmas to test
+			+ 1 		# extra test for qsort instability
+			+ 3		# tests for sort::current
+			+ 3;		# tests for "defaults" and "no sort"
+
+# 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;
 }
 
-use sort qw( stable _qsort );
-ok(sort::current() eq 'quicksort stable');
 
+# 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 the following test (#58) fails, see the comments in pp_sort.c
+    # for Perl_sortsv().
+    if ($expect_unstable) {
+	ok($unstable_num > 0, 'Instability ok');
+    }
+}
+
+# Test with no pragma still loaded -- stability expected (this is a mergesort)
+main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);
+
+{
+    use sort qw(_qsort);
+    my $sort_current; BEGIN { $sort_current = sort::current(); }
+    is($sort_current, 'quicksort', 'sort::current for _qsort');
+    main(sub { sort {&{$_[0]}} @{$_[1]} }, 1);
+}
+
+{
+    use sort qw(_mergesort);
+    my $sort_current; BEGIN { $sort_current = sort::current(); }
+    is($sort_current, 'mergesort', 'sort::current for _mergesort');
+    main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);
+}
+
+{
+    use sort qw(_qsort stable);
+    my $sort_current; BEGIN { $sort_current = sort::current(); }
+    is($sort_current, 'quicksort stable', 'sort::current for _qsort stable');
+    main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);
+}
+
+# Tests added to check "defaults" subpragma, and "no sort"
+
+{
+    use sort qw(_qsort stable);
+    no sort qw(_qsort);
+    my $sort_current; BEGIN { $sort_current = sort::current(); }
+    is($sort_current, 'stable', 'sort::current after no _qsort');
+}
+
+{
+    use sort qw(defaults _qsort);
+    my $sort_current; BEGIN { $sort_current = sort::current(); }
+    is($sort_current, 'quicksort', 'sort::current after defaults _qsort');
+}
+
+{
+    use sort qw(defaults stable);
+    my $sort_current; BEGIN { $sort_current = sort::current(); }
+    is($sort_current, 'stable', 'sort::current after defaults stable');
+}