This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Re: [PATCH] Make the 'sort' pragma lexically scoped
authorRobin Houston <robin@cpan.org>
Mon, 19 Dec 2005 18:46:00 +0000 (18:46 +0000)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Mon, 19 Dec 2005 18:17:19 +0000 (18:17 +0000)
Message-ID: <20051219174620.GA17940@rpc142.cs.man.ac.uk>

p4raw-id: //depot/perl@26402

15 files changed:
embed.fnc
embed.h
ext/B/B/Concise.pm
ext/B/t/concise-xs.t
ext/B/t/f_sort.t
global.sym
lib/feature.pm
lib/sort.pm
lib/sort.t
op.c
op.h
pod/perlapi.pod
pp_sort.c
proto.h
toke.c

index eb19e98..ccc1500 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -453,6 +453,7 @@ Afp |SV*    |mess           |NN const char* pat|...
 Ap     |SV*    |vmess          |NN const char* pat|NULLOK va_list* args
 p      |void   |qerror         |NN SV* err
 Apd    |void   |sortsv         |NN SV** array|size_t num_elts|SVCOMPARE_t cmp
+Apd    |void   |sortsv_flags   |NN SV** array|size_t num_elts|SVCOMPARE_t cmp|U32 flags
 Apd    |int    |mg_clear       |NN SV* sv
 Apd    |int    |mg_copy        |NN SV* sv|NN SV* nsv|NULLOK const char* key|I32 klen
 pd     |void   |mg_localize    |NN SV* sv|NN SV* nsv
diff --git a/embed.h b/embed.h
index 9788e82..c2242cb 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define qerror                 Perl_qerror
 #endif
 #define sortsv                 Perl_sortsv
+#define sortsv_flags           Perl_sortsv_flags
 #define mg_clear               Perl_mg_clear
 #define mg_copy                        Perl_mg_copy
 #ifdef PERL_CORE
 #define qerror(a)              Perl_qerror(aTHX_ a)
 #endif
 #define sortsv(a,b,c)          Perl_sortsv(aTHX_ a,b,c)
+#define sortsv_flags(a,b,c,d)  Perl_sortsv_flags(aTHX_ a,b,c,d)
 #define mg_clear(a)            Perl_mg_clear(aTHX_ a)
 #define mg_copy(a,b,c,d)       Perl_mg_copy(aTHX_ a,b,c,d)
 #ifdef PERL_CORE
index c84578e..9b44b05 100644 (file)
@@ -590,16 +590,14 @@ $priv{"flip"}{64} = $priv{"flop"}{64} = "LINENUM";
 $priv{"list"}{64} = "GUESSED";
 $priv{"delete"}{64} = "SLICE";
 $priv{"exists"}{64} = "SUB";
-$priv{$_}{64} = "LOCALE"
-  for ("sort", "prtf", "sprintf", "slt", "sle", "seq", "sne", "sgt", "sge",
-       "scmp", "lc", "uc", "lcfirst", "ucfirst");
-@{$priv{"sort"}}{1,2,4,8,16} = ("NUM", "INT", "REV", "INPLACE","DESC");
+@{$priv{"sort"}}{1,2,4,8,16,32,64} = ("NUM", "INT", "REV", "INPLACE","DESC","QSORT","STABLE");
 $priv{"threadsv"}{64} = "SVREFd";
 @{$priv{$_}}{16,32,64,128} = ("INBIN","INCR","OUTBIN","OUTCR")
   for ("open", "backtick");
 $priv{"exit"}{128} = "VMS";
 $priv{$_}{2} = "FTACCESS"
   for ("ftrread", "ftrwrite", "ftrexec", "fteread", "ftewrite", "fteexec");
+$priv{"entereval"}{2} = "HAS_HH";
 if ($] >= 5.009) {
   # Stacked filetests are post 5.8.x
   $priv{$_}{4} = "FTSTACKED"
index fe45773..0ac1aea 100644 (file)
@@ -94,7 +94,7 @@ use Getopt::Std;
 use Carp;
 use Test::More tests => ( 1 * !!$Config::Config{useithreads}
                          + 3 * ($] > 5.009)
-                         + 12 * ($] >= 5.009003)
+                         + 14 * ($] >= 5.009003)
                          + 777 );
 
 require_ok("B::Concise");
index ccd7d8d..513c2e2 100644 (file)
@@ -675,7 +675,7 @@ checkOptree(note   => q{},
 # 3  <0> pushmark s
 # 4  <#> gv[*old] s
 # 5  <1> rv2av[t9] lK/1
-# 6  <@> sort lKS*
+# 6  <@> sort lKS*/STABLE
 # 7  <0> pushmark s
 # 8  <#> gv[*new] s
 # 9  <1> rv2av[t2] lKRM*/1
@@ -687,7 +687,7 @@ EOT_EOT
 # 3  <0> pushmark s
 # 4  <$> gv(*old) s
 # 5  <1> rv2av[t5] lK/1
-# 6  <@> sort lKS*
+# 6  <@> sort lKS*/STABLE
 # 7  <0> pushmark s
 # 8  <$> gv(*new) s
 # 9  <1> rv2av[t1] lKRM*/1
index eb73405..376f23e 100644 (file)
@@ -242,6 +242,7 @@ Perl_markstack_grow
 Perl_mess
 Perl_vmess
 Perl_sortsv
+Perl_sortsv_flags
 Perl_mg_clear
 Perl_mg_copy
 Perl_mg_find
index e0981d0..fe54994 100644 (file)
@@ -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",
 );
 
 
index e785003..e8d6446 100644 (file)
@@ -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
 
index 8828083..62c5529 100644 (file)
@@ -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');
+}
diff --git a/op.c b/op.c
index fc1c6a8..3dd0cdb 100644 (file)
--- a/op.c
+++ b/op.c
@@ -6231,6 +6231,21 @@ Perl_ck_sort(pTHX_ OP *o)
 {
     OP *firstkid;
 
+    if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
+    {
+       HV *hinthv = GvHV(PL_hintgv);
+       if (hinthv) {
+           SV **svp = hv_fetch(hinthv, "sort", 4, 0);
+           if (svp) {
+               I32 sorthints = (I32)SvIV(*svp);
+               if ((sorthints & HINT_SORT_QUICKSORT) != 0)
+                   o->op_private |= OPpSORT_QSORT;
+               if ((sorthints & HINT_SORT_STABLE) != 0)
+                   o->op_private |= OPpSORT_STABLE;
+           }
+       }
+    }
+
     if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
        simplify_sort(o);
     firstkid = cLISTOPo->op_first->op_sibling;         /* get past pushmark */
diff --git a/op.h b/op.h
index e687f42..d973a6f 100644 (file)
--- a/op.h
+++ b/op.h
@@ -215,6 +215,9 @@ Deprecated.  Use C<GIMME_V> instead.
 #define OPpSORT_REVERSE                4       /* Reversed sort */
 #define OPpSORT_INPLACE                8       /* sort in-place; eg @a = sort @a */
 #define OPpSORT_DESCEND                16      /* Descending sort */
+#define OPpSORT_QSORT          32      /* Use quicksort (not mergesort) */
+#define OPpSORT_STABLE         64      /* Use a stable algorithm */
+
 /* Private for OP_THREADSV */
 #define OPpDONE_SVREF          64      /* Been through newSVREF once */
 
index 2f701e5..2931da4 100644 (file)
@@ -317,13 +317,24 @@ Sort an array. Here is an example:
 
     sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale);
 
-See lib/sort.pm for details about controlling the sorting algorithm.
+Currently this always uses mergesort. See sortsv_flags for a more
+flexible routine.
 
        void    sortsv(SV** array, size_t num_elts, SVCOMPARE_t cmp)
 
 =for hackers
 Found in file pp_sort.c
 
+=item sortsv_flags
+X<sortsv_flags>
+
+Sort an array, with various options.
+
+       void    sortsv_flags(SV** array, size_t num_elts, SVCOMPARE_t cmp, U32 flags)
+
+=for hackers
+Found in file pp_sort.c
+
 
 =back
 
index 652d12a..1be5dce 100644 (file)
--- a/pp_sort.c
+++ b/pp_sort.c
 #define sv_cmp_static Perl_sv_cmp
 #define sv_cmp_locale_static Perl_sv_cmp_locale
 
-#define dSORTHINTS   SV *hintsv = GvSV(gv_fetchpv("sort::hints", GV_ADDMULTI, SVt_IV))
-#define SORTHINTS    (SvIOK(hintsv) ? ((I32)SvIV(hintsv)) : 0)
-
 #ifndef SMALLSORT
 #define        SMALLSORT (200)
 #endif
 
+/* Flags for qsortsv and mergesortsv */
+#define SORTf_DESC   1
+#define SORTf_STABLE 2
+#define SORTf_QSORT  4
+
 /*
  * The mergesort implementation is by Peter M. Mcilroy <pmcilroy@lucent.com>.
  *
@@ -1339,10 +1341,7 @@ cmpindir_desc(pTHX_ gptr a, gptr b)
 STATIC void
 S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
 {
-
-    dSORTHINTS;
-
-    if (SORTHINTS & HINT_SORT_STABLE) {
+    if ((flags & SORTf_STABLE) != 0) {
         register gptr **pp, *q;
         register size_t n, j, i;
         gptr *small[SMALLSORT], **indir, tmp;
@@ -1361,7 +1360,7 @@ S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
 
         /* sort, with indirection */
         S_qsortsvu(aTHX_ (gptr *)indir, nmemb,
-                   flags ? cmpindir_desc : cmpindir);
+                   ((flags & SORTf_DESC) != 0 ? cmpindir_desc : cmpindir));
 
         pp = indir;
         q = list1;
@@ -1404,7 +1403,7 @@ S_qsortsv(pTHX_ gptr *list1, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
         if (indir != small) { Safefree(indir); }
         /* restore prevailing comparison routine */
         PL_sort_RealCmp = savecmp;
-    } else if (flags) {
+    } else if ((flags & SORTf_DESC) != 0) {
         SVCOMPARE_t savecmp = PL_sort_RealCmp; /* Save current comparison routine, if any */
         PL_sort_RealCmp = cmp; /* Put comparison routine where cmp_desc can find it */
         cmp = cmp_desc;
@@ -1425,7 +1424,8 @@ Sort an array. Here is an example:
 
     sortsv(AvARRAY(av), av_len(av)+1, Perl_sv_cmp_locale);
 
-See lib/sort.pm for details about controlling the sorting algorithm.
+Currently this always uses mergesort. See sortsv_flags for a more
+flexible routine.
 
 =cut
 */
@@ -1433,38 +1433,23 @@ See lib/sort.pm for details about controlling the sorting algorithm.
 void
 Perl_sortsv(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
 {
-    void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
-      = S_mergesortsv;
-    dSORTHINTS;
-    const I32 hints = SORTHINTS;
-    if (hints & HINT_SORT_QUICKSORT) {
-       sortsvp = S_qsortsv;
-    }
-    else {
-       /* The default as of 5.8.0 is mergesort */
-       sortsvp = S_mergesortsv;
-    }
-
-    sortsvp(aTHX_ array, nmemb, cmp, 0);
+    sortsv_flags(array, nmemb, cmp, 0);
 }
 
+/*
+=for apidoc sortsv_flags
 
-static void
-S_sortsv_desc(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
+Sort an array, with various options.
+
+=cut
+*/
+void
+Perl_sortsv_flags(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
 {
     void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
-      = S_mergesortsv;
-    dSORTHINTS;
-    const I32 hints = SORTHINTS;
-    if (hints & HINT_SORT_QUICKSORT) {
-       sortsvp = S_qsortsv;
-    }
-    else {
-       /* The default as of 5.8.0 is mergesort */
-       sortsvp = S_mergesortsv;
-    }
+      = ((flags & SORTf_QSORT) != 0 ? S_qsortsv : S_mergesortsv);
 
-    sortsvp(aTHX_ array, nmemb, cmp, 1);
+    sortsvp(aTHX_ array, nmemb, cmp, flags);
 }
 
 #define SvNSIOK(sv) ((SvFLAGS(sv) & SVf_NOK) || ((SvFLAGS(sv) & (SVf_IOK|SVf_IVisUV)) == SVf_IOK))
@@ -1488,10 +1473,18 @@ PP(pp_sort)
     I32 sorting_av = 0;
     const U8 priv = PL_op->op_private;
     const U8 flags = PL_op->op_flags;
-    void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp)
-      = Perl_sortsv;
+    U32 sort_flags = 0;
+    void (*sortsvp)(pTHX_ SV **array, size_t nmemb, SVCOMPARE_t cmp, U32 flags)
+      = Perl_sortsv_flags;
     I32 all_SIVs = 1;
 
+    if ((priv & OPpSORT_DESCEND) != 0)
+       sort_flags |= SORTf_DESC;
+    if ((priv & OPpSORT_QSORT) != 0)
+       sort_flags |= SORTf_QSORT;
+    if ((priv & OPpSORT_STABLE) != 0)
+       sort_flags |= SORTf_STABLE;
+
     if (gimme != G_ARRAY) {
        SP = MARK;
        EXTEND(SP,1);
@@ -1572,10 +1565,6 @@ PP(pp_sort)
        max = SP - MARK;
    }
 
-    if (priv & OPpSORT_DESCEND) {
-       sortsvp = S_sortsv_desc;
-    }
-
     /* shuffle stack down, removing optional initial cv (p1!=p2), plus
      * any nulls; also stringify or converting to integer or number as
      * required any args */
@@ -1675,7 +1664,8 @@ PP(pp_sort)
            
            start = p1 - max;
            sortsvp(aTHX_ start, max,
-                   is_xsub ? S_sortcv_xsub : hasargs ? S_sortcv_stacked : S_sortcv);
+                   (is_xsub ? S_sortcv_xsub : hasargs ? S_sortcv_stacked : S_sortcv),
+                   sort_flags);
 
            if (!(flags & OPf_SPECIAL)) {
                LEAVESUB(cv);
@@ -1699,9 +1689,10 @@ PP(pp_sort)
                            ? ( overloading
                                ? S_amagic_cmp_locale
                                : sv_cmp_locale_static)
-                           : ( overloading ? S_amagic_cmp : sv_cmp_static)));
+                           : ( overloading ? S_amagic_cmp : sv_cmp_static)),
+                   sort_flags);
        }
-       if (priv & OPpSORT_REVERSE) {
+       if ((priv & OPpSORT_REVERSE) != 0) {
            SV **q = start+max-1;
            while (start < q) {
                SV * const tmp = *start;
diff --git a/proto.h b/proto.h
index 6106bb7..f1922a3 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1246,6 +1246,9 @@ PERL_CALLCONV void        Perl_qerror(pTHX_ SV* err)
 PERL_CALLCONV void     Perl_sortsv(pTHX_ SV** array, size_t num_elts, SVCOMPARE_t cmp)
                        __attribute__nonnull__(pTHX_1);
 
+PERL_CALLCONV void     Perl_sortsv_flags(pTHX_ SV** array, size_t num_elts, SVCOMPARE_t cmp, U32 flags)
+                       __attribute__nonnull__(pTHX_1);
+
 PERL_CALLCONV int      Perl_mg_clear(pTHX_ SV* sv)
                        __attribute__nonnull__(pTHX_1);
 
diff --git a/toke.c b/toke.c
index ceb521f..1b07e56 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -468,7 +468,10 @@ STATIC bool
 S_feature_is_enabled(pTHX_ char *name, STRLEN namelen)
 {
     HV * const hinthv = GvHV(PL_hintgv);
-    return (hinthv && hv_exists(hinthv, name, namelen));
+    char he_name[32] = "feature_";
+    (void) strncpy(&he_name[8], name, 24);
+    
+    return (hinthv && hv_exists(hinthv, he_name, 8 + namelen));
 }
 
 /*