#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
+#define CHANGE_TYPE(o,type) \
+ STMT_START { \
+ o->op_type = (OPCODE)type; \
+ o->op_ppaddr = PL_ppaddr[type]; \
+ } STMT_END
+
STATIC const char*
S_gv_ename(pTHX_ GV *gv)
{
PERL_ARGS_ASSERT_OP_CLEAR;
#ifdef PERL_MAD
- /* if (o->op_madprop && o->op_madprop->mad_next)
- abort(); */
- /* FIXME for MAD - if I uncomment these two lines t/op/pack.t fails with
- "modification of a read only value" for a reason I can't fathom why.
- It's the "" stringification of $_, where $_ was set to '' in a foreach
- loop, but it defies simplification into a small test case.
- However, commenting them out has caused ext/List/Util/t/weak.t to fail
- the last test. */
- /*
- mad_free(o->op_madprop);
- o->op_madprop = 0;
- */
+ mad_free(o->op_madprop);
+ o->op_madprop = 0;
#endif
retry:
case OP_GVSV:
case OP_GV:
case OP_AELEMFAST:
- if (! (o->op_type == OP_AELEMFAST && o->op_flags & OPf_SPECIAL)) {
- /* not an OP_PADAV replacement */
+ {
GV *gv = (o->op_type == OP_GV || o->op_type == OP_GVSV)
#ifdef USE_ITHREADS
&& PL_curpad
break;
/* FALL THROUGH */
case OP_TRANS:
+ case OP_TRANSR:
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
#ifdef USE_ITHREADS
if (cPADOPo->op_padix > 0) {
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);
case OP_SPRINTF:
case OP_AELEM:
case OP_AELEMFAST:
+ case OP_AELEMFAST_LEX:
case OP_ASLICE:
case OP_HELEM:
case OP_HSLICE:
case OP_NOT:
kid = cUNOPo->op_first;
if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
- kid->op_type != OP_TRANS) {
+ kid->op_type != OP_TRANS && kid->op_type != OP_TRANSR) {
goto func_ops;
}
useless = "negative pattern binding (!~)";
case OP_SUBST:
if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
- useless = "Non-destructive substitution (s///r)";
+ useless = "non-destructive substitution (s///r)";
+ break;
+
+ case OP_TRANSR:
+ useless = "non-destructive transliteration (tr///r)";
break;
case OP_RV2GV:
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
*/
OP *
-Perl_op_lvalue(pTHX_ OP *o, I32 type)
+Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
{
dVAR;
OP *kid;
if ((type == OP_UNDEF || type == OP_REFGEN) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
- /* The default is to set op_private to the number of children,
- which for a UNOP such as RV2CV is always 1. And w're using
- the bit for a flag in RV2CV, so we need it clear. */
+ /* Both ENTERSUB and RV2CV use this bit, but for different pur-
+ poses, so we need it clear. */
o->op_private &= ~1;
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
/* FALL THROUGH */
default:
nomod:
+ if (flags & OP_LVALUE_NO_CROAK) return NULL;
/* grep, foreach, subcalls, refgen */
- if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
+ if (type == OP_GREPSTART || type == OP_ENTERSUB
+ || type == OP_REFGEN || type == OP_LEAVESUBLV)
break;
yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
break;
case OP_AELEMFAST:
+ case OP_AELEMFAST_LEX:
localize = -1;
PL_modcount++;
break;
break;
case OP_KEYS:
- if (type != OP_SASSIGN)
+ case OP_RKEYS:
+ if (type != OP_SASSIGN && type != OP_LEAVESUBLV)
goto nomod;
goto lvalue_func;
case OP_SUBSTR:
/* FALL THROUGH */
case OP_POS:
case OP_VEC:
+ lvalue_func:
if (type == OP_LEAVESUBLV)
o->op_private |= OPpMAYBE_LVSUB;
- lvalue_func:
pad_free(o->op_targ);
o->op_targ = pad_alloc(o->op_type, SVs_PADMY);
assert(SvTYPE(PAD_SV(o->op_targ)) == SVt_NULL);
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)
{
case OP_CONCAT:
case OP_SUBST:
case OP_TRANS:
+ case OP_TRANSR:
case OP_READ:
case OP_SYSREAD:
case OP_RECV:
o->op_flags |= OPf_SPECIAL;
o->op_private &= ~1;
}
+ else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
+ o->op_private |= OPpENTERSUB_DEREF;
+ o->op_flags |= OPf_MOD;
+ }
+
break;
case OP_COND_EXPR:
{
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;
}
o = scalar(op_append_list(OP_LIST, rops, o));
o->op_private |= OPpLVAL_INTRO;
}
- else
+ else {
+ /* The listop in rops might have a pushmark at the beginning,
+ which will mess up list assignment. */
+ LISTOP * const lrops = (LISTOP *)rops; /* for brevity */
+ if (rops->op_type == OP_LIST &&
+ lrops->op_first && lrops->op_first->op_type == OP_PUSHMARK)
+ {
+ OP * const pushmark = lrops->op_first;
+ lrops->op_first = pushmark->op_sibling;
+ op_free(pushmark);
+ }
o = op_append_list(OP_LIST, o, rops);
+ }
}
PL_parser->in_my = FALSE;
PL_parser->in_my_stash = NULL;
|| ltype == OP_PADHV) && ckWARN(WARN_MISC))
{
const char * const desc
- = PL_op_desc[(rtype == OP_SUBST || rtype == OP_TRANS)
+ = PL_op_desc[(
+ rtype == OP_SUBST || rtype == OP_TRANS
+ || rtype == OP_TRANSR
+ )
? (int)rtype : OP_MATCH];
const char * const sample = ((ltype == OP_RV2AV || ltype == OP_PADAV)
? "@array" : "%hash");
no_bareword_allowed(right);
}
- /* !~ doesn't make sense with s///r, so error on it for now */
+ /* !~ doesn't make sense with /r, so error on it for now */
if (rtype == OP_SUBST && (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT) &&
type == OP_NOT)
yyerror("Using !~ with s///r doesn't make sense");
+ if (rtype == OP_TRANSR && type == OP_NOT)
+ yyerror("Using !~ with tr///r doesn't make sense");
ismatchop = (rtype == OP_MATCH ||
rtype == OP_SUBST ||
- rtype == OP_TRANS)
+ rtype == OP_TRANS || rtype == OP_TRANSR)
&& !(right->op_flags & OPf_SPECIAL);
if (ismatchop && right->op_private & OPpTARGET_MY) {
right->op_targ = 0;
OP *newleft;
right->op_flags |= OPf_STACKED;
- if (rtype != OP_MATCH &&
+ if (rtype != OP_MATCH && rtype != OP_TRANSR &&
! (rtype == OP_TRANS &&
right->op_private & OPpTRANS_IDENTICAL) &&
! (rtype == OP_SUBST &&
newleft = op_lvalue(left, rtype);
else
newleft = left;
- if (right->op_type == OP_TRANS)
+ if (right->op_type == OP_TRANS || right->op_type == OP_TRANSR)
o = newBINOP(OP_NULL, OPf_STACKED, scalar(newleft), right);
else
o = op_prepend_elem(rtype, scalar(newleft), right);
/*
=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">.
case 0:
CALLRUNOPS(aTHX);
sv = *(PL_stack_sp--);
- if (o->op_targ && sv == PAD_SV(o->op_targ)) /* grab pad temp? */
+ if (o->op_targ && sv == PAD_SV(o->op_targ)) { /* grab pad temp? */
+#ifdef PERL_MAD
+ /* Can't simply swipe the SV from the pad, because that relies on
+ the op being freed "real soon now". Under MAD, this doesn't
+ happen (see the #ifdef below). */
+ sv = newSVsv(sv);
+#else
pad_swipe(o->op_targ, FALSE);
+#endif
+ }
else if (SvTEMP(sv)) { /* grab mortal temp? */
SvREFCNT_inc_simple_void(sv);
SvTEMP_off(sv);
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;
MADPROP *
Perl_newMADPROP(pTHX_ char key, char type, void* val, I32 vlen)
{
- MADPROP *mp;
- Newxz(mp, 1, MADPROP);
+ MADPROP *const mp = (MADPROP *) PerlMemShared_malloc(sizeof(MADPROP));
mp->mad_next = 0;
mp->mad_key = key;
mp->mad_vlen = vlen;
PerlIO_printf(PerlIO_stderr(), "Unrecognized mad\n");
break;
}
- Safefree(mp);
+ PerlMemShared_free(mp);
}
#endif
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));
}
}
PERL_ARGS_ASSERT_PMRUNTIME;
- if (o->op_type == OP_SUBST || o->op_type == OP_TRANS) {
+ if (
+ o->op_type == OP_SUBST
+ || o->op_type == OP_TRANS || o->op_type == OP_TRANSR
+ ) {
/* last element in list is the replacement; pop it */
OP* kid;
repl = cLISTOPx(expr)->op_last;
op_free(oe);
}
- if (o->op_type == OP_TRANS) {
+ if (o->op_type == OP_TRANS || o->op_type == OP_TRANSR) {
return pmtrans(o, expr, repl);
}
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) {
ENTER;
SAVEVPTR(PL_curcop);
- lex_start(NULL, NULL, 0);
+ lex_start(NULL, NULL, LEX_START_SAME_FILTER);
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
veop, modname, imop);
LEAVE;
other = newUNOP(OP_NULL, OPf_SPECIAL, other);
else if (other->op_type == OP_MATCH
|| other->op_type == OP_SUBST
+ || other->op_type == OP_TRANSR
|| other->op_type == OP_TRANS)
/* Mark the op as being unbindable with =~ */
other->op_flags |= OPf_SPECIAL;
if (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH)
+ || k1->op_type == OP_EACH
+ || k1->op_type == OP_AEACH)
{
warnop = ((k1->op_type == OP_NULL)
? (OPCODE)k1->op_targ : k1->op_type);
if (live->op_type == OP_LEAVE)
live = newUNOP(OP_NULL, OPf_SPECIAL, live);
else if (live->op_type == OP_MATCH || live->op_type == OP_SUBST
- || live->op_type == OP_TRANS)
+ || live->op_type == OP_TRANS || live->op_type == OP_TRANSR)
/* Mark the op as being unbindable with =~ */
live->op_flags |= OPf_SPECIAL;
return live;
if (k1 && (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH))
+ || k1->op_type == OP_EACH
+ || k1->op_type == OP_AEACH))
expr = newUNOP(OP_DEFINED, 0, expr);
break;
}
if (k1 && (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
|| (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
- || k1->op_type == OP_EACH))
+ || k1->op_type == OP_EACH
+ || k1->op_type == OP_AEACH))
expr = newUNOP(OP_DEFINED, 0, expr);
break;
}
OP_ENTERWHEN, OP_LEAVEWHEN, 0);
}
-/*
-=head1 Embedding Functions
-
-=for apidoc cv_undef
-
-Clear out all the active components of a CV. This can happen either
-by an explicit C<undef &foo>, or by the reference count going to zero.
-In the former case, we keep the CvOUTSIDE pointer, so that any anonymous
-children can still follow the full lexical scope chain.
-
-=cut
-*/
-
-void
-Perl_cv_undef(pTHX_ CV *cv)
-{
- dVAR;
-
- PERL_ARGS_ASSERT_CV_UNDEF;
-
- DEBUG_X(PerlIO_printf(Perl_debug_log,
- "CV undef: cv=0x%"UVxf" comppad=0x%"UVxf"\n",
- PTR2UV(cv), PTR2UV(PL_comppad))
- );
-
-#ifdef USE_ITHREADS
- if (CvFILE(cv) && !CvISXSUB(cv)) {
- /* for XSUBs CvFILE point directly to static memory; __FILE__ */
- Safefree(CvFILE(cv));
- }
- CvFILE(cv) = NULL;
-#endif
-
- if (!CvISXSUB(cv) && CvROOT(cv)) {
- if (SvTYPE(cv) == SVt_PVCV && CvDEPTH(cv))
- Perl_croak(aTHX_ "Can't undef active subroutine");
- ENTER;
-
- PAD_SAVE_SETNULLPAD();
-
- op_free(CvROOT(cv));
- CvROOT(cv) = NULL;
- CvSTART(cv) = NULL;
- LEAVE;
- }
- SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
- CvGV_set(cv, NULL);
-
- pad_undef(cv);
-
- /* remove CvOUTSIDE unless this is an undef rather than a free */
- if (!SvREFCNT(cv) && CvOUTSIDE(cv)) {
- if (!CvWEAKOUTSIDE(cv))
- SvREFCNT_dec(CvOUTSIDE(cv));
- CvOUTSIDE(cv) = NULL;
- }
- if (CvCONST(cv)) {
- SvREFCNT_dec(MUTABLE_SV(CvXSUBANY(cv).any_ptr));
- CvCONST_off(cv);
- }
- if (CvISXSUB(cv) && CvXSUB(cv)) {
- CvXSUB(cv) = NULL;
- }
- /* delete all flags except WEAKOUTSIDE and CVGV_RC, which indicate the
- * ref status of CvOUTSIDE and CvGV */
- CvFLAGS(cv) &= (CVf_WEAKOUTSIDE|CVf_CVGV_RC);
-}
-
void
Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p,
const STRLEN len)
* 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;
#ifdef PERL_MAD
|| block->op_type == OP_NULL
#endif
- )&& !attrs) {
+ )) {
if (CvFLAGS(PL_compcv)) {
/* might have had built-in attrs applied */
- if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && ckWARN(WARN_MISC))
+ const bool pureperl = !CvISXSUB(cv) && CvROOT(cv);
+ if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && pureperl
+ && ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC), "lvalue attribute ignored after the subroutine has been defined");
- CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS & ~CVf_LVALUE);
+ CvFLAGS(cv) |=
+ (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS
+ & ~(CVf_LVALUE * pureperl));
}
+ if (attrs) goto attrs;
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
goto done;
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);
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH_set(cv, PL_curstash);
}
+ attrs:
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
HV *stash = name && GvSTASH(CvGV(cv)) ? GvSTASH(CvGV(cv)) : PL_curstash;
exit. */
PL_breakable_sub_gen++;
- if (CvLVALUE(cv)) {
- CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0,
- op_lvalue(scalarseq(block), OP_LEAVESUBLV));
- block->op_attached = 1;
- }
- else {
- /* This makes sub {}; work as expected. */
- if (block->op_type == OP_STUB) {
+ /* This makes sub {}; work as expected. */
+ if (block->op_type == OP_STUB) {
OP* const newblock = newSTATEOP(0, NULL, 0);
#ifdef PERL_MAD
op_getmad(block,newblock,'B');
op_free(block);
#endif
block = newblock;
- }
- else
- block->op_attached = 1;
- CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block));
}
+ else block->op_attached = 1;
+ CvROOT(cv) = CvLVALUE(cv)
+ ? newUNOP(OP_LEAVESUBLV, 0,
+ op_lvalue(scalarseq(block), OP_LEAVESUBLV))
+ : newUNOP(OP_LEAVESUB, 0, scalarseq(block));
CvROOT(cv)->op_private |= OPpREFCOUNTED;
OpREFCNT_set(CvROOT(cv), 1);
CvSTART(cv) = LINKLIST(CvROOT(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 */
}
kid->op_sibling = sibl;
*tokid = kid;
}
- else if (kid->op_type != OP_RV2AV && kid->op_type != OP_PADAV)
+ else if (kid->op_type == OP_CONST
+ && ( !SvROK(cSVOPx_sv(kid))
+ || SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV )
+ )
bad_type(numargs, "array", PL_op_desc[type], kid);
- op_lvalue(kid, type);
+ /* Defer checks to run-time if we have a scalar arg */
+ if (kid->op_type == OP_RV2AV || kid->op_type == OP_PADAV)
+ op_lvalue(kid, type);
+ else scalar(kid);
break;
case OA_HVREF:
if (kid->op_type == OP_CONST &&
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;
return newUNOP(type, 0, scalar(argop));
#endif
}
- return scalar(modkids(ck_fun(o), type));
+ return scalar(ck_fun(o));
}
OP *
Perl_croak(aTHX_ "panic: ck_split");
kid = kid->op_sibling;
op_free(cLISTOPo->op_first);
- cLISTOPo->op_first = kid;
- if (!kid) {
+ if (kid)
+ cLISTOPo->op_first = kid;
+ else {
cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
cLISTOPo->op_last = kid; /* There was only one element previously */
}
const char *p = proto;
const char *const end = proto;
contextclass = 0;
- while (*--p != '[') {}
+ while (*--p != '[')
+ /* \[$] accepts any scalar lvalue */
+ if (*p == '$'
+ && Perl_op_lvalue_flags(aTHX_
+ scalar(o3),
+ OP_READ, /* not entersub */
+ OP_LVALUE_NO_CROAK
+ )) goto wrapref;
bad_type(arg, Perl_form(aTHX_ "one of %.*s",
(int)(end - p), p),
gv_ename(namegv), o3);
o3->op_type == OP_HELEM ||
o3->op_type == OP_AELEM)
goto wrapref;
- if (!contextclass)
+ if (!contextclass) {
+ /* \$ accepts any scalar lvalue */
+ if (Perl_op_lvalue_flags(aTHX_
+ scalar(o3),
+ OP_READ, /* not entersub */
+ OP_LVALUE_NO_CROAK
+ )) goto wrapref;
bad_type(arg, "scalar", gv_ename(namegv), o3);
+ }
break;
case '@':
if (o3->op_type == OP_RV2AV ||
cv = rv2cv_op_cv(cvop, RV2CVOPCV_MARK_EARLY);
namegv = cv ? (GV*)rv2cv_op_cv(cvop, RV2CVOPCV_RETURN_NAME_GV) : NULL;
+ o->op_private &= ~1;
o->op_private |= OPpENTERSUB_HASTARG;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
if (PERLDB_SUB && PL_curstash != PL_debstash)
Perl_ck_each(pTHX_ OP *o)
{
dVAR;
- OP *kid = o->op_flags & OPf_KIDS ? cLISTOPo->op_first : NULL;
+ OP *kid = o->op_flags & OPf_KIDS ? cUNOPo->op_first : NULL;
+ const unsigned orig_type = o->op_type;
+ const unsigned array_type = orig_type == OP_EACH ? OP_AEACH
+ : orig_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
+ const unsigned ref_type = orig_type == OP_EACH ? OP_REACH
+ : orig_type == OP_KEYS ? OP_RKEYS : OP_RVALUES;
PERL_ARGS_ASSERT_CK_EACH;
if (kid) {
- if (kid->op_type == OP_PADAV || kid->op_type == OP_RV2AV) {
- const unsigned new_type = o->op_type == OP_EACH ? OP_AEACH
- : o->op_type == OP_KEYS ? OP_AKEYS : OP_AVALUES;
- o->op_type = new_type;
- o->op_ppaddr = PL_ppaddr[new_type];
- }
- else if (!(kid->op_type == OP_PADHV || kid->op_type == OP_RV2HV
- || (kid->op_type == OP_CONST && kid->op_private & OPpCONST_BARE)
- )) {
- bad_type(1, "hash or array", PL_op_desc[o->op_type], kid);
- return o;
+ switch (kid->op_type) {
+ case OP_PADHV:
+ case OP_RV2HV:
+ break;
+ case OP_PADAV:
+ case OP_RV2AV:
+ CHANGE_TYPE(o, array_type);
+ break;
+ case OP_CONST:
+ if (kid->op_private == OPpCONST_BARE
+ || !SvROK(cSVOPx_sv(kid))
+ || ( SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVAV
+ && SvTYPE(SvRV(cSVOPx_sv(kid))) != SVt_PVHV )
+ )
+ /* we let ck_fun handle it */
+ break;
+ default:
+ CHANGE_TYPE(o, ref_type);
+ scalar(kid);
}
}
- return ck_fun(o);
+ /* if treating as a reference, defer additional checks to runtime */
+ return o->op_type == ref_type ? o : ck_fun(o);
}
/* caller is supposed to assign the return to the
SAVEOP();
SAVEVPTR(PL_curcop);
for (; o; o = o->op_next) {
+#if defined(PERL_MAD) && defined(USE_ITHREADS)
+ MADPROP *mp = o->op_madprop;
+ while (mp) {
+ if (mp->mad_type == MAD_OP && mp->mad_vlen) {
+ OP *prop_op = (OP *) mp->mad_val;
+ /* I *think* that this is roughly the right thing to do. It
+ seems that sometimes the optree hooked into the madprops
+ doesn't have its next pointers set, so it's not possible to
+ use them to locate all the OPs needing a fixup. Possibly
+ it's a bit overkill calling LINKLIST to do this, when we
+ could instead iterate over the OPs (without changing them)
+ the way op_linklist does internally. However, I'm not sure
+ if there are corner cases where we have a chain of partially
+ linked OPs. Or even if we do, does that matter? Or should
+ we always iterate on op_first,op_next? */
+ LINKLIST(prop_op);
+ do {
+ if (prop_op->op_opt)
+ break;
+ prop_op->op_opt = 1;
+ switch (prop_op->op_type) {
+ case OP_CONST:
+ case OP_HINTSEVAL:
+ case OP_METHOD_NAMED:
+ /* Duplicate the "relocate sv to the pad for thread
+ safety" code, as otherwise an opfree of this madprop
+ in the wrong thread will free the SV to the wrong
+ interpreter. */
+ if (((SVOP *)prop_op)->op_sv) {
+ const PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
+ sv_setsv(PAD_SVl(ix),((SVOP *)prop_op)->op_sv);
+ SvREFCNT_dec(((SVOP *)prop_op)->op_sv);
+ ((SVOP *)prop_op)->op_sv = NULL;
+ }
+ break;
+ }
+ } while ((prop_op = prop_op->op_next));
+ }
+ mp = mp->mad_next;
+ }
+#endif
if (o->op_opt)
break;
/* By default, this op has now been optimised. A couple of cases below
/* 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;
if (o->op_type == OP_GV) {
gv = cGVOPo_gv;
GvAVn(gv);
+ o->op_type = OP_AELEMFAST;
}
else
- o->op_flags |= OPf_SPECIAL;
- o->op_type = OP_AELEMFAST;
+ o->op_type = OP_AELEMFAST_LEX;
}
break;
}
/* 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,
case OP_RV2SV:
case OP_RV2AV:
case OP_RV2HV:
- if (oldop
- && ( oldop->op_type == OP_AELEM
+ if (oldop &&
+ (
+ (
+ ( oldop->op_type == OP_AELEM
|| oldop->op_type == OP_PADSV
|| oldop->op_type == OP_RV2SV
|| oldop->op_type == OP_RV2GV
|| oldop->op_type == OP_HELEM
)
&& (oldop->op_private & OPpDEREF)
+ )
+ || ( oldop->op_type == OP_ENTERSUB
+ && oldop->op_private & OPpENTERSUB_DEREF )
+ )
) {
o->op_private |= OPpDEREFed;
}
assert (!cPMOP->op_pmstashstartu.op_pmreplstart);
}
break;
+
+ case OP_CUSTOM: {
+ Perl_cpeep_t cpeep =
+ XopENTRY(Perl_custom_op_xop(aTHX_ o), xop_peep);
+ if (cpeep)
+ cpeep(aTHX_ o, oldop);
+ break;
+ }
+
}
oldop = o;
}
CALL_RPEEP(o);
}
-const char*
-Perl_custom_op_name(pTHX_ const OP* o)
-{
- dVAR;
- const IV index = PTR2IV(o->op_ppaddr);
- SV* keysv;
- HE* he;
+/*
+=head1 Custom Operators
- PERL_ARGS_ASSERT_CUSTOM_OP_NAME;
+=for apidoc Ao||custom_op_xop
+Return the XOP structure for a given custom op. This function should be
+considered internal to OP_NAME and the other access macros: use them instead.
- if (!PL_custom_op_names) /* This probably shouldn't happen */
- return (char *)PL_op_name[OP_CUSTOM];
+=cut
+*/
- keysv = sv_2mortal(newSViv(index));
+const XOP *
+Perl_custom_op_xop(pTHX_ const OP *o)
+{
+ SV *keysv;
+ HE *he = NULL;
+ XOP *xop;
+
+ static const XOP xop_null = { 0, 0, 0, 0, 0 };
+
+ PERL_ARGS_ASSERT_CUSTOM_OP_XOP;
+ assert(o->op_type == OP_CUSTOM);
+
+ /* This is wrong. It assumes a function pointer can be cast to IV,
+ * which isn't guaranteed, but this is what the old custom OP code
+ * did. In principle it should be safer to Copy the bytes of the
+ * pointer into a PV: since the new interface is hidden behind
+ * functions, this can be changed later if necessary. */
+ /* Change custom_op_xop if this ever happens */
+ keysv = sv_2mortal(newSViv(PTR2IV(o->op_ppaddr)));
+
+ if (PL_custom_ops)
+ he = hv_fetch_ent(PL_custom_ops, keysv, 0, 0);
+
+ /* assume noone will have just registered a desc */
+ if (!he && PL_custom_op_names &&
+ (he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0))
+ ) {
+ const char *pv;
+ STRLEN l;
+
+ /* XXX does all this need to be shared mem? */
+ Newxz(xop, 1, XOP);
+ pv = SvPV(HeVAL(he), l);
+ XopENTRY_set(xop, xop_name, savepvn(pv, l));
+ if (PL_custom_op_descs &&
+ (he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0))
+ ) {
+ pv = SvPV(HeVAL(he), l);
+ XopENTRY_set(xop, xop_desc, savepvn(pv, l));
+ }
+ Perl_custom_op_register(aTHX_ o->op_ppaddr, xop);
+ return xop;
+ }
- he = hv_fetch_ent(PL_custom_op_names, keysv, 0, 0);
- if (!he)
- return (char *)PL_op_name[OP_CUSTOM]; /* Don't know who you are */
+ if (!he) return &xop_null;
- return SvPV_nolen(HeVAL(he));
+ xop = INT2PTR(XOP *, SvIV(HeVAL(he)));
+ return xop;
}
-const char*
-Perl_custom_op_desc(pTHX_ const OP* o)
-{
- dVAR;
- const IV index = PTR2IV(o->op_ppaddr);
- SV* keysv;
- HE* he;
+/*
+=for apidoc Ao||custom_op_register
+Register a custom op. See L<perlguts/"Custom Operators">.
+
+=cut
+*/
- PERL_ARGS_ASSERT_CUSTOM_OP_DESC;
+void
+Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop)
+{
+ SV *keysv;
- if (!PL_custom_op_descs)
- return (char *)PL_op_desc[OP_CUSTOM];
+ PERL_ARGS_ASSERT_CUSTOM_OP_REGISTER;
- keysv = sv_2mortal(newSViv(index));
+ /* see the comment in custom_op_xop */
+ keysv = sv_2mortal(newSViv(PTR2IV(ppaddr)));
- he = hv_fetch_ent(PL_custom_op_descs, keysv, 0, 0);
- if (!he)
- return (char *)PL_op_desc[OP_CUSTOM];
+ if (!PL_custom_ops)
+ PL_custom_ops = newHV();
- return SvPV_nolen(HeVAL(he));
+ if (!hv_store_ent(PL_custom_ops, keysv, newSViv(PTR2IV(xop)), 0))
+ Perl_croak(aTHX_ "panic: can't register custom OP %s", xop->xop_name);
}
#include "XSUB.h"
https://perl5.git.perl.org / perl5.git / blobdiff