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 */
+#if defined(USE_ITHREADS) && IVSIZE > U32SIZE && IVSIZE > PTRSIZE
+ /* 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
+ 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;
}
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);
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;
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;
case OP_LCFIRST:
case OP_UC:
case OP_LC:
+ case OP_FC:
case OP_SLT:
case OP_SGT:
case OP_SLE:
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");
}
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 (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>
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);
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);
dVAR;
o->op_type = OP_PADCV;
o->op_ppaddr = PL_ppaddr[OP_PADCV];
- return o;
}
return newUNOP(OP_RV2CV, flags, scalar(o));
}
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);
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);
{
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));
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)\"?)");
}
https://perl5.git.perl.org / perl5.git / blobdiff