PP(pp_const)
{
- dVAR;
dSP;
XPUSHs(cSVOP_sv);
RETURN;
PP(pp_nextstate)
{
- dVAR;
PL_curcop = (COP*)PL_op;
+ PL_sawalias = 0;
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
FREETMPS;
PP(pp_gvsv)
{
- dVAR;
dSP;
EXTEND(SP,1);
- if (PL_op->op_private & OPpLVAL_INTRO)
+ if (UNLIKELY(PL_op->op_private & OPpLVAL_INTRO))
PUSHs(save_scalar(cGVOP_gv));
else
PUSHs(GvSVn(cGVOP_gv));
+ if (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv))
+ PL_sawalias = TRUE;
RETURN;
}
+
+/* also used for: pp_lineseq() pp_regcmaybe() pp_scalar() pp_scope() */
+
PP(pp_null)
{
- dVAR;
return NORMAL;
}
-/* This is sometimes called directly by pp_coreargs and pp_grepstart. */
+/* This is sometimes called directly by pp_coreargs, pp_grepstart and
+ amagic_call. */
PP(pp_pushmark)
{
- dVAR;
PUSHMARK(PL_stack_sp);
return NORMAL;
}
PP(pp_stringify)
{
- dVAR; dSP; dTARGET;
+ dSP; dTARGET;
SV * const sv = TOPs;
SETs(TARG);
sv_copypv(TARG, sv);
PP(pp_gv)
{
- dVAR; dSP;
+ dSP;
XPUSHs(MUTABLE_SV(cGVOP_gv));
+ if (isGV(cGVOP_gv)
+ && (GvREFCNT(cGVOP_gv) > 1 || GvALIASED_SV(cGVOP_gv)))
+ PL_sawalias = TRUE;
RETURN;
}
+
+/* also used for: pp_andassign() */
+
PP(pp_and)
{
- dVAR;
PERL_ASYNC_CHECK();
{
/* SP is not used to remove a variable that is saved across the
PP(pp_sassign)
{
- dVAR; dSP;
+ dSP;
/* sassign keeps its args in the optree traditionally backwards.
So we pop them differently.
*/
SV * const temp = left;
left = right; right = temp;
}
- if (TAINTING_get && TAINT_get && !SvTAINTED(right))
+ if (TAINTING_get && UNLIKELY(TAINT_get) && !SvTAINTED(right))
TAINT_NOT;
- if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
+ if (UNLIKELY(PL_op->op_private & OPpASSIGN_CV_TO_GV)) {
+ /* *foo =\&bar */
SV * const cv = SvRV(right);
const U32 cv_type = SvTYPE(cv);
const bool is_gv = isGV_with_GP(left);
}
if (
- SvTEMP(left) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
+ UNLIKELY(SvTEMP(left)) && !SvSMAGICAL(left) && SvREFCNT(left) == 1 &&
(!isGV_with_GP(left) || SvFAKE(left)) && ckWARN(WARN_MISC)
)
Perl_warner(aTHX_
PP(pp_cond_expr)
{
- dVAR; dSP;
+ dSP;
PERL_ASYNC_CHECK();
if (SvTRUEx(POPs))
RETURNOP(cLOGOP->op_other);
PP(pp_unstack)
{
- dVAR;
PERL_ASYNC_CHECK();
TAINT_NOT; /* Each statement is presumed innocent */
PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
PP(pp_concat)
{
- dVAR; dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
+ dSP; dATARGET; tryAMAGICbin_MG(concat_amg, AMGf_assign);
{
dPOPTOPssrl;
bool lbyte;
else
SvUTF8_off(TARG);
}
- else { /* $l .= $r */
- if (!SvOK(TARG)) {
+ else { /* $l .= $r and left == TARG */
+ if (!SvOK(left)) {
if (left == right && ckWARN(WARN_UNINITIALIZED)) /* $l .= $l */
report_uninit(right);
sv_setpvs(left, "");
}
- SvPV_force_nomg_nolen(left);
+ else {
+ SvPV_force_nomg_nolen(left);
+ }
lbyte = !DO_UTF8(left);
if (IN_BYTES)
- SvUTF8_off(TARG);
+ SvUTF8_off(left);
}
if (!rcopied) {
- if (left == right)
- /* $r.$r: do magic twice: tied might return different 2nd time */
- SvGETMAGIC(right);
rpv = SvPV_nomg_const(right, rlen);
rbyte = !DO_UTF8(right);
}
if (lbyte != rbyte) {
- /* sv_utf8_upgrade_nomg() may reallocate the stack */
- PUTBACK;
if (lbyte)
sv_utf8_upgrade_nomg(TARG);
else {
sv_utf8_upgrade_nomg(right);
rpv = SvPV_nomg_const(right, rlen);
}
- SPAGAIN;
}
sv_catpvn_nomg(TARG, rpv, rlen);
dSP;
const SSize_t maxarg = AvFILL(av) + 1;
EXTEND(SP, maxarg);
- if (SvRMAGICAL(av)) {
+ if (UNLIKELY(SvRMAGICAL(av))) {
PADOFFSET i;
for (i=0; i < (PADOFFSET)maxarg; i++) {
SV ** const svp = av_fetch(av, i, FALSE);
PADOFFSET i;
for (i=0; i < (PADOFFSET)maxarg; i++) {
SV * const sv = AvARRAY(av)[i];
- SP[i+1] = sv ? sv : &PL_sv_undef;
+ SP[i+1] = LIKELY(sv) ? sv : &PL_sv_undef;
}
}
SP += maxarg;
PP(pp_padrange)
{
- dVAR; dSP;
+ dSP;
PADOFFSET base = PL_op->op_targ;
int count = (int)(PL_op->op_private) & OPpPADRANGE_COUNTMASK;
int i;
(base << (OPpPADRANGE_COUNTSHIFT + SAVE_TIGHT_SHIFT))
| (count << SAVE_TIGHT_SHIFT)
| SAVEt_CLEARPADRANGE);
- assert(OPpPADRANGE_COUNTMASK + 1 == (1 <<OPpPADRANGE_COUNTSHIFT));
+ STATIC_ASSERT_STMT(OPpPADRANGE_COUNTMASK + 1 == (1 << OPpPADRANGE_COUNTSHIFT));
assert((payload >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) == base);
{
dSS_ADD;
PP(pp_padsv)
{
- dVAR; dSP;
+ dSP;
EXTEND(SP, 1);
{
OP * const op = PL_op;
PP(pp_readline)
{
- dVAR;
dSP;
if (TOPs) {
SvGETMAGIC(TOPs);
PUTBACK;
Perl_pp_rv2gv(aTHX);
PL_last_in_gv = MUTABLE_GV(*PL_stack_sp--);
+ if (PL_last_in_gv == (GV *)&PL_sv_undef)
+ PL_last_in_gv = NULL;
+ else
+ assert(isGV_with_GP(PL_last_in_gv));
}
}
return do_readline();
PP(pp_eq)
{
- dVAR; dSP;
+ dSP;
SV *left, *right;
tryAMAGICbin_MG(eq_amg, AMGf_set|AMGf_numeric);
RETURN;
}
+
+/* also used for: pp_i_predec() pp_i_preinc() pp_predec() */
+
PP(pp_preinc)
{
- dVAR; dSP;
+ dSP;
const bool inc =
PL_op->op_type == OP_PREINC || PL_op->op_type == OP_I_PREINC;
- if (SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs)))
+ if (UNLIKELY(SvTYPE(TOPs) >= SVt_PVAV || (isGV_with_GP(TOPs) && !SvFAKE(TOPs))))
Perl_croak_no_modify();
- if (!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
+ if (LIKELY(!SvREADONLY(TOPs) && !SvGMAGICAL(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs))
&& SvIVX(TOPs) != (inc ? IV_MAX : IV_MIN))
{
SvIV_set(TOPs, SvIVX(TOPs) + (inc ? 1 : -1));
return NORMAL;
}
+
+/* also used for: pp_orassign() */
+
PP(pp_or)
{
- dVAR; dSP;
+ dSP;
PERL_ASYNC_CHECK();
if (SvTRUE(TOPs))
RETURN;
}
}
+
+/* also used for: pp_dor() pp_dorassign() */
+
PP(pp_defined)
{
- dVAR; dSP;
+ dSP;
SV* sv;
bool defined;
const int op_type = PL_op->op_type;
if (is_dor) {
PERL_ASYNC_CHECK();
sv = TOPs;
- if (!sv || !SvANY(sv)) {
+ if (UNLIKELY(!sv || !SvANY(sv))) {
if (op_type == OP_DOR)
--SP;
RETURNOP(cLOGOP->op_other);
else {
/* OP_DEFINED */
sv = POPs;
- if (!sv || !SvANY(sv))
+ if (UNLIKELY(!sv || !SvANY(sv)))
RETPUSHNO;
}
PP(pp_add)
{
- dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
+ dSP; dATARGET; bool useleft; SV *svl, *svr;
tryAMAGICbin_MG(add_amg, AMGf_assign|AMGf_numeric);
svr = TOPs;
svl = TOPm1s;
if (aiv >= 0) {
auv = aiv;
auvok = 1; /* Now acting as a sign flag. */
- } else { /* 2s complement assumption for IV_MIN */
- auv = (UV)-aiv;
+ } else {
+ auv = (aiv == IV_MIN) ? (UV)aiv : (UV)(-aiv);
}
}
a_valid = 1;
buv = biv;
buvok = 1;
} else
- buv = (UV)-biv;
+ buv = (biv == IV_MIN) ? (UV)biv : (UV)(-biv);
}
/* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
else "IV" now, independent of how it came in.
else {
/* Negate result */
if (result <= (UV)IV_MIN)
- SETi( -(IV)result );
+ SETi(result == (UV)IV_MIN
+ ? IV_MIN : -(IV)result);
else {
/* result valid, but out of range for IV. */
SETn( -(NV)result );
}
}
+
+/* also used for: pp_aelemfast_lex() */
+
PP(pp_aelemfast)
{
- dVAR; dSP;
+ dSP;
AV * const av = PL_op->op_type == OP_AELEMFAST_LEX
? MUTABLE_AV(PAD_SV(PL_op->op_targ)) : GvAVn(cGVOP_gv);
const U32 lval = PL_op->op_flags & OPf_MOD;
- SV** const svp = av_fetch(av, PL_op->op_private, lval);
+ SV** const svp = av_fetch(av, (I8)PL_op->op_private, lval);
SV *sv = (svp ? *svp : &PL_sv_undef);
+
+ if (UNLIKELY(!svp && lval))
+ DIE(aTHX_ PL_no_aelem, (int)(I8)PL_op->op_private);
+
EXTEND(SP, 1);
if (!lval && SvRMAGICAL(av) && SvGMAGICAL(sv)) /* see note in pp_helem() */
mg_get(sv);
PP(pp_join)
{
- dVAR; dSP; dMARK; dTARGET;
+ dSP; dMARK; dTARGET;
MARK++;
do_join(TARG, *MARK, MARK, SP);
SP = MARK;
PP(pp_pushre)
{
- dVAR; dSP;
+ dSP;
#ifdef DEBUGGING
/*
* We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
/* Oversized hot code. */
+/* also used for: pp_say() */
+
PP(pp_print)
{
- dVAR; dSP; dMARK; dORIGMARK;
+ dSP; dMARK; dORIGMARK;
PerlIO *fp;
MAGIC *mg;
GV * const gv
RETURN;
}
+
+/* also used for: pp_rv2hv() */
+/* also called directly by pp_lvavref */
+
PP(pp_rv2av)
{
- dVAR; dSP; dTOPss;
+ dSP; dTOPss;
const I32 gimme = GIMME_V;
static const char an_array[] = "an ARRAY";
static const char a_hash[] = "a HASH";
- const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
+ const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV
+ || PL_op->op_type == OP_LVAVREF;
const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
SvGETMAGIC(sv);
if (SvROK(sv)) {
- if (SvAMAGIC(sv)) {
+ if (UNLIKELY(SvAMAGIC(sv))) {
sv = amagic_deref_call(sv, is_pp_rv2av ? to_av_amg : to_hv_amg);
}
sv = SvRV(sv);
- if (SvTYPE(sv) != type)
+ if (UNLIKELY(SvTYPE(sv) != type))
/* diag_listed_as: Not an ARRAY reference */
DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
- else if (PL_op->op_flags & OPf_MOD
- && PL_op->op_private & OPpLVAL_INTRO)
+ else if (UNLIKELY(PL_op->op_flags & OPf_MOD
+ && PL_op->op_private & OPpLVAL_INTRO))
Perl_croak(aTHX_ "%s", PL_no_localize_ref);
}
- else if (SvTYPE(sv) != type) {
+ else if (UNLIKELY(SvTYPE(sv) != type)) {
GV *gv;
if (!isGV_with_GP(sv)) {
SETs(sv);
RETURN;
}
- else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ else if (UNLIKELY(PL_op->op_private & OPpMAYBE_LVSUB)) {
const I32 flags = is_lvalue_sub();
if (flags && !(flags & OPpENTERSUB_INARGS)) {
if (gimme != G_ARRAY)
if (is_pp_rv2av) {
AV *const av = MUTABLE_AV(sv);
- /* The guts of pp_rv2av, with no intending change to preserve history
- (until such time as we get tools that can do blame annotation across
- whitespace changes. */
+ /* The guts of pp_rv2av */
if (gimme == G_ARRAY) {
SP--;
PUTBACK;
&& (!SvRMAGICAL(sv) || !mg_find(sv, PERL_MAGIC_tied)))
SETs(HvUSEDKEYS(sv) ? &PL_sv_yes : sv_2mortal(newSViv(0)));
else if (gimme == G_SCALAR) {
- dTARGET;
+ dTARG;
TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
- SPAGAIN;
SETTARG;
}
}
STATIC void
S_do_oddball(pTHX_ SV **oddkey, SV **firstkey)
{
- dVAR;
-
PERL_ARGS_ASSERT_DO_ODDBALL;
if (*oddkey) {
* Don't bother if LHS is just an empty hash or array.
*/
- if ( (PL_op->op_private & OPpASSIGN_COMMON)
+ if ( (PL_op->op_private & OPpASSIGN_COMMON || PL_sawalias)
&& (
firstlelem != lastlelem
|| ! ((sv = *firstlelem))
) {
EXTEND_MORTAL(lastrelem - firstrelem + 1);
for (relem = firstrelem; relem <= lastrelem; relem++) {
- if ((sv = *relem)) {
+ if (LIKELY((sv = *relem))) {
TAINT_NOT; /* Each item is independent */
/* Dear TODO test in t/op/sort.t, I love you.
(It's relying on a panic, not a "semi-panic" from newSVsv()
and then an assertion failure below.) */
- if (SvIS_FREED(sv)) {
+ if (UNLIKELY(SvIS_FREED(sv))) {
Perl_croak(aTHX_ "panic: attempt to copy freed scalar %p",
(void*)sv);
}
ary = NULL;
hash = NULL;
- while (lelem <= lastlelem) {
+ while (LIKELY(lelem <= lastlelem)) {
+ bool alias = FALSE;
TAINT_NOT; /* Each item stands on its own, taintwise. */
sv = *lelem++;
+ if (UNLIKELY(!sv)) {
+ alias = TRUE;
+ sv = *lelem++;
+ ASSUME(SvTYPE(sv) == SVt_PVAV);
+ }
switch (SvTYPE(sv)) {
case SVt_PVAV:
ary = MUTABLE_AV(sv);
i = 0;
while (relem <= lastrelem) { /* gobble up all the rest */
SV **didstore;
- if (*relem)
+ if (LIKELY(*relem))
SvGETMAGIC(*relem); /* before newSV, in case it dies */
- sv = newSV(0);
- sv_setsv_nomg(sv, *relem);
- *(relem++) = sv;
+ if (LIKELY(!alias)) {
+ sv = newSV(0);
+ sv_setsv_nomg(sv, *relem);
+ *relem = sv;
+ }
+ else {
+ if (!SvROK(*relem))
+ DIE(aTHX_ "Assigned value is not a reference");
+ if (SvTYPE(SvRV(*relem)) > SVt_PVLV)
+ /* diag_listed_as: Assigned value is not %s reference */
+ DIE(aTHX_
+ "Assigned value is not a SCALAR reference");
+ if (lval)
+ *relem = sv_mortalcopy(*relem);
+ /* XXX else check for weak refs? */
+ sv = SvREFCNT_inc_simple_NN(SvRV(*relem));
+ }
+ relem++;
didstore = av_store(ary,i++,sv);
if (magic) {
if (!didstore)
}
TAINT_NOT;
}
- if (PL_delaymagic & DM_ARRAY_ISA)
+ if (UNLIKELY(PL_delaymagic & DM_ARRAY_ISA))
SvSETMAGIC(MUTABLE_SV(ary));
LEAVE;
break;
magic = SvMAGICAL(hash) != 0;
odd = ((lastrelem - firsthashrelem)&1)? 0 : 1;
- if ( odd ) {
+ if (UNLIKELY(odd)) {
do_oddball(lastrelem, firsthashrelem);
/* we have firstlelem to reuse, it's not needed anymore
*/
ENTER;
SAVEFREESV(SvREFCNT_inc_simple_NN(sv));
hv_clear(hash);
- while (relem < lastrelem+odd) { /* gobble up all the rest */
+ while (LIKELY(relem < lastrelem+odd)) { /* gobble up all the rest */
HE *didstore;
assert(*relem);
/* Copy the key if aassign is called in lvalue context,
break;
}
if (relem <= lastrelem) {
- if (
+ if (UNLIKELY(
SvTEMP(sv) && !SvSMAGICAL(sv) && SvREFCNT(sv) == 1 &&
(!isGV_with_GP(sv) || SvFAKE(sv)) && ckWARN(WARN_MISC)
- )
+ ))
Perl_warner(aTHX_
packWARN(WARN_MISC),
"Useless assignment to a temporary"
break;
}
}
- if (PL_delaymagic & ~DM_DELAY) {
+ if (UNLIKELY(PL_delaymagic & ~DM_DELAY)) {
/* Will be used to set PL_tainting below */
Uid_t tmp_uid = PerlProc_getuid();
Uid_t tmp_euid = PerlProc_geteuid();
Gid_t tmp_gid = PerlProc_getgid();
Gid_t tmp_egid = PerlProc_getegid();
+ /* XXX $> et al currently silently ignore failures */
if (PL_delaymagic & DM_UID) {
#ifdef HAS_SETRESUID
- (void)setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
- (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
- (Uid_t)-1);
+ PERL_UNUSED_RESULT(
+ setresuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1,
+ (Uid_t)-1));
#else
# ifdef HAS_SETREUID
- (void)setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
- (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1);
+ PERL_UNUSED_RESULT(
+ setreuid((PL_delaymagic & DM_RUID) ? PL_delaymagic_uid : (Uid_t)-1,
+ (PL_delaymagic & DM_EUID) ? PL_delaymagic_euid : (Uid_t)-1));
# else
# ifdef HAS_SETRUID
if ((PL_delaymagic & DM_UID) == DM_RUID) {
- (void)setruid(PL_delaymagic_uid);
+ PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
PL_delaymagic &= ~DM_RUID;
}
# endif /* HAS_SETRUID */
# ifdef HAS_SETEUID
if ((PL_delaymagic & DM_UID) == DM_EUID) {
- (void)seteuid(PL_delaymagic_euid);
+ PERL_UNUSED_RESULT(seteuid(PL_delaymagic_euid));
PL_delaymagic &= ~DM_EUID;
}
# endif /* HAS_SETEUID */
if (PL_delaymagic & DM_UID) {
if (PL_delaymagic_uid != PL_delaymagic_euid)
DIE(aTHX_ "No setreuid available");
- (void)PerlProc_setuid(PL_delaymagic_uid);
+ PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
}
# endif /* HAS_SETREUID */
#endif /* HAS_SETRESUID */
+
tmp_uid = PerlProc_getuid();
tmp_euid = PerlProc_geteuid();
}
+ /* XXX $> et al currently silently ignore failures */
if (PL_delaymagic & DM_GID) {
#ifdef HAS_SETRESGID
- (void)setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
- (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
- (Gid_t)-1);
+ PERL_UNUSED_RESULT(
+ setresgid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1,
+ (Gid_t)-1));
#else
# ifdef HAS_SETREGID
- (void)setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
- (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1);
+ PERL_UNUSED_RESULT(
+ setregid((PL_delaymagic & DM_RGID) ? PL_delaymagic_gid : (Gid_t)-1,
+ (PL_delaymagic & DM_EGID) ? PL_delaymagic_egid : (Gid_t)-1));
# else
# ifdef HAS_SETRGID
if ((PL_delaymagic & DM_GID) == DM_RGID) {
- (void)setrgid(PL_delaymagic_gid);
+ PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
PL_delaymagic &= ~DM_RGID;
}
# endif /* HAS_SETRGID */
# ifdef HAS_SETEGID
if ((PL_delaymagic & DM_GID) == DM_EGID) {
- (void)setegid(PL_delaymagic_egid);
+ PERL_UNUSED_RESULT(setegid(PL_delaymagic_egid));
PL_delaymagic &= ~DM_EGID;
}
# endif /* HAS_SETEGID */
if (PL_delaymagic & DM_GID) {
if (PL_delaymagic_gid != PL_delaymagic_egid)
DIE(aTHX_ "No setregid available");
- (void)PerlProc_setgid(PL_delaymagic_gid);
+ PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
}
# endif /* HAS_SETREGID */
#endif /* HAS_SETRESGID */
+
tmp_gid = PerlProc_getgid();
tmp_egid = PerlProc_getegid();
}
PP(pp_qr)
{
- dVAR; dSP;
+ dSP;
PMOP * const pm = cPMOP;
REGEXP * rx = PM_GETRE(pm);
SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
SvROK_on(rv);
cvp = &( ReANY((REGEXP *)SvRV(rv))->qr_anoncv);
- if ((cv = *cvp) && CvCLONE(*cvp)) {
+ if (UNLIKELY((cv = *cvp) && CvCLONE(*cvp))) {
*cvp = cv_clone(cv);
SvREFCNT_dec_NN(cv);
}
(void)sv_bless(rv, stash);
}
- if (RX_ISTAINTED(rx)) {
+ if (UNLIKELY(RX_ISTAINTED(rx))) {
SvTAINTED_on(rv);
SvTAINTED_on(SvRV(rv));
}
PP(pp_match)
{
- dVAR; dSP; dTARG;
+ dSP; dTARG;
PMOP *pm = cPMOP;
PMOP *dynpm = pm;
const char *s;
const char *truebase; /* Start of string */
REGEXP *rx = PM_GETRE(pm);
bool rxtainted;
- const I32 gimme = GIMME;
+ const I32 gimme = GIMME_V;
STRLEN len;
const I32 oldsave = PL_savestack_ix;
I32 had_zerolen = 0;
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
- else if (PL_op->op_private & OPpTARGET_MY)
+ else if (ARGTARG)
GETTARGET;
else {
TARG = DEFSV;
EXTEND_MORTAL(nparens + i);
for (i = !i; i <= nparens; i++) {
PUSHs(sv_newmortal());
- if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
+ if (LIKELY((RX_OFFS(rx)[i].start != -1)
+ && RX_OFFS(rx)[i].end != -1 ))
+ {
const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
const char * const s = RX_OFFS(rx)[i].start + truebase;
- if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
- len < 0 || len > strend - s)
+ if (UNLIKELY(RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0
+ || len < 0 || len > strend - s))
DIE(aTHX_ "panic: pp_match start/end pointers, i=%ld, "
"start=%ld, end=%ld, s=%p, strend=%p, len=%"UVuf,
(long) i, (long) RX_OFFS(rx)[i].start,
LEAVE_SCOPE(oldsave);
RETURN;
}
- /* NOTREACHED */
+ NOT_REACHED; /* NOTREACHED */
-nope:
+ nope:
if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
if (!mg)
mg = mg_find_mglob(TARG);
OP *
Perl_do_readline(pTHX)
{
- dVAR; dSP; dTARGETSTACKED;
+ dSP; dTARGETSTACKED;
SV *sv;
STRLEN tmplen = 0;
STRLEN offset;
if (IoFLAGS(io) & IOf_ARGV) {
if (IoFLAGS(io) & IOf_START) {
IoLINES(io) = 0;
- if (av_len(GvAVn(PL_last_in_gv)) < 0) {
+ if (av_tindex(GvAVn(PL_last_in_gv)) < 0) {
IoFLAGS(io) &= ~IOf_START;
- do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
+ do_open6(PL_last_in_gv, "-", 1, NULL, NULL, 0);
SvTAINTED_off(GvSVn(PL_last_in_gv)); /* previous tainting irrelevant */
sv_setpvs(GvSVn(PL_last_in_gv), "-");
SvSETMAGIC(GvSV(PL_last_in_gv));
goto have_fp;
}
}
- fp = nextargv(PL_last_in_gv);
+ fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
if (!fp) { /* Note: fp != IoIFP(io) */
(void)do_close(PL_last_in_gv, FALSE); /* now it does*/
}
if (gimme == G_SCALAR) {
/* undef TARG, and push that undefined value */
if (type != OP_RCATLINE) {
- SV_CHECK_THINKFIRST_COW_DROP(TARG);
- SvOK_off(TARG);
+ sv_setsv(TARG,NULL);
}
PUSHTARG;
}
{
PerlIO_clearerr(fp);
if (IoFLAGS(io) & IOf_ARGV) {
- fp = nextargv(PL_last_in_gv);
+ fp = nextargv(PL_last_in_gv, PL_op->op_flags & OPf_SPECIAL);
if (fp)
continue;
(void)do_close(PL_last_in_gv, FALSE);
}
}
for (t1 = SvPVX_const(sv); *t1; t1++)
- if (!isALPHANUMERIC(*t1) &&
- strchr("$&*(){}[]'\";\\|?<>~`", *t1))
+#ifdef __VMS
+ if (strchr("*%?", *t1))
+#else
+ if (strchr("$&*(){}[]'\";\\|?<>~`", *t1))
+#endif
break;
if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
(void)POPs; /* Unmatched wildcard? Chuck it... */
PP(pp_helem)
{
- dVAR; dSP;
+ dSP;
HE* he;
SV **svp;
SV * const keysv = POPs;
RETURN;
}
+
+/* a stripped-down version of Perl_softref2xv() for use by
+ * pp_multideref(), which doesn't use PL_op->op_flags */
+
+GV *
+S_softref2xv_lite(pTHX_ SV *const sv, const char *const what,
+ const svtype type)
+{
+ if (PL_op->op_private & HINT_STRICT_REFS) {
+ if (SvOK(sv))
+ Perl_die(aTHX_ PL_no_symref_sv, sv,
+ (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what);
+ else
+ Perl_die(aTHX_ PL_no_usym, what);
+ }
+ if (!SvOK(sv))
+ Perl_die(aTHX_ PL_no_usym, what);
+ return gv_fetchsv_nomg(sv, GV_ADD, type);
+}
+
+
+/* Handle one or more aggregate derefs and array/hash indexings, e.g.
+ * $h->{foo} or $a[0]{$key}[$i] or f()->[1]
+ *
+ * op_aux points to an array of unions of UV / IV / SV* / PADOFFSET.
+ * Each of these either contains a set of actions, or an argument, such as
+ * an IV to use as an array index, or a lexical var to retrieve.
+ * Several actions re stored per UV; we keep shifting new actions off the
+ * one UV, and only reload when it becomes zero.
+ */
+
+PP(pp_multideref)
+{
+ SV *sv = NULL; /* init to avoid spurious 'may be used uninitialized' */
+ UNOP_AUX_item *items = cUNOP_AUXx(PL_op)->op_aux;
+ UV actions = items->uv;
+
+ assert(actions);
+ /* this tells find_uninit_var() where we're up to */
+ PL_multideref_pc = items;
+
+ while (1) {
+ /* there are three main classes of action; the first retrieve
+ * the initial AV or HV from a variable or the stack; the second
+ * does the equivalent of an unrolled (/DREFAV, rv2av, aelem),
+ * the third an unrolled (/DREFHV, rv2hv, helem).
+ */
+ switch (actions & MDEREF_ACTION_MASK) {
+
+ case MDEREF_reload:
+ actions = (++items)->uv;
+ continue;
+
+ case MDEREF_AV_padav_aelem: /* $lex[...] */
+ sv = PAD_SVl((++items)->pad_offset);
+ goto do_AV_aelem;
+
+ case MDEREF_AV_gvav_aelem: /* $pkg[...] */
+ sv = UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(sv));
+ sv = (SV*)GvAVn((GV*)sv);
+ goto do_AV_aelem;
+
+ case MDEREF_AV_pop_rv2av_aelem: /* expr->[...] */
+ {
+ dSP;
+ sv = POPs;
+ PUTBACK;
+ goto do_AV_rv2av_aelem;
+ }
+
+ case MDEREF_AV_gvsv_vivify_rv2av_aelem: /* $pkg->[...] */
+ sv = UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(sv));
+ sv = GvSVn((GV*)sv);
+ goto do_AV_vivify_rv2av_aelem;
+
+ case MDEREF_AV_padsv_vivify_rv2av_aelem: /* $lex->[...] */
+ sv = PAD_SVl((++items)->pad_offset);
+ /* FALLTHROUGH */
+
+ do_AV_vivify_rv2av_aelem:
+ case MDEREF_AV_vivify_rv2av_aelem: /* vivify, ->[...] */
+ /* this is the OPpDEREF action normally found at the end of
+ * ops like aelem, helem, rv2sv */
+ sv = vivify_ref(sv, OPpDEREF_AV);
+ /* FALLTHROUGH */
+
+ do_AV_rv2av_aelem:
+ /* this is basically a copy of pp_rv2av when it just has the
+ * sKR/1 flags */
+ SvGETMAGIC(sv);
+ if (LIKELY(SvROK(sv))) {
+ if (UNLIKELY(SvAMAGIC(sv))) {
+ sv = amagic_deref_call(sv, to_av_amg);
+ }
+ sv = SvRV(sv);
+ if (UNLIKELY(SvTYPE(sv) != SVt_PVAV))
+ DIE(aTHX_ "Not an ARRAY reference");
+ }
+ else if (SvTYPE(sv) != SVt_PVAV) {
+ if (!isGV_with_GP(sv))
+ sv = (SV*)S_softref2xv_lite(aTHX_ sv, "an ARRAY", SVt_PVAV);
+ sv = MUTABLE_SV(GvAVn((GV*)sv));
+ }
+ /* FALLTHROUGH */
+
+ do_AV_aelem:
+ {
+ /* retrieve the key; this may be either a lexical or package
+ * var (whose index/ptr is stored as an item) or a signed
+ * integer constant stored as an item.
+ */
+ SV *elemsv;
+ IV elem = 0; /* to shut up stupid compiler warnings */
+
+
+ assert(SvTYPE(sv) == SVt_PVAV);
+
+ switch (actions & MDEREF_INDEX_MASK) {
+ case MDEREF_INDEX_none:
+ goto finish;
+ case MDEREF_INDEX_const:
+ elem = (++items)->iv;
+ break;
+ case MDEREF_INDEX_padsv:
+ elemsv = PAD_SVl((++items)->pad_offset);
+ goto check_elem;
+ case MDEREF_INDEX_gvsv:
+ elemsv = UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(elemsv));
+ elemsv = GvSVn((GV*)elemsv);
+ check_elem:
+ if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv)
+ && ckWARN(WARN_MISC)))
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Use of reference \"%"SVf"\" as array index",
+ SVfARG(elemsv));
+ /* the only time that S_find_uninit_var() needs this
+ * is to determine which index value triggered the
+ * undef warning. So just update it here. Note that
+ * since we don't save and restore this var (e.g. for
+ * tie or overload execution), its value will be
+ * meaningless apart from just here */
+ PL_multideref_pc = items;
+ elem = SvIV(elemsv);
+ break;
+ }
+
+
+ /* this is basically a copy of pp_aelem with OPpDEREF skipped */
+
+ if (!(actions & MDEREF_FLAG_last)) {
+ SV** svp = av_fetch((AV*)sv, elem, 1);
+ if (!svp || ! (sv=*svp))
+ DIE(aTHX_ PL_no_aelem, elem);
+ break;
+ }
+
+ if (PL_op->op_private &
+ (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
+ {
+ if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
+ sv = av_exists((AV*)sv, elem) ? &PL_sv_yes : &PL_sv_no;
+ }
+ else {
+ I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
+ sv = av_delete((AV*)sv, elem, discard);
+ if (discard)
+ return NORMAL;
+ if (!sv)
+ sv = &PL_sv_undef;
+ }
+ }
+ else {
+ const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
+ const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
+ const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
+ bool preeminent = TRUE;
+ AV *const av = (AV*)sv;
+ SV** svp;
+
+ if (UNLIKELY(localizing)) {
+ MAGIC *mg;
+ HV *stash;
+
+ /* If we can determine whether the element exist,
+ * Try to preserve the existenceness of a tied array
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise. */
+ if (SvCANEXISTDELETE(av))
+ preeminent = av_exists(av, elem);
+ }
+
+ svp = av_fetch(av, elem, lval && !defer);
+
+ if (lval) {
+ if (!svp || !(sv = *svp)) {
+ IV len;
+ if (!defer)
+ DIE(aTHX_ PL_no_aelem, elem);
+ len = av_tindex(av);
+ sv = sv_2mortal(newSVavdefelem(av,
+ /* Resolve a negative index now, unless it points
+ * before the beginning of the array, in which
+ * case record it for error reporting in
+ * magic_setdefelem. */
+ elem < 0 && len + elem >= 0
+ ? len + elem : elem, 1));
+ }
+ else {
+ if (UNLIKELY(localizing)) {
+ if (preeminent) {
+ save_aelem(av, elem, svp);
+ sv = *svp; /* may have changed */
+ }
+ else
+ SAVEADELETE(av, elem);
+ }
+ }
+ }
+ else {
+ sv = (svp ? *svp : &PL_sv_undef);
+ /* see note in pp_helem() */
+ if (SvRMAGICAL(av) && SvGMAGICAL(sv))
+ mg_get(sv);
+ }
+ }
+
+ }
+ finish:
+ {
+ dSP;
+ XPUSHs(sv);
+ RETURN;
+ }
+ /* NOTREACHED */
+
+
+
+
+ case MDEREF_HV_padhv_helem: /* $lex{...} */
+ sv = PAD_SVl((++items)->pad_offset);
+ goto do_HV_helem;
+
+ case MDEREF_HV_gvhv_helem: /* $pkg{...} */
+ sv = UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(sv));
+ sv = (SV*)GvHVn((GV*)sv);
+ goto do_HV_helem;
+
+ case MDEREF_HV_pop_rv2hv_helem: /* expr->{...} */
+ {
+ dSP;
+ sv = POPs;
+ PUTBACK;
+ goto do_HV_rv2hv_helem;
+ }
+
+ case MDEREF_HV_gvsv_vivify_rv2hv_helem: /* $pkg->{...} */
+ sv = UNOP_AUX_item_sv(++items);
+ assert(isGV_with_GP(sv));
+ sv = GvSVn((GV*)sv);
+ goto do_HV_vivify_rv2hv_helem;
+
+ case MDEREF_HV_padsv_vivify_rv2hv_helem: /* $lex->{...} */
+ sv = PAD_SVl((++items)->pad_offset);
+ /* FALLTHROUGH */
+
+ do_HV_vivify_rv2hv_helem:
+ case MDEREF_HV_vivify_rv2hv_helem: /* vivify, ->{...} */
+ /* this is the OPpDEREF action normally found at the end of
+ * ops like aelem, helem, rv2sv */
+ sv = vivify_ref(sv, OPpDEREF_HV);
+ /* FALLTHROUGH */
+
+ do_HV_rv2hv_helem:
+ /* this is basically a copy of pp_rv2hv when it just has the
+ * sKR/1 flags (and pp_rv2hv is aliased to pp_rv2av) */
+
+ SvGETMAGIC(sv);
+ if (LIKELY(SvROK(sv))) {
+ if (UNLIKELY(SvAMAGIC(sv))) {
+ sv = amagic_deref_call(sv, to_hv_amg);
+ }
+ sv = SvRV(sv);
+ if (UNLIKELY(SvTYPE(sv) != SVt_PVHV))
+ DIE(aTHX_ "Not a HASH reference");
+ }
+ else if (SvTYPE(sv) != SVt_PVHV) {
+ if (!isGV_with_GP(sv))
+ sv = (SV*)S_softref2xv_lite(aTHX_ sv, "a HASH", SVt_PVHV);
+ sv = MUTABLE_SV(GvHVn((GV*)sv));
+ }
+ /* FALLTHROUGH */
+
+ do_HV_helem:
+ {
+ /* retrieve the key; this may be either a lexical / package
+ * var or a string constant, whose index/ptr is stored as an
+ * item
+ */
+ SV *keysv = NULL; /* to shut up stupid compiler warnings */
+
+ assert(SvTYPE(sv) == SVt_PVHV);
+
+ switch (actions & MDEREF_INDEX_MASK) {
+ case MDEREF_INDEX_none:
+ goto finish;
+
+ case MDEREF_INDEX_const:
+ keysv = UNOP_AUX_item_sv(++items);
+ break;
+
+ case MDEREF_INDEX_padsv:
+ keysv = PAD_SVl((++items)->pad_offset);
+ break;
+
+ case MDEREF_INDEX_gvsv:
+ keysv = UNOP_AUX_item_sv(++items);
+ keysv = GvSVn((GV*)keysv);
+ break;
+ }
+
+ /* see comment above about setting this var */
+ PL_multideref_pc = items;
+
+
+ /* ensure that candidate CONSTs have been HEKified */
+ assert( ((actions & MDEREF_INDEX_MASK) != MDEREF_INDEX_const)
+ || SvTYPE(keysv) >= SVt_PVMG
+ || !SvOK(keysv)
+ || SvROK(keysv)
+ || SvIsCOW_shared_hash(keysv));
+
+ /* this is basically a copy of pp_helem with OPpDEREF skipped */
+
+ if (!(actions & MDEREF_FLAG_last)) {
+ HE *he = hv_fetch_ent((HV*)sv, keysv, 1, 0);
+ if (!he || !(sv=HeVAL(he)) || sv == &PL_sv_undef)
+ DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
+ break;
+ }
+
+ if (PL_op->op_private &
+ (OPpMULTIDEREF_EXISTS|OPpMULTIDEREF_DELETE))
+ {
+ if (PL_op->op_private & OPpMULTIDEREF_EXISTS) {
+ sv = hv_exists_ent((HV*)sv, keysv, 0)
+ ? &PL_sv_yes : &PL_sv_no;
+ }
+ else {
+ I32 discard = (GIMME_V == G_VOID) ? G_DISCARD : 0;
+ sv = hv_delete_ent((HV*)sv, keysv, discard, 0);
+ if (discard)
+ return NORMAL;
+ if (!sv)
+ sv = &PL_sv_undef;
+ }
+ }
+ else {
+ const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
+ const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
+ const bool localizing = PL_op->op_private & OPpLVAL_INTRO;
+ bool preeminent = TRUE;
+ SV **svp;
+ HV * const hv = (HV*)sv;
+ HE* he;
+
+ if (UNLIKELY(localizing)) {
+ MAGIC *mg;
+ HV *stash;
+
+ /* If we can determine whether the element exist,
+ * Try to preserve the existenceness of a tied hash
+ * element by using EXISTS and DELETE if possible.
+ * Fallback to FETCH and STORE otherwise. */
+ if (SvCANEXISTDELETE(hv))
+ preeminent = hv_exists_ent(hv, keysv, 0);
+ }
+
+ he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
+ svp = he ? &HeVAL(he) : NULL;
+
+
+ if (lval) {
+ if (!svp || !(sv = *svp) || sv == &PL_sv_undef) {
+ SV* lv;
+ SV* key2;
+ if (!defer)
+ DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
+ lv = sv_newmortal();
+ sv_upgrade(lv, SVt_PVLV);
+ LvTYPE(lv) = 'y';
+ sv_magic(lv, key2 = newSVsv(keysv),
+ PERL_MAGIC_defelem, NULL, 0);
+ /* sv_magic() increments refcount */
+ SvREFCNT_dec_NN(key2);
+ LvTARG(lv) = SvREFCNT_inc_simple(hv);
+ LvTARGLEN(lv) = 1;
+ sv = lv;
+ }
+ else {
+ if (localizing) {
+ if (HvNAME_get(hv) && isGV(sv))
+ save_gp(MUTABLE_GV(sv),
+ !(PL_op->op_flags & OPf_SPECIAL));
+ else if (preeminent) {
+ save_helem_flags(hv, keysv, svp,
+ (PL_op->op_flags & OPf_SPECIAL)
+ ? 0 : SAVEf_SETMAGIC);
+ sv = *svp; /* may have changed */
+ }
+ else
+ SAVEHDELETE(hv, keysv);
+ }
+ }
+ }
+ else {
+ sv = (svp && *svp ? *svp : &PL_sv_undef);
+ /* see note in pp_helem() */
+ if (SvRMAGICAL(hv) && SvGMAGICAL(sv))
+ mg_get(sv);
+ }
+ }
+ goto finish;
+ }
+
+ } /* switch */
+
+ actions >>= MDEREF_SHIFT;
+ } /* while */
+ /* NOTREACHED */
+}
+
+
PP(pp_iter)
{
- dVAR; dSP;
+ dSP;
PERL_CONTEXT *cx;
SV *oldsv;
SV **itersvp;
It has SvPVX of "" and SvCUR of 0, which is what we want. */
STRLEN maxlen = 0;
const char *max = SvPV_const(end, maxlen);
- if (SvNIOK(cur) || SvCUR(cur) > maxlen)
+ if (UNLIKELY(SvNIOK(cur) || SvCUR(cur) > maxlen))
RETPUSHNO;
oldsv = *itersvp;
- if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
+ if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
/* safe to reuse old SV */
sv_setsv(oldsv, cur);
}
case CXt_LOOP_LAZYIV: /* integer increment */
{
IV cur = cx->blk_loop.state_u.lazyiv.cur;
- if (cur > cx->blk_loop.state_u.lazyiv.end)
+ if (UNLIKELY(cur > cx->blk_loop.state_u.lazyiv.end))
RETPUSHNO;
oldsv = *itersvp;
/* don't risk potential race */
- if (SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv)) {
+ if (LIKELY(SvREFCNT(oldsv) == 1 && !SvMAGICAL(oldsv))) {
/* safe to reuse old SV */
sv_setiv(oldsv, cur);
}
SvREFCNT_dec_NN(oldsv);
}
- if (cur == IV_MAX) {
+ if (UNLIKELY(cur == IV_MAX)) {
/* Handle end of range at IV_MAX */
cx->blk_loop.state_u.lazyiv.end = IV_MIN;
} else
}
if (PL_op->op_private & OPpITER_REVERSED) {
ix = --cx->blk_loop.state_u.ary.ix;
- if (ix <= (av_is_stack ? cx->blk_loop.resetsp : -1))
+ if (UNLIKELY(ix <= (av_is_stack ? cx->blk_loop.resetsp : -1)))
RETPUSHNO;
}
else {
ix = ++cx->blk_loop.state_u.ary.ix;
- if (ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av)))
+ if (UNLIKELY(ix > (av_is_stack ? cx->blk_oldsp : AvFILL(av))))
RETPUSHNO;
}
- if (SvMAGICAL(av) || AvREIFY(av)) {
+ if (UNLIKELY(SvMAGICAL(av) || AvREIFY(av))) {
SV * const * const svp = av_fetch(av, ix, FALSE);
sv = svp ? *svp : NULL;
}
sv = AvARRAY(av)[ix];
}
- if (sv) {
- if (SvIS_FREED(sv)) {
+ if (UNLIKELY(cx->cx_type & CXp_FOR_LVREF)) {
+ SvSetMagicSV(*itersvp, sv);
+ break;
+ }
+
+ if (LIKELY(sv)) {
+ if (UNLIKELY(SvIS_FREED(sv))) {
*itersvp = NULL;
Perl_croak(aTHX_ "Use of freed value in iteration");
}
- if (SvPADTMP(sv) && !IS_PADGV(sv))
+ if (SvPADTMP(sv)) {
sv = newSVsv(sv);
+ }
else {
SvTEMP_off(sv);
SvREFCNT_inc_simple_void_NN(sv);
PL_tainted will get set (via TAINT_set) if any component of the pattern
is tainted, e.g. /.*$tainted/. At the end of pattern compilation,
the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via
-TAINT_get).
+TAINT_get). It will also be set if any component of the pattern matches
+based on locale-dependent behavior.
When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to
the pattern is marked as tainted. This means that subsequent usage, such
as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED,
on the new pattern too.
-At the start of execution of a pattern, the RXf_TAINTED_SEEN flag on the
-regex is cleared; during execution, locale-variant ops such as POSIXL may
-set RXf_TAINTED_SEEN.
-
RXf_TAINTED_SEEN is used post-execution by the get magic code
of $1 et al to indicate whether the returned value should be tainted.
It is the responsibility of the caller of the pattern (i.e. pp_match,
PP(pp_subst)
{
- dVAR; dSP; dTARG;
+ dSP; dTARG;
PMOP *pm = cPMOP;
PMOP *rpm = pm;
char *s;
char *strend;
const char *c;
STRLEN clen;
- I32 iters = 0;
- I32 maxiters;
+ SSize_t iters = 0;
+ SSize_t maxiters;
bool once;
U8 rxtainted = 0; /* holds various SUBST_TAINT_* flag bits.
See "how taint works" above */
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
- else if (PL_op->op_private & OPpTARGET_MY)
+ else if (ARGTARG)
GETTARGET;
else {
TARG = DEFSV;
if (DO_UTF8(TARG) && !doutf8) {
nsv = sv_newmortal();
SvSetSV(nsv, dstr);
- if (PL_encoding)
- sv_recode_to_utf8(nsv, PL_encoding);
+ if (IN_ENCODING)
+ sv_recode_to_utf8(nsv, _get_encoding());
else
sv_utf8_upgrade(nsv);
c = SvPV_const(nsv, clen);
d = s = RX_OFFS(rx)[0].start + orig;
do {
I32 i;
- if (iters++ > maxiters)
+ if (UNLIKELY(iters++ > maxiters))
DIE(aTHX_ "Substitution loop");
- if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
+ if (UNLIKELY(RX_MATCH_TAINTED(rx))) /* run time pattern taint, eg locale */
rxtainted |= SUBST_TAINT_PAT;
m = RX_OFFS(rx)[0].start + orig;
if ((i = m - s)) {
Move(s, d, i+1, char); /* include the NUL */
}
SPAGAIN;
- mPUSHi((I32)iters);
+ mPUSHi(iters);
}
}
else {
}
first = TRUE;
do {
- if (iters++ > maxiters)
+ if (UNLIKELY(iters++ > maxiters))
DIE(aTHX_ "Substitution loop");
- if (RX_MATCH_TAINTED(rx))
+ if (UNLIKELY(RX_MATCH_TAINTED(rx)))
rxtainted |= SUBST_TAINT_PAT;
if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
char *old_s = s;
first = FALSE;
}
else {
- if (PL_encoding) {
+ if (IN_ENCODING) {
if (!nsv) nsv = sv_newmortal();
sv_copypv(nsv, repl);
- if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, PL_encoding);
+ if (!DO_UTF8(nsv)) sv_recode_to_utf8(nsv, _get_encoding());
sv_catsv(dstr, nsv);
}
else sv_catsv(dstr, repl);
- if (SvTAINTED(repl))
+ if (UNLIKELY(SvTAINTED(repl)))
rxtainted |= SUBST_TAINT_REPL;
}
if (once)
SvPV_set(dstr, NULL);
SPAGAIN;
- mPUSHi((I32)iters);
+ mPUSHi(iters);
}
}
PP(pp_grepwhile)
{
- dVAR; dSP;
+ dSP;
if (SvTRUEx(POPs))
PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
LEAVE_with_name("grep_item"); /* exit inner scope */
/* All done yet? */
- if (PL_stack_base + *PL_markstack_ptr > SP) {
+ if (UNLIKELY(PL_stack_base + *PL_markstack_ptr > SP)) {
I32 items;
const I32 gimme = GIMME_V;
SAVEVPTR(PL_curpm);
src = PL_stack_base[*PL_markstack_ptr];
- if (SvPADTMP(src) && !IS_PADGV(src)) {
+ if (SvPADTMP(src)) {
src = PL_stack_base[*PL_markstack_ptr] = sv_mortalcopy(src);
PL_tmps_floor++;
}
PP(pp_leavesub)
{
- dVAR; dSP;
+ dSP;
SV **mark;
SV **newsp;
PMOP *newpm;
PERL_CONTEXT *cx;
SV *sv;
- if (CxMULTICALL(&cxstack[cxstack_ix]))
+ if (CxMULTICALL(&cxstack[cxstack_ix])) {
+ /* entry zero of a stack is always PL_sv_undef, which
+ * simplifies converting a '()' return into undef in scalar context */
+ assert(PL_stack_sp > PL_stack_base || *PL_stack_base == &PL_sv_undef);
return 0;
+ }
POPBLOCK(cx,newpm);
cxstack_ix++; /* temporarily protect top context */
TAINT_NOT;
if (gimme == G_SCALAR) {
MARK = newsp + 1;
- if (MARK <= SP) {
+ if (LIKELY(MARK <= SP)) {
if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
&& !SvMAGICAL(TOPs)) {
PP(pp_entersub)
{
- dVAR; dSP; dPOPss;
+ dSP; dPOPss;
GV *gv;
CV *cv;
PERL_CONTEXT *cx;
I32 gimme;
const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
- if (!sv)
+ if (UNLIKELY(!sv))
DIE(aTHX_ "Not a CODE reference");
- switch (SvTYPE(sv)) {
- /* This is overwhelming the most common case: */
- case SVt_PVGV:
- we_have_a_glob:
- if (!(cv = GvCVu((const GV *)sv))) {
- HV *stash;
- cv = sv_2cv(sv, &stash, &gv, 0);
- }
- if (!cv) {
- ENTER;
- SAVETMPS;
- goto try_autoload;
- }
- break;
- case SVt_PVLV:
- if(isGV_with_GP(sv)) goto we_have_a_glob;
- /*FALLTHROUGH*/
- default:
- if (sv == &PL_sv_yes) { /* unfound import, ignore */
- if (hasargs)
- SP = PL_stack_base + POPMARK;
- else
- (void)POPMARK;
- RETURN;
- }
- SvGETMAGIC(sv);
- if (SvROK(sv)) {
- if (SvAMAGIC(sv)) {
- sv = amagic_deref_call(sv, to_cv_amg);
- /* Don't SPAGAIN here. */
- }
- }
- else {
- const char *sym;
- STRLEN len;
- if (!SvOK(sv))
- DIE(aTHX_ PL_no_usym, "a subroutine");
- sym = SvPV_nomg_const(sv, len);
- if (PL_op->op_private & HINT_STRICT_REFS)
- DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
- cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
- break;
- }
- cv = MUTABLE_CV(SvRV(sv));
- if (SvTYPE(cv) == SVt_PVCV)
- break;
- /* FALL THROUGH */
- case SVt_PVHV:
- case SVt_PVAV:
- DIE(aTHX_ "Not a CODE reference");
- /* This is the second most common case: */
- case SVt_PVCV:
- cv = MUTABLE_CV(sv);
- break;
+ /* This is overwhelmingly the most common case: */
+ if (!LIKELY(SvTYPE(sv) == SVt_PVGV && (cv = GvCVu((const GV *)sv)))) {
+ switch (SvTYPE(sv)) {
+ case SVt_PVGV:
+ we_have_a_glob:
+ if (!(cv = GvCVu((const GV *)sv))) {
+ HV *stash;
+ cv = sv_2cv(sv, &stash, &gv, 0);
+ }
+ if (!cv) {
+ ENTER;
+ SAVETMPS;
+ goto try_autoload;
+ }
+ break;
+ case SVt_PVLV:
+ if(isGV_with_GP(sv)) goto we_have_a_glob;
+ /* FALLTHROUGH */
+ default:
+ if (sv == &PL_sv_yes) { /* unfound import, ignore */
+ if (hasargs)
+ SP = PL_stack_base + POPMARK;
+ else
+ (void)POPMARK;
+ RETURN;
+ }
+ SvGETMAGIC(sv);
+ if (SvROK(sv)) {
+ if (SvAMAGIC(sv)) {
+ sv = amagic_deref_call(sv, to_cv_amg);
+ /* Don't SPAGAIN here. */
+ }
+ }
+ else {
+ const char *sym;
+ STRLEN len;
+ if (!SvOK(sv))
+ DIE(aTHX_ PL_no_usym, "a subroutine");
+ sym = SvPV_nomg_const(sv, len);
+ if (PL_op->op_private & HINT_STRICT_REFS)
+ DIE(aTHX_ "Can't use string (\"%" SVf32 "\"%s) as a subroutine ref while \"strict refs\" in use", sv, len>32 ? "..." : "");
+ cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
+ break;
+ }
+ cv = MUTABLE_CV(SvRV(sv));
+ if (SvTYPE(cv) == SVt_PVCV)
+ break;
+ /* FALLTHROUGH */
+ case SVt_PVHV:
+ case SVt_PVAV:
+ DIE(aTHX_ "Not a CODE reference");
+ /* This is the second most common case: */
+ case SVt_PVCV:
+ cv = MUTABLE_CV(sv);
+ break;
+ }
}
ENTER;
retry:
- if (CvCLONE(cv) && ! CvCLONED(cv))
+ if (UNLIKELY(CvCLONE(cv) && ! CvCLONED(cv)))
DIE(aTHX_ "Closure prototype called");
- if (!CvROOT(cv) && !CvXSUB(cv)) {
+ if (UNLIKELY(!CvROOT(cv) && !CvXSUB(cv))) {
GV* autogv;
SV* sub_name;
/* anonymous or undef'd function leaves us no recourse */
- if (CvANON(cv) || !(gv = CvGV(cv))) {
- if (CvNAMED(cv))
- DIE(aTHX_ "Undefined subroutine &%"HEKf" called",
- HEKfARG(CvNAME_HEK(cv)));
+ if (CvLEXICAL(cv) && CvHASGV(cv))
+ DIE(aTHX_ "Undefined subroutine &%"SVf" called",
+ SVfARG(cv_name(cv, NULL, 0)));
+ if (CvANON(cv) || !CvHASGV(cv)) {
DIE(aTHX_ "Undefined subroutine called");
}
/* autoloaded stub? */
- if (cv != GvCV(gv)) {
+ if (cv != GvCV(gv = CvGV(cv))) {
cv = GvCV(gv);
}
/* should call AUTOLOAD now? */
else {
-try_autoload:
+ try_autoload:
if ((autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
GvNAMEUTF8(gv) ? SVf_UTF8 : 0)))
{
goto retry;
}
- gimme = GIMME_V;
- if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
+ if (UNLIKELY((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub)
+ && !CvNODEBUG(cv)))
+ {
Perl_get_db_sub(aTHX_ &sv, cv);
if (CvISXSUB(cv))
PL_curcopdb = PL_curcop;
if (CvLVALUE(cv)) {
/* check for lsub that handles lvalue subroutines */
- cv = GvCV(gv_HVadd(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVHV)));
+ cv = GvCV(gv_fetchpvs("DB::lsub", GV_ADDMULTI, SVt_PVCV));
/* if lsub not found then fall back to DB::sub */
if (!cv) cv = GvCV(PL_DBsub);
} else {
DIE(aTHX_ "No DB::sub routine defined");
}
+ gimme = GIMME_V;
+
if (!(CvISXSUB(cv))) {
/* This path taken at least 75% of the time */
dMARK;
- SSize_t items = SP - MARK;
PADLIST * const padlist = CvPADLIST(cv);
+ I32 depth;
+
PUSHBLOCK(cx, CXt_SUB, MARK);
PUSHSUB(cx);
cx->blk_sub.retop = PL_op->op_next;
- CvDEPTH(cv)++;
- if (CvDEPTH(cv) >= 2) {
+ if (UNLIKELY((depth = ++CvDEPTH(cv)) >= 2)) {
PERL_STACK_OVERFLOW_CHECK();
- pad_push(padlist, CvDEPTH(cv));
+ pad_push(padlist, depth);
}
SAVECOMPPAD();
- PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
- if (hasargs) {
+ PAD_SET_CUR_NOSAVE(padlist, depth);
+ if (LIKELY(hasargs)) {
AV *const av = MUTABLE_AV(PAD_SVl(0));
- if (AvREAL(av)) {
+ SSize_t items;
+ AV **defavp;
+
+ if (UNLIKELY(AvREAL(av))) {
/* @_ is normally not REAL--this should only ever
* happen when DB::sub() calls things that modify @_ */
av_clear(av);
AvREAL_off(av);
AvREIFY_on(av);
}
- cx->blk_sub.savearray = GvAV(PL_defgv);
- GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
+ defavp = &GvAV(PL_defgv);
+ cx->blk_sub.savearray = *defavp;
+ *defavp = MUTABLE_AV(SvREFCNT_inc_simple_NN(av));
CX_CURPAD_SAVE(cx->blk_sub);
cx->blk_sub.argarray = av;
- ++MARK;
+ items = SP - MARK;
- if (items - 1 > AvMAX(av)) {
+ if (UNLIKELY(items - 1 > AvMAX(av))) {
SV **ary = AvALLOC(av);
AvMAX(av) = items - 1;
Renew(ary, items, SV*);
AvARRAY(av) = ary;
}
- Copy(MARK,AvARRAY(av),items,SV*);
+ Copy(MARK+1,AvARRAY(av),items,SV*);
AvFILLp(av) = items - 1;
MARK = AvARRAY(av);
while (items--) {
if (*MARK)
{
- if (SvPADTMP(*MARK) && !IS_PADGV(*MARK))
+ if (SvPADTMP(*MARK)) {
*MARK = sv_mortalcopy(*MARK);
+ }
SvTEMP_off(*MARK);
}
MARK++;
}
}
SAVETMPS;
- if ((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
- !CvLVALUE(cv))
+ if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
+ !CvLVALUE(cv)))
DIE(aTHX_ "Can't modify non-lvalue subroutine call");
/* warning must come *after* we fully set up the context
* stuff so that __WARN__ handlers can safely dounwind()
* if they want to
*/
- if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
- && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
+ if (UNLIKELY(depth == PERL_SUB_DEPTH_WARN
+ && ckWARN(WARN_RECURSION)
+ && !(PERLDB_SUB && cv == GvCV(PL_DBsub))))
sub_crush_depth(cv);
RETURNOP(CvSTART(cv));
}
SAVETMPS;
PUTBACK;
- if (((PL_op->op_private
+ if (UNLIKELY(((PL_op->op_private
& PUSHSUB_GET_LVALUE_MASK(Perl_is_lvalue_sub)
) & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
- !CvLVALUE(cv))
+ !CvLVALUE(cv)))
DIE(aTHX_ "Can't modify non-lvalue subroutine call");
- if (!hasargs && GvAV(PL_defgv)) {
+ if (UNLIKELY(!hasargs && GvAV(PL_defgv))) {
/* 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 */
SSize_t items = SP - mark;
while (items--) {
mark++;
- if (*mark && SvPADTMP(*mark) && !IS_PADGV(*mark))
+ if (*mark && SvPADTMP(*mark)) {
*mark = sv_mortalcopy(*mark);
+ }
}
}
/* We assume first XSUB in &DB::sub is the called one. */
- if (PL_curcopdb) {
+ if (UNLIKELY(PL_curcopdb)) {
SAVEVPTR(PL_curcop);
PL_curcop = PL_curcopdb;
PL_curcopdb = NULL;
CvXSUB(cv)(aTHX_ cv);
/* Enforce some sanity in scalar context. */
- if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
- if (markix > PL_stack_sp - PL_stack_base)
- *(PL_stack_base + markix) = &PL_sv_undef;
- else
- *(PL_stack_base + markix) = *PL_stack_sp;
- PL_stack_sp = PL_stack_base + markix;
+ if (gimme == G_SCALAR) {
+ SV **svp = PL_stack_base + markix + 1;
+ if (svp != PL_stack_sp) {
+ *svp = svp > PL_stack_sp ? &PL_sv_undef : *PL_stack_sp;
+ PL_stack_sp = svp;
+ }
}
LEAVE;
return NORMAL;
if (CvANON(cv))
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
else {
- HEK *const hek = CvNAME_HEK(cv);
- SV *tmpstr;
- if (hek) {
- tmpstr = sv_2mortal(newSVhek(hek));
- }
- else {
- tmpstr = sv_newmortal();
- gv_efullname3(tmpstr, CvGV(cv), NULL);
- }
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
- SVfARG(tmpstr));
+ SVfARG(cv_name(cv,NULL,0)));
}
}
PP(pp_aelem)
{
- dVAR; dSP;
+ dSP;
SV** svp;
SV* const elemsv = POPs;
IV elem = SvIV(elemsv);
bool preeminent = TRUE;
SV *sv;
- if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
+ if (UNLIKELY(SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC)))
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Use of reference \"%"SVf"\" as array index",
SVfARG(elemsv));
- if (SvTYPE(av) != SVt_PVAV)
+ if (UNLIKELY(SvTYPE(av) != SVt_PVAV))
RETPUSHUNDEF;
- if (localizing) {
+ if (UNLIKELY(localizing)) {
MAGIC *mg;
HV *stash;
IV len;
if (!defer)
DIE(aTHX_ PL_no_aelem, elem);
- len = av_len(av);
+ len = av_tindex(av);
mPUSHs(newSVavdefelem(av,
/* Resolve a negative index now, unless it points before the
beginning of the array, in which case record it for error
1));
RETURN;
}
- if (localizing) {
+ if (UNLIKELY(localizing)) {
if (preeminent)
save_aelem(av, elem, svp);
else
return sv;
}
-PP(pp_method)
+PERL_STATIC_INLINE HV *
+S_opmethod_stash(pTHX_ SV* meth)
{
- dVAR; dSP;
- SV* const sv = TOPs;
-
- if (SvROK(sv)) {
- SV* const rsv = SvRV(sv);
- if (SvTYPE(rsv) == SVt_PVCV) {
- SETs(rsv);
- RETURN;
- }
- }
-
- SETs(method_common(sv, NULL));
- RETURN;
-}
-
-PP(pp_method_named)
-{
- dVAR; dSP;
- SV* const sv = cSVOP_sv;
- U32 hash = SvSHARED_HASH(sv);
-
- XPUSHs(method_common(sv, &hash));
- RETURN;
-}
-
-STATIC SV *
-S_method_common(pTHX_ SV* meth, U32* hashp)
-{
- dVAR;
SV* ob;
- GV* gv;
HV* stash;
- SV *packsv = NULL;
- SV * const sv = PL_stack_base + TOPMARK == PL_stack_sp
+
+ SV* const sv = PL_stack_base + TOPMARK == PL_stack_sp
? (Perl_croak(aTHX_ "Can't call method \"%"SVf"\" without a "
"package or object reference", SVfARG(meth)),
(SV *)NULL)
: *(PL_stack_base + TOPMARK + 1);
- PERL_ARGS_ASSERT_METHOD_COMMON;
+ PERL_ARGS_ASSERT_OPMETHOD_STASH;
- if (!sv)
+ if (UNLIKELY(!sv))
undefined:
Perl_croak(aTHX_ "Can't call method \"%"SVf"\" on an undefined value",
SVfARG(meth));
- SvGETMAGIC(sv);
+ if (UNLIKELY(SvGMAGICAL(sv))) mg_get(sv);
+ else if (SvIsCOW_shared_hash(sv)) { /* MyClass->meth() */
+ stash = gv_stashsv(sv, GV_CACHE_ONLY);
+ if (stash) return stash;
+ }
+
if (SvROK(sv))
ob = MUTABLE_SV(SvRV(sv));
else if (!SvOK(sv)) goto undefined;
GV* iogv;
STRLEN packlen;
const char * const packname = SvPV_nomg_const(sv, packlen);
- const bool packname_is_utf8 = !!SvUTF8(sv);
- const HE* const he =
- (const HE *)hv_common(
- PL_stashcache, NULL, packname, packlen,
- packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
- );
-
- if (he) {
- stash = INT2PTR(HV*,SvIV(HeVAL(he)));
- DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
- stash, sv));
- goto fetch;
- }
+ const U32 packname_utf8 = SvUTF8(sv);
+ stash = gv_stashpvn(packname, packlen, packname_utf8 | GV_CACHE_ONLY);
+ if (stash) return stash;
if (!(iogv = gv_fetchpvn_flags(
- packname, packlen, SVf_UTF8 * packname_is_utf8, SVt_PVIO
+ packname, packlen, packname_utf8, SVt_PVIO
)) ||
!(ob=MUTABLE_SV(GvIO(iogv))))
{
SVfARG(meth));
}
/* assume it's a package name */
- stash = gv_stashpvn(packname, packlen, packname_is_utf8 ? SVf_UTF8 : 0);
- if (!stash)
- packsv = sv;
- else {
- SV* const ref = newSViv(PTR2IV(stash));
- (void)hv_store(PL_stashcache, packname,
- packname_is_utf8 ? -(I32)packlen : (I32)packlen, ref, 0);
- DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for '%"SVf"'\n",
- stash, sv));
- }
- goto fetch;
+ stash = gv_stashpvn(packname, packlen, packname_utf8);
+ if (stash) return stash;
+ else return MUTABLE_HV(sv);
}
/* it _is_ a filehandle name -- replace with a reference */
*(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV(MUTABLE_SV(iogv)));
: meth));
}
- stash = SvSTASH(ob);
+ return SvSTASH(ob);
+}
+
+PP(pp_method)
+{
+ dSP;
+ GV* gv;
+ HV* stash;
+ SV* const meth = TOPs;
+
+ if (SvROK(meth)) {
+ SV* const rmeth = SvRV(meth);
+ if (SvTYPE(rmeth) == SVt_PVCV) {
+ SETs(rmeth);
+ RETURN;
+ }
+ }
+
+ stash = opmethod_stash(meth);
- fetch:
- /* NOTE: stash may be null, hope hv_fetch_ent and
- gv_fetchmethod can cope (it seems they can) */
+ gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
+ assert(gv);
- /* shortcut for simple names */
- if (hashp) {
- const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
- if (he) {
- gv = MUTABLE_GV(HeVAL(he));
- if (isGV(gv) && GvCV(gv) &&
- (!GvCVGEN(gv) || GvCVGEN(gv)
- == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
- return MUTABLE_SV(GvCV(gv));
- }
+ SETs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
+ RETURN;
+}
+
+#define METHOD_CHECK_CACHE(stash,cache,meth) \
+ const HE* const he = hv_fetch_ent(cache, meth, 0, 0); \
+ if (he) { \
+ gv = MUTABLE_GV(HeVAL(he)); \
+ if (isGV(gv) && GvCV(gv) && (!GvCVGEN(gv) || GvCVGEN(gv) \
+ == (PL_sub_generation + HvMROMETA(stash)->cache_gen))) \
+ { \
+ XPUSHs(MUTABLE_SV(GvCV(gv))); \
+ RETURN; \
+ } \
+ } \
+
+PP(pp_method_named)
+{
+ dSP;
+ GV* gv;
+ SV* const meth = cMETHOPx_meth(PL_op);
+ HV* const stash = opmethod_stash(meth);
+
+ if (LIKELY(SvTYPE(stash) == SVt_PVHV)) {
+ METHOD_CHECK_CACHE(stash, stash, meth);
}
- gv = gv_fetchmethod_sv_flags(stash ? stash : MUTABLE_HV(packsv),
- meth, GV_AUTOLOAD | GV_CROAK);
+ gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
+ assert(gv);
+
+ XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
+ RETURN;
+}
+
+PP(pp_method_super)
+{
+ dSP;
+ GV* gv;
+ HV* cache;
+ SV* const meth = cMETHOPx_meth(PL_op);
+ HV* const stash = CopSTASH(PL_curcop);
+ /* Actually, SUPER doesn't need real object's (or class') stash at all,
+ * as it uses CopSTASH. However, we must ensure that object(class) is
+ * correct (this check is done by S_opmethod_stash) */
+ opmethod_stash(meth);
+
+ if ((cache = HvMROMETA(stash)->super)) {
+ METHOD_CHECK_CACHE(stash, cache, meth);
+ }
+
+ gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
+ assert(gv);
+
+ XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
+ RETURN;
+}
+
+PP(pp_method_redir)
+{
+ dSP;
+ GV* gv;
+ SV* const meth = cMETHOPx_meth(PL_op);
+ HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
+ opmethod_stash(meth); /* not used but needed for error checks */
+ if (stash) { METHOD_CHECK_CACHE(stash, stash, meth); }
+ else stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
+
+ gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK);
assert(gv);
- return isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv);
+ XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
+ RETURN;
+}
+
+PP(pp_method_redir_super)
+{
+ dSP;
+ GV* gv;
+ HV* cache;
+ SV* const meth = cMETHOPx_meth(PL_op);
+ HV* stash = gv_stashsv(cMETHOPx_rclass(PL_op), 0);
+ opmethod_stash(meth); /* not used but needed for error checks */
+
+ if (UNLIKELY(!stash)) stash = MUTABLE_HV(cMETHOPx_rclass(PL_op));
+ else if ((cache = HvMROMETA(stash)->super)) {
+ METHOD_CHECK_CACHE(stash, cache, meth);
+ }
+
+ gv = gv_fetchmethod_sv_flags(stash, meth, GV_AUTOLOAD|GV_CROAK|GV_SUPER);
+ assert(gv);
+
+ XPUSHs(isGV(gv) ? MUTABLE_SV(GvCV(gv)) : MUTABLE_SV(gv));
+ RETURN;
}
/*
- * Local variables:
- * c-indentation-style: bsd
- * c-basic-offset: 4
- * indent-tabs-mode: nil
- * End:
- *
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff