PERL_ARGS_ASSERT_SCALARBOOLEAN;
- if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
+ if (o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST
+ && !(cBINOPo->op_first->op_flags & OPf_SPECIAL)) {
if (ckWARN(WARN_SYNTAX)) {
const line_t oldline = CopLINE(PL_curcop);
I<type> represents the context type, roughly based on the type of op that
would do the modifying, although C<local()> is represented by OP_NULL,
because it has no op type of its own (it is signalled by a flag on
-the lvalue op). This function detects things that can't be modified,
-such as C<$x+1>, and generates errors for them. It also flags things
-that need to behave specially in an lvalue context, such as C<$$x>
-which might have to vivify a reference in C<$x>.
+the lvalue op).
+
+This function detects things that can't be modified, such as C<$x+1>, and
+generates errors for them. For example, C<$x+1 = 2> would cause it to be
+called with an op of type OP_ADD and a C<type> argument of OP_SASSIGN.
+
+It also flags things that need to behave specially in an lvalue context,
+such as C<$$x = 5> which might have to vivify a reference in C<$x>.
=cut
*/
return o;
}
+/* Do not use this. It will be removed after 5.14. */
+OP *
+Perl_mod(pTHX_ OP *o, I32 type)
+{
+ return op_lvalue(o,type);
+}
+
+
STATIC bool
S_scalar_mod_type(const OP *o, I32 type)
{
{
dVAR;
I32 type;
+ const bool stately = PL_parser && PL_parser->in_my == KEY_state;
PERL_ARGS_ASSERT_MY_KID;
}
o->op_flags |= OPf_MOD;
o->op_private |= OPpLVAL_INTRO;
- if (PL_parser->in_my == KEY_state)
+ if (stately)
o->op_private |= OPpPAD_STATE;
return o;
}
/*
=head1 Compile-time scope hooks
-=for apidoc Ao||blockhook_register
+=for apidoc Aox||blockhook_register
Register a set of hooks to be called when the Perl lexical scope changes
at compile time. See L<perlguts/"Compile-time scope hooks">.
PL_op = curop = LINKLIST(o);
o->op_next = 0;
CALL_PEEP(curop);
- pp_pushmark();
+ Perl_pp_pushmark(aTHX);
CALLRUNOPS(aTHX);
PL_op = curop;
assert (!(curop->op_flags & OPf_SPECIAL));
assert(curop->op_type == OP_RANGE);
- pp_anonlist();
+ Perl_pp_anonlist(aTHX);
PL_tmps_floor = oldtmps_floor;
o->op_type = OP_RV2AV;
U8 range_mark = UTF_TO_NATIVE(0xff);
sv_catpvn(transv, (char *)&range_mark, 1);
}
- t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
- UNICODE_ALLOW_SUPER);
+ t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
t = (const U8*)SvPVX_const(transv);
tlen = SvCUR(transv);
if (PL_hints & HINT_RE_TAINT)
pmop->op_pmflags |= PMf_RETAINT;
if (PL_hints & HINT_LOCALE) {
- pmop->op_pmflags |= PMf_LOCALE;
+ set_regex_charset(&(pmop->op_pmflags), REGEX_LOCALE_CHARSET);
}
else if ((! (PL_hints & HINT_BYTES)) && (PL_hints & HINT_UNI_8_BIT)) {
- pmop->op_pmflags |= RXf_PMf_UNICODE;
+ set_regex_charset(&(pmop->op_pmflags), REGEX_UNICODE_CHARSET);
}
if (PL_hints & HINT_RE_FLAGS) {
SV *reflags = Perl_refcounted_he_fetch_pvn(aTHX_
);
if (reflags && SvOK(reflags)) pmop->op_pmflags |= SvIV(reflags);
reflags = Perl_refcounted_he_fetch_pvn(aTHX_
- PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_dul"), 0, 0
+ PL_compiling.cop_hints_hash, STR_WITH_LEN("reflags_charset"), 0, 0
);
if (reflags && SvOK(reflags)) {
- pmop->op_pmflags &= ~(RXf_PMf_LOCALE|RXf_PMf_UNICODE);
- pmop->op_pmflags |= SvIV(reflags);
+ set_regex_charset(&(pmop->op_pmflags), (regex_charset)SvIV(reflags));
}
}
if (expr->op_type == OP_CONST) {
SV *pat = ((SVOP*)expr)->op_sv;
- U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
+ U32 pm_flags = pm->op_pmflags & RXf_PMf_COMPILETIME;
if (o->op_flags & OPf_SPECIAL)
pm_flags |= RXf_SPLIT;
rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP);
/* /$x/ may cause an eval, since $x might be qr/(?{..})/ */
- PL_cv_has_eval = 1;
+ if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1;
/* establish postfix order */
if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) {
#ifdef PERL_MAD
OP *pegop = newOP(OP_NULL,0);
#endif
+ SV *use_version = NULL;
PERL_ARGS_ASSERT_UTILIZE;
}
else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
imop = NULL; /* use 5.0; */
- if (!aver)
+ if (aver)
+ use_version = ((SVOP*)idop)->op_sv;
+ else
idop->op_private |= OPpCONST_NOVER;
}
else {
newSTATEOP(0, NULL, veop)),
newSTATEOP(0, NULL, imop) ));
+ if (use_version) {
+ /* If we request a version >= 5.9.5, load feature.pm with the
+ * feature bundle that corresponds to the required version. */
+ use_version = sv_2mortal(new_version(use_version));
+
+ if (vcmp(use_version,
+ sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
+ SV *const importsv = vnormal(use_version);
+ *SvPVX_mutable(importsv) = ':';
+ ENTER_with_name("load_feature");
+ Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
+ LEAVE_with_name("load_feature");
+ }
+ /* If a version >= 5.11.0 is requested, strictures are on by default! */
+ if (vcmp(use_version,
+ sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
+ PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
+ }
+ }
+
/* The "did you use incorrect case?" warning used to be here.
* The problem is that on case-insensitive filesystems one
* might get false positives for "use" (and "require"):
PL_parser->copline = NOLINE;
PL_parser->expect = XSTATE;
PL_cop_seqmax++; /* Purely for B::*'s benefit */
+ if (PL_cop_seqmax == PERL_PADSEQ_INTRO) /* not a legal value */
+ PL_cop_seqmax++;
#ifdef PERL_MAD
if (!PL_madskills) {
* cv && CvCONST(cv)
*
* We have just cloned an anon prototype that was marked as a const
- * candidiate. Try to grab the current value, and in the case of
+ * candidate. Try to grab the current value, and in the case of
* PADSV, ignore it if it has multiple references. Return the value.
*/
if (sv && o->op_next == o)
return sv;
if (o->op_next != o) {
- if (type == OP_NEXTSTATE || type == OP_NULL || type == OP_PUSHMARK)
+ if (type == OP_NEXTSTATE
+ || (type == OP_NULL && !(o->op_flags & OPf_KIDS))
+ || type == OP_PUSHMARK)
continue;
if (type == OP_DBSTATE)
continue;
}
CV *
-Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block)
-{
- return Perl_newATTRSUB(aTHX_ floor, o, proto, NULL, block);
-}
-
-CV *
Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
{
dVAR;
CvISXSUB_on(cv);
}
else {
- GvCV(gv) = NULL;
+ GvCV_set(gv, NULL);
cv = newCONSTSUB(NULL, name, const_sv);
}
mro_method_changed_in( /* sub Foo::Bar () { 123 } */
#endif
) {
cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
- cv_undef(cv);
+ AV *const temp_av = CvPADLIST(cv);
+ CV *const temp_cv = CvOUTSIDE(cv);
+
+ assert(!CvWEAKOUTSIDE(cv));
+ assert(!CvCVGV_RC(cv));
+ assert(CvGV(cv) == gv);
+
+ SvPOK_off(cv);
CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
- if (!CvWEAKOUTSIDE(cv))
- SvREFCNT_dec(CvOUTSIDE(cv));
CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
CvOUTSIDE_SEQ(cv) = CvOUTSIDE_SEQ(PL_compcv);
- CvOUTSIDE(PL_compcv) = 0;
CvPADLIST(cv) = CvPADLIST(PL_compcv);
- CvPADLIST(PL_compcv) = 0;
+ CvOUTSIDE(PL_compcv) = temp_cv;
+ CvPADLIST(PL_compcv) = temp_av;
+
+#ifdef USE_ITHREADS
+ if (CvFILE(cv) && !CvISXSUB(cv)) {
+ /* for XSUBs CvFILE point directly to static memory; __FILE__ */
+ Safefree(CvFILE(cv));
+ }
+#endif
+ CvFILE_set_from_cop(cv, PL_curcop);
+ CvSTASH_set(cv, PL_curstash);
+
/* inner references to PL_compcv must be fixed up ... */
pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
if (PERLDB_INTER)/* Advice debugger on the new sub. */
else {
cv = PL_compcv;
if (name) {
- GvCV(gv) = cv;
+ GvCV_set(gv, cv);
if (PL_madskills) {
if (strEQ(name, "import")) {
PL_formfeed = MUTABLE_SV(cv);
DEBUG_x( dump_sub(gv) );
Perl_av_create_and_push(aTHX_ &PL_beginav, MUTABLE_SV(cv));
- GvCV(gv) = 0; /* cv has been hijacked */
+ GvCV_set(gv,0); /* cv has been hijacked */
call_list(oldscope, PL_beginav);
PL_curcop = &PL_compiling;
} else
return;
DEBUG_x( dump_sub(gv) );
- GvCV(gv) = 0; /* cv has been hijacked */
+ GvCV_set(gv,0); /* cv has been hijacked */
}
}
else {
cv = MUTABLE_CV(newSV_type(SVt_PVCV));
if (name) {
- GvCV(gv) = cv;
+ GvCV_set(gv,cv);
GvCVGEN(gv) = 0;
mro_method_changed_in(GvSTASH(gv)); /* newXS */
}
o = ck_fun(o);
if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
- op_append_elem(OP_GLOB, o, newDEFSVOP());
+ op_append_elem(OP_GLOB, o, newDEFSVOP()); /* glob() => glob($_) */
if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
&& GvCVu(gv) && GvIMPORTED_CV(gv)))
newSVpvs("File::Glob"), NULL, NULL, NULL);
if((glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV))) {
gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
- GvCV(gv) = GvCV(glob_gv);
+ GvCV_set(gv, GvCV(glob_gv));
SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
GvIMPORTED_CV_on(gv);
}
}
#endif /* PERL_EXTERNAL_GLOB */
+ assert(!(o->op_flags & OPf_SPECIAL));
if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
+ /* convert
+ * glob
+ * \ null - const(wildcard)
+ * into
+ * null
+ * \ enter
+ * \ list
+ * \ mark - glob - rv2cv
+ * | \ gv(CORE::GLOBAL::glob)
+ * |
+ * \ null - const(wildcard) - const(ix)
+ */
+ 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->op_type = OP_LIST;
- o->op_ppaddr = PL_ppaddr[OP_LIST];
- cLISTOPo->op_first->op_type = OP_PUSHMARK;
- cLISTOPo->op_first->op_ppaddr = PL_ppaddr[OP_PUSHMARK];
- cLISTOPo->op_first->op_targ = 0;
+ o = newLISTOP(OP_LIST, 0, o, NULL);
o = newUNOP(OP_ENTERSUB, OPf_STACKED,
op_append_elem(OP_LIST, o,
scalar(newUNOP(OP_RV2CV, 0,
newGVOP(OP_GV, 0, gv)))));
o = newUNOP(OP_NULL, 0, ck_subr(o));
- o->op_targ = OP_GLOB; /* hint at what it used to be */
+ o->op_targ = OP_GLOB; /* hint at what it used to be: eg in newWHILEOP */
return o;
}
gv = newGVgen("main");
}
if (kid->op_sibling) {
OP *kkid = kid->op_sibling;
- if (kkid->op_type == OP_PADSV
+ /* For state variable assignment, kkid is a list op whose op_last
+ is a padsv. */
+ if ((kkid->op_type == OP_PADSV ||
+ (kkid->op_type == OP_LIST &&
+ (kkid = cLISTOPx(kkid)->op_last)->op_type == OP_PADSV
+ )
+ )
&& (kkid->op_private & OPpLVAL_INTRO)
&& SvPAD_STATE(*av_fetch(PL_comppad_name, kkid->op_targ, FALSE))) {
const PADOFFSET target = kkid->op_targ;
other->op_targ = target;
/* Because we change the type of the op here, we will skip the
- assinment binop->op_last = binop->op_first->op_sibling; at the
+ assignment binop->op_last = binop->op_first->op_sibling; at the
end of Perl_newBINOP(). So need to do it here. */
cBINOPo->op_last = cBINOPo->op_first->op_sibling;
/* Two NEXTSTATEs in a row serve no purpose. Except if they happen
to carry two labels. For now, take the easier option, and skip
this optimisation if the first NEXTSTATE has a label. */
- if (!CopLABEL((COP*)o)) {
+ if (!CopLABEL((COP*)o) && !PERLDB_NOOPT) {
OP *nextop = o->op_next;
while (nextop && nextop->op_type == OP_NULL)
nextop = nextop->op_next;
/* Make the CONST have a shared SV */
svp = cSVOPx_svp(((BINOP*)o)->op_last);
- if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
+ if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv))
+ && SvTYPE(sv) < SVt_PVMG && !SvROK(sv)) {
key = SvPV_const(sv, keylen);
lexname = newSVpvn_share(key,
SvUTF8(sv) ? -(I32)keylen : (I32)keylen,