OP *o;
size_t opsz, space;
+ /* We only allocate ops from the slab during subroutine compilation.
+ We find the slab via PL_compcv, hence that must be non-NULL. It could
+ also be pointing to a subroutine which is now fully set up (CvROOT()
+ pointing to the top of the optree for that sub), or a subroutine
+ which isn't using the slab allocator. If our sanity checks aren't met,
+ don't use a slab, but allocate the OP directly from the heap. */
if (!PL_compcv || CvROOT(PL_compcv)
|| (CvSTART(PL_compcv) && !CvSLABBED(PL_compcv)))
return PerlMemShared_calloc(1, sz);
- if (!CvSTART(PL_compcv)) { /* sneak it in here */
+ /* 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
+ accessed via CvROOT(). So if CvSTART() is NULL, no slab has been
+ allocated yet. See the commit message for 8be227ab5eaa23f2 for more
+ details. */
+ if (!CvSTART(PL_compcv)) {
CvSTART(PL_compcv) =
(OP *)(slab = S_new_slab(aTHX_ PERL_SLAB_SIZE));
CvSLABBED_on(PL_compcv);
opsz = SIZE_TO_PSIZE(sz);
sz = opsz + OPSLOT_HEADER_P;
+ /* The slabs maintain a free list of OPs. In particular, constant folding
+ will free up OPs, so it makes sense to re-use them where possible. A
+ freed up slot is used in preference to a new allocation. */
if (slab->opslab_freed) {
OP **too = &slab->opslab_freed;
o = *too;
}
#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);
}
}
else if (len == 2 && name[1] == '_' && !is_our)
- /* diag_listed_as: Use of my $_ is deprecated */
- Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
- "Use of %s $_ is deprecated",
+ /* diag_listed_as: Use of my $_ is experimental */
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_EXPERIMENTAL__LEXICAL_TOPIC),
+ "Use of %s $_ is experimental",
PL_parser->in_my == KEY_state
? "state"
: "my");
FreeOp(o);
}
-#ifdef USE_ITHREADS
-# define forget_pmop(a,b) S_forget_pmop(aTHX_ a,b)
-#else
-# define forget_pmop(a,b) S_forget_pmop(aTHX_ a)
-#endif
-
/* Destructor */
void
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() */
#endif
if (still_valid) {
int try_downgrade = SvREFCNT(gv) == 2;
- SvREFCNT_dec(gv);
+ SvREFCNT_dec_NN(gv);
if (try_downgrade)
gv_try_downgrade(gv);
}
if (!(cPMOPo->op_pmflags & PMf_CODELIST_PRIVATE))
op_free(cPMOPo->op_code_list);
cPMOPo->op_code_list = NULL;
- forget_pmop(cPMOPo, 1);
+ forget_pmop(cPMOPo);
cPMOPo->op_pmreplrootu.op_pmreplroot = NULL;
/* we use the same protection as the "SAFE" version of the PM_ macros
* here since sv_clean_all might release some PMOPs
if (! specialWARN(cop->cop_warnings))
PerlMemShared_free(cop->cop_warnings);
cophh_free(CopHINTHASH_get(cop));
+ if (PL_curcop == cop)
+ PL_curcop = NULL;
}
STATIC void
S_forget_pmop(pTHX_ PMOP *const o
-#ifdef USE_ITHREADS
- , U32 flags
-#endif
)
{
HV * const pmstash = PmopSTASH(o);
}
if (PL_curpm == o)
PL_curpm = NULL;
-#ifdef USE_ITHREADS
- if (flags)
- PmopSTASH_free(o);
-#endif
}
STATIC void
case OP_PUSHRE:
case OP_MATCH:
case OP_QR:
- forget_pmop((PMOP*)kid, 0);
+ forget_pmop((PMOP*)kid);
}
find_and_forget_pmops(kid);
kid = kid->op_sibling;
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(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,
0);
- SvREFCNT_dec(sv);
+ SvREFCNT_dec_NN(sv);
*svp = lexname;
}
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)
}
break;
}
+ case OP_ASLICE:
+ S_scalar_slice_warning(aTHX_ o);
+ break;
case OP_SUBST: {
if (cPMOPo->op_pmreplrootu.op_pmreplroot)
/* FALL THROUGH */
case OP_ASLICE:
case OP_HSLICE:
- if (type == OP_LEAVESUBLV)
- o->op_private |= OPpMAYBE_LVSUB;
localize = 1;
/* FALL THROUGH */
case OP_AASSIGN:
+ if (type == OP_LEAVESUBLV)
+ o->op_private |= OPpMAYBE_LVSUB;
+ /* FALL THROUGH */
case OP_NEXTSTATE:
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;
)
? (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();
while (1) {
if (*s && strchr("@$%*", *s) && *++s
- && (isALNUM(*s) || UTF8_IS_CONTINUED(*s))) {
+ && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) {
s++;
sigil = TRUE;
- while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)))
+ while (*s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s)))
s++;
while (*s && (strchr(", \t\n", *s)))
s++;
case OP_LCFIRST:
case OP_UC:
case OP_LC:
+ case OP_FC:
case OP_SLT:
case OP_SGT:
case OP_SLE:
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->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");
}
LINKLIST(expr);
- /* fix up DO blocks; treat each one as a separate little sub */
+ /* fix up DO blocks; treat each one as a separate little sub;
+ * also, mark any arrays as LIST/REF */
if (expr->op_type == OP_LIST) {
OP *o;
for (o = cLISTOPx(expr)->op_first; o; o = o->op_sibling) {
+
+ if (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) {
+ assert( !(o->op_flags & OPf_WANT));
+ /* push the array rather than its contents. The regex
+ * engine will retrieve and join the elements later */
+ o->op_flags |= (OPf_WANT_LIST | OPf_REF);
+ continue;
+ }
+
if (!(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)))
continue;
o->op_next = NULL; /* undo temporary hack from above */
scalar(o);
LINKLIST(o);
if (cLISTOPo->op_first->op_type == OP_LEAVE) {
- LISTOP *leave = cLISTOPx(cLISTOPo->op_first);
+ LISTOP *leaveop = cLISTOPx(cLISTOPo->op_first);
/* skip ENTER */
- assert(leave->op_first->op_type == OP_ENTER);
- assert(leave->op_first->op_sibling);
- o->op_next = leave->op_first->op_sibling;
- /* skip LEAVE */
- assert(leave->op_flags & OPf_KIDS);
- assert(leave->op_last->op_next = (OP*)leave);
- leave->op_next = NULL; /* stop on last op */
- op_null((OP*)leave);
+ assert(leaveop->op_first->op_type == OP_ENTER);
+ assert(leaveop->op_first->op_sibling);
+ o->op_next = leaveop->op_first->op_sibling;
+ /* skip leave */
+ assert(leaveop->op_flags & OPf_KIDS);
+ assert(leaveop->op_last->op_next == (OP*)leaveop);
+ leaveop->op_next = NULL; /* stop on last op */
+ op_null((OP*)leaveop);
}
else {
/* skip SCOPE */
finalize_optree(o);
}
}
+ else if (expr->op_type == OP_PADAV || expr->op_type == OP_RV2AV) {
+ assert( !(expr->op_flags & OPf_WANT));
+ /* push the array rather than its contents. The regex
+ * engine will retrieve and join the elements later */
+ expr->op_flags |= (OPf_WANT_LIST | OPf_REF);
+ }
PL_hints |= HINT_BLOCK_SCOPE;
pm = (PMOP*)o;
U32 rx_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
regexp_engine const *eng = current_re_engine();
+ if (o->op_flags & OPf_SPECIAL)
+ rx_flags |= RXf_SPLIT;
+
if (!has_code || !eng->op_comp) {
/* compile-time simple constant pattern */
pm->op_pmflags |= PMf_CODELIST_PRIVATE;
}
+ if (o->op_flags & OPf_SPECIAL)
+ pm->op_pmflags |= PMf_SPLIT;
+
/* the OP_REGCMAYBE is a placeholder in the non-threaded case
* to allow its op_next to be pointed past the regcomp and
* preceding stacking ops;
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
Constructs, checks, and returns an op of any type that involves an
embedded C-level pointer (PV). I<type> is the opcode. I<flags> gives
the eight bits of C<op_flags>. I<pv> supplies the C-level pointer, which
-must have been allocated using L</PerlMemShared_malloc>; the memory will
+must have been allocated using C<PerlMemShared_malloc>; the memory will
be freed when the op is destroyed.
=cut
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));
= MUTABLE_GV(cSVOPx(tmpop)->op_sv);
cSVOPx(tmpop)->op_sv = NULL; /* steal it */
#endif
- pm->op_pmflags |= PMf_ONCE;
tmpop = cUNOPo->op_first; /* to list (nulled) */
tmpop = ((UNOP*)tmpop)->op_first; /* to pushmark */
tmpop->op_sibling = NULL; /* don't free split */
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);
+ }
+ }
}
}
}
Constructs a state op (COP). The state op is normally a C<nextstate> op,
but will be a C<dbstate> op if debugging is enabled for currently-compiled
-code. The state op is populated from L</PL_curcop> (or L</PL_compiling>).
+code. The state op is populated from C<PL_curcop> (or C<PL_compiling>).
If I<label> is non-null, it supplies the name of a label to attach to
the state op; this function takes ownership of the memory pointed at by
I<label>, and will free it. I<flags> gives the eight bits of C<op_flags>
#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));
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_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;
}
)
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>. */
&PadARRAY(PadlistARRAY(CvPADLIST(outcv))[CvDEPTH(outcv)])[pax];
if (reusable) cv_clone_into(clonee, *spot);
else *spot = cv_clone(clonee);
- SvREFCNT_dec(clonee);
+ SvREFCNT_dec_NN(clonee);
cv = *spot;
SvPADMY_on(cv);
}
)
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);
),
cv, const_svp);
}
- SvREFCNT_dec(cv);
+ SvREFCNT_dec_NN(cv);
cv = NULL;
}
}
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));
}
#endif
kUNOP->op_first = newop;
}
+ /* transforms OP_REFGEN into OP_SREFGEN, OP_CHOP into OP_SCHOP,
+ * and OP_CHOMP into OP_SCHOMP */
o->op_ppaddr = PL_ppaddr[++o->op_type];
return ck_fun(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);
}
* \ mark - glob - rv2cv
* | \ gv(CORE::GLOBAL::glob)
* |
- * \ null - const(wildcard) - const(ix)
+ * \ null - const(wildcard)
*/
o->op_flags |= OPf_SPECIAL;
o->op_targ = pad_alloc(OP_GLOB, SVs_PADTMP);
- op_append_elem(OP_GLOB, o,
- newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
o = newLISTOP(OP_LIST, 0, o, NULL);
o = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, o,
gv = (GV *)newSV(0);
gv_init(gv, 0, "", 0, 0);
gv_IOadd(gv);
-#ifndef PERL_EXTERNAL_GLOB
- sv_setiv(GvSVn(gv),PL_glob_index++);
-#endif
op_append_elem(OP_GLOB, o, newGVOP(OP_GV, 0, gv));
- SvREFCNT_dec(gv); /* newGVOP increased it */
+ SvREFCNT_dec_NN(gv); /* newGVOP increased it */
scalarkids(o);
return o;
}
if (kid)
kid = kid->op_sibling; /* get past "big" */
if (kid && kid->op_type == OP_CONST) {
- const bool save_taint = TAINT_get; /* accepted unused var warning if NO_TAINT_SUPPORT */
- fbm_compile(((SVOP*)kid)->op_sv, 0);
+ const bool save_taint = TAINT_get;
+ 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);
+#endif
}
}
return ck_fun(o);
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 */
cLISTOPo->op_last = kid; /* There was only one element previously */
}
- if (kid->op_type == OP_CONST && !(kid->op_private & OPpCONST_FOLDED)) {
- SV * const sv = kSVOP->op_sv;
- if (SvPOK(sv) && SvCUR(sv) == 1 && *SvPVX(sv) == ' ')
- o->op_flags |= OPf_SPECIAL;
- }
if (kid->op_type != OP_MATCH || kid->op_flags & OPf_STACKED) {
OP * const sibl = kid->op_sibling;
kid->op_sibling = 0;
- kid = pmruntime( newPMOP(OP_MATCH, 0), kid, 0, 0);
+ kid = pmruntime( newPMOP(OP_MATCH, OPf_SPECIAL), kid, 0, 0); /* OPf_SPECIAL is used to trigger split " " behavior */
if (cLISTOPo->op_first == cLISTOPo->op_last)
cLISTOPo->op_last = kid;
cLISTOPo->op_first = kid;
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)\"?)");
}
&& ( 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