}
/* push the elements of av onto the stack.
- * XXX Note that padav has similar code but without the mg_get().
- * I suspect that the mg_get is no longer needed, but while padav
- * differs, it can't share this function */
+ * Returns PL_op->op_next to allow tail-call optimisation of its callers */
-STATIC void
+STATIC OP*
S_pushav(pTHX_ AV* const av)
{
dSP;
PADOFFSET i;
for (i=0; i < (PADOFFSET)maxarg; i++) {
SV ** const svp = av_fetch(av, i, FALSE);
- /* See note in pp_helem, and bug id #27839 */
- SP[i+1] = svp
- ? SvGMAGICAL(*svp) ? (mg_get(*svp), *svp) : *svp
- : &PL_sv_undef;
+ SP[i+1] = svp ? *svp : &PL_sv_undef;
}
}
else {
}
SP += maxarg;
PUTBACK;
+ return NORMAL;
}
if (PL_op->op_flags & OPf_SPECIAL) {
/* fake the RHS of my ($x,$y,..) = @_ */
PUSHMARK(SP);
- S_pushav(aTHX_ GvAVn(PL_defgv));
+ (void)S_pushav(aTHX_ GvAVn(PL_defgv));
SPAGAIN;
}
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));
+ assert((SV*)PL_last_in_gv == &PL_sv_undef || isGV_with_GP(PL_last_in_gv));
}
}
return do_readline();
}
+/* do the common parts of pp_padhv() and pp_rv2hv()
+ * It assumes the caller has done EXTEND(SP, 1) or equivalent.
+ * 'is_keys' indicates the OPpPADHV_ISKEYS/OPpRV2HV_ISKEYS flag is set.
+ * 'has_targ' indicates that the op has a target - this should
+ * be a compile-time constant so that the code can constant-folded as
+ * appropriate
+ * */
+
+PERL_STATIC_INLINE OP*
+S_padhv_rv2hv_common(pTHX_ HV *hv, U8 gimme, bool is_keys, bool has_targ)
+{
+ bool is_tied;
+ bool is_bool;
+ MAGIC *mg;
+ dSP;
+ IV i;
+ SV *sv;
+
+ assert(PL_op->op_type == OP_PADHV || PL_op->op_type == OP_RV2HV);
+
+ if (gimme == G_ARRAY) {
+ hv_pushkv(hv, 3);
+ return NORMAL;
+ }
+
+ if (is_keys)
+ /* 'keys %h' masquerading as '%h': reset iterator */
+ (void)hv_iterinit(hv);
+
+ if (gimme == G_VOID)
+ return NORMAL;
+
+ is_bool = ( PL_op->op_private & OPpTRUEBOOL
+ || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
+ && block_gimme() == G_VOID));
+ is_tied = SvRMAGICAL(hv) && (mg = mg_find(MUTABLE_SV(hv), PERL_MAGIC_tied));
+
+ if (UNLIKELY(is_tied)) {
+ if (is_keys && !is_bool) {
+ i = 0;
+ while (hv_iternext(hv))
+ i++;
+ goto push_i;
+ }
+ else {
+ sv = magic_scalarpack(hv, mg);
+ goto push_sv;
+ }
+ }
+ else {
+ i = HvUSEDKEYS(hv);
+ if (is_bool) {
+ sv = i ? &PL_sv_yes : &PL_sv_zero;
+ push_sv:
+ PUSHs(sv);
+ }
+ else {
+ push_i:
+ if (has_targ) {
+ dTARGET;
+ PUSHi(i);
+ }
+ else
+#ifdef PERL_OP_PARENT
+ if (is_keys) {
+ /* parent op should be an unused OP_KEYS whose targ we can
+ * use */
+ dTARG;
+ OP *k;
+
+ assert(!OpHAS_SIBLING(PL_op));
+ k = PL_op->op_sibparent;
+ assert(k->op_type == OP_KEYS);
+ TARG = PAD_SV(k->op_targ);
+ PUSHi(i);
+ }
+ else
+#endif
+ mPUSHi(i);
+ }
+ }
+
+ PUTBACK;
+ return NORMAL;
+}
+
+
+/* This is also called directly by pp_lvavref. */
+PP(pp_padav)
+{
+ dSP; dTARGET;
+ U8 gimme;
+ assert(SvTYPE(TARG) == SVt_PVAV);
+ if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
+ if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
+ EXTEND(SP, 1);
+
+ if (PL_op->op_flags & OPf_REF) {
+ PUSHs(TARG);
+ RETURN;
+ }
+ else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS)) {
+ if (GIMME_V == G_SCALAR)
+ /* diag_listed_as: Can't return %s to lvalue scalar context */
+ Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
+ PUSHs(TARG);
+ RETURN;
+ }
+ }
+
+ gimme = GIMME_V;
+ if (gimme == G_ARRAY)
+ return S_pushav(aTHX_ (AV*)TARG);
+
+ if (gimme == G_SCALAR) {
+ const SSize_t maxarg = AvFILL(MUTABLE_AV(TARG)) + 1;
+ if (!maxarg)
+ PUSHs(&PL_sv_zero);
+ else if (PL_op->op_private & OPpTRUEBOOL)
+ PUSHs(&PL_sv_yes);
+ else
+ mPUSHi(maxarg);
+ }
+ RETURN;
+}
+
+
+PP(pp_padhv)
+{
+ dSP; dTARGET;
+ U8 gimme;
+
+ assert(SvTYPE(TARG) == SVt_PVHV);
+ if (UNLIKELY( PL_op->op_private & OPpLVAL_INTRO ))
+ if (LIKELY( !(PL_op->op_private & OPpPAD_STATE) ))
+ SAVECLEARSV(PAD_SVl(PL_op->op_targ));
+
+ EXTEND(SP, 1);
+
+ if (PL_op->op_flags & OPf_REF) {
+ PUSHs(TARG);
+ RETURN;
+ }
+ else if (PL_op->op_private & OPpMAYBE_LVSUB) {
+ const I32 flags = is_lvalue_sub();
+ if (flags && !(flags & OPpENTERSUB_INARGS)) {
+ if (GIMME_V == G_SCALAR)
+ /* diag_listed_as: Can't return %s to lvalue scalar context */
+ Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
+ PUSHs(TARG);
+ RETURN;
+ }
+ }
+
+ gimme = GIMME_V;
+
+ return S_padhv_rv2hv_common(aTHX_ (HV*)TARG, gimme,
+ cBOOL(PL_op->op_private & OPpPADHV_ISKEYS),
+ 0 /* has_targ*/);
+}
+
+
/* also used for: pp_rv2hv() */
/* also called directly by pp_lvavref */
if (is_pp_rv2av) {
AV *const av = MUTABLE_AV(sv);
- /* The guts of pp_rv2av */
+
if (gimme == G_ARRAY) {
SP--;
PUTBACK;
- S_pushav(aTHX_ av);
- SPAGAIN;
+ return S_pushav(aTHX_ av);
}
- else if (gimme == G_SCALAR) {
+
+ if (gimme == G_SCALAR) {
const SSize_t maxarg = AvFILL(av) + 1;
if (PL_op->op_private & OPpTRUEBOOL)
SETs(maxarg ? &PL_sv_yes : &PL_sv_zero);
}
}
else {
- bool tied;
- /* The guts of pp_rv2hv */
- if (gimme == G_ARRAY) { /* array wanted */
- *PL_stack_sp = sv;
- return Perl_do_kv(aTHX);
- }
-
- if (PL_op->op_private & OPpRV2HV_ISKEYS)
- /* 'keys %h' masquerading as '%h': reset iterator */
- (void)hv_iterinit(MUTABLE_HV(sv));
-
- tied = SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied);
-
- if ( ( PL_op->op_private & OPpTRUEBOOL
- || ( PL_op->op_private & OPpMAYBE_TRUEBOOL
- && block_gimme() == G_VOID)
- )
- && !tied)
- SETs(HvUSEDKEYS(MUTABLE_HV(sv)) ? &PL_sv_yes : &PL_sv_zero);
- else if (gimme == G_SCALAR) {
- dTARG;
- if (PL_op->op_private & OPpRV2HV_ISKEYS) {
- IV i;
- if (tied) {
- i = 0;
- while (hv_iternext(MUTABLE_HV(sv)))
- i++;
- }
- else
- i = HvUSEDKEYS(MUTABLE_HV(sv));
- (void)POPs;
- mPUSHi(i);
- }
- else {
- TARG = Perl_hv_scalar(aTHX_ MUTABLE_HV(sv));
- SETTARG;
- }
- }
+ SP--; PUTBACK;
+ return S_padhv_rv2hv_common(aTHX_ (HV*)sv, gimme,
+ cBOOL(PL_op->op_private & OPpRV2HV_ISKEYS),
+ 1 /* has_targ*/);
}
RETURN;
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
+#elif defined(HAS_SETREUID)
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
+#else
# ifdef HAS_SETRUID
if ((PL_delaymagic & DM_UID) == DM_RUID) {
PERL_UNUSED_RESULT(setruid(PL_delaymagic_uid));
DIE(aTHX_ "No setreuid available");
PERL_UNUSED_RESULT(PerlProc_setuid(PL_delaymagic_uid));
}
-# endif /* HAS_SETREUID */
#endif /* HAS_SETRESUID */
tmp_uid = PerlProc_getuid();
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
+#elif defined(HAS_SETREGID)
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
+#else
# ifdef HAS_SETRGID
if ((PL_delaymagic & DM_GID) == DM_RGID) {
PERL_UNUSED_RESULT(setrgid(PL_delaymagic_gid));
DIE(aTHX_ "No setregid available");
PERL_UNUSED_RESULT(PerlProc_setgid(PL_delaymagic_gid));
}
-# endif /* HAS_SETREGID */
#endif /* HAS_SETRESGID */
tmp_gid = PerlProc_getgid();
RETURN;
}
if (localizing) {
- if (HvNAME_get(hv) && isGV(*svp))
+ if (HvNAME_get(hv) && isGV_or_RVCV(*svp))
save_gp(MUTABLE_GV(*svp), !(PL_op->op_flags & OPf_SPECIAL));
else if (preeminent)
save_helem_flags(hv, keysv, svp,
}
else {
if (localizing) {
- if (HvNAME_get(hv) && isGV(sv))
+ if (HvNAME_get(hv) && isGV_or_RVCV(sv))
save_gp(MUTABLE_GV(sv),
!(PL_op->op_flags & OPf_SPECIAL));
else if (preeminent) {
AvARRAY(av) = ary;
}
- Copy(MARK+1,AvARRAY(av),items,SV*);
+ if (items)
+ Copy(MARK+1,AvARRAY(av),items,SV*);
AvFILLp(av) = items - 1;
}
if (UNLIKELY((cx->blk_u16 & OPpENTERSUB_LVAL_MASK) == OPpLVAL_INTRO &&
assert(CvXSUB(cv));
CvXSUB(cv)(aTHX_ cv);
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+ /* This duplicates the check done in runops_debug(), but provides more
+ * information in the common case of the fault being with an XSUB.
+ *
+ * It should also catch an XSUB pushing more than it extends
+ * in scalar context.
+ */
+ if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
+ Perl_croak_nocontext(
+ "panic: XSUB %s::%s (%s) failed to extend arg stack: "
+ "base=%p, sp=%p, hwm=%p\n",
+ HvNAME(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)), CvFILE(cv),
+ PL_stack_base, PL_stack_sp,
+ PL_stack_base + PL_curstackinfo->si_stack_hwm);
+#endif
/* Enforce some sanity in scalar context. */
if (is_scalar) {
SV **svp = PL_stack_base + markix + 1;
https://perl5.git.perl.org / perl5.git / blobdiff