Re: [PATCH] Make the 'sort' pragma lexically scoped

Message-ID: <20051219174620.GA17940@rpc142.cs.man.ac.uk>

p4raw-id: //depot/perl@26402

3 files changed, 85 insertions, 91 deletions

diff --git a/lib/feature.pm b/lib/feature.pm
index e0981d08a9..fe549944bc 100644
--- a/lib/feature.pm
+++ b/lib/feature.pm
@@ -5,9 +5,9 @@ $feature::hint_bits = 0x04020000; # HINT_LOCALIZE_HH | HINT_HH_FOR_EVAL
 
 # (feature name) => (internal name, used in %^H)
 my %feature = (
-    switch => 'switch',
-    "~~"   => "~~",
-    say    => "say",
+    switch => 'feature_switch',
+    "~~"   => "feature_~~",
+    say    => "feature_say",
 );
 
 
diff --git a/lib/sort.pm b/lib/sort.pm
index e785003f4f..e8d6446ba4 100644
--- a/lib/sort.pm
+++ b/lib/sort.pm
@@ -2,12 +2,10 @@ package sort;
 
 our $VERSION = '1.02';
 
-# Currently the hints for pp_sort are stored in the global variable
-# $sort::hints. An improvement would be to store them in $^H{SORT} and have
-# this information available somewhere in the listop OP_SORT, to allow lexical
-# scoping of this pragma. -- rgs 2002-04-30
+# The hints for pp_sort are now stored in $^H{sort}; older versions
+# of perl used the global variable $sort::hints. -- rjh 2005-12-19
 
-our $hints	       = 0;
+$sort::hint_bits = 0x04020000; # HINT_LOCALIZE_HH | HINT_HH_FOR_EVAL
 
 $sort::quicksort_bit   = 0x00000001;
 $sort::mergesort_bit   = 0x00000002;
@@ -24,22 +22,24 @@ sub import {
     }
     local $_;
     no warnings 'uninitialized';	# bitops would warn
+    $^H{sort} //= 0;
     while ($_ = shift(@_)) {
 	if (/^_q(?:uick)?sort$/) {
-	    $hints &= ~$sort::sort_bits;
-	    $hints |=  $sort::quicksort_bit;
+	    $^H{sort} &= ~$sort::sort_bits;
+	    $^H{sort} |=  $sort::quicksort_bit;
 	} elsif ($_ eq '_mergesort') {
-	    $hints &= ~$sort::sort_bits;
-	    $hints |=  $sort::mergesort_bit;
+	    $^H{sort} &= ~$sort::sort_bits;
+	    $^H{sort} |=  $sort::mergesort_bit;
 	} elsif ($_ eq 'stable') {
-	    $hints |=  $sort::stable_bit;
+	    $^H{sort} |=  $sort::stable_bit;
 	} elsif ($_ eq 'defaults') {
-	    $hints =   0;
+	    $^H{sort} =   0;
 	} else {
 	    require Carp;
 	    Carp::croak("sort: unknown subpragma '$_'");
 	}
     }
+    $^H |= $sort::hint_bits;
 }
 
 sub unimport {
@@ -52,11 +52,11 @@ sub unimport {
     no warnings 'uninitialized';	# bitops would warn
     while ($_ = shift(@_)) {
 	if (/^_q(?:uick)?sort$/) {
-	    $hints &= ~$sort::sort_bits;
+	    $^H{sort} &= ~$sort::sort_bits;
 	} elsif ($_ eq '_mergesort') {
-	    $hints &= ~$sort::sort_bits;
+	    $^H{sort} &= ~$sort::sort_bits;
 	} elsif ($_ eq 'stable') {
-	    $hints &= ~$sort::stable_bit;
+	    $^H{sort} &= ~$sort::stable_bit;
 	} else {
 	    require Carp;
 	    Carp::croak("sort: unknown subpragma '$_'");
@@ -66,10 +66,10 @@ sub unimport {
 
 sub current {
     my @sort;
-    if ($hints) {
-	push @sort, 'quicksort' if $hints & $sort::quicksort_bit;
-	push @sort, 'mergesort' if $hints & $sort::mergesort_bit;
-	push @sort, 'stable'    if $hints & $sort::stable_bit;
+    if ($^H{sort}) {
+	push @sort, 'quicksort' if $^H{sort} & $sort::quicksort_bit;
+	push @sort, 'mergesort' if $^H{sort} & $sort::mergesort_bit;
+	push @sort, 'stable'    if $^H{sort} & $sort::stable_bit;
     }
     push @sort, 'mergesort' unless @sort;
     join(' ', @sort);
@@ -92,7 +92,10 @@ sort - perl pragma to control sort() behaviour
 
     use sort '_qsort';		# alias for quicksort
 
-    my $current = sort::current();	# identify prevailing algorithm
+    my $current;
+    BEGIN {
+	$current = sort::current();	# identify prevailing algorithm
+    }
 
 =head1 DESCRIPTION
 
@@ -152,50 +155,46 @@ have exactly the same effect, leaving the choice of sort algorithm open.
 
 =head1 CAVEATS
 
-This pragma is not lexically scoped: its effect is global to the program
-it appears in.  That means the following will probably not do what you
-expect, because I<both> pragmas take effect at compile time, before
-I<either> C<sort()> happens.
+As of Perl 5.10, this pragma is lexically scoped and takes effect
+at compile time. In earlier versions its effect was global and took
+effect at run-time; the documentation suggested using C<eval()> to
+change the behaviour:
 
-  { use sort "_quicksort";
+  { eval 'use sort qw(defaults _quicksort)'; # force quicksort
+    eval 'no sort "stable"';      # stability not wanted
     print sort::current . "\n";
     @a = sort @b;
+    eval 'use sort "defaults"';   # clean up, for others
   }
-  { use sort "stable";
+  { eval 'use sort qw(defaults stable)';     # force stability
     print sort::current . "\n";
     @c = sort @d;
+    eval 'use sort "defaults"';   # clean up, for others
   }
-  # prints:
-  # quicksort stable
-  # quicksort stable
 
-You can achieve the effect you probably wanted by using C<eval()>
-to defer the pragmas until run time.  Use the quoted argument
-form of C<eval()>, I<not> the BLOCK form, as in
+Such code no longer has the desired effect, for two reasons.
+Firstly, the use of C<eval()> means that the sorting algorithm
+is not changed until runtime, by which time it's too late to
+have any effect. Secondly, C<sort::current> is also called at
+run-time, when in fact the compile-time value of C<sort::current>
+is the one that matters.
 
-  eval { use sort "_quicksort" }; # WRONG
+So now this code would be written:
 
-or the effect will still be at compile time.
-Reset to default options before selecting other subpragmas
-(in case somebody carelessly left them on) and after sorting,
-as a courtesy to others.
-
-  { eval 'use sort qw(defaults _quicksort)'; # force quicksort
-    eval 'no sort "stable"';      # stability not wanted
-    print sort::current . "\n";
+  { use sort qw(defaults _quicksort); # force quicksort
+    no sort "stable";      # stability not wanted
+    my $current;
+    BEGIN { $current = print sort::current; }
+    print "$current\n";
     @a = sort @b;
-    eval 'use sort "defaults"';   # clean up, for others
+    # Pragmas go out of scope at the end of the block
   }
-  { eval 'use sort qw(defaults stable)';     # force stability
-    print sort::current . "\n";
+  { use sort qw(defaults stable);     # force stability
+    my $current;
+    BEGIN { $current = print sort::current; }
+    print "$current\n";
     @c = sort @d;
-    eval 'use sort "defaults"';   # clean up, for others
   }
-  # prints:
-  # quicksort
-  # stable
-
-Scoping for this pragma may change in future versions.
 
 =cut
 
diff --git a/lib/sort.t b/lib/sort.t
index 8828083066..62c5529c21 100644
--- a/lib/sort.t
+++ b/lib/sort.t
@@ -99,7 +99,7 @@ sub checkequal {
 # Test sort on arrays of various sizes (set up in @TestSizes)
 
 sub main {
-    my ($expect_unstable) = @_;
+    my ($dothesort, $expect_unstable) = @_;
     my ($ts, $unsorted, @sorted, $status);
     my $unstable_num = 0;
 
@@ -108,9 +108,9 @@ sub main {
 	# Sort only on item portion of each element.
 	# There will typically be many repeated items,
 	# and their order had better be preserved.
-	@sorted = sort { substr($a, 0, $RootWidth)
+	@sorted = $dothesort->(sub { substr($a, 0, $RootWidth)
 				    cmp
-	                 substr($b, 0, $RootWidth) } @$unsorted;
+	                 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.
@@ -119,9 +119,9 @@ sub main {
 	    ++$unstable_num;
 	}
 	is($status, '', "order ok for size $ts");
-	@sorted = sort { substr($a, $RootWidth)
+	@sorted = $dothesort->(sub { substr($a, $RootWidth)
 				    cmp
-	                 substr($b, $RootWidth) } @sorted;
+			    substr($b, $RootWidth) }, \@sorted);
 	$status = checkequal(\@sorted, $unsorted);
 	is($status, '', "contents ok for size $ts");
     }
@@ -133,51 +133,46 @@ sub main {
 }
 
 # Test with no pragma still loaded -- stability expected (this is a mergesort)
-main(0);
+main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);
 
-# XXX We're using this eval "..." trick to force recompilation,
-# to ensure that the correct pragma is enabled when main() is run.
-# Currently 'use sort' modifies $sort::hints at compile-time, but
-# pp_sort() fetches its value at run-time.
-# The order of those evals is important.
-
-eval q{
+{
     use sort qw(_qsort);
-    is(sort::current(), 'quicksort', 'sort::current for _qsort');
-    main(1);
-};
-die $@ if $@;
+    my $sort_current; BEGIN { $sort_current = sort::current(); }
+    is($sort_current, 'quicksort', 'sort::current for _qsort');
+    main(sub { sort {&{$_[0]}} @{$_[1]} }, 1);
+}
 
-eval q{
+{
     use sort qw(_mergesort);
-    is(sort::current(), 'mergesort', 'sort::current for _mergesort');
-    main(0);
-};
-die $@ if $@;
+    my $sort_current; BEGIN { $sort_current = sort::current(); }
+    is($sort_current, 'mergesort', 'sort::current for _mergesort');
+    main(sub { sort {&{$_[0]}} @{$_[1]} }, 0);
+}
 
-eval q{
+{
     use sort qw(_qsort stable);
-    is(sort::current(), 'quicksort stable', 'sort::current for _qsort stable');
-    main(0);
-};
-die $@ if $@;
+    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"
 
-eval q{
+{
+    use sort qw(_qsort stable);
     no sort qw(_qsort);
-    is(sort::current(), 'stable', 'sort::current after no _qsort');
-};
-die $@ if $@;
+    my $sort_current; BEGIN { $sort_current = sort::current(); }
+    is($sort_current, 'stable', 'sort::current after no _qsort');
+}
 
-eval q{
+{
     use sort qw(defaults _qsort);
-    is(sort::current(), 'quicksort', 'sort::current after defaults _qsort');
-};
-die $@ if $@;
+    my $sort_current; BEGIN { $sort_current = sort::current(); }
+    is($sort_current, 'quicksort', 'sort::current after defaults _qsort');
+}
 
-eval q{
+{
     use sort qw(defaults stable);
-    is(sort::current(), 'stable', 'sort::current after defaults stable');
-};
-die $@ if $@;
+    my $sort_current; BEGIN { $sort_current = sort::current(); }
+    is($sort_current, 'stable', 'sort::current after defaults stable');
+}