|| (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
return PerlMemShared_calloc(1, sz);
-#if defined(USE_ITHREADS) && IVSIZE > U32SIZE
- /* Work around a goof with alignment on our part. For sparc32 (and
- possibly other architectures), if built with -Duse64bitint, the IV
- op_pmoffset in struct pmop should be 8 byte aligned, but the slab
- allocator is only providing 4 byte alignment. The real fix is to change
- the IV to a type the same size as a pointer, such as size_t, but we
- can't do that without breaking the ABI, which is a no-no in a maint
- release. So instead, simply allocate struct pmop directly, which will be
- suitably aligned: */
- if (sz == sizeof(struct pmop))
- return PerlMemShared_calloc(1, sz);
-#endif
-
/* While the subroutine is under construction, the slabs are accessed via
CvSTART(), to avoid needing to expand PVCV by one pointer for something
unneeded at runtime. Once a subroutine is constructed, the slabs are
}
#else
-# define Slab_to_rw(op)
+# define Slab_to_rw(op) NOOP
#endif
/* This cannot possibly be right, but it was copied from the old slab
}
STATIC void
-S_bad_type_sv(pTHX_ I32 n, const char *t, SV *namesv, U32 flags, const OP *kid)
+S_bad_type_gv(pTHX_ I32 n, const char *t, GV *gv, U32 flags, const OP *kid)
{
- PERL_ARGS_ASSERT_BAD_TYPE_SV;
+ SV * const namesv = gv_ename(gv);
+ PERL_ARGS_ASSERT_BAD_TYPE_GV;
yyerror_pv(Perl_form(aTHX_ "Type of arg %d to %"SVf" must be %s (not %s)",
(int)n, SVfARG(namesv), t, OP_DESC(kid)), SvUTF8(namesv) | flags);
if (type == OP_NULL)
type = (OPCODE)o->op_targ;
- if (o->op_slabbed) {
- Slab_to_rw(OpSLAB(o));
- }
+ if (o->op_slabbed)
+ Slab_to_rw(OpSLAB(o));
/* COP* is not cleared by op_clear() so that we may track line
* numbers etc even after null() */
if (! specialWARN(cop->cop_warnings))
PerlMemShared_free(cop->cop_warnings);
cophh_free(CopHINTHASH_get(cop));
+ if (PL_curcop == cop)
+ PL_curcop = NULL;
}
STATIC void
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:
else if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = NULL;
else if (SvPOK(sv)) {
- /* perl4's way of mixing documentation and code
- (before the invention of POD) was based on a
- trick to mix nroff and perl code. The trick was
- built upon these three nroff macros being used in
- void context. The pink camel has the details in
- the script wrapman near page 319. */
- const char * const maybe_macro = SvPVX_const(sv);
- if (strnEQ(maybe_macro, "di", 2) ||
- strnEQ(maybe_macro, "ds", 2) ||
- strnEQ(maybe_macro, "ig", 2))
- useless = NULL;
- else {
- SV * const dsv = newSVpvs("");
- useless_sv
- = Perl_newSVpvf(aTHX_
- "a constant (%s)",
- pv_pretty(dsv, maybe_macro,
- SvCUR(sv), 32, NULL, NULL,
- PERL_PV_PRETTY_DUMP
- | PERL_PV_ESCAPE_NOCLEAR
- | PERL_PV_ESCAPE_UNI_DETECT));
- SvREFCNT_dec_NN(dsv);
- }
+ SV * const dsv = newSVpvs("");
+ useless_sv
+ = Perl_newSVpvf(aTHX_
+ "a constant (%s)",
+ pv_pretty(dsv, SvPVX_const(sv),
+ SvCUR(sv), 32, NULL, NULL,
+ PERL_PV_PRETTY_DUMP
+ | PERL_PV_ESCAPE_NOCLEAR
+ | PERL_PV_ESCAPE_UNI_DETECT));
+ SvREFCNT_dec_NN(dsv);
}
else if (SvOK(sv)) {
useless_sv = Perl_newSVpvf(aTHX_ "a constant (%"SVf")", sv);
case OP_EXEC:
if ( o->op_sibling
&& (o->op_sibling->op_type == OP_NEXTSTATE || o->op_sibling->op_type == OP_DBSTATE)
- && ckWARN(WARN_SYNTAX))
+ && ckWARN(WARN_EXEC))
{
if (o->op_sibling->op_sibling) {
const OPCODE type = o->op_sibling->op_sibling->op_type;
* Despite being a "constant", the SV is written to,
* for reference counts, sv_upgrade() etc. */
if (cSVOPo->op_sv) {
- const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
- if (o->op_type != OP_METHOD_NAMED &&
- (SvPADTMP(cSVOPo->op_sv) || SvPADMY(cSVOPo->op_sv)))
- {
- /* If op_sv is already a PADTMP/MY then it is being used by
- * some pad, so make a copy. */
- sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
- if (!SvIsCOW(PAD_SVl(ix))) SvREADONLY_on(PAD_SVl(ix));
- SvREFCNT_dec(cSVOPo->op_sv);
- }
- else 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));
- SvPADTMP_on(cSVOPo->op_sv);
- 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));
- }
+ const PADOFFSET ix = pad_alloc(OP_CONST, SVf_READONLY);
+ 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;
}
/* Make the CONST have a shared SV */
svp = cSVOPx_svp(((BINOP*)o)->op_last);
- if ((!SvIsCOW(sv = *svp))
- && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
+ if ((!SvIsCOW_shared_hash(sv = *svp))
+ && SvTYPE(sv) < SVt_PVMG && SvOK(sv) && !SvROK(sv)) {
key = SvPV_const(sv, keylen);
lexname = newSVpvn_share(key,
SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
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)
lvalue_func:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
- pad_free(o->op_targ);
- o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
- assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
if (o->op_flags & OPf_KIDS)
op_lvalue(cBINOPo->op_first->op_sibling, type);
break;
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")",
CALL_BLOCK_HOOKS(bhk_pre_end, &retval);
LEAVE_SCOPE(floor);
- CopHINTS_set(&PL_compiling, PL_hints);
if (needblockscope)
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
o = pad_leavemy();
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)
SvREFCNT_inc_simple_void(sv);
SvTEMP_off(sv);
}
+ else { assert(SvIMMORTAL(sv)); }
break;
case 3:
/* Something tried to die. Abandon constant folding. */
op_free(o);
#endif
assert(sv);
+ if (type == OP_STRINGIFY) SvPADTMP_off(sv);
+ else if (!SvIMMORTAL(sv)) SvPADTMP_on(sv);
if (type == OP_RV2GV)
newop = newGVOP(OP_GV, 0, MUTABLE_GV(sv));
else
- newop = newSVOP(OP_CONST, OPpCONST_FOLDED<<8, MUTABLE_SV(sv));
+ {
+ 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;
list(o);
if (PL_parser && PL_parser->error_count)
o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
o->op_opt = 0; /* needs to be revisited in rpeep() */
curop = ((UNOP*)o)->op_first;
- ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
+ av = (AV *)SvREFCNT_inc_NN(*PL_stack_sp--);
+ ((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, (SV *)av);
+ if (AvFILLp(av) != -1)
+ for (svp = AvARRAY(av) + AvFILLp(av); svp >= AvARRAY(av); --svp)
+ SvPADTMP_on(*svp);
#ifdef PERL_MAD
op_getmad(curop,o,'O');
#else
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(del && rlen == tlen) {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Useless use of /d modifier in transliteration operator");
- } else if(rlen > tlen) {
+ } else if(rlen > tlen && !complement) {
Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Replacement list is longer than search list");
}
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
return CHECKOP(type, padop);
}
-#endif /* !USE_ITHREADS */
+#endif /* USE_ITHREADS */
/*
=for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
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)
return TRUE;
}
else if (curop->op_type == OP_PUSHRE) {
+ GV *const gv =
#ifdef USE_ITHREADS
- if (((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff) {
- GV *const gv = MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff));
- if (gv == PL_defgv
- || (int)GvASSIGN_GENERATION(gv) == PL_generation)
- return TRUE;
- GvASSIGN_GENERATION_set(gv, PL_generation);
- }
+ ((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff
+ ? MUTABLE_GV(PAD_SVl(((PMOP*)curop)->op_pmreplrootu.op_pmtargetoff))
+ : NULL;
#else
- GV *const gv
- = ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
+ ((PMOP*)curop)->op_pmreplrootu.op_pmtargetgv;
+#endif
if (gv) {
if (gv == PL_defgv
|| (int)GvASSIGN_GENERATION(gv) == PL_generation)
return TRUE;
GvASSIGN_GENERATION_set(gv, PL_generation);
}
-#endif
}
else
return TRUE;
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));
if (PL_modcount < RETURN_UNLIMITED_NUMBER &&
((LISTOP*)right)->op_last->op_type == OP_CONST)
{
- SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
+ SV ** const svp =
+ &((SVOP*)((LISTOP*)right)->op_last)->op_sv;
+ SV * const sv = *svp;
if (SvIOK(sv) && SvIVX(sv) == 0)
+ {
+ if (right->op_private & OPpSPLIT_IMPLIM) {
+ /* our own SV, created in ck_split */
+ SvREADONLY_off(sv);
sv_setiv(sv, PL_modcount+1);
+ }
+ else {
+ /* SV may belong to someone else */
+ SvREFCNT_dec(sv);
+ *svp = newSViv(PL_modcount+1);
+ }
+ }
}
}
}
#ifdef NATIVE_HINTS
cop->op_private |= NATIVE_HINTS;
#endif
- CopHINTS_set(&PL_compiling, CopHINTS_get(cop));
cop->op_next = (OP*)cop;
cop->cop_seq = seq;
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;
}
else {
}
*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;
}
NewOp(1101, logop, 1, LOGOP);
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 */
Perl_cv_ckproto_len_flags(pTHX_ const CV *cv, const GV *gv, const char *p,
const STRLEN len, const U32 flags)
{
- const char * const cvp = SvROK(cv) ? "" : CvPROTO(cv);
- const STRLEN clen = CvPROTOLEN(cv);
+ SV *name = NULL, *msg;
+ const char * cvp = SvROK(cv) ? "" : CvPROTO(cv);
+ STRLEN clen = CvPROTOLEN(cv), plen = len;
PERL_ARGS_ASSERT_CV_CKPROTO_LEN_FLAGS;
- if (((!p != !cvp) /* One has prototype, one has not. */
- || (p && (
- (flags & SVf_UTF8) == SvUTF8(cv)
- ? len != clen || memNE(cvp, p, len)
- : flags & SVf_UTF8
- ? bytes_cmp_utf8((const U8 *)cvp, clen,
- (const U8 *)p, len)
- : bytes_cmp_utf8((const U8 *)p, len,
- (const U8 *)cvp, clen)
- )
- )
- )
- && ckWARN_d(WARN_PROTOTYPE)) {
- SV* const msg = sv_newmortal();
- SV* name = NULL;
+ if (p == NULL && cvp == NULL)
+ return;
- if (gv)
- {
- if (isGV(gv))
- gv_efullname3(name = sv_newmortal(), gv, NULL);
- else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
- name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1,
- SvUTF8(gv)|SVs_TEMP);
- else name = (SV *)gv;
- }
- sv_setpvs(msg, "Prototype mismatch:");
- if (name)
- Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
- if (cvp)
- Perl_sv_catpvf(aTHX_ msg, " (%"SVf")",
- SVfARG(newSVpvn_flags(cvp,clen, SvUTF8(cv)|SVs_TEMP))
- );
- else
- sv_catpvs(msg, ": none");
- sv_catpvs(msg, " vs ");
- if (p)
- Perl_sv_catpvf(aTHX_ msg, "(%"SVf")", SVfARG(newSVpvn_flags(p, len, flags | SVs_TEMP)));
- else
- sv_catpvs(msg, "none");
- Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
+ if (!ckWARN_d(WARN_PROTOTYPE))
+ return;
+
+ if (p && cvp) {
+ p = S_strip_spaces(aTHX_ p, &plen);
+ cvp = S_strip_spaces(aTHX_ cvp, &clen);
+ if ((flags & SVf_UTF8) == SvUTF8(cv)) {
+ if (plen == clen && memEQ(cvp, p, plen))
+ return;
+ } else {
+ if (flags & SVf_UTF8) {
+ if (bytes_cmp_utf8((const U8 *)cvp, clen, (const U8 *)p, plen) == 0)
+ return;
+ }
+ else {
+ if (bytes_cmp_utf8((const U8 *)p, plen, (const U8 *)cvp, clen) == 0)
+ return;
+ }
+ }
}
+
+ msg = sv_newmortal();
+
+ if (gv)
+ {
+ if (isGV(gv))
+ gv_efullname3(name = sv_newmortal(), gv, NULL);
+ else if (SvPOK(gv) && *SvPVX((SV *)gv) == '&')
+ name = newSVpvn_flags(SvPVX((SV *)gv)+1, SvCUR(gv)-1, SvUTF8(gv)|SVs_TEMP);
+ else name = (SV *)gv;
+ }
+ sv_setpvs(msg, "Prototype mismatch:");
+ if (name)
+ Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name));
+ if (cvp)
+ Perl_sv_catpvf(aTHX_ msg, " (%"UTF8f")",
+ UTF8fARG(SvUTF8(cv),clen,cvp)
+ );
+ else
+ sv_catpvs(msg, ": none");
+ sv_catpvs(msg, " vs ");
+ if (p)
+ Perl_sv_catpvf(aTHX_ msg, "(%"UTF8f")", UTF8fARG(flags & SVf_UTF8,len,p));
+ else
+ sv_catpvs(msg, "none");
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg));
}
static void const_sv_xsub(pTHX_ CV* cv);
+static void const_av_xsub(pTHX_ CV* cv);
/*
SV *
Perl_cv_const_sv(pTHX_ const CV *const cv)
{
+ SV *sv;
PERL_UNUSED_CONTEXT;
if (!cv)
return NULL;
if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
return NULL;
+ sv = CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
+ if (sv && SvTYPE(sv) == SVt_PVAV) return NULL;
+ return sv;
+}
+
+SV *
+Perl_cv_const_sv_or_av(pTHX_ const CV * const cv)
+{
+ PERL_UNUSED_CONTEXT;
+ if (!cv)
+ return NULL;
+ assert (SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM);
return CvCONST(cv) ? MUTABLE_SV(CvXSUBANY(cv).any_ptr) : NULL;
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
- * Can be called in 3 ways:
- *
- * !cv
- * look for a single OP_CONST with attached value: return the value
- *
- * cv && CvCLONE(cv) && !CvCONST(cv)
- *
- * examine the clone prototype, and if contains only a single
- * OP_CONST referencing a pad const, or a single PADSV referencing
- * an outer lexical, return a non-zero value to indicate the CV is
- * a candidate for "constizing" at clone time
- *
- * cv && CvCONST(cv)
- *
- * We have just cloned an anon prototype that was marked as a const
- * candidate. Try to grab the current value, and in the case of
- * PADSV, ignore it if it has multiple references. In this case we
- * return a newly created *copy* of the value.
*/
SV *
-Perl_op_const_sv(pTHX_ const OP *o, CV *cv)
+Perl_op_const_sv(pTHX_ const OP *o)
{
dVAR;
SV *sv = NULL;
return NULL;
if (type == OP_CONST && cSVOPo->op_sv)
sv = cSVOPo->op_sv;
- else if (cv && type == OP_CONST) {
- sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
- if (!sv)
- return NULL;
- }
- else if (cv && type == OP_PADSV) {
- if (CvCONST(cv)) { /* newly cloned anon */
- sv = PAD_BASE_SV(CvPADLIST(cv), o->op_targ);
- /* the candidate should have 1 ref from this pad and 1 ref
- * from the parent */
- if (!sv || SvREFCNT(sv) != 2)
- return NULL;
- sv = newSVsv(sv);
- SvREADONLY_on(sv);
- return sv;
- }
- else {
- if (PAD_COMPNAME_FLAGS(o->op_targ) & SVf_FAKE)
- sv = &PL_sv_undef; /* an arbitrary non-null value */
- }
- }
else {
return NULL;
}
[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);
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv = op_const_sv(block);
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
}
if (const_sv) {
SvREFCNT_inc_simple_void_NN(const_sv);
+ SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
cv_forget_slab(cv);
op_free(block);
SvREFCNT_dec(compcv);
PL_compcv = NULL;
- goto clone;
+ goto setname;
}
/* Checking whether outcv is CvOUTSIDE(compcv) is not sufficient to
determine whether this sub definition is in the same scope as its
cv = compcv;
*spot = cv;
}
+ setname:
if (!CvNAME_HEK(cv)) {
CvNAME_HEK_set(cv,
hek
0)
);
}
+ if (const_sv) goto clone;
+
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
- if (CvCLONE(cv)) {
- assert(!CvCONST(cv));
- if (ps && !*ps && op_const_sv(block, cv))
- CvCONST_on(cv);
- }
-
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
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);
)
const_sv = NULL;
else
- const_sv = op_const_sv(block, NULL);
+ const_sv = op_const_sv(block);
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
}
if (const_sv) {
SvREFCNT_inc_simple_void_NN(const_sv);
+ SvFLAGS(const_sv) = (SvFLAGS(const_sv) & ~SVs_PADMY) | SVs_PADTMP;
if (cv) {
assert(!CvROOT(cv) && !CvCONST(cv));
cv_forget_slab(cv);
pad_tidy(CvCLONE(cv) ? padtidy_SUBCLONE : padtidy_SUB);
- if (CvCLONE(cv)) {
- assert(!CvCONST(cv));
- if (ps && !*ps && op_const_sv(block, cv))
- CvCONST_on(cv);
- }
-
attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
GvCV_set(gv,0); /* cv has been hijacked */
call_list(oldscope, PL_beginav);
- CopHINTS_set(&PL_compiling, PL_hints);
LEAVE;
}
else
{
dVAR;
CV* cv;
-#ifdef USE_ITHREADS
const char *const file = CopFILE(PL_curcop);
-#else
- SV *const temp_sv = CopFILESV(PL_curcop);
- const char *const file = temp_sv ? SvPV_nolen_const(temp_sv) : NULL;
-#endif
ENTER;
and so doesn't get free()d. (It's expected to be from the C pre-
processor __FILE__ directive). But we need a dynamically allocated one,
and we need it to get freed. */
- cv = newXS_len_flags(name, len, const_sv_xsub, file ? file : "", "",
+ cv = newXS_len_flags(name, len,
+ sv && SvTYPE(sv) == SVt_PVAV
+ ? const_av_xsub
+ : const_sv_xsub,
+ file ? file : "", "",
&sv, XS_DYNAMIC_FILENAME | flags);
CvXSUBANY(cv).any_ptr = SvREFCNT_inc_simple(sv);
CvCONST_on(cv);
Perl_newSTUB(pTHX_ GV *gv, bool fake)
{
CV *cv = MUTABLE_CV(newSV_type(SVt_PVCV));
+ GV *cvgv;
PERL_ARGS_ASSERT_NEWSTUB;
assert(!GvCVu(gv));
GvCV_set(gv, cv);
GvCVGEN(gv) = 0;
if (!fake && HvENAME_HEK(GvSTASH(gv)))
gv_method_changed(gv);
- CvGV_set(cv, gv);
+ if (SvFAKE(gv)) {
+ cvgv = gv_fetchsv((SV *)gv, GV_ADDMULTI, SVt_PVCV);
+ SvFAKE_off(cvgv);
+ }
+ else cvgv = gv;
+ CvGV_set(cv, cvgv);
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
GvMULTI_on(gv);
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);
dVAR;
o->op_type = OP_PADCV;
o->op_ppaddr = PL_ppaddr[OP_PADCV];
- return o;
}
return newUNOP(OP_RV2CV, flags, scalar(o));
}
/* 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;
PL_hints |= HINT_BLOCK_SCOPE;
if (o->op_flags & OPf_KIDS) {
SVOP * const kid = (SVOP*)cUNOPo->op_first;
+ assert(kid);
- if (!kid) {
- o->op_flags &= ~OPf_KIDS;
- op_null(o);
- }
- else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
+ if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
LOGOP *enter;
#ifdef PERL_MAD
OP* const oldo = o;
(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;
Perl_croak(aTHX_ "Constant is not %s reference", badtype);
return o;
}
+ if (SvTYPE(kidsv) == SVt_PVAV) return o;
if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
const char *badthing;
switch (o->op_type) {
SvREFCNT_dec(kid->op_sv);
#ifdef USE_ITHREADS
/* XXX hack: dependence on sizeof(PADOP) <= sizeof(SVOP) */
+ assert (sizeof(PADOP) <= sizeof(SVOP));
kPADOP->op_padix = pad_alloc(OP_GV, SVs_PADTMP);
SvREFCNT_dec(PAD_SVl(kPADOP->op_padix));
GvIN_PAD_on(gv);
const OPCODE kidtype = kid->op_type;
if (kidtype == OP_CONST && (kid->op_private & OPpCONST_BARE)
- && !(kid->op_private & OPpCONST_FOLDED)) {
+ && !kid->op_folded) {
OP * const newop = newGVOP(type, OPf_REF,
gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
#ifdef PERL_MAD
}
if (name) {
SV *namesv;
- targ = pad_alloc(OP_RV2GV, SVs_PADTMP);
+ 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);
}
kid = kid->op_sibling; /* get past "big" */
if (kid && kid->op_type == OP_CONST) {
const bool save_taint = TAINT_get;
- fbm_compile(((SVOP*)kid)->op_sv, 0);
+ SV *sv = kSVOP->op_sv;
+ if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
+ sv = newSV(0);
+ sv_copypv(sv, kSVOP->op_sv);
+ SvREFCNT_dec_NN(kSVOP->op_sv);
+ kSVOP->op_sv = sv;
+ }
+ if (SvOK(sv)) fbm_compile(sv, 0);
TAINT_set(save_taint);
#ifdef NO_TAINT_SUPPORT
PERL_UNUSED_VAR(save_taint);
kid = kid->op_sibling;
else if (kid && !kid->op_sibling) { /* print HANDLE; */
if (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE
- && !(kid->op_private & OPpCONST_FOLDED)) {
+ && !kid->op_folded) {
o->op_flags |= OPf_STACKED; /* make it a filehandle */
kid = newUNOP(OP_RV2GV, OPf_REF, scalar(kid));
cLISTOPo->op_first->op_sibling = kid;
const char * const method = SvPVX_const(sv);
if (!(strchr(method, ':') || strchr(method, '\''))) {
OP *cmop;
- if (!SvIsCOW(sv)) {
+ if (!SvIsCOW_shared_hash(sv)) {
sv = newSVpvn_share(method, SvUTF8(sv) ? -(I32)SvCUR(sv) : (I32)SvCUR(sv), 0);
}
else {
{
dVAR;
OP *firstkid;
- HV * const hinthv = GvHV(PL_hintgv);
+ OP *kid;
+ HV * const hinthv =
+ PL_hints & HINT_LOCALIZE_HH ? GvHV(PL_hintgv) : NULL;
+ U8 stacked;
PERL_ARGS_ASSERT_CK_SORT;
if (o->op_flags & OPf_STACKED)
simplify_sort(o);
firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
- if (o->op_flags & OPf_STACKED) { /* may have been cleared */
+ if ((stacked = o->op_flags & OPf_STACKED)) { /* may have been cleared */
OP *kid = cUNOPx(firstkid)->op_first; /* get past null */
if (kid->op_type == OP_SCOPE || kid->op_type == OP_LEAVE) {
firstkid = firstkid->op_sibling;
}
- /* provide list context for arguments */
- list(firstkid);
+ for (kid = firstkid; kid; kid = kid->op_sibling) {
+ /* provide list context for arguments */
+ list(kid);
+ if (stacked)
+ op_lvalue(kid, OP_GREPSTART);
+ }
return o;
}
PERL_ARGS_ASSERT_SIMPLIFY_SORT;
- if (!(o->op_flags & OPf_STACKED))
- return;
GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, SVt_PV));
kid = kUNOP->op_first; /* get past null */
scalar(kid);
if (!kid->op_sibling)
+ {
op_append_elem(OP_SPLIT, o, newSVOP(OP_CONST, 0, newSViv(0)));
+ o->op_private |= OPpSPLIT_IMPLIM;
+ }
assert(kid->op_sibling);
kid = kid->op_sibling;
=cut
*/
+/* shared by toke.c:yylex */
+CV *
+Perl_find_lexical_cv(pTHX_ PADOFFSET off)
+{
+ PADNAME *name = PAD_COMPNAME(off);
+ CV *compcv = PL_compcv;
+ while (PadnameOUTER(name)) {
+ assert(PARENT_PAD_INDEX(name));
+ compcv = CvOUTSIDE(PL_compcv);
+ name = PadlistNAMESARRAY(CvPADLIST(compcv))
+ [off = PARENT_PAD_INDEX(name)];
+ }
+ assert(!PadnameIsOUR(name));
+ if (!PadnameIsSTATE(name) && SvMAGICAL(name)) {
+ MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
+ assert(mg);
+ assert(mg->mg_obj);
+ return (CV *)mg->mg_obj;
+ }
+ return (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
+}
+
CV *
Perl_rv2cv_op_cv(pTHX_ OP *cvop, U32 flags)
{
gv = NULL;
} break;
case OP_PADCV: {
- PADNAME *name = PAD_COMPNAME(rvop->op_targ);
- CV *compcv = PL_compcv;
- PADOFFSET off = rvop->op_targ;
- while (PadnameOUTER(name)) {
- assert(PARENT_PAD_INDEX(name));
- compcv = CvOUTSIDE(PL_compcv);
- name = PadlistNAMESARRAY(CvPADLIST(compcv))
- [off = PARENT_PAD_INDEX(name)];
- }
- assert(!PadnameIsOUR(name));
- if (!PadnameIsSTATE(name)) {
- MAGIC * mg = mg_find(name, PERL_MAGIC_proto);
- assert(mg);
- assert(mg->mg_obj);
- cv = (CV *)mg->mg_obj;
- }
- else cv =
- (CV *)AvARRAY(PadlistARRAY(CvPADLIST(compcv))[1])[off];
+ cv = find_lexical_cv(rvop->op_targ);
gv = NULL;
} break;
default: {
if (SvTYPE(protosv) == SVt_PVCV)
proto = CvPROTO(protosv), proto_len = CvPROTOLEN(protosv);
else proto = SvPV(protosv, proto_len);
+ proto = S_strip_spaces(aTHX_ proto, &proto_len);
proto_end = proto + proto_len;
aop = cUNOPx(entersubop)->op_first;
if (!aop->op_sibling)
proto++;
arg++;
if (o3->op_type != OP_REFGEN && o3->op_type != OP_UNDEF)
- bad_type_sv(arg,
+ bad_type_gv(arg,
arg == 1 ? "block or sub {}" : "sub {}",
- gv_ename(namegv), 0, o3);
+ namegv, 0, o3);
break;
case '*':
/* '*' allows any scalar type, including bareword */
OP_READ, /* not entersub */
OP_LVALUE_NO_CROAK
)) goto wrapref;
- bad_type_sv(arg, Perl_form(aTHX_ "one of %.*s",
+ bad_type_gv(arg, Perl_form(aTHX_ "one of %.*s",
(int)(end - p), p),
- gv_ename(namegv), 0, o3);
+ namegv, 0, o3);
} else
goto oops;
break;
if (o3->op_type == OP_RV2GV)
goto wrapref;
if (!contextclass)
- bad_type_sv(arg, "symbol", gv_ename(namegv), 0, o3);
+ bad_type_gv(arg, "symbol", namegv, 0, o3);
break;
case '&':
if (o3->op_type == OP_ENTERSUB)
goto wrapref;
if (!contextclass)
- bad_type_sv(arg, "subroutine entry", gv_ename(namegv), 0,
+ bad_type_gv(arg, "subroutine entry", namegv, 0,
o3);
break;
case '$':
OP_READ, /* not entersub */
OP_LVALUE_NO_CROAK
)) goto wrapref;
- bad_type_sv(arg, "scalar", gv_ename(namegv), 0, o3);
+ bad_type_gv(arg, "scalar", namegv, 0, o3);
}
break;
case '@':
o3->op_type == OP_PADAV)
goto wrapref;
if (!contextclass)
- bad_type_sv(arg, "array", gv_ename(namegv), 0, o3);
+ bad_type_gv(arg, "array", namegv, 0, o3);
break;
case '%':
if (o3->op_type == OP_RV2HV ||
o3->op_type == OP_PADHV)
goto wrapref;
if (!contextclass)
- bad_type_sv(arg, "hash", gv_ename(namegv), 0, o3);
+ bad_type_gv(arg, "hash", namegv, 0, o3);
break;
wrapref:
{
really need is a new call checker API that accepts a
GV or string (or GV or CV). */
HEK * const hek = CvNAME_HEK(cv);
- assert(hek);
+ /* After a syntax error in a lexical sub, the cv that
+ rv2cv_op_cv returns may be a nameless stub. */
+ if (!hek) return ck_entersub_args_list(o);;
namegv = (GV *)sv_newmortal();
gv_init_pvn(namegv, PL_curstash, HEK_KEY(hek), HEK_LEN(hek),
SVf_UTF8 * !!HEK_UTF8(hek));
OP *
Perl_ck_svconst(pTHX_ OP *o)
{
+ SV * const sv = cSVOPo->op_sv;
PERL_ARGS_ASSERT_CK_SVCONST;
PERL_UNUSED_CONTEXT;
- if (!SvIsCOW(cSVOPo->op_sv)) SvREADONLY_on(cSVOPo->op_sv);
+#ifdef PERL_OLD_COPY_ON_WRITE
+ if (SvIsCOW(sv)) sv_force_normal(sv);
+#elif defined(PERL_NEW_COPY_ON_WRITE)
+ /* Since the read-only flag may be used to protect a string buffer, we
+ cannot do copy-on-write with existing read-only scalars that are not
+ already copy-on-write scalars. To allow $_ = "hello" to do COW with
+ that constant, mark the constant as COWable here, if it is not
+ already read-only. */
+ if (!SvREADONLY(sv) && !SvIsCOW(sv) && SvCANCOW(sv)) {
+ SvIsCOW_on(sv);
+ CowREFCNT(sv) = 0;
+ }
+#endif
+ SvREADONLY_on(sv);
return o;
}
if (kid->op_type == OP_NULL)
kid = (SVOP*)kid->op_sibling;
if (kid && kid->op_type == OP_CONST &&
- (kid->op_private & (OPpCONST_BARE|OPpCONST_FOLDED))
- == OPpCONST_BARE)
+ (kid->op_private & OPpCONST_BARE) &&
+ !kid->op_folded)
{
o->op_flags |= OPf_SPECIAL;
kid->op_private &= ~OPpCONST_STRICT;
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;
name, hash ? "keys " : "", name
);
else if (hash)
+ /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"length() used on %%hash (did you mean \"scalar(keys %%hash)\"?)");
else
+ /* diag_listed_as: length() used on %s (did you mean "scalar(%s)"?) */
Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"length() used on @array (did you mean \"scalar(@array)\"?)");
}
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;
}
dVAR;
dXSARGS;
SV *const sv = MUTABLE_SV(XSANY.any_ptr);
- if (items != 0) {
- NOOP;
-#if 0
- /* diag_listed_as: SKIPME */
- Perl_croak(aTHX_ "usage: %s::%s()",
- HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
-#endif
- }
+ PERL_UNUSED_ARG(items);
if (!sv) {
XSRETURN(0);
}
XSRETURN(1);
}
+static void
+const_av_xsub(pTHX_ CV* cv)
+{
+ dVAR;
+ dXSARGS;
+ AV * const av = MUTABLE_AV(XSANY.any_ptr);
+ SP -= items;
+ assert(av);
+#ifndef DEBUGGING
+ if (!av) {
+ XSRETURN(0);
+ }
+#endif
+ if (SvRMAGICAL(av))
+ Perl_croak(aTHX_ "Magical list constants are not supported");
+ if (GIMME_V != G_ARRAY) {
+ EXTEND(SP, 1);
+ ST(0) = newSViv((IV)AvFILLp(av)+1);
+ XSRETURN(1);
+ }
+ EXTEND(SP, AvFILLp(av)+1);
+ Copy(AvARRAY(av), &ST(0), AvFILLp(av)+1, SV *);
+ XSRETURN(AvFILLp(av)+1);
+}
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff