Robert Sanders <Robert.Sanders@linux.org>
Robert Spier <rspier@pobox.com>
Robin Barker <RMBarker@cpan.org>
-Robin Houston <robin@kitsite.com>
+Robin Houston <robin@cpan.org>
Rocco Caputo <troc@netrus.net>
Roderick Schertler <roderick@argon.org>
Rodger Anderson <rodger@boi.hp.com>
ext/List/Util/lib/List/Util.pm List::Util
ext/List/Util/lib/Scalar/Util.pm Scalar::Util
ext/List/Util/Makefile.PL Util extension
+ext/List/Util/multicall.h Util extension
ext/List/Util/README Util extension
ext/List/Util/t/blessed.t Scalar::Util
ext/List/Util/t/dualvar.t Scalar::Util
#define CXt_BLOCK 5
#define CXt_FORMAT 6
+/* private flags for CXt_SUB and CXt_NULL */
+#define CXp_MULTICALL 0x00000400 /* part of a multicall (so don't
+ tear down context on exit). */
+
/* private flags for CXt_EVAL */
#define CXp_REAL 0x00000100 /* truly eval'', not a lookalike */
#define CXp_TRYBLOCK 0x00000200 /* eval{}, not eval'' or similar */
#endif
#define CxTYPE(c) ((c)->cx_type & CXTYPEMASK)
+#define CxMULTICALL(c) (((c)->cx_type & CXp_MULTICALL) \
+ == CXp_MULTICALL)
#define CxREALEVAL(c) (((c)->cx_type & (CXt_EVAL|CXp_REAL)) \
== (CXt_EVAL|CXp_REAL))
#define CxTRYBLOCK(c) (((c)->cx_type & (CXt_EVAL|CXp_TRYBLOCK)) \
#define IN_PERL_COMPILETIME (PL_curcop == &PL_compiling)
#define IN_PERL_RUNTIME (PL_curcop != &PL_compiling)
+/*
+=head1 Multicall Functions
+
+=for apidoc Ams||dMULTICALL
+Declare local variables for a multicall. See L<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||PUSH_MULTICALL
+Opening bracket for a lightweight callback.
+See L<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||MULTICALL
+Make a lightweight callback. See L<perlcall/Lightweight Callbacks>.
+
+=for apidoc Ams||POP_MULTICALL
+Closing bracket for a lightweight callback.
+See L<perlcall/Lightweight Callbacks>.
+
+=cut
+*/
+
+#define dMULTICALL \
+ SV **newsp; /* set by POPBLOCK */ \
+ PERL_CONTEXT *cx; \
+ CV *cv; \
+ OP *multicall_cop; \
+ bool multicall_oldcatch; \
+ U8 hasargs = 0 /* used by PUSHSUB */
+
+#define PUSH_MULTICALL \
+ STMT_START { \
+ AV* padlist = CvPADLIST(cv); \
+ ENTER; \
+ multicall_oldcatch = CATCH_GET; \
+ SAVETMPS; SAVEVPTR(PL_op); \
+ CATCH_SET(TRUE); \
+ PUSHBLOCK(cx, CXt_SUB|CXp_MULTICALL, PL_stack_sp); \
+ PUSHSUB(cx); \
+ if (++CvDEPTH(cv) >= 2) { \
+ PERL_STACK_OVERFLOW_CHECK(); \
+ Perl_pad_push(aTHX_ padlist, CvDEPTH(cv)); \
+ } \
+ SAVECOMPPAD(); \
+ PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv)); \
+ multicall_cop = CvSTART(cv); \
+ } STMT_END
+
+#define MULTICALL \
+ STMT_START { \
+ PL_op = multicall_cop; \
+ CALLRUNOPS(aTHX); \
+ } STMT_END
+
+#define POP_MULTICALL \
+ STMT_START { \
+ LEAVESUB(cv); \
+ CvDEPTH(cv)--; \
+ POPBLOCK(cx,PL_curpm); \
+ CATCH_SET(multicall_oldcatch); \
+ LEAVE; \
+ } STMT_END
pd |void |do_dump_pad |I32 level|NN PerlIO *file|NULLOK PADLIST *padlist|int full
pd |void |pad_fixup_inner_anons|NN PADLIST *padlist|NN CV *old_cv|NN CV *new_cv
-pd |void |pad_push |NN PADLIST *padlist|int depth
+pdX |void |pad_push |NN PADLIST *padlist|int depth
pR |HV* |pad_compname_type|const PADOFFSET po
#if defined(PERL_IN_PAD_C) || defined(PERL_DECL_PROT)
#define PL_screamnext (vTHX->Tscreamnext)
#define PL_secondgv (vTHX->Tsecondgv)
#define PL_sortcop (vTHX->Tsortcop)
-#define PL_sortcxix (vTHX->Tsortcxix)
#define PL_sortstash (vTHX->Tsortstash)
#define PL_stack_base (vTHX->Tstack_base)
#define PL_stack_max (vTHX->Tstack_max)
#define PL_Tscreamnext PL_screamnext
#define PL_Tsecondgv PL_secondgv
#define PL_Tsortcop PL_sortcop
-#define PL_Tsortcxix PL_sortcxix
#define PL_Tsortstash PL_sortstash
#define PL_Tstack_base PL_stack_base
#define PL_Tstack_max PL_stack_max
#include <perl.h>
#include <XSUB.h>
+#include "multicall.h"
+
#ifndef PERL_VERSION
# include <patchlevel.h>
# if !(defined(PERL_VERSION) || (SUBVERSION > 0 && defined(PATCHLEVEL)))
#define dVAR dNOOP
#endif
+#ifndef GvSVn
+# define GvSVn GvSV
+#endif
+
MODULE=List::Util PACKAGE=List::Util
void
PROTOTYPE: &@
CODE:
{
- dVAR;
+ dVAR; dMULTICALL;
SV *ret = sv_newmortal();
int index;
GV *agv,*bgv,*gv;
HV *stash;
- CV *cv;
- OP *reducecop;
- PERL_CONTEXT *cx;
- SV** newsp;
I32 gimme = G_SCALAR;
- U8 hasargs = 0;
- bool oldcatch = CATCH_GET;
+ SV **args = &PL_stack_base[ax];
if(items <= 1) {
XSRETURN_UNDEF;
}
+ cv = sv_2cv(block, &stash, &gv, 0);
+ PUSH_MULTICALL;
agv = gv_fetchpv("a", TRUE, SVt_PV);
bgv = gv_fetchpv("b", TRUE, SVt_PV);
SAVESPTR(GvSV(agv));
SAVESPTR(GvSV(bgv));
GvSV(agv) = ret;
- cv = sv_2cv(block, &stash, &gv, 0);
- reducecop = CvSTART(cv);
- SAVESPTR(CvROOT(cv)->op_ppaddr);
- CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
-#ifdef PAD_SET_CUR
- PAD_SET_CUR(CvPADLIST(cv),1);
-#else
- SAVESPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
-#endif
- SAVETMPS;
- SAVESPTR(PL_op);
- SvSetSV(ret, ST(1));
- CATCH_SET(TRUE);
- PUSHBLOCK(cx, CXt_SUB, SP);
- PUSHSUB(cx);
+ SvSetSV(ret, args[1]);
for(index = 2 ; index < items ; index++) {
- GvSV(bgv) = ST(index);
- PL_op = reducecop;
- CALLRUNOPS(aTHX);
+ GvSV(bgv) = args[index];
+ MULTICALL;
SvSetSV(ret, *PL_stack_sp);
}
+ POP_MULTICALL;
ST(0) = ret;
- POPBLOCK(cx,PL_curpm);
- CATCH_SET(oldcatch);
XSRETURN(1);
}
PROTOTYPE: &@
CODE:
{
- dVAR;
+ dVAR; dMULTICALL;
int index;
GV *gv;
HV *stash;
- CV *cv;
- OP *reducecop;
- PERL_CONTEXT *cx;
- SV** newsp;
I32 gimme = G_SCALAR;
- U8 hasargs = 0;
- bool oldcatch = CATCH_GET;
+ SV **args = &PL_stack_base[ax];
if(items <= 1) {
XSRETURN_UNDEF;
}
- SAVESPTR(GvSV(PL_defgv));
cv = sv_2cv(block, &stash, &gv, 0);
- reducecop = CvSTART(cv);
- SAVESPTR(CvROOT(cv)->op_ppaddr);
- CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
-#ifdef PAD_SET_CUR
- PAD_SET_CUR(CvPADLIST(cv),1);
-#else
- SAVESPTR(PL_curpad);
- PL_curpad = AvARRAY((AV*)AvARRAY(CvPADLIST(cv))[1]);
-#endif
- SAVETMPS;
- SAVESPTR(PL_op);
- CATCH_SET(TRUE);
- PUSHBLOCK(cx, CXt_SUB, SP);
- PUSHSUB(cx);
+ PUSH_MULTICALL;
+ SAVESPTR(GvSV(PL_defgv));
for(index = 1 ; index < items ; index++) {
- GvSV(PL_defgv) = ST(index);
- PL_op = reducecop;
- CALLRUNOPS(aTHX);
+ GvSV(PL_defgv) = args[index];
+ MULTICALL;
if (SvTRUE(*PL_stack_sp)) {
+ POP_MULTICALL;
ST(0) = ST(index);
- POPBLOCK(cx,PL_curpm);
- CATCH_SET(oldcatch);
XSRETURN(1);
}
}
- POPBLOCK(cx,PL_curpm);
- CATCH_SET(oldcatch);
+ POP_MULTICALL;
XSRETURN_UNDEF;
}
BOOT:
{
+ HV *lu_stash = gv_stashpvn("List::Util", 10, TRUE);
+ GV *rmcgv = *(GV**)hv_fetch(lu_stash, "REAL_MULTICALL", 14, TRUE);
+ SV *rmcsv;
#if !defined(SvWEAKREF) || !defined(SvVOK)
- HV *stash = gv_stashpvn("Scalar::Util", 12, TRUE);
- GV *vargv = *(GV**)hv_fetch(stash, "EXPORT_FAIL", 11, TRUE);
+ HV *su_stash = gv_stashpvn("Scalar::Util", 12, TRUE);
+ GV *vargv = *(GV**)hv_fetch(su_stash, "EXPORT_FAIL", 11, TRUE);
AV *varav;
if (SvTYPE(vargv) != SVt_PVGV)
- gv_init(vargv, stash, "Scalar::Util", 12, TRUE);
+ gv_init(vargv, su_stash, "Scalar::Util", 12, TRUE);
varav = GvAVn(vargv);
#endif
+ if (SvTYPE(rmcgv) != SVt_PVGV)
+ gv_init(rmcgv, lu_stash, "List::Util", 12, TRUE);
+ rmcsv = GvSVn(rmcgv);
#ifndef SvWEAKREF
av_push(varav, newSVpv("weaken",6));
av_push(varav, newSVpv("isweak",6));
#ifndef SvVOK
av_push(varav, newSVpv("isvstring",9));
#endif
+#ifdef REAL_MULTICALL
+ sv_setsv(rmcsv, &PL_sv_yes);
+#else
+ sv_setsv(rmcsv, &PL_sv_no);
+#endif
}
@ISA = qw(Exporter);
@EXPORT_OK = qw(first min max minstr maxstr reduce sum shuffle);
-$VERSION = "1.17";
+$VERSION = "1.18";
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@ISA = qw(Exporter);
@EXPORT_OK = qw(blessed dualvar reftype weaken isweak tainted readonly openhandle refaddr isvstring looks_like_number set_prototype);
-$VERSION = "1.17";
+$VERSION = "1.18";
$VERSION = eval $VERSION;
sub export_fail {
sub refaddr($) {
my $pkg = ref($_[0]) or return undef;
- bless $_[0], 'Scalar::Util::Fake';
+ if (blessed($_[0])) {
+ bless $_[0], 'Scalar::Util::Fake';
+ }
+ else {
+ $pkg = undef;
+ }
"$_[0]" =~ /0x(\w+)/;
my $i = do { local $^W; hex $1 };
- bless $_[0], $pkg;
+ bless $_[0], $pkg if defined $pkg;
$i;
}
}
}
-use Test::More tests => 8;
use List::Util qw(first);
+use Test::More;
+plan tests => ($::PERL_ONLY ? 15 : 17);
my $v;
ok(defined &first, 'defined');
($v) = foobar();
is($v, undef, 'wantarray');
+# Can we leave the sub with 'return'?
+$v = first {return ($_>6)} 2,4,6,12;
+is($v, 12, 'return');
+# ... even in a loop?
+$v = first {while(1) {return ($_>6)} } 2,4,6,12;
+is($v, 12, 'return from loop');
+
+# Does it work from another package?
+{ package Foo;
+ ::is(List::Util::first(sub{$_>4},(1..4,24)), 24, 'other package');
+}
+
+# Can we undefine a first sub while it's running?
+sub self_immolate {undef &self_immolate; 1}
+eval { $v = first \&self_immolate, 1,2; };
+like($@, qr/^Can't undef active subroutine/, "undef active sub");
+
+# Redefining an active sub should not fail, but whether the
+# redefinition takes effect immediately depends on whether we're
+# running the Perl or XS implementation.
+
+sub self_updating { local $^W; *self_updating = sub{1} ;1}
+eval { $v = first \&self_updating, 1,2; };
+is($@, '', 'redefine self');
+
+{ my $failed = 0;
+
+ sub rec { my $n = shift;
+ if (!defined($n)) { # No arg means we're being called by first()
+ return 1; }
+ if ($n<5) { rec($n+1); }
+ else { $v = first \&rec, 1,2; }
+ $failed = 1 if !defined $n;
+ }
+
+ rec(1);
+ ok(!$failed, 'from active sub');
+}
+
+# Calling a sub from first should leave its refcount unchanged.
+SKIP: {
+ skip("No Internals::SvREFCNT", 1) if !defined &Internals::SvREFCNT;
+ sub huge {$_>1E6}
+ my $refcnt = &Internals::SvREFCNT(\&huge);
+ $v = first \&huge, 1..6;
+ is(&Internals::SvREFCNT(\&huge), $refcnt, "Refcount unchanged");
+}
+
+# The remainder of the tests are only relevant for the XS
+# implementation. The Perl-only implementation behaves differently
+# (and more flexibly) in a way that we can't emulate from XS.
+if (!$::PERL_ONLY) { SKIP: {
+
+ skip("Poor man's MULTICALL can't cope", 2)
+ if !$List::Util::REAL_MULTICALL;
+
+ # Can we goto a label from the 'first' sub?
+ eval {()=first{goto foo} 1,2; foo: 1};
+ like($@, qr/^Can't "goto" out of a pseudo block/, "goto label");
+
+ # Can we goto a subroutine?
+ eval {()=first{goto sub{}} 1,2;};
+ like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub");
+
+} }
sub List::Util::bootstrap {}
(my $f = __FILE__) =~ s/p_//;
+$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once!
do $f;
sub List::Util::bootstrap {}
(my $f = __FILE__) =~ s/p_//;
+$::PERL_ONLY = $::PERL_ONLY = 1; # Mustn't use it only once!
do $f;
# force perl-only version to be tested
sub List::Util::bootstrap {}
-BEGIN {
- unless (-d 'blib') {
- chdir 't' if -d 't';
- @INC = '../lib';
- require Config; import Config;
- keys %Config; # Silence warning
- if ($Config{extensions} !~ /\bList\/Util\b/) {
- print "1..0 # Skip: List::Util was not built\n";
- exit 0;
- }
- }
-}
-
-use Test::More tests => 4;
-
-use Scalar::Util qw(tainted);
-
-ok( !tainted(1), 'constant number');
-
-my $var = 2;
-
-ok( !tainted($var), 'known variable');
-
-my $key = (keys %ENV)[0];
-
-ok( tainted($ENV{$key}), 'environment variable');
-
-$var = $ENV{$key};
-ok( tainted($var), 'copy of environment variable');
+(my $f = __FILE__) =~ s/p_//;
+do "./$f";
use List::Util qw(reduce min);
-use Test::More tests => 14;
+use Test::More;
+plan tests => ($::PERL_ONLY ? 21 : 23);
my $v = reduce {};
$v = reduce { $a * $b } 1,2,3;
is( $a, 8, 'restore $a');
is( $b, 9, 'restore $b');
+
+# Can we leave the sub with 'return'?
+$v = reduce {return $a+$b} 2,4,6;
+is($v, 12, 'return');
+
+# ... even in a loop?
+$v = reduce {while(1) {return $a+$b} } 2,4,6;
+is($v, 12, 'return from loop');
+
+# Does it work from another package?
+{ package Foo;
+ $a = $b;
+ ::is((List::Util::reduce {$a*$b} (1..4)), 24, 'other package');
+}
+
+# Can we undefine a reduce sub while it's running?
+sub self_immolate {undef &self_immolate; 1}
+eval { $v = reduce \&self_immolate, 1,2; };
+like($@, qr/^Can't undef active subroutine/, "undef active sub");
+
+# Redefining an active sub should not fail, but whether the
+# redefinition takes effect immediately depends on whether we're
+# running the Perl or XS implementation.
+
+sub self_updating { local $^W; *self_updating = sub{1} ;1 }
+eval { $v = reduce \&self_updating, 1,2; };
+is($@, '', 'redefine self');
+
+{ my $failed = 0;
+
+ sub rec { my $n = shift;
+ if (!defined($n)) { # No arg means we're being called by reduce()
+ return 1; }
+ if ($n<5) { rec($n+1); }
+ else { $v = reduce \&rec, 1,2; }
+ $failed = 1 if !defined $n;
+ }
+
+ rec(1);
+ ok(!$failed, 'from active sub');
+}
+
+# Calling a sub from reduce should leave its refcount unchanged.
+SKIP: {
+ skip("No Internals::SvREFCNT", 1) if !defined &Internals::SvREFCNT;
+ sub mult {$a*$b}
+ my $refcnt = &Internals::SvREFCNT(\&mult);
+ $v = reduce \&mult, 1..6;
+ is(&Internals::SvREFCNT(\&mult), $refcnt, "Refcount unchanged");
+}
+
+# The remainder of the tests are only relevant for the XS
+# implementation. The Perl-only implementation behaves differently
+# (and more flexibly) in a way that we can't emulate from XS.
+if (!$::PERL_ONLY) { SKIP: {
+
+ skip("Poor man's MULTICALL can't cope", 2)
+ if !$List::Util::REAL_MULTICALL;
+
+ # Can we goto a label from the reduction sub?
+ eval {()=reduce{goto foo} 1,2; foo: 1};
+ like($@, qr/^Can't "goto" out of a pseudo block/, "goto label");
+
+ # Can we goto a subroutine?
+ eval {()=reduce{goto sub{}} 1,2;};
+ like($@, qr/^Can't goto subroutine from a sort sub/, "goto sub");
+
+} }
}
-use Test::More tests => 19;
+use Test::More tests => 29;
use Scalar::Util qw(refaddr);
use vars qw($t $y $x *F $v $r);
my $n = "$r";
$n =~ /0x(\w+)/;
my $addr = do { local $^W; hex $1 };
+ my $before = ref($r);
is( refaddr($r), $addr, $n);
+ is( ref($r), $before, $n);
my $obj = bless $r, 'FooBar';
is( refaddr($r), $addr, "blessed with overload $n");
+ is( ref($r), 'FooBar', $n);
}
{
exit 0;
}
}
+ elsif(!grep {/blib/} @INC) {
+ unshift(@INC, qw(./inc ./blib/arch ./blib/lib));
+ }
}
use Test::More tests => 4;
PL_linestart
PL_modcount
PL_pending_ident
- PL_sortcxix
PL_sublex_info
PL_timesbuf
main
PL_linestart
PL_modcount
PL_pending_ident
- PL_sortcxix
PL_sublex_info
PL_timesbuf
PL_collation_ix
PL_linestart
PL_modcount
PL_pending_ident
- PL_sortcxix
PL_sublex_info
PL_timesbuf
main
SAVEFREESV(PL_compcv);
goto done;
}
- /* ahem, death to those who redefine active sort subs */
- if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
- Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
if (block) {
if (ckWARN(WARN_REDEFINE)
|| (CvCONST(cv)
pop pop ck_shift s% A?
shift shift ck_shift s% A?
unshift unshift ck_fun imsT@ A L
-sort sort ck_sort m@ C? L
+sort sort ck_sort dm@ C? L
reverse reverse ck_fun mt@ L
grepstart grep ck_grep dm@ C L
#define PL_secondgv (*Perl_Tsecondgv_ptr(aTHX))
#undef PL_sortcop
#define PL_sortcop (*Perl_Tsortcop_ptr(aTHX))
-#undef PL_sortcxix
-#define PL_sortcxix (*Perl_Tsortcxix_ptr(aTHX))
#undef PL_sortstash
#define PL_sortstash (*Perl_Tsortstash_ptr(aTHX))
#undef PL_stack_base
L<perlapi/eval_pv>). Once this code reference is in hand, it
can be mixed in with all the previous examples we've shown.
+=head1 LIGHTWEIGHT CALLBACKS
+
+Sometimes you need to invoke the same subroutine repeatedly.
+This usually happens with a function that acts on a list of
+values, such as Perl's built-in sort(). You can pass a
+comparison function to sort(), which will then be invoked
+for every pair of values that needs to be compared. The first()
+and reduce() functions from L<List::Util> follow a similar
+pattern.
+
+In this case it is possible to speed up the routine (often
+quite substantially) by using the lightweight callback API.
+The idea is that the calling context only needs to be
+created and destroyed once, and the sub can be called
+arbitrarily many times in between.
+
+It is usual to pass parameters using global variables -- typically
+$_ for one parameter, or $a and $b for two parameters -- rather
+than via @_. (It is possible to use the @_ mechanism if you know
+what you're doing, though there is as yet no supported API for
+it. It's also inherently slower.)
+
+The pattern of macro calls is like this:
+
+ dMULTICALL; /* Declare variables (including 'CV* cv') */
+ I32 gimme = G_SCALAR; /* context of the call: G_SCALAR,
+ * G_LIST, or G_VOID */
+
+ /* Here you must arrange for 'cv' to be set to the CV of
+ * the sub you want to call. */
+
+ PUSH_MULTICALL; /* Set up the calling context */
+
+ /* loop */ {
+ /* set the value(s) af your parameter variables */
+ MULTICALL; /* Make the actual call */
+ } /* end of loop */
+
+ POP_MULTICALL; /* Tear down the calling context */
+
+For some concrete examples, see the implementation of the
+first() and reduce() functions of List::Util 1.18. There you
+will also find a header file that emulates the multicall API
+on older versions of perl.
+
=head1 SEE ALSO
L<perlxs>, L<perlguts>, L<perlembed>
you tried to jump out of a sort() block or subroutine, which is a no-no.
See L<perlfunc/goto>.
+=item Can't goto subroutine from a sort sub (or similar callback)
+(F) The "goto subroutine" call can't be used to jump out of the
+comparison sub for a sort(), or from a similar callback (such
+as the reduce() function in List::Util).
+
=item Can't goto subroutine from an eval-%s
(F) The "goto subroutine" call can't be used to jump out of an eval
or define F<PERL_ENV_TABLES> (see L<perlvms>) so that environ is not
searched.
-=item Can't redefine active sort subroutine %s
-
-(F) Perl optimizes the internal handling of sort subroutines and keeps
-pointers into them. You tried to redefine one such sort subroutine when
-it was currently active, which is not allowed. If you really want to do
-this, you should write C<sort { &func } @x> instead of C<sort func @x>.
-
=item Can't "redo" outside a loop block
(F) A "redo" statement was executed to restart the current block, but
SV *sv;
OP *retop;
- if (PL_curstackinfo->si_type == PERLSI_SORT) {
- if (cxstack_ix == PL_sortcxix
- || dopoptosub(cxstack_ix) <= PL_sortcxix)
- {
- if (cxstack_ix > PL_sortcxix)
- dounwind(PL_sortcxix);
- AvARRAY(PL_curstack)[1] = *SP;
- PL_stack_sp = PL_stack_base + 1;
+ cxix = dopoptosub(cxstack_ix);
+ if (cxix < 0) {
+ if (CxMULTICALL(cxstack)) { /* In this case we must be in a
+ * sort block, which is a CXt_NULL
+ * not a CXt_SUB */
+ dounwind(0);
return 0;
}
+ else
+ DIE(aTHX_ "Can't return outside a subroutine");
}
-
- cxix = dopoptosub(cxstack_ix);
- if (cxix < 0)
- DIE(aTHX_ "Can't return outside a subroutine");
if (cxix < cxstack_ix)
dounwind(cxix);
+ if (CxMULTICALL(&cxstack[cxix]))
+ return 0;
+
POPBLOCK(cx,newpm);
switch (CxTYPE(cx)) {
case CXt_SUB:
else
DIE(aTHX_ "Can't goto subroutine from an eval-block");
}
+ else if (CxMULTICALL(cx))
+ DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs) {
/* put @_ back onto stack */
AV* av = cx->blk_sub.argarray;
gotoprobe = PL_main_root;
break;
case CXt_SUB:
- if (CvDEPTH(cx->blk_sub.cv)) {
+ if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
gotoprobe = CvROOT(cx->blk_sub.cv);
break;
}
register PERL_CONTEXT *cx;
SV *sv;
+ if (CxMULTICALL(&cxstack[cxstack_ix]))
+ return 0;
+
POPBLOCK(cx,newpm);
cxstack_ix++; /* temporarily protect top context */
register PERL_CONTEXT *cx;
SV *sv;
+ if (CxMULTICALL(&cxstack[cxstack_ix]))
+ return 0;
+
POPBLOCK(cx,newpm);
cxstack_ix++; /* temporarily protect top context */
if (is_xsub)
PL_sortcop = (OP*)cv;
- else {
+ else
PL_sortcop = CvSTART(cv);
- SAVEVPTR(CvROOT(cv)->op_ppaddr);
- CvROOT(cv)->op_ppaddr = PL_ppaddr[OP_NULL];
-
- SAVECOMPPAD();
- PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
- }
}
}
else {
}
}
else {
+ if (SvREADONLY(av))
+ Perl_croak(aTHX_ PL_no_modify);
+ else
+ SvREADONLY_on(av);
p1 = p2 = AvARRAY(av);
sorting_av = 1;
}
CATCH_SET(TRUE);
PUSHSTACKi(PERLSI_SORT);
if (!hasargs && !is_xsub) {
- if (PL_sortstash != stash || !PL_firstgv || !PL_secondgv) {
- SAVESPTR(PL_firstgv);
- SAVESPTR(PL_secondgv);
- PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
- PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
- PL_sortstash = stash;
- }
+ SAVESPTR(PL_firstgv);
+ SAVESPTR(PL_secondgv);
+ SAVESPTR(PL_sortstash);
+ PL_firstgv = gv_fetchpv("a", TRUE, SVt_PV);
+ PL_secondgv = gv_fetchpv("b", TRUE, SVt_PV);
+ PL_sortstash = stash;
SAVESPTR(GvSV(PL_firstgv));
SAVESPTR(GvSV(PL_secondgv));
}
cx->cx_type = CXt_SUB;
cx->blk_gimme = G_SCALAR;
PUSHSUB(cx);
- }
- PL_sortcxix = cxstack_ix;
+ if (!is_xsub) {
+ AV* padlist = CvPADLIST(cv);
+
+ if (++CvDEPTH(cv) >= 2) {
+ PERL_STACK_OVERFLOW_CHECK();
+ pad_push(padlist, CvDEPTH(cv));
+ }
+ SAVECOMPPAD();
+ PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
- if (hasargs && !is_xsub) {
- /* This is mostly copied from pp_entersub */
- AV *av = (AV*)PAD_SVl(0);
+ if (hasargs) {
+ /* This is mostly copied from pp_entersub */
+ AV *av = (AV*)PAD_SVl(0);
- cx->blk_sub.savearray = GvAV(PL_defgv);
- GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
- CX_CURPAD_SAVE(cx->blk_sub);
- cx->blk_sub.argarray = av;
+ cx->blk_sub.savearray = GvAV(PL_defgv);
+ GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
+ CX_CURPAD_SAVE(cx->blk_sub);
+ cx->blk_sub.argarray = av;
+ }
+
+ }
}
+ cx->cx_type |= CXp_MULTICALL;
start = p1 - max;
sortsvp(aTHX_ start, max,
is_xsub ? sortcv_xsub : hasargs ? sortcv_stacked : sortcv);
+ if (!(flags & OPf_SPECIAL)) {
+ LEAVESUB(cv);
+ if (!is_xsub)
+ CvDEPTH(cv)--;
+ }
POPBLOCK(cx,PL_curpm);
PL_stack_sp = newsp;
POPSTACK;
}
}
}
- if (av && !sorting_av) {
+ if (sorting_av)
+ SvREADONLY_off(av);
+ else if (av && !sorting_av) {
/* simulate pp_aassign of tied AV */
SV** const base = ORIGMARK+1;
for (i=0; i < max; i++) {
GvNAMELEN(dstr) = len;
SvFAKE_on(dstr); /* can coerce to non-glob */
}
- /* ahem, death to those who redefine active sort subs */
- else if (PL_curstackinfo->si_type == PERLSI_SORT
- && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
- Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
- GvNAME(dstr));
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE((GV*)dstr)) {
if (!GvCVGEN((GV*)dstr) &&
(CvROOT(cv) || CvXSUB(cv)))
{
- /* ahem, death to those who redefine
- * active sort subs */
- if (PL_curstackinfo->si_type == PERLSI_SORT &&
- PL_sortcop == CvSTART(cv))
- Perl_croak(aTHX_
- "Can't redefine active sort subroutine %s",
- GvENAME((GV*)dstr));
/* Redefining a sub - warning is mandatory if
it was a const and its value changed. */
if (ckWARN(WARN_REDEFINE)
PL_sortstash = hv_dup(proto_perl->Tsortstash, param);
PL_firstgv = gv_dup(proto_perl->Tfirstgv, param);
PL_secondgv = gv_dup(proto_perl->Tsecondgv, param);
- PL_sortcxix = proto_perl->Tsortcxix;
PL_efloatbuf = Nullch; /* reinits on demand */
PL_efloatsize = 0; /* reinits on demand */
@INC = '../lib';
}
use warnings;
-print "1..129\n";
+print "1..141\n";
# these shouldn't hang
{
sub Backwards { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
sub Backwards_stacked($$) { my($a,$b) = @_; $a lt $b ? 1 : $a gt $b ? -1 : 0 }
+sub Backwards_other { $a lt $b ? 1 : $a gt $b ? -1 : 0 }
my $upperfirst = 'A' lt 'a';
print ("@b" eq '1 2 3 4' ? "ok 16\n" : "not ok 16\n");
print "# x = '@b'\n";
-# redefining sort sub inside the sort sub should fail
-sub twoface { *twoface = sub { $a <=> $b }; &twoface }
+# redefining sort sub inside the sort sub should not fail
+sub twoface { no warnings 'redefine'; *twoface = sub { $a <=> $b }; &twoface }
eval { @b = sort twoface 4,1,3,2 };
-print ($@ =~ /redefine active sort/ ? "ok 17\n" : "not ok 17\n");
+print ($@ eq '' ? "ok 17\n" : "not ok 17\n");
-# redefining sort subs outside the sort should not fail
+# redefining sort subs outside the sort should also not fail
eval { no warnings 'redefine'; *twoface = sub { &Backwards } };
print $@ ? "not ok 18\n" : "ok 18\n";
{
no warnings 'redefine';
- *twoface = sub { *twoface = *Backwards; $a <=> $b };
+ *twoface = sub { *twoface = *Backwards_other; $a <=> $b };
}
-eval { @b = sort twoface 4,1 };
-print ($@ =~ /redefine active sort/ ? "ok 20\n" : "not ok 20\n");
+# The redefinition should not take effect during the sort
+eval { @b = sort twoface 4,1,9,5 };
+print (($@ eq "" && "@b" eq "1 4 5 9") ? "ok 20\n" : "not ok 20 # $@|@b\n");
{
no warnings 'redefine';
*twoface = sub {
eval 'sub twoface { $a <=> $b }';
- die($@ =~ /redefine active sort/ ? "ok 21\n" : "not ok 21\n");
+ die($@ eq "" ? "ok 21\n" : "not ok 21\n");
$a <=> $b;
};
}
eval { @b = sort twoface 4,1 };
-print $@ ? "$@" : "not ok 21\n";
+print($@ ? "$@" : "not ok 21 # $@\n");
eval <<'CODE';
my @result = sort main'Backwards 'one', 'two';
@output = reverse (0, sort(qw(C A B)));
ok "@output", "C B A 0", 'reversed sort with leading argument';
+
+eval { @output = sort {goto sub {}} 1,2; };
+print(($@ =~ /^Can't goto subroutine outside a subroutine/ ?
+ "ok " :
+ "not ok "),
+ $test++, " # $@");
+
+sub goto_sub {goto sub{}}
+eval { @output = sort goto_sub 1,2; };
+print(($@ =~ /^Can't goto subroutine from a sort sub/ ?
+ "ok " :
+ "not ok "),
+ $test++, " # $@");
+
+eval { @output = sort {goto label} 1,2; };
+print(($@ =~ /^Can't "goto" out of a pseudo block/ ?
+ "ok " :
+ "not ok "),
+ $test++, " # $@");
+
+sub goto_label {goto label}
+label: eval { @output = sort goto_label 1,2; };
+print(($@ =~ /^Can't "goto" out of a pseudo block/ ?
+ "ok " :
+ "not ok "),
+ $test++, " # $@");
+
+sub self_immolate {undef &self_immolate; $a<=>$b}
+eval { @output = sort self_immolate 1,2,3 };
+print(($@ =~ /^Can't undef active subroutine/ ?
+ "ok " :
+ "not ok "),
+ $test++, " # $@");
+
+{
+ my $failed = 0;
+
+ sub rec {
+ my $n = shift;
+ if (!defined($n)) { # No arg means we're being called by sort()
+ return 1;
+ }
+ if ($n<5) { rec($n+1); }
+ else { () = sort rec 1,2; }
+
+ $failed = 1 if !defined $n;
+ }
+
+ rec(1);
+ print((!$failed ? "ok " : "not ok "), $test++, " - sort from active sub\n");
+}
+
+# $a and $b are set in the package the sort() is called from,
+# *not* the package the sort sub is in. This is longstanding
+# de facto behaviour that shouldn't be broken.
+package main;
+my $answer = "ok ";
+() = sort OtherPack::foo 1,2,3,4;
+
+{package OtherPack; sub foo {
+ $answer = "not ok " if
+ defined($a) || defined($b) || !defined($main::a) || !defined($main::b);
+ $main::a <=> $main::b;
+}}
+
+print $answer, $test++, "\n";
+
+
+# Bug 36430 - sort called in package2 while a
+# sort in package1 is active should set $package2::a/b.
+
+$answer = "ok ";
+my @list = sort { A::min(@$a) <=> A::min(@$b) }
+ [3, 1, 5], [2, 4], [0];
+
+print $answer, $test++, "\n";
+
+package A;
+sub min {
+ my @list = sort {
+ $answer = "not ok " if !defined($a) || !defined($b);
+ $a <=> $b;
+ } @_;
+ $list[0];
+}
+
+# Bug 7567 - an array shouldn't be modifiable while it's being
+# sorted in-place.
+eval { @a=(1..8); @a = sort { @a = (0) } @a; };
+
+print(($@ =~ /^Modification of a read-only value attempted/ ?
+ "ok " :
+ "not ok "),
+ $test++, " # $@");
+
+# Sorting shouldn't increase the refcount of a sub
+sub foo {(1+$a) <=> (1+$b)}
+my $refcnt = &Internals::SvREFCNT(\&foo);
+@output = sort foo 3,7,9;
+package Foo;
+ok($refcnt, &Internals::SvREFCNT(\&foo), "sort sub refcnt");
+
+# Sorting a read-only array in-place shouldn't be allowed
+my @readonly = (1..10);
+Internals::SvREADONLY(@readonly, 1);
+eval { @readonly = sort @readonly; };
+print(($@ =~ /^Modification of a read-only value attempted/ ?
+ "ok " :
+ "not ok "),
+ $test++, " # $@");
+
+# Using return() should be okay even in a deeper context
+@b = sort {while (1) {return ($a <=> $b)} } 1..10;
+ok("@b", "1 2 3 4 5 6 7 8 9 10", "return within loop");
+
+# Clearing the array we're sorting should be okay.
+@a = (1..10);
+@b = sort {@a=(); ($a+1)<=>($b+1)} @a;
+ok("@b", "1 2 3 4 5 6 7 8 9 10", "clear array being sorted");
print "1..0 # Skip: no dynamic loading on miniperl, no threads\n";
exit 0;
}
- plan(3);
+ plan(4);
}
use threads;
threads->new(sub { $ref = $object } )->join; # $ref = $object causes problems
print "ok";
EOI
+
+#PR30333 - sort() crash with threads
+sub mycmp { length($b) <=> length($a) }
+
+sub do_sort_one_thread {
+ my $kid = shift;
+ print "# kid $kid before sort\n";
+ my @list = ( 'x', 'yy', 'zzz', 'a', 'bb', 'ccc', 'aaaaa', 'z',
+ 'hello', 's', 'thisisalongname', '1', '2', '3',
+ 'abc', 'xyz', '1234567890', 'm', 'n', 'p' );
+
+ for my $j (1..99999) {
+ for my $k (sort mycmp @list) {}
+ }
+ print "# kid $kid after sort, sleeping 1\n";
+ sleep(1);
+ print "# kid $kid exit\n";
+}
+
+sub do_sort_threads {
+ my $nthreads = shift;
+ my @kids = ();
+ for my $i (1..$nthreads) {
+ my $t = threads->new(\&do_sort_one_thread, $i);
+ print "# parent $$: continue\n";
+ push(@kids, $t);
+ }
+ for my $t (@kids) {
+ print "# parent $$: waiting for join\n";
+ $t->join();
+ print "# parent $$: thread exited\n";
+ }
+}
+
+do_sort_threads(2); # crashes
+ok(1);
PERLVAR(Tsortstash, HV *) /* which is in some package or other */
PERLVAR(Tfirstgv, GV *) /* $a */
PERLVAR(Tsecondgv, GV *) /* $b */
-PERLVAR(Tsortcxix, I32) /* from pp_ctl.c */
/* float buffer */
PERLVAR(Tefloatbuf, char*)
projects / p5sagit/p5-mst-13.2.git / commitdiff