/* pp_hot.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* Fire, Foes! Awake!
*/
+/* This file contains 'hot' pp ("push/pop") functions that
+ * execute the opcodes that make up a perl program. A typical pp function
+ * expects to find its arguments on the stack, and usually pushes its
+ * results onto the stack, hence the 'pp' terminology. Each OP structure
+ * contains a pointer to the relevant pp_foo() function.
+ *
+ * By 'hot', we mean common ops whose execution speed is critical.
+ * By gathering them together into a single file, we encourage
+ * CPU cache hits on hot code. Also it could be taken as a warning not to
+ * change any code in this file unless you're sure it won't affect
+ * performance.
+ */
+
#include "EXTERN.h"
#define PERL_IN_PP_HOT_C
#include "perl.h"
dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
{
dPOPTOPssrl;
- STRLEN llen;
- char* lpv;
bool lbyte;
STRLEN rlen;
- char* rpv = SvPV(right, rlen); /* mg_get(right) happens here */
- bool rbyte = !SvUTF8(right);
+ const char *rpv = SvPV(right, rlen); /* mg_get(right) happens here */
+ const bool rbyte = !DO_UTF8(right);
+ bool rcopied = FALSE;
if (TARG == right && right != left) {
right = sv_2mortal(newSVpvn(rpv, rlen));
- rpv = SvPV(right, rlen); /* no point setting UTF8 here */
+ rpv = SvPV(right, rlen); /* no point setting UTF-8 here */
+ rcopied = TRUE;
}
if (TARG != left) {
- lpv = SvPV(left, llen); /* mg_get(left) may happen here */
- lbyte = !SvUTF8(left);
+ STRLEN llen;
+ const char* const lpv = SvPV(left, llen); /* mg_get(left) may happen here */
+ lbyte = !DO_UTF8(left);
sv_setpvn(TARG, lpv, llen);
if (!lbyte)
SvUTF8_on(TARG);
SvUTF8_off(TARG);
}
else { /* TARG == left */
+ STRLEN llen;
if (SvGMAGICAL(left))
mg_get(left); /* or mg_get(left) may happen here */
if (!SvOK(TARG))
- sv_setpv(left, "");
- lpv = SvPV_nomg(left, llen);
- lbyte = !SvUTF8(left);
- }
-
-#if defined(PERL_Y2KWARN)
- if ((SvIOK(right) || SvNOK(right)) && ckWARN(WARN_Y2K) && SvOK(TARG)) {
- if (llen >= 2 && lpv[llen - 2] == '1' && lpv[llen - 1] == '9'
- && (llen == 2 || !isDIGIT(lpv[llen - 3])))
- {
- Perl_warner(aTHX_ packWARN(WARN_Y2K), "Possible Y2K bug: %s",
- "about to append an integer to '19'");
- }
+ sv_setpvn(left, "", 0);
+ (void)SvPV_nomg(left, llen); /* Needed to set UTF8 flag */
+ lbyte = !DO_UTF8(left);
+ if (IN_BYTES)
+ SvUTF8_off(TARG);
}
-#endif
if (lbyte != rbyte) {
if (lbyte)
sv_utf8_upgrade_nomg(TARG);
else {
+ if (!rcopied)
+ right = sv_2mortal(newSVpvn(rpv, rlen));
sv_utf8_upgrade_nomg(right);
rpv = SvPV(right, rlen);
}
if (PL_op->op_flags & OPf_MOD) {
if (PL_op->op_private & OPpLVAL_INTRO)
SAVECLEARSV(PAD_SVl(PL_op->op_targ));
- else if (PL_op->op_private & OPpDEREF) {
+ if (PL_op->op_private & OPpDEREF) {
PUTBACK;
vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
SPAGAIN;
{
dSP; tryAMAGICbinSET(eq,0);
#ifndef NV_PRESERVES_UV
- if (SvROK(TOPs) && SvROK(TOPm1s)) {
+ if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
SP--;
SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
RETURN;
PP(pp_preinc)
{
dSP;
- if (SvTYPE(TOPs) > SVt_PVLV)
+ if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
DIE(aTHX_ PL_no_modify);
if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
&& SvIVX(TOPs) != IV_MAX)
{
- ++SvIVX(TOPs);
+ SvIV_set(TOPs, SvIVX(TOPs) + 1);
SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
}
else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
{
/* Most of this is lifted straight from pp_defined */
dSP;
- register SV* sv;
+ register SV* const sv = TOPs;
- sv = TOPs;
if (!sv || !SvANY(sv)) {
--SP;
RETURNOP(cLOGOP->op_other);
if ((auvok = SvUOK(TOPm1s)))
auv = SvUVX(TOPm1s);
else {
- register IV aiv = SvIVX(TOPm1s);
+ register const IV aiv = SvIVX(TOPm1s);
if (aiv >= 0) {
auv = aiv;
auvok = 1; /* Now acting as a sign flag. */
if (buvok)
buv = SvUVX(TOPs);
else {
- register IV biv = SvIVX(TOPs);
+ register const IV biv = SvIVX(TOPs);
if (biv >= 0) {
buv = biv;
buvok = 1;
PP(pp_aelemfast)
{
dSP;
- AV *av = GvAV(cGVOP_gv);
- U32 lval = PL_op->op_flags & OPf_MOD;
+ AV *av = PL_op->op_flags & OPf_SPECIAL ?
+ (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
+ const U32 lval = PL_op->op_flags & OPf_MOD;
SV** svp = av_fetch(av, PL_op->op_private, lval);
SV *sv = (svp ? *svp : &PL_sv_undef);
EXTEND(SP, 1);
PP(pp_print)
{
- dSP; dMARK; dORIGMARK;
+ dVAR; dSP; dMARK; dORIGMARK;
GV *gv;
IO *io;
register PerlIO *fp;
SETs((SV*)av);
RETURN;
}
+ else if (PL_op->op_flags & OPf_MOD
+ && PL_op->op_private & OPpLVAL_INTRO)
+ Perl_croak(aTHX_ PL_no_localize_ref);
}
else {
if (SvTYPE(sv) == SVt_PVAV) {
GV *gv;
if (SvTYPE(sv) != SVt_PVGV) {
- char *sym;
- STRLEN len;
-
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_usym, "an ARRAY");
if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
+ report_uninit(sv);
if (GIMME == G_ARRAY) {
(void)POPs;
RETURN;
}
RETSETUNDEF;
}
- sym = SvPV(sv,len);
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
- gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
+ gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVAV);
if (!gv
- && (!is_gv_magical(sym,len,0)
- || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
+ && (!is_gv_magical_sv(sv,0)
+ || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV))))
{
RETSETUNDEF;
}
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
- gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
+ DIE(aTHX_ PL_no_symref_sv, sv, "an ARRAY");
+ gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVAV);
}
}
else {
}
if (GIMME == G_ARRAY) {
- I32 maxarg = AvFILL(av) + 1;
+ const I32 maxarg = AvFILL(av) + 1;
(void)POPs; /* XXXX May be optimized away? */
EXTEND(SP, maxarg);
if (SvRMAGICAL(av)) {
U32 i;
for (i=0; i < (U32)maxarg; i++) {
SV **svp = av_fetch(av, i, FALSE);
- SP[i+1] = (svp) ? *svp : &PL_sv_undef;
+ /* See note in pp_helem, and bug id #27839 */
+ SP[i+1] = svp
+ ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
+ : &PL_sv_undef;
}
}
else {
}
else if (GIMME_V == G_SCALAR) {
dTARGET;
- I32 maxarg = AvFILL(av) + 1;
+ const I32 maxarg = AvFILL(av) + 1;
SETi(maxarg);
}
RETURN;
{
dSP; dTOPss;
HV *hv;
+ const I32 gimme = GIMME_V;
+ static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
if (SvROK(sv)) {
wasref:
RETURN;
}
else if (LVRET) {
- if (GIMME == G_SCALAR)
- Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
+ if (gimme != G_ARRAY)
+ Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
SETs((SV*)hv);
RETURN;
}
+ else if (PL_op->op_flags & OPf_MOD
+ && PL_op->op_private & OPpLVAL_INTRO)
+ Perl_croak(aTHX_ PL_no_localize_ref);
}
else {
if (SvTYPE(sv) == SVt_PVHV) {
RETURN;
}
else if (LVRET) {
- if (GIMME == G_SCALAR)
- Perl_croak(aTHX_ "Can't return hash to lvalue"
- " scalar context");
+ if (gimme != G_ARRAY)
+ Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
SETs((SV*)hv);
RETURN;
}
GV *gv;
if (SvTYPE(sv) != SVt_PVGV) {
- char *sym;
- STRLEN len;
-
if (SvGMAGICAL(sv)) {
mg_get(sv);
if (SvROK(sv))
PL_op->op_private & HINT_STRICT_REFS)
DIE(aTHX_ PL_no_usym, "a HASH");
if (ckWARN(WARN_UNINITIALIZED))
- report_uninit();
- if (GIMME == G_ARRAY) {
+ report_uninit(sv);
+ if (gimme == G_ARRAY) {
SP--;
RETURN;
}
RETSETUNDEF;
}
- sym = SvPV(sv,len);
if ((PL_op->op_flags & OPf_SPECIAL) &&
!(PL_op->op_flags & OPf_MOD))
{
- gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
+ gv = (GV*)gv_fetchsv(sv, FALSE, SVt_PVHV);
if (!gv
- && (!is_gv_magical(sym,len,0)
- || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
+ && (!is_gv_magical_sv(sv,0)
+ || !(gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV))))
{
RETSETUNDEF;
}
}
else {
if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ PL_no_symref, sym, "a HASH");
- gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
+ DIE(aTHX_ PL_no_symref_sv, sv, "a HASH");
+ gv = (GV*)gv_fetchsv(sv, TRUE, SVt_PVHV);
}
}
else {
RETURN;
}
else if (LVRET) {
- if (GIMME == G_SCALAR)
- Perl_croak(aTHX_ "Can't return hash to lvalue"
- " scalar context");
+ if (gimme != G_ARRAY)
+ Perl_croak(aTHX_ return_hash_to_lvalue_scalar );
SETs((SV*)hv);
RETURN;
}
}
}
- if (GIMME == G_ARRAY) { /* array wanted */
+ if (gimme == G_ARRAY) { /* array wanted */
*PL_stack_sp = (SV*)hv;
return do_kv();
}
- else {
+ else if (gimme == G_SCALAR) {
dTARGET;
- if (HvFILL(hv))
- Perl_sv_setpvf(aTHX_ TARG, "%"IVdf"/%"IVdf,
- (IV)HvFILL(hv), (IV)HvMAX(hv) + 1);
- else
- sv_setiv(TARG, 0);
-
+ TARG = Perl_hv_scalar(aTHX_ hv);
SETTARG;
- RETURN;
}
+ RETURN;
}
STATIC void
HE *didstore;
if (ckWARN(WARN_MISC)) {
+ const char *err;
if (relem == firstrelem &&
SvROK(*relem) &&
(SvTYPE(SvRV(*relem)) == SVt_PVAV ||
SvTYPE(SvRV(*relem)) == SVt_PVHV))
{
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Reference found where even-sized list expected");
+ err = "Reference found where even-sized list expected";
}
else
- Perl_warner(aTHX_ packWARN(WARN_MISC),
- "Odd number of elements in hash assignment");
+ err = "Odd number of elements in hash assignment";
+ Perl_warner(aTHX_ packWARN(WARN_MISC), err);
}
tmpstr = NEWSV(29,0);
PP(pp_aassign)
{
- dSP;
+ dVAR; dSP;
SV **lastlelem = PL_stack_sp;
SV **lastrelem = PL_stack_base + POPMARK;
SV **firstrelem = PL_stack_base + POPMARK + 1;
HV *hash;
I32 i;
int magic;
+ int duplicates = 0;
+ SV **firsthashrelem = 0; /* "= 0" keeps gcc 2.95 quiet */
+
PL_delaymagic = DM_DELAY; /* catch simultaneous items */
+ gimme = GIMME_V;
/* If there's a common identifier on both sides we have to take
* special care that assigning the identifier on the left doesn't
i = 0;
while (relem <= lastrelem) { /* gobble up all the rest */
SV **didstore;
- sv = NEWSV(28,0);
assert(*relem);
- sv_setsv(sv,*relem);
+ sv = newSVsv(*relem);
*(relem++) = sv;
didstore = av_store(ary,i++,sv);
if (magic) {
hash = (HV*)sv;
magic = SvMAGICAL(hash) != 0;
hv_clear(hash);
+ firsthashrelem = relem;
while (relem < lastrelem) { /* gobble up all the rest */
HE *didstore;
if (*relem)
sv_setsv(tmpstr,*relem); /* value */
*(relem++) = tmpstr;
+ if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
+ /* key overwrites an existing entry */
+ duplicates += 2;
didstore = hv_store_ent(hash,sv,tmpstr,0);
if (magic) {
if (SvSMAGICAL(tmpstr))
if (PL_delaymagic & ~DM_DELAY) {
if (PL_delaymagic & DM_UID) {
#ifdef HAS_SETRESUID
- (void)setresuid(PL_uid,PL_euid,(Uid_t)-1);
+ (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
+ (Uid_t)-1);
#else
# ifdef HAS_SETREUID
- (void)setreuid(PL_uid,PL_euid);
+ (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
# else
# ifdef HAS_SETRUID
if ((PL_delaymagic & DM_UID) == DM_RUID) {
# endif /* HAS_SETRUID */
# ifdef HAS_SETEUID
if ((PL_delaymagic & DM_UID) == DM_EUID) {
- (void)seteuid(PL_uid);
+ (void)seteuid(PL_euid);
PL_delaymagic &= ~DM_EUID;
}
# endif /* HAS_SETEUID */
}
if (PL_delaymagic & DM_GID) {
#ifdef HAS_SETRESGID
- (void)setresgid(PL_gid,PL_egid,(Gid_t)-1);
+ (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
+ (Gid_t)-1);
#else
# ifdef HAS_SETREGID
- (void)setregid(PL_gid,PL_egid);
+ (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
# else
# ifdef HAS_SETRGID
if ((PL_delaymagic & DM_GID) == DM_RGID) {
# endif /* HAS_SETRGID */
# ifdef HAS_SETEGID
if ((PL_delaymagic & DM_GID) == DM_EGID) {
- (void)setegid(PL_gid);
+ (void)setegid(PL_egid);
PL_delaymagic &= ~DM_EGID;
}
# endif /* HAS_SETEGID */
}
PL_delaymagic = 0;
- gimme = GIMME_V;
if (gimme == G_VOID)
SP = firstrelem - 1;
else if (gimme == G_SCALAR) {
dTARGET;
SP = firstrelem;
- SETi(lastrelem - firstrelem + 1);
+ SETi(lastrelem - firstrelem + 1 - duplicates);
}
else {
- if (ary || hash)
+ if (ary)
+ SP = lastrelem;
+ else if (hash) {
+ if (duplicates) {
+ /* Removes from the stack the entries which ended up as
+ * duplicated keys in the hash (fix for [perl #24380]) */
+ Move(firsthashrelem + duplicates,
+ firsthashrelem, duplicates, SV**);
+ lastrelem -= duplicates;
+ }
SP = lastrelem;
+ }
else
SP = firstrelem + (lastlelem - firstlelem);
lelem = firstlelem + (relem - firstrelem);
char *truebase; /* Start of string */
register REGEXP *rx = PM_GETRE(pm);
bool rxtainted;
- I32 gimme = GIMME;
+ const I32 gimme = GIMME;
STRLEN len;
I32 minmatch = 0;
- I32 oldsave = PL_savestack_ix;
+ const I32 oldsave = PL_savestack_ix;
I32 update_minmatch = 1;
I32 had_zerolen = 0;
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
+ else if (PL_op->op_private & OPpTARGET_MY)
+ GETTARGET;
else {
TARG = DEFSV;
EXTEND(SP,1);
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
- if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
- SAVEINT(PL_multiline);
- PL_multiline = pm->op_pmflags & PMf_MULTILINE;
- }
-
play_it_again:
if (global && rx->startp[0] != -1) {
t = s = rx->endp[0] + truebase;
RX_MATCH_TAINTED_on(rx);
TAINT_IF(RX_MATCH_TAINTED(rx));
if (gimme == G_ARRAY) {
- I32 nparens, i, len;
+ const I32 nparens = rx->nparens;
+ I32 i = (global && !nparens) ? 1 : 0;
+ I32 len;
- nparens = rx->nparens;
- if (global && !nparens)
- i = 1;
- else
- i = 0;
SPAGAIN; /* EVAL blocks could move the stack. */
EXTEND(SP, nparens + i);
EXTEND_MORTAL(nparens + i);
/*SUPPRESS 560*/
if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
len = rx->endp[i] - rx->startp[i];
+ s = rx->startp[i] + truebase;
if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
len < 0 || len > strend - s)
DIE(aTHX_ "panic: pp_match start/end pointers");
- s = rx->startp[i] + truebase;
sv_setpvn(*SP, s, len);
if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
SvUTF8_on(*SP);
}
if (PL_sawampersand) {
I32 off;
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
+ if (DEBUG_C_TEST) {
+ PerlIO_printf(Perl_debug_log,
+ "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
+ (int) SvTYPE(TARG), truebase, t,
+ (int)(t-truebase));
+ }
+ rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
+ rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
+ assert (SvPOKp(rx->saved_copy));
+ } else
+#endif
+ {
- rx->subbeg = savepvn(t, strend - t);
+ rx->subbeg = savepvn(t, strend - t);
+#ifdef PERL_COPY_ON_WRITE
+ rx->saved_copy = Nullsv;
+#endif
+ }
rx->sublen = strend - t;
RX_MATCH_COPIED_on(rx);
off = rx->startp[0] = s - t;
rx->startp[0] = s - truebase;
rx->endp[0] = s - truebase + rx->minlen;
}
- rx->nparens = rx->lastparen = 0; /* used by @- and @+ */
+ rx->nparens = rx->lastparen = rx->lastcloseparen = 0; /* used by @-, @+, and $^N */
LEAVE_SCOPE(oldsave);
RETPUSHYES;
OP *
Perl_do_readline(pTHX)
{
- dSP; dTARGETSTACKED;
+ dVAR; dSP; dTARGETSTACKED;
register SV *sv;
STRLEN tmplen = 0;
STRLEN offset;
PerlIO *fp;
- register IO *io = GvIO(PL_last_in_gv);
- register I32 type = PL_op->op_type;
- I32 gimme = GIMME_V;
+ register IO * const io = GvIO(PL_last_in_gv);
+ register const I32 type = PL_op->op_type;
+ const I32 gimme = GIMME_V;
MAGIC *mg;
if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
}
if (gimme == G_SCALAR) {
/* undef TARG, and push that undefined value */
- SV_CHECK_THINKFIRST_COW_DROP(TARG);
- (void)SvOK_off(TARG);
+ if (type != OP_RCATLINE) {
+ SV_CHECK_THINKFIRST_COW_DROP(TARG);
+ SvOK_off(TARG);
+ }
PUSHTARG;
}
RETURN;
sv_unref(sv);
(void)SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
- if (!tmplen)
+ if (!tmplen && !SvREADONLY(sv))
Sv_Grow(sv, 80); /* try short-buffering it */
offset = 0;
if (type == OP_RCATLINE && SvOK(sv)) {
for (;;) {
PUTBACK;
if (!sv_gets(sv, fp, offset)
- && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
+ && (type == OP_GLOB
+ || SNARF_EOF(gimme, PL_rs, io, sv)
+ || PerlIO_error(fp)))
{
PerlIO_clearerr(fp);
if (IoFLAGS(io) & IOf_ARGV) {
}
}
if (gimme == G_SCALAR) {
- SV_CHECK_THINKFIRST_COW_DROP(TARG);
- (void)SvOK_off(TARG);
+ if (type != OP_RCATLINE) {
+ SV_CHECK_THINKFIRST_COW_DROP(TARG);
+ SvOK_off(TARG);
+ }
SPAGAIN;
PUSHTARG;
}
tmps = SvEND(sv) - 1;
if (*tmps == *SvPVX(PL_rs)) {
*tmps = '\0';
- SvCUR(sv)--;
+ SvCUR_set(sv, SvCUR(sv) - 1);
}
}
for (tmps = SvPVX(sv); *tmps; tmps++)
(void)POPs; /* Unmatched wildcard? Chuck it... */
continue;
}
+ } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
+ const U8 *s = (U8*)SvPVX(sv) + offset;
+ const STRLEN len = SvCUR(sv) - offset;
+ const U8 *f;
+
+ if (ckWARN(WARN_UTF8) &&
+ !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
+ /* Emulate :encoding(utf8) warning in the same case. */
+ Perl_warner(aTHX_ packWARN(WARN_UTF8),
+ "utf8 \"\\x%02X\" does not map to Unicode",
+ f < (U8*)SvEND(sv) ? *f : 0);
}
if (gimme == G_ARRAY) {
if (SvLEN(sv) - SvCUR(sv) > 20) {
- SvLEN_set(sv, SvCUR(sv)+1);
- Renew(SvPVX(sv), SvLEN(sv), char);
+ SvPV_shrink_to_cur(sv);
}
sv = sv_2mortal(NEWSV(58, 80));
continue;
}
else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
/* try to reclaim a bit of scalar space (only on 1st alloc) */
- if (SvCUR(sv) < 60)
- SvLEN_set(sv, 80);
- else
- SvLEN_set(sv, SvCUR(sv)+40); /* allow some slop */
- Renew(SvPVX(sv), SvLEN(sv), char);
+ const STRLEN new_len
+ = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
+ SvPV_renew(sv, new_len);
}
RETURN;
}
PP(pp_enter)
{
- dSP;
+ dVAR; dSP;
register PERL_CONTEXT *cx;
I32 gimme = OP_GIMME(PL_op, -1);
SV **svp;
SV *keysv = POPs;
HV *hv = (HV*)POPs;
- U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
- U32 defer = PL_op->op_private & OPpLVAL_DEFER;
+ const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
+ const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
SV *sv;
#ifdef PERL_COPY_ON_WRITE
- U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
+ const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
#else
- U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
+ const U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
#endif
I32 preeminent = 0;
SV* lv;
SV* key2;
if (!defer) {
- STRLEN n_a;
- DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
+ DIE(aTHX_ PL_no_helem_sv, keysv);
}
lv = sv_newmortal();
sv_upgrade(lv, SVt_PVLV);
else {
if (!preeminent) {
STRLEN keylen;
- char *key = SvPV(keysv, keylen);
+ const char * const key = SvPV(keysv, keylen);
SAVEDELETE(hv, savepvn(key,keylen), keylen);
} else
save_helem(hv, keysv, svp);
PP(pp_leave)
{
- dSP;
+ dVAR; dSP;
register PERL_CONTEXT *cx;
- register SV **mark;
SV **newsp;
PMOP *newpm;
I32 gimme;
if (gimme == G_VOID)
SP = newsp;
else if (gimme == G_SCALAR) {
+ register SV **mark;
MARK = newsp + 1;
if (MARK <= SP) {
if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
}
else if (gimme == G_ARRAY) {
/* in case LEAVE wipes old return values */
+ register SV **mark;
for (mark = newsp + 1; mark <= SP; mark++) {
if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
*mark = sv_mortalcopy(*mark);
{
dSP;
register PERL_CONTEXT *cx;
- SV* sv;
+ SV *sv, *oldsv;
AV* av;
SV **itersvp;
if (cx->blk_loop.iterlval) {
/* string increment */
register SV* cur = cx->blk_loop.iterlval;
- STRLEN maxlen;
- char *max = SvPV((SV*)av, maxlen);
+ STRLEN maxlen = 0;
+ const char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
/* we need a fresh SV every time so that loop body sees a
* completely new SV for closures/references to work as
* they used to */
- SvREFCNT_dec(*itersvp);
+ oldsv = *itersvp;
*itersvp = newSVsv(cur);
+ SvREFCNT_dec(oldsv);
}
if (strEQ(SvPVX(cur), max))
sv_setiv(cur, 0); /* terminate next time */
/* we need a fresh SV every time so that loop body sees a
* completely new SV for closures/references to work as they
* used to */
- SvREFCNT_dec(*itersvp);
+ oldsv = *itersvp;
*itersvp = newSViv(cx->blk_loop.iterix++);
+ SvREFCNT_dec(oldsv);
}
RETPUSHYES;
}
/* iterate array */
- if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
- RETPUSHNO;
-
- SvREFCNT_dec(*itersvp);
+ if (PL_op->op_private & OPpITER_REVERSED) {
+ /* In reverse, use itermax as the min :-) */
+ if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
+ RETPUSHNO;
- if (SvMAGICAL(av) || AvREIFY(av)) {
- SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
- if (svp)
- sv = *svp;
- else
- sv = Nullsv;
+ if (SvMAGICAL(av) || AvREIFY(av)) {
+ SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
+ if (svp)
+ sv = *svp;
+ else
+ sv = Nullsv;
+ }
+ else {
+ sv = AvARRAY(av)[cx->blk_loop.iterix--];
+ }
}
else {
- sv = AvARRAY(av)[++cx->blk_loop.iterix];
+ if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
+ AvFILL(av)))
+ RETPUSHNO;
+
+ if (SvMAGICAL(av) || AvREIFY(av)) {
+ SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
+ if (svp)
+ sv = *svp;
+ else
+ sv = Nullsv;
+ }
+ else {
+ sv = AvARRAY(av)[++cx->blk_loop.iterix];
+ }
+ }
+
+ if (sv && SvREFCNT(sv) == 0) {
+ *itersvp = Nullsv;
+ Perl_croak(aTHX_ "Use of freed value in iteration");
}
+
if (sv)
SvTEMP_off(sv);
else
sv = (SV*)lv;
}
+ oldsv = *itersvp;
*itersvp = SvREFCNT_inc(sv);
+ SvREFCNT_dec(oldsv);
+
RETPUSHYES;
}
I32 oldsave = PL_savestack_ix;
STRLEN slen;
bool doutf8 = FALSE;
+#ifdef PERL_COPY_ON_WRITE
+ bool is_cow;
+#endif
+ SV *nsv = Nullsv;
/* known replacement string? */
dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
+ else if (PL_op->op_private & OPpTARGET_MY)
+ GETTARGET;
else {
TARG = DEFSV;
EXTEND(SP,1);
}
+#ifdef PERL_COPY_ON_WRITE
+ /* Awooga. Awooga. "bool" types that are actually char are dangerous,
+ because they make integers such as 256 "false". */
+ is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
+#else
if (SvIsCOW(TARG))
sv_force_normal_flags(TARG,0);
- if (SvREADONLY(TARG)
- || (SvTYPE(TARG) > SVt_PVLV
- && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
+#endif
+ if (
+#ifdef PERL_COPY_ON_WRITE
+ !is_cow &&
+#endif
+ (SvREADONLY(TARG)
+ || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
+ && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
DIE(aTHX_ PL_no_modify);
PUTBACK;
rx = PM_GETRE(pm);
}
r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
- ? REXEC_COPY_STR : 0;
+ ? REXEC_COPY_STR : 0;
if (SvSCREAM(TARG))
r_flags |= REXEC_SCREAM;
- if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
- SAVEINT(PL_multiline);
- PL_multiline = pm->op_pmflags & PMf_MULTILINE;
- }
+
orig = m = s;
if (rx->reganch & RE_USE_INTUIT) {
PL_bostr = orig;
if (dstr) {
/* replacement needing upgrading? */
if (DO_UTF8(TARG) && !doutf8) {
- SV *nsv = sv_newmortal();
+ nsv = sv_newmortal();
SvSetSV(nsv, dstr);
if (PL_encoding)
sv_recode_to_utf8(nsv, PL_encoding);
}
/* can do inplace substitution? */
- if (c && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
- && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
+ if (c
+#ifdef PERL_COPY_ON_WRITE
+ && !is_cow
+#endif
+ && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
+ && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
+ && (!doutf8 || SvUTF8(TARG))) {
if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
r_flags | REXEC_CHECKED))
{
LEAVE_SCOPE(oldsave);
RETURN;
}
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(TARG)) {
+ assert (!force_on_match);
+ goto have_a_cow;
+ }
+#endif
if (force_on_match) {
force_on_match = 0;
s = SvPV_force(TARG, len);
s = SvPV_force(TARG, len);
goto force_it;
}
+#ifdef PERL_COPY_ON_WRITE
+ have_a_cow:
+#endif
rxtainted |= RX_MATCH_TAINTED(rx);
- dstr = NEWSV(25, len);
- sv_setpvn(dstr, m, s-m);
+ dstr = newSVpvn(m, s-m);
if (DO_UTF8(TARG))
SvUTF8_on(dstr);
PL_curpm = pm;
if (!c) {
register PERL_CONTEXT *cx;
SPAGAIN;
+ ReREFCNT_inc(rx);
PUSHSUBST(cx);
RETURNOP(cPMOP->op_pmreplroot);
}
strend = s + (strend - m);
}
m = rx->startp[0] + orig;
- sv_catpvn(dstr, s, m-s);
+ if (doutf8 && !SvUTF8(dstr))
+ sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
+ else
+ sv_catpvn(dstr, s, m-s);
s = rx->endp[0] + orig;
if (clen)
sv_catpvn(dstr, c, clen);
break;
} while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
TARG, NULL, r_flags));
- if (doutf8 && !DO_UTF8(dstr)) {
- SV* nsv = sv_2mortal(newSVpvn(s, strend - s));
-
- sv_utf8_upgrade(nsv);
- sv_catpvn(dstr, SvPVX(nsv), SvCUR(nsv));
- }
+ if (doutf8 && !DO_UTF8(TARG))
+ sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
else
sv_catpvn(dstr, s, strend - s);
- (void)SvOOK_off(TARG);
- if (SvLEN(TARG))
- Safefree(SvPVX(TARG));
- SvPVX(TARG) = SvPVX(dstr);
+#ifdef PERL_COPY_ON_WRITE
+ /* The match may make the string COW. If so, brilliant, because that's
+ just saved us one malloc, copy and free - the regexp has donated
+ the old buffer, and we malloc an entirely new one, rather than the
+ regexp malloc()ing a buffer and copying our original, only for
+ us to throw it away here during the substitution. */
+ if (SvIsCOW(TARG)) {
+ sv_force_normal_flags(TARG, SV_COW_DROP_PV);
+ } else
+#endif
+ {
+ SvPV_free(TARG);
+ }
+ SvPV_set(TARG, SvPVX(dstr));
SvCUR_set(TARG, SvCUR(dstr));
SvLEN_set(TARG, SvLEN(dstr));
doutf8 |= DO_UTF8(dstr);
- SvPVX(dstr) = 0;
+ SvPV_set(dstr, (char*)0);
sv_free(dstr);
TAINT_IF(rxtainted & 1);
PP(pp_grepwhile)
{
- dSP;
+ dVAR; dSP;
if (SvTRUEx(POPs))
PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
(void)POPMARK; /* pop dst */
SP = PL_stack_base + POPMARK; /* pop original mark */
if (gimme == G_SCALAR) {
- dTARGET;
- XPUSHi(items);
+ if (PL_op->op_private & OPpGREP_LEX) {
+ SV* sv = sv_newmortal();
+ sv_setiv(sv, items);
+ PUSHs(sv);
+ }
+ else {
+ dTARGET;
+ XPUSHi(items);
+ }
}
else if (gimme == G_ARRAY)
SP += items;
src = PL_stack_base[*PL_markstack_ptr];
SvTEMP_off(src);
- DEFSV = src;
+ if (PL_op->op_private & OPpGREP_LEX)
+ PAD_SVl(PL_op->op_targ) = src;
+ else
+ DEFSV = src;
RETURNOP(cLOGOP->op_other);
}
PP(pp_leavesub)
{
- dSP;
+ dVAR; dSP;
SV **mark;
SV **newsp;
PMOP *newpm;
SV *sv;
POPBLOCK(cx,newpm);
+ cxstack_ix++; /* temporarily protect top context */
TAINT_NOT;
if (gimme == G_SCALAR) {
}
PUTBACK;
+ LEAVE;
+ cxstack_ix--;
POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
PL_curpm = newpm; /* ... and pop $1 et al */
- LEAVE;
LEAVESUB(sv);
- return pop_return();
+ return cx->blk_sub.retop;
}
/* This duplicates the above code because the above code must not
* get any slower by more conditions */
PP(pp_leavesublv)
{
- dSP;
+ dVAR; dSP;
SV **mark;
SV **newsp;
PMOP *newpm;
SV *sv;
POPBLOCK(cx,newpm);
+ cxstack_ix++; /* temporarily protect top context */
TAINT_NOT;
* the refcounts so the caller gets a live guy. Cannot set
* TEMP, so sv_2mortal is out of question. */
if (!CvLVALUE(cx->blk_sub.cv)) {
+ LEAVE;
+ cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
- LEAVE;
LEAVESUB(sv);
DIE(aTHX_ "Can't modify non-lvalue subroutine call");
}
EXTEND_MORTAL(1);
if (MARK == SP) {
if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
+ LEAVE;
+ cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
- LEAVE;
LEAVESUB(sv);
DIE(aTHX_ "Can't return %s from lvalue subroutine",
SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
}
}
else { /* Should not happen? */
+ LEAVE;
+ cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
- LEAVE;
LEAVESUB(sv);
DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
(MARK > SP ? "Empty array" : "Array"));
&& SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
/* Might be flattened array after $#array = */
PUTBACK;
+ LEAVE;
+ cxstack_ix--;
POPSUB(cx,sv);
PL_curpm = newpm;
- LEAVE;
LEAVESUB(sv);
DIE(aTHX_ "Can't return a %s from lvalue subroutine",
SvREADONLY(TOPs) ? "readonly value" : "temporary");
}
PUTBACK;
+ LEAVE;
+ cxstack_ix--;
POPSUB(cx,sv); /* Stack values are safe: release CV and @_ ... */
PL_curpm = newpm; /* ... and pop $1 et al */
- LEAVE;
LEAVESUB(sv);
- return pop_return();
+ return cx->blk_sub.retop;
}
{
SV *dbsv = GvSV(PL_DBsub);
+ save_item(dbsv);
if (!PERLDB_SUB_NN) {
GV *gv = CvGV(cv);
- save_item(dbsv);
if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
|| strEQ(GvNAME(gv), "END")
|| ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
}
}
else {
- (void)SvUPGRADE(dbsv, SVt_PVIV);
+ const int type = SvTYPE(dbsv);
+ if (type < SVt_PVIV && type != SVt_IV)
+ sv_upgrade(dbsv, SVt_PVIV);
(void)SvIOK_on(dbsv);
- SAVEIV(SvIVX(dbsv));
- SvIVX(dbsv) = PTR2IV(cv); /* Do it the quickest way */
+ SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
}
if (CvXSUB(cv))
PP(pp_entersub)
{
- dSP; dPOPss;
+ dVAR; dSP; dPOPss;
GV *gv;
HV *stash;
register CV *cv;
register PERL_CONTEXT *cx;
I32 gimme;
- bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
+ const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
if (!sv)
DIE(aTHX_ "Not a CODE reference");
break;
default:
if (!SvROK(sv)) {
- char *sym;
- STRLEN n_a;
-
+ const char *sym;
if (sv == &PL_sv_yes) { /* unfound import, ignore */
if (hasargs)
SP = PL_stack_base + POPMARK;
goto got_rv;
sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
}
- else
+ else {
+ STRLEN n_a;
sym = SvPV(sv, n_a);
+ }
if (!sym)
DIE(aTHX_ PL_no_usym, "a subroutine");
if (PL_op->op_private & HINT_STRICT_REFS)
gimme = GIMME_V;
if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
+ if (CvASSERTION(cv) && PL_DBassertion)
+ sv_setiv(PL_DBassertion, 1);
+
cv = get_db_sub(&sv, cv);
- if (!cv)
- DIE(aTHX_ "No DBsub routine");
+ if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
+ DIE(aTHX_ "No DB::sub routine defined");
}
if (!(CvXSUB(cv))) {
dMARK;
register I32 items = SP - MARK;
AV* padlist = CvPADLIST(cv);
- push_return(PL_op->op_next);
PUSHBLOCK(cx, CXt_SUB, MARK);
PUSHSUB(cx);
+ cx->blk_sub.retop = PL_op->op_next;
CvDEPTH(cv)++;
/* XXX This would be a natural place to set C<PL_compcv = cv> so
* that eval'' ops within this sub know the correct lexical space.
* Owing the speed considerations, we choose instead to search for
* the cv using find_runcv() when calling doeval().
*/
- if (CvDEPTH(cv) < 2)
- (void)SvREFCNT_inc(cv);
- else {
+ if (CvDEPTH(cv) >= 2) {
PERL_STACK_OVERFLOW_CHECK();
- pad_push(padlist, CvDEPTH(cv), 1);
+ pad_push(padlist, CvDEPTH(cv));
}
PAD_SET_CUR(padlist, CvDEPTH(cv));
if (hasargs)
ary = AvALLOC(av);
if (AvARRAY(av) != ary) {
AvMAX(av) += AvARRAY(av) - AvALLOC(av);
- SvPVX(av) = (char*)ary;
+ SvPV_set(av, (char*)ary);
}
if (items > AvMAX(av) + 1) {
AvMAX(av) = items - 1;
Renew(ary,items,SV*);
AvALLOC(av) = ary;
- SvPVX(av) = (char*)ary;
+ SvPV_set(av, (char*)ary);
}
}
Copy(MARK,AvARRAY(av),items,SV*);
/* Need to copy @_ to stack. Alternative may be to
* switch stack to @_, and copy return values
* back. This would allow popping @_ in XSUB, e.g.. XXXX */
- AV* av;
- I32 items;
- av = GvAV(PL_defgv);
- items = AvFILLp(av) + 1; /* @_ is not tieable */
+ AV * const av = GvAV(PL_defgv);
+ const I32 items = AvFILLp(av) + 1; /* @_ is not tieable */
if (items) {
/* Mark is at the end of the stack. */
{
dSP;
SV** svp;
- SV* elemsv = POPs;
+ SV* const elemsv = POPs;
IV elem = SvIV(elemsv);
AV* av = (AV*)POPs;
- U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
- U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
+ const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
+ const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
SV *sv;
if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
RETPUSHUNDEF;
svp = av_fetch(av, elem, lval && !defer);
if (lval) {
+#ifdef PERL_MALLOC_WRAP
+ if (SvUOK(elemsv)) {
+ const UV uv = SvUV(elemsv);
+ elem = uv > IV_MAX ? IV_MAX : uv;
+ }
+ else if (SvNOK(elemsv))
+ elem = (IV)SvNV(elemsv);
+ if (elem > 0) {
+ static const char oom_array_extend[] =
+ "Out of memory during array extend"; /* Duplicated in av.c */
+ MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
+ }
+#endif
if (!svp || *svp == &PL_sv_undef) {
SV* lv;
if (!defer)
if (SvTYPE(sv) < SVt_RV)
sv_upgrade(sv, SVt_RV);
else if (SvTYPE(sv) >= SVt_PV) {
- (void)SvOOK_off(sv);
- Safefree(SvPVX(sv));
- SvLEN(sv) = SvCUR(sv) = 0;
+ SvPV_free(sv);
+ SvLEN_set(sv, 0);
+ SvCUR_set(sv, 0);
}
switch (to_what) {
case OPpDEREF_SV:
- SvRV(sv) = NEWSV(355,0);
+ SvRV_set(sv, NEWSV(355,0));
break;
case OPpDEREF_AV:
- SvRV(sv) = (SV*)newAV();
+ SvRV_set(sv, (SV*)newAV());
break;
case OPpDEREF_HV:
- SvRV(sv) = (SV*)newHV();
+ SvRV_set(sv, (SV*)newHV());
break;
}
SvROK_on(sv);
PP(pp_method_named)
{
dSP;
- SV* sv = cSVOP->op_sv;
+ SV* sv = cSVOP_sv;
U32 hash = SvUVX(sv);
XPUSHs(method_common(sv, &hash));
SV* ob;
GV* gv;
HV* stash;
- char* name;
STRLEN namelen;
- char* packname = 0;
+ const char* packname = 0;
SV *packsv = Nullsv;
STRLEN packlen;
+ const char *name = SvPV(meth, namelen);
- name = SvPV(meth, namelen);
sv = *(PL_stack_base + TOPMARK + 1);
if (!sv)
/* this isn't a reference */
packname = Nullch;
+
+ if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
+ HE* he;
+ he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
+ if (he) {
+ stash = INT2PTR(HV*,SvIV(HeVAL(he)));
+ goto fetch;
+ }
+ }
+
if (!SvOK(sv) ||
- !(packname = SvPV(sv, packlen)) ||
- !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
+ !(packname) ||
+ !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
!(ob=(SV*)GvIO(iogv)))
{
/* this isn't the name of a filehandle either */
stash = gv_stashpvn(packname, packlen, FALSE);
if (!stash)
packsv = sv;
+ else {
+ SV* ref = newSViv(PTR2IV(stash));
+ hv_store(PL_stashcache, packname, packlen, ref, 0);
+ }
goto fetch;
}
/* it _is_ a filehandle name -- replace with a reference */
cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
don't want that.
*/
- char* leaf = name;
- char* sep = Nullch;
- char* p;
+ const char* leaf = name;
+ const char* sep = Nullch;
+ const char* p;
for (p = name; *p; p++) {
if (*p == '\'')
/* the method name is unqualified or starts with SUPER:: */
packname = sep ? CopSTASHPV(PL_curcop) :
stash ? HvNAME(stash) : packname;
- packlen = strlen(packname);
+ if (!packname)
+ Perl_croak(aTHX_
+ "Can't use anonymous symbol table for method lookup");
+ else
+ packlen = strlen(packname);
}
else {
/* the method name is qualified */
}
return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
projects / p5sagit/p5-mst-13.2.git / blobdiff