{
dVAR;
dSP;
- if ( PL_op->op_flags & OPf_SPECIAL )
- /* This is a const op added to hold the hints hash for
- pp_entereval. The hash can be modified by the code
- being eval'ed, so we return a copy instead. */
- mXPUSHs((SV*)Perl_hv_copy_hints_hv(aTHX_ (HV*)cSVOP_sv));
- else
- /* Normal const. */
- XPUSHs(cSVOP_sv);
+ XPUSHs(cSVOP_sv);
RETURN;
}
return NORMAL;
}
-PP(pp_setstate)
-{
- dVAR;
- PL_curcop = (COP*)PL_op;
- return NORMAL;
-}
-
PP(pp_pushmark)
{
dVAR;
{
dVAR; dSP; dTOPss;
const I32 gimme = GIMME_V;
- static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
- static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
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;
}
else if (LVRET) {
if (gimme != G_ARRAY)
- Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
- : return_hash_to_lvalue_scalar);
+ goto croak_cant_return;
SETs(sv);
RETURN;
}
}
else if (LVRET) {
if (gimme != G_ARRAY)
- Perl_croak(aTHX_
- is_pp_rv2av ? return_array_to_lvalue_scalar
- : return_hash_to_lvalue_scalar);
+ goto croak_cant_return;
SETs(sv);
RETURN;
}
}
else if (LVRET) {
if (gimme != G_ARRAY)
- Perl_croak(aTHX_
- is_pp_rv2av ? return_array_to_lvalue_scalar
- : return_hash_to_lvalue_scalar);
+ goto croak_cant_return;
SETs(sv);
RETURN;
}
}
}
RETURN;
+
+ croak_cant_return:
+ Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
+ is_pp_rv2av ? "array" : "hash");
+ RETURN;
}
STATIC void
S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
{
dVAR;
+
+ PERL_ARGS_ASSERT_DO_ODDBALL;
+
if (*relem) {
SV *tmpstr;
const HE *didstore;
*(relem++) = sv;
didstore = av_store(ary,i++,sv);
if (magic) {
- if (SvSMAGICAL(sv))
+ if (SvSMAGICAL(sv)) {
+ /* More magic can happen in the mg_set callback, so we
+ * backup the delaymagic for now. */
+ U16 dmbak = PL_delaymagic;
+ PL_delaymagic = 0;
mg_set(sv);
+ PL_delaymagic = dmbak;
+ }
if (!didstore)
sv_2mortal(sv);
}
duplicates += 2;
didstore = hv_store_ent(hash,sv,tmpstr,0);
if (magic) {
- if (SvSMAGICAL(tmpstr))
+ if (SvSMAGICAL(tmpstr)) {
+ U16 dmbak = PL_delaymagic;
+ PL_delaymagic = 0;
mg_set(tmpstr);
+ PL_delaymagic = dmbak;
+ }
if (!didstore)
sv_2mortal(tmpstr);
}
}
else
sv_setsv(sv, &PL_sv_undef);
- SvSETMAGIC(sv);
+
+ if (SvSMAGICAL(sv)) {
+ U16 dmbak = PL_delaymagic;
+ PL_delaymagic = 0;
+ mg_set(sv);
+ PL_delaymagic = dmbak;
+ }
break;
}
}
dVAR; dSP;
register PERL_CONTEXT *cx;
SV *sv, *oldsv;
- AV* av;
SV **itersvp;
+ AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
+ bool av_is_stack = FALSE;
EXTEND(SP, 1);
cx = &cxstack[cxstack_ix];
DIE(aTHX_ "panic: pp_iter");
itersvp = CxITERVAR(cx);
- av = cx->blk_loop.iterary;
- if (SvTYPE(av) != SVt_PVAV) {
- /* iterate ($min .. $max) */
- if (cx->blk_loop.iterlval) {
+ if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
/* string increment */
- register SV* cur = cx->blk_loop.iterlval;
+ SV* cur = cx->blk_loop.state_u.lazysv.cur;
+ SV *end = cx->blk_loop.state_u.lazysv.end;
+ /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
+ It has SvPVX of "" and SvCUR of 0, which is what we want. */
STRLEN maxlen = 0;
- const char *max =
- SvOK((SV*)av) ?
- SvPV_const((SV*)av, maxlen) : (const char *)"";
+ const char *max = SvPV_const(end, maxlen);
if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
RETPUSHYES;
}
RETPUSHNO;
- }
+ }
+ else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
/* integer increment */
- if (cx->blk_loop.iterix > cx->blk_loop.itermax)
+ if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
RETPUSHNO;
/* don't risk potential race */
if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
/* safe to reuse old SV */
- sv_setiv(*itersvp, cx->blk_loop.iterix++);
+ sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
}
else
{
* completely new SV for closures/references to work as they
* used to */
oldsv = *itersvp;
- *itersvp = newSViv(cx->blk_loop.iterix++);
+ *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
SvREFCNT_dec(oldsv);
}
/* Handle end of range at IV_MAX */
- if ((cx->blk_loop.iterix == IV_MIN) &&
- (cx->blk_loop.itermax == IV_MAX))
+ if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
+ (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
{
- cx->blk_loop.iterix++;
- cx->blk_loop.itermax++;
+ cx->blk_loop.state_u.lazyiv.cur++;
+ cx->blk_loop.state_u.lazyiv.end++;
}
RETPUSHYES;
}
/* iterate array */
+ assert(CxTYPE(cx) == CXt_LOOP_FOR);
+ av = cx->blk_loop.state_u.ary.ary;
+ if (!av) {
+ av_is_stack = TRUE;
+ av = PL_curstack;
+ }
if (PL_op->op_private & OPpITER_REVERSED) {
- /* In reverse, use itermax as the min :-) */
- if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
+ if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
+ ? cx->blk_loop.resetsp + 1 : 0))
RETPUSHNO;
if (SvMAGICAL(av) || AvREIFY(av)) {
- SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
+ SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
sv = svp ? *svp : NULL;
}
else {
- sv = AvARRAY(av)[--cx->blk_loop.iterix];
+ sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
}
}
else {
- if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
+ if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
AvFILL(av)))
RETPUSHNO;
if (SvMAGICAL(av) || AvREIFY(av)) {
- SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
+ SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
sv = svp ? *svp : NULL;
}
else {
- sv = AvARRAY(av)[++cx->blk_loop.iterix];
+ sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
}
}
Perl_croak(aTHX_ "Use of freed value in iteration");
}
- if (sv)
+ if (sv) {
SvTEMP_off(sv);
+ SvREFCNT_inc_simple_void_NN(sv);
+ }
else
sv = &PL_sv_undef;
- if (av != PL_curstack && sv == &PL_sv_undef) {
- SV *lv = cx->blk_loop.iterlval;
- if (lv && SvREFCNT(lv) > 1) {
- SvREFCNT_dec(lv);
- lv = NULL;
- }
- if (lv)
- SvREFCNT_dec(LvTARG(lv));
- else {
- lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
- LvTYPE(lv) = 'y';
- sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
- }
+ if (!av_is_stack && sv == &PL_sv_undef) {
+ SV *lv = newSV_type(SVt_PVLV);
+ LvTYPE(lv) = 'y';
+ sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
LvTARG(lv) = SvREFCNT_inc_simple(av);
- LvTARGOFF(lv) = cx->blk_loop.iterix;
+ LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
LvTARGLEN(lv) = (STRLEN)UV_MAX;
- sv = (SV*)lv;
+ sv = lv;
}
oldsv = *itersvp;
- *itersvp = SvREFCNT_inc_simple_NN(sv);
+ *itersvp = sv;
SvREFCNT_dec(oldsv);
RETPUSHYES;
if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
&& !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
sub_crush_depth(cv);
-#if 0
- DEBUG_S(PerlIO_printf(Perl_debug_log,
- "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
-#endif
RETURNOP(CvSTART(cv));
}
else {
void
Perl_sub_crush_depth(pTHX_ CV *cv)
{
+ PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
+
if (CvANON(cv))
Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
else {
void
Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
{
+ PERL_ARGS_ASSERT_VIVIFY_REF;
+
SvGETMAGIC(sv);
if (!SvOK(sv)) {
if (SvREADONLY(sv))
const char * const name = SvPV_const(meth, namelen);
SV * const sv = *(PL_stack_base + TOPMARK + 1);
+ PERL_ARGS_ASSERT_METHOD_COMMON;
+
if (!sv)
Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
}
}
- gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
-
- if (!gv) {
- /* This code tries to figure out just what went wrong with
- gv_fetchmethod. It therefore needs to duplicate a lot of
- the internals of that function. We can't move it inside
- Perl_gv_fetchmethod_autoload(), however, since that would
- cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
- don't want that.
- */
- const char* leaf = name;
- const char* sep = NULL;
- const char* p;
-
- for (p = name; *p; p++) {
- if (*p == '\'')
- sep = p, leaf = p + 1;
- else if (*p == ':' && *(p + 1) == ':')
- sep = p, leaf = p + 2;
- }
- if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
- /* the method name is unqualified or starts with SUPER:: */
-#ifndef USE_ITHREADS
- if (sep)
- stash = CopSTASH(PL_curcop);
-#else
- bool need_strlen = 1;
- if (sep) {
- packname = CopSTASHPV(PL_curcop);
- }
- else
-#endif
- if (stash) {
- HEK * const packhek = HvNAME_HEK(stash);
- if (packhek) {
- packname = HEK_KEY(packhek);
- packlen = HEK_LEN(packhek);
-#ifdef USE_ITHREADS
- need_strlen = 0;
-#endif
- } else {
- goto croak;
- }
- }
+ gv = gv_fetchmethod_flags(stash ? stash : (HV*)packsv, name,
+ GV_AUTOLOAD | GV_CROAK);
- if (!packname) {
- croak:
- Perl_croak(aTHX_
- "Can't use anonymous symbol table for method lookup");
- }
-#ifdef USE_ITHREADS
- if (need_strlen)
- packlen = strlen(packname);
-#endif
+ assert(gv);
- }
- else {
- /* the method name is qualified */
- packname = name;
- packlen = sep - name;
- }
-
- /* we're relying on gv_fetchmethod not autovivifying the stash */
- if (gv_stashpvn(packname, packlen, 0)) {
- Perl_croak(aTHX_
- "Can't locate object method \"%s\" via package \"%.*s\"",
- leaf, (int)packlen, packname);
- }
- else {
- Perl_croak(aTHX_
- "Can't locate object method \"%s\" via package \"%.*s\""
- " (perhaps you forgot to load \"%.*s\"?)",
- leaf, (int)packlen, packname, (int)packlen, packname);
- }
- }
return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
}
https://perl5.git.perl.org / perl5.git / blobdiff