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
#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
$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"
use Carp;
use Test::More tests => ( 1 * !!$Config::Config{useithreads}
+ 3 * ($] > 5.009)
- + 12 * ($] >= 5.009003)
+ + 14 * ($] >= 5.009003)
+ 777 );
require_ok("B::Concise");
# 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
# 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
Perl_mess
Perl_vmess
Perl_sortsv
+Perl_sortsv_flags
Perl_mg_clear
Perl_mg_copy
Perl_mg_find
# (feature name) => (internal name, used in %^H)
my %feature = (
- switch => 'switch',
- "~~" => "~~",
- say => "say",
+ switch => 'feature_switch',
+ "~~" => "feature_~~",
+ say => "feature_say",
);
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;
}
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 {
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 '$_'");
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);
use sort '_qsort'; # alias for quicksort
- my $current = sort::current(); # identify prevailing algorithm
+ my $current;
+ BEGIN {
+ $current = sort::current(); # identify prevailing algorithm
+ }
=head1 DESCRIPTION
=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
# 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;
# 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.
++$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");
}
}
# 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');
+}
{
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 */
#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 */
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
#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>.
*
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;
/* sort, with indirection */
S_qsortsvu(aTHX_ (gptr *)indir, nmemb,
- flags ? cmpindir_desc : cmpindir);
+ ((flags & SORTf_DESC) != 0 ? cmpindir_desc : cmpindir));
pp = indir;
q = list1;
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;
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
*/
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))
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);
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 */
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);
? ( 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;
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);
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));
}
/*
projects / p5sagit/p5-mst-13.2.git / commitdiff