return scalar(o);
}
+static SV *
+S_op_varname(pTHX_ const OP *o)
+{
+ assert(o);
+ assert(o->op_type == OP_PADAV || o->op_type == OP_RV2AV ||
+ o->op_type == OP_PADHV || o->op_type == OP_RV2HV);
+ {
+ const char funny = o->op_type == OP_PADAV
+ || o->op_type == OP_RV2AV ? '@' : '%';
+ if (o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) {
+ GV *gv;
+ if (cUNOPo->op_first->op_type != OP_GV
+ || !(gv = cGVOPx_gv(cUNOPo->op_first)))
+ return NULL;
+ return varname(gv, funny, 0, NULL, 0, 1);
+ }
+ return
+ varname(MUTABLE_GV(PL_compcv), funny, o->op_targ, NULL, 0, 1);
+ }
+}
+
+static void
+S_scalar_slice_warning(pTHX_ const OP *o)
+{
+ OP *kid;
+ const char lbrack =
+ o->op_type == OP_KVHSLICE || o->op_type == OP_HSLICE ? '{' : '[';
+ const char rbrack =
+ o->op_type == OP_KVHSLICE || o->op_type == OP_HSLICE ? '}' : ']';
+ const char funny =
+ o->op_type == OP_ASLICE || o->op_type == OP_HSLICE ? '@' : '%';
+ SV *name;
+ SV *keysv;
+ const char *key = NULL;
+
+ if (!(o->op_private & OPpSLICEWARNING))
+ return;
+ if (PL_parser && PL_parser->error_count)
+ /* This warning can be nonsensical when there is a syntax error. */
+ return;
+
+ kid = cLISTOPo->op_first;
+ kid = kid->op_sibling; /* get past pushmark */
+ /* weed out false positives: any ops that can return lists */
+ switch (kid->op_type) {
+ case OP_BACKTICK:
+ case OP_GLOB:
+ case OP_READLINE:
+ case OP_MATCH:
+ case OP_RV2AV:
+ case OP_EACH:
+ case OP_VALUES:
+ case OP_KEYS:
+ case OP_SPLIT:
+ case OP_LIST:
+ case OP_SORT:
+ case OP_REVERSE:
+ case OP_ENTERSUB:
+ case OP_CALLER:
+ case OP_LSTAT:
+ case OP_STAT:
+ case OP_READDIR:
+ case OP_SYSTEM:
+ case OP_TMS:
+ case OP_LOCALTIME:
+ case OP_GMTIME:
+ case OP_ENTEREVAL:
+ case OP_REACH:
+ case OP_RKEYS:
+ case OP_RVALUES:
+ return;
+ }
+ assert(kid->op_sibling);
+ name = S_op_varname(aTHX_ kid->op_sibling);
+ if (!name) /* XS module fiddling with the op tree */
+ return;
+ if (kid->op_type == OP_CONST) {
+ keysv = kSVOP_sv;
+ if (SvPOK(kSVOP_sv)) {
+ SV *sv = keysv;
+ keysv = sv_newmortal();
+ pv_pretty(keysv, SvPVX_const(sv), SvCUR(sv), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP |PERL_PV_ESCAPE_UNI_DETECT);
+ }
+ else if (!SvOK(keysv))
+ key = "undef";
+ }
+ else key = "...";
+ assert(SvPOK(name));
+ sv_chop(name,SvPVX(name)+1);
+ if (key)
+ /* diag_listed_as: Scalar value %%s[%s] better written as $%s[%s] */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Scalar value %c%"SVf"%c%s%c better written as $%"SVf
+ "%c%s%c",
+ funny, SVfARG(name), lbrack, key, rbrack, SVfARG(name),
+ lbrack, key, rbrack);
+ else
+ /* diag_listed_as: Scalar value %%s[%s] better written as $%s[%s] */
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Scalar value %c%"SVf"%c%"SVf"%c better written as $%"
+ SVf"%c%"SVf"%c",
+ funny, SVfARG(name), lbrack, keysv, rbrack,
+ SVfARG(name), lbrack, keysv, rbrack);
+}
+
OP *
Perl_scalar(pTHX_ OP *o)
{
case OP_SORT:
Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
break;
+ case OP_KVHSLICE:
+ case OP_KVASLICE:
+ S_scalar_slice_warning(aTHX_ o);
}
return o;
}
case OP_AELEMFAST:
case OP_AELEMFAST_LEX:
case OP_ASLICE:
+ case OP_KVASLICE:
case OP_HELEM:
case OP_HSLICE:
+ case OP_KVHSLICE:
case OP_UNPACK:
case OP_PACK:
case OP_JOIN:
* for reference counts, sv_upgrade() etc. */
if (cSVOPo->op_sv) {
const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
- if (o->op_type != OP_METHOD_NAMED
- && cSVOPo->op_sv == &PL_sv_undef) {
- /* PL_sv_undef is hack - it's unsafe to store it in the
- AV that is the pad, because av_fetch treats values of
- PL_sv_undef as a "free" AV entry and will merrily
- replace them with a new SV, causing pad_alloc to think
- that this pad slot is free. (When, clearly, it is not)
- */
- SvOK_off(PAD_SVl(ix));
- SvPADTMP_on(PAD_SVl(ix));
- SvREADONLY_on(PAD_SVl(ix));
- }
- else {
- SvREFCNT_dec(PAD_SVl(ix));
- PAD_SETSV(ix, cSVOPo->op_sv);
- /* XXX I don't know how this isn't readonly already. */
- if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
- }
+ SvREFCNT_dec(PAD_SVl(ix));
+ PAD_SETSV(ix, cSVOPo->op_sv);
+ /* XXX I don't know how this isn't readonly already. */
+ if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
cSVOPo->op_sv = NULL;
o->op_targ = ix;
}
fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
if (!fields || !GvHV(*fields))
break;
- key = SvPV_const(*svp, keylen);
- if (!hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
+ if (!hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
"in variable %"SVf" of type %"HEKf,
SVfARG(*svp), SVfARG(lexname),
SV *lexname;
GV **fields;
SV **svp;
- const char *key;
- STRLEN keylen;
SVOP *first_key_op, *key_op;
+ S_scalar_slice_warning(aTHX_ o);
+
if ((o->op_private & (OPpLVAL_INTRO))
/* I bet there's always a pushmark... */
|| ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
if (key_op->op_type != OP_CONST)
continue;
svp = cSVOPx_svp(key_op);
- key = SvPV_const(*svp, keylen);
- if (!hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : (I32)keylen, FALSE)) {
+ if (!hv_fetch_ent(GvHV(*fields), *svp, FALSE, 0)) {
Perl_croak(aTHX_ "No such class field \"%"SVf"\" "
"in variable %"SVf" of type %"HEKf,
SVfARG(*svp), SVfARG(lexname),
}
break;
}
+ case OP_ASLICE:
+ S_scalar_slice_warning(aTHX_ o);
+ break;
case OP_SUBST: {
if (cPMOPo->op_pmreplrootu.op_pmreplroot)
case OP_DBSTATE:
PL_modcount = RETURN_UNLIMITED_NUMBER;
break;
+ case OP_KVHSLICE:
+ case OP_KVASLICE:
+ if (type == OP_LEAVESUBLV)
+ o->op_private |= OPpMAYBE_LVSUB;
+ goto nomod;
case OP_AV2ARYLEN:
PL_hints |= HINT_BLOCK_SCOPE;
if (type == OP_LEAVESUBLV)
attrs)));
}
+STATIC void
+S_move_proto_attr(pTHX_ OP **proto, OP **attrs, const GV * name)
+{
+ OP *new_proto = NULL;
+ STRLEN pvlen;
+ char *pv;
+ OP *o;
+
+ PERL_ARGS_ASSERT_MOVE_PROTO_ATTR;
+
+ if (!*attrs)
+ return;
+
+ o = *attrs;
+ if (o->op_type == OP_CONST) {
+ pv = SvPV(cSVOPo_sv, pvlen);
+ if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
+ SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
+ SV ** const tmpo = cSVOPx_svp(o);
+ SvREFCNT_dec(cSVOPo_sv);
+ *tmpo = tmpsv;
+ new_proto = o;
+ *attrs = NULL;
+ }
+ } else if (o->op_type == OP_LIST) {
+ OP * lasto = NULL;
+ assert(o->op_flags & OPf_KIDS);
+ assert(cLISTOPo->op_first->op_type == OP_PUSHMARK);
+ /* Counting on the first op to hit the lasto = o line */
+ for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
+ if (o->op_type == OP_CONST) {
+ pv = SvPV(cSVOPo_sv, pvlen);
+ if (pvlen >= 10 && memEQ(pv, "prototype(", 10)) {
+ SV * const tmpsv = newSVpvn_flags(pv + 10, pvlen - 11, SvUTF8(cSVOPo_sv));
+ SV ** const tmpo = cSVOPx_svp(o);
+ SvREFCNT_dec(cSVOPo_sv);
+ *tmpo = tmpsv;
+ if (new_proto && ckWARN(WARN_MISC)) {
+ STRLEN new_len;
+ const char * newp = SvPV(cSVOPo_sv, new_len);
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
+ "Attribute prototype(%"UTF8f") discards earlier prototype attribute in same sub",
+ UTF8fARG(SvUTF8(cSVOPo_sv), new_len, newp));
+ op_free(new_proto);
+ }
+ else if (new_proto)
+ op_free(new_proto);
+ new_proto = o;
+ lasto->op_sibling = o->op_sibling;
+ continue;
+ }
+ }
+ lasto = o;
+ }
+ /* If the list is now just the PUSHMARK, scrap the whole thing; otherwise attributes.xs
+ would get pulled in with no real need */
+ if (!cLISTOPx(*attrs)->op_first->op_sibling) {
+ op_free(*attrs);
+ *attrs = NULL;
+ }
+ }
+
+ if (new_proto) {
+ SV *svname;
+ if (isGV(name)) {
+ svname = sv_newmortal();
+ gv_efullname3(svname, name, NULL);
+ }
+ else if (SvPOK(name) && *SvPVX((SV *)name) == '&')
+ svname = newSVpvn_flags(SvPVX((SV *)name)+1, SvCUR(name)-1, SvUTF8(name)|SVs_TEMP);
+ else
+ svname = (SV *)name;
+ if (ckWARN(WARN_ILLEGALPROTO))
+ (void)validate_proto(svname, cSVOPx_sv(new_proto), TRUE);
+ if (*proto && ckWARN(WARN_PROTOTYPE)) {
+ STRLEN old_len, new_len;
+ const char * oldp = SvPV(cSVOPx_sv(*proto), old_len);
+ const char * newp = SvPV(cSVOPx_sv(new_proto), new_len);
+
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
+ "Prototype '%"UTF8f"' overridden by attribute 'prototype(%"UTF8f")'"
+ " in %"SVf,
+ UTF8fARG(SvUTF8(cSVOPx_sv(*proto)), old_len, oldp),
+ UTF8fARG(SvUTF8(cSVOPx_sv(new_proto)), new_len, newp),
+ SVfARG(svname));
+ }
+ if (*proto)
+ op_free(*proto);
+ *proto = new_proto;
+ }
+}
+
STATIC OP *
S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
{
)
? (int)rtype : OP_MATCH];
const bool isary = ltype == OP_RV2AV || ltype == OP_PADAV;
- GV *gv;
SV * const name =
- (ltype == OP_RV2AV || ltype == OP_RV2HV)
- ? cUNOPx(left)->op_first->op_type == OP_GV
- && (gv = cGVOPx_gv(cUNOPx(left)->op_first))
- ? varname(gv, isary ? '@' : '%', 0, NULL, 0, 1)
- : NULL
- : varname(
- (GV *)PL_compcv, isary ? '@' : '%', left->op_targ, NULL, 0, 1
- );
+ S_op_varname(aTHX_ left);
if (name)
Perl_warner(aTHX_ packWARN(WARN_MISC),
"Applying %s to %"SVf" will act on scalar(%"SVf")",
break;
case OP_REPEAT:
if (o->op_private & OPpREPEAT_DOLIST) goto nope;
+ break;
+ case OP_SREFGEN:
+ if (cUNOPx(cUNOPo->op_first)->op_first->op_type != OP_CONST
+ || SvPADTMP(cSVOPx_sv(cUNOPx(cUNOPo->op_first)->op_first)))
+ goto nope;
}
if (PL_parser && PL_parser->error_count)
newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
else
{
- newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
- newop->op_folded = 1;
+ newop = newSVOP(OP_CONST, 0, MUTABLE_SV(sv));
+ if (type != OP_STRINGIFY) newop->op_folded = 1;
}
op_getmad(o,newop,'f');
return newop;
{
dVAR;
OP *curop;
- const I32 oldtmps_floor = PL_tmps_floor;
+ const SSize_t oldtmps_floor = PL_tmps_floor;
SV **svp;
AV *av;
rend = r + len;
}
-/* There are several snags with this code on EBCDIC:
- 1. 0xFF is a legal UTF-EBCDIC byte (there are no illegal bytes).
- 2. scan_const() in toke.c has encoded chars in native encoding which makes
- ranges at least in EBCDIC 0..255 range the bottom odd.
-*/
+/* There is a snag with this code on EBCDIC: scan_const() in toke.c has
+ * encoded chars in native encoding which makes ranges in the EBCDIC 0..255
+ * odd. */
if (complement) {
U8 tmpbuf[UTF8_MAXBYTES+1];
i = 0;
transv = newSVpvs("");
while (t < tend) {
- cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
+ cp[2*i] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
t += ulen;
- if (t < tend && NATIVE_TO_UTF(*t) == 0xff) {
+ if (t < tend && *t == ILLEGAL_UTF8_BYTE) {
t++;
- cp[2*i+1] = utf8n_to_uvuni(t, tend-t, &ulen, flags);
+ cp[2*i+1] = utf8n_to_uvchr(t, tend-t, &ulen, flags);
t += ulen;
}
else {
UV val = cp[2*j];
diff = val - nextmin;
if (diff > 0) {
- t = uvuni_to_utf8(tmpbuf,nextmin);
+ t = uvchr_to_utf8(tmpbuf,nextmin);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
if (diff > 1) {
- U8 range_mark = UTF_TO_NATIVE(0xff);
- t = uvuni_to_utf8(tmpbuf, val - 1);
+ U8 range_mark = ILLEGAL_UTF8_BYTE;
+ t = uvchr_to_utf8(tmpbuf, val - 1);
sv_catpvn(transv, (char *)&range_mark, 1);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
}
if (val >= nextmin)
nextmin = val + 1;
}
- t = uvuni_to_utf8(tmpbuf,nextmin);
+ t = uvchr_to_utf8(tmpbuf,nextmin);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
{
- U8 range_mark = UTF_TO_NATIVE(0xff);
+ U8 range_mark = ILLEGAL_UTF8_BYTE;
sv_catpvn(transv, (char *)&range_mark, 1);
}
- t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
+ t = uvchr_to_utf8(tmpbuf, 0x7fffffff);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
t = (const U8*)SvPVX_const(transv);
tlen = SvCUR(transv);
while (t < tend || tfirst <= tlast) {
/* see if we need more "t" chars */
if (tfirst > tlast) {
- tfirst = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
+ tfirst = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
t += ulen;
- if (t < tend && NATIVE_TO_UTF(*t) == 0xff) { /* illegal utf8 val indicates range */
+ if (t < tend && *t == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
t++;
- tlast = (I32)utf8n_to_uvuni(t, tend - t, &ulen, flags);
+ tlast = (I32)utf8n_to_uvchr(t, tend - t, &ulen, flags);
t += ulen;
}
else
/* now see if we need more "r" chars */
if (rfirst > rlast) {
if (r < rend) {
- rfirst = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
+ rfirst = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
r += ulen;
- if (r < rend && NATIVE_TO_UTF(*r) == 0xff) { /* illegal utf8 val indicates range */
+ if (r < rend && *r == ILLEGAL_UTF8_BYTE) { /* illegal utf8 val indicates range */
r++;
- rlast = (I32)utf8n_to_uvuni(r, rend - r, &ulen, flags);
+ rlast = (I32)utf8n_to_uvchr(r, rend - r, &ulen, flags);
r += ulen;
}
else
swash = MUTABLE_SV(swash_init("utf8", "", listsv, bits, none));
#ifdef USE_ITHREADS
- cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP);
+ cPADOPo->op_padix = pad_alloc(OP_TRANS, SVf_READONLY);
SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
PAD_SETSV(cPADOPo->op_padix, swash);
SvPADTMP_on(swash);
if (repl) {
OP *curop = repl;
bool konst;
- if (pm->op_pmflags & PMf_EVAL) {
- if (CopLINE(PL_curcop) < (line_t)PL_parser->multi_end)
- CopLINE_set(PL_curcop, (line_t)PL_parser->multi_end);
- }
/* If we are looking at s//.../e with a single statement, get past
the implicit do{}. */
if (curop->op_type == OP_NULL && curop->op_flags & OPf_KIDS
if (type == OP_LIST || flags & OPf_PARENS ||
type == OP_RV2AV || type == OP_RV2HV ||
- type == OP_ASLICE || type == OP_HSLICE)
+ type == OP_ASLICE || type == OP_HSLICE ||
+ type == OP_KVASLICE || type == OP_KVHSLICE)
return TRUE;
if (type == OP_PADAV || type == OP_PADHV)
OP *curop;
bool maybe_common_vars = TRUE;
+ if (left->op_type == OP_ASLICE || left->op_type == OP_HSLICE)
+ left->op_private &= ~ OPpSLICEWARNING;
+
PL_modcount = 0;
left = op_lvalue(left, OP_AASSIGN);
curop = list(force_list(left));
SAVEFREEPV(label);
}
- if (PL_parser && PL_parser->copline == NOLINE)
+ if (PL_parser->preambling != NOLINE) {
+ CopLINE_set(cop, PL_parser->preambling);
+ PL_parser->copline = NOLINE;
+ }
+ else if (PL_parser->copline == NOLINE)
CopLINE_set(cop, CopLINE(PL_curcop));
else {
CopLINE_set(cop, PL_parser->copline);
/* this line can have a breakpoint - store the cop in IV */
AV *av = CopFILEAVx(PL_curcop);
if (av) {
- SV * const * const svp = av_fetch(av, (I32)CopLINE(cop), FALSE);
+ SV * const * const svp = av_fetch(av, CopLINE(cop), FALSE);
if (svp && *svp != &PL_sv_undef ) {
(void)SvIOK_on(*svp);
SvIV_set(*svp, PTR2IV(cop));
first = *firstp;
other = *otherp;
+ /* [perl #59802]: Warn about things like "return $a or $b", which
+ is parsed as "(return $a) or $b" rather than "return ($a or
+ $b)". NB: This also applies to xor, which is why we do it
+ here.
+ */
+ switch (first->op_type) {
+ case OP_NEXT:
+ case OP_LAST:
+ case OP_REDO:
+ /* XXX: Perhaps we should emit a stronger warning for these.
+ Even with the high-precedence operator they don't seem to do
+ anything sensible.
+
+ But until we do, fall through here.
+ */
+ case OP_RETURN:
+ case OP_EXIT:
+ case OP_DIE:
+ case OP_GOTO:
+ /* XXX: Currently we allow people to "shoot themselves in the
+ foot" by explicitly writing "(return $a) or $b".
+
+ Warn unless we are looking at the result from folding or if
+ the programmer explicitly grouped the operators like this.
+ The former can occur with e.g.
+
+ use constant FEATURE => ( $] >= ... );
+ sub { not FEATURE and return or do_stuff(); }
+ */
+ if (!first->op_folded && !(first->op_flags & OPf_PARENS))
+ Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
+ "Possible precedence issue with control flow operator");
+ /* XXX: Should we optimze this to "return $a;" (i.e. remove
+ the "or $b" part)?
+ */
+ break;
+ }
+
if (type == OP_XOR) /* Not short circuit, but here by precedence. */
return newBINOP(type, flags, scalar(first), scalar(other));
|| other->op_type == OP_TRANS)
/* Mark the op as being unbindable with =~ */
other->op_flags |= OPf_SPECIAL;
- else if (other->op_type == OP_CONST)
- other->op_private |= OPpCONST_FOLDED;
other->op_folded = 1;
return other;
}
*otherp = NULL;
- if (first->op_type == OP_CONST)
- first->op_private |= OPpCONST_SHORTCIRCUIT;
+ if (cstop->op_type == OP_CONST)
+ cstop->op_private |= OPpCONST_SHORTCIRCUIT;
if (PL_madskills) {
first = newUNOP(OP_NULL, 0, first);
op_getmad(other, first, '2');
|| live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
/* Mark the op as being unbindable with =~ */
live->op_flags |= OPf_SPECIAL;
- else if (live->op_type == OP_CONST)
- live->op_private |= OPpCONST_FOLDED;
live->op_folded = 1;
return live;
}
else if(cond
&& (cond->op_type == OP_ASLICE
- || cond->op_type == OP_HSLICE)) {
+ || cond->op_type == OP_KVASLICE
+ || cond->op_type == OP_HSLICE
+ || cond->op_type == OP_KVHSLICE)) {
/* anonlist now needs a list from this op, was previously used in
* scalar context */
[CvDEPTH(outcv) ? CvDEPTH(outcv) : 1])[pax];
spot = (CV **)svspot;
+ if (!(PL_parser && PL_parser->error_count))
+ move_proto_attr(&proto, &attrs, (GV *)name);
+
if (proto) {
assert(proto->op_type == OP_CONST);
ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
OPSLAB *slab = NULL;
#endif
- if (proto) {
- assert(proto->op_type == OP_CONST);
- ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
- ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
- }
- else
- ps = NULL;
-
if (o_is_gv) {
gv = (GV*)o;
o = NULL;
has_name = FALSE;
}
+ if (!ec)
+ move_proto_attr(&proto, &attrs, gv);
+
+ if (proto) {
+ assert(proto->op_type == OP_CONST);
+ ps = SvPV_const(((SVOP*)proto)->op_sv, ps_len);
+ ps_utf8 = SvUTF8(((SVOP*)proto)->op_sv);
+ }
+ else
+ ps = NULL;
+
if (!PL_madskills) {
if (o)
SAVEFREEOP(o);
switch (o->op_type) {
case OP_PADSV:
+ case OP_PADHV:
o->op_type = OP_PADAV;
o->op_ppaddr = PL_ppaddr[OP_PADAV];
return ref(o, OP_RV2AV);
case OP_RV2SV:
+ case OP_RV2HV:
o->op_type = OP_RV2AV;
o->op_ppaddr = PL_ppaddr[OP_RV2AV];
ref(o, OP_RV2AV);
/* FALL THROUGH */
case OP_HELEM:
break;
+ case OP_KVASLICE:
+ Perl_croak(aTHX_ "delete argument is index/value array slice,"
+ " use array slice");
+ case OP_KVHSLICE:
+ Perl_croak(aTHX_ "delete argument is key/value hash slice, use"
+ " hash slice");
default:
- Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
- OP_DESC(o));
+ Perl_croak(aTHX_ "delete argument is not a HASH or ARRAY "
+ "element or slice");
}
if (kid->op_private & OPpLVAL_INTRO)
o->op_private |= OPpLVAL_INTRO;
(void) ref(kid, o->op_type);
if (kid->op_type != OP_RV2CV
&& !(PL_parser && PL_parser->error_count))
- Perl_croak(aTHX_ "%s argument is not a subroutine name",
- OP_DESC(o));
+ Perl_croak(aTHX_
+ "exists argument is not a subroutine name");
o->op_private |= OPpEXISTS_SUB;
}
else if (kid->op_type == OP_AELEM)
o->op_flags |= OPf_SPECIAL;
else if (kid->op_type != OP_HELEM)
- Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or a subroutine",
- OP_DESC(o));
+ Perl_croak(aTHX_ "exists argument is not a HASH or ARRAY "
+ "element or a subroutine");
op_null(kid);
}
return o;
SV *namesv;
targ = pad_alloc(OP_RV2GV, SVf_READONLY);
namesv = PAD_SVl(targ);
- SvUPGRADE(namesv, SVt_PV);
if (want_dollar && *name != '$')
sv_setpvs(namesv, "$");
+ else
+ sv_setpvs(namesv, "");
sv_catpvn(namesv, name, len);
if ( name_utf8 ) SvUTF8_on(namesv);
}
switch (kid->op_type) {
case OP_PADHV:
case OP_PADAV:
- name = varname(
- (GV *)PL_compcv, hash ? '%' : '@', kid->op_targ,
- NULL, 0, 1
- );
- break;
case OP_RV2HV:
case OP_RV2AV:
- if (cUNOPx(kid)->op_first->op_type != OP_GV) break;
- {
- GV *gv = cGVOPx_gv(cUNOPx(kid)->op_first);
- if (!gv) break;
- name = varname(gv, hash?'%':'@', 0, NULL, 0, 1);
- }
+ name = S_op_varname(aTHX_ kid);
break;
default:
return o;
old_count
= (oldoldop->op_private & OPpPADRANGE_COUNTMASK);
- assert(oldoldop->op_targ + old_count == base);
- if (old_count < OPpPADRANGE_COUNTMASK - count) {
+ /* Do not assume pad offsets for $c and $d are con-
+ tiguous in
+ my ($a,$b,$c);
+ my ($d,$e,$f);
+ */
+ if ( oldoldop->op_targ + old_count == base
+ && old_count < OPpPADRANGE_COUNTMASK - count) {
base = oldoldop->op_targ;
count += old_count;
reuse = 1;
&& ( p->op_next->op_type == OP_NEXTSTATE
|| p->op_next->op_type == OP_DBSTATE)
&& count < OPpPADRANGE_COUNTMASK
+ && base + count == p->op_targ
) {
- assert(base + count == p->op_targ);
count++;
followop = p->op_next;
}
https://perl5.git.perl.org / perl5.git / blobdiff