-static bool
-S_vivifies(const OPCODE type)
-{
- switch(type) {
- case OP_RV2AV: case OP_ASLICE:
- case OP_RV2HV: case OP_KVASLICE:
- case OP_RV2SV: case OP_HSLICE:
- case OP_AELEMFAST: case OP_KVHSLICE:
- case OP_HELEM:
- case OP_AELEM:
- return 1;
- }
- return 0;
-}
-
-
-/* apply lvalue reference (aliasing) context to the optree o.
- * E.g. in
- * \($x,$y) = (...)
- * o would be the list ($x,$y) and type would be OP_AASSIGN.
- * It may descend and apply this to children too, for example in
- * \( $cond ? $x, $y) = (...)
- */
-
-static void
-S_lvref(pTHX_ OP *o, I32 type)
-{
- dVAR;
- OP *kid;
- OP * top_op = o;
-
- while (1) {
- switch (o->op_type) {
- case OP_COND_EXPR:
- o = OpSIBLING(cUNOPo->op_first);
- continue;
-
- case OP_PUSHMARK:
- goto do_next;
-
- case OP_RV2AV:
- if (cUNOPo->op_first->op_type != OP_GV) goto badref;
- o->op_flags |= OPf_STACKED;
- if (o->op_flags & OPf_PARENS) {
- if (o->op_private & OPpLVAL_INTRO) {
- yyerror(Perl_form(aTHX_ "Can't modify reference to "
- "localized parenthesized array in list assignment"));
- goto do_next;
- }
- slurpy:
- OpTYPE_set(o, OP_LVAVREF);
- o->op_private &= OPpLVAL_INTRO|OPpPAD_STATE;
- o->op_flags |= OPf_MOD|OPf_REF;
- goto do_next;
- }
- o->op_private |= OPpLVREF_AV;
- goto checkgv;
-
- case OP_RV2CV:
- kid = cUNOPo->op_first;
- if (kid->op_type == OP_NULL)
- kid = cUNOPx(OpSIBLING(kUNOP->op_first))
- ->op_first;
- o->op_private = OPpLVREF_CV;
- if (kid->op_type == OP_GV)
- o->op_flags |= OPf_STACKED;
- else if (kid->op_type == OP_PADCV) {
- o->op_targ = kid->op_targ;
- kid->op_targ = 0;
- op_free(cUNOPo->op_first);
- cUNOPo->op_first = NULL;
- o->op_flags &=~ OPf_KIDS;
- }
- else goto badref;
- break;
-
- case OP_RV2HV:
- if (o->op_flags & OPf_PARENS) {
- parenhash:
- yyerror(Perl_form(aTHX_ "Can't modify reference to "
- "parenthesized hash in list assignment"));
- goto do_next;
- }
- o->op_private |= OPpLVREF_HV;
- /* FALLTHROUGH */
- case OP_RV2SV:
- checkgv:
- if (cUNOPo->op_first->op_type != OP_GV) goto badref;
- o->op_flags |= OPf_STACKED;
- break;
-
- case OP_PADHV:
- if (o->op_flags & OPf_PARENS) goto parenhash;
- o->op_private |= OPpLVREF_HV;
- /* FALLTHROUGH */
- case OP_PADSV:
- PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
- break;
-
- case OP_PADAV:
- PAD_COMPNAME_GEN_set(o->op_targ, PERL_INT_MAX);
- if (o->op_flags & OPf_PARENS) goto slurpy;
- o->op_private |= OPpLVREF_AV;
- break;
-
- case OP_AELEM:
- case OP_HELEM:
- o->op_private |= OPpLVREF_ELEM;
- o->op_flags |= OPf_STACKED;
- break;
-
- case OP_ASLICE:
- case OP_HSLICE:
- OpTYPE_set(o, OP_LVREFSLICE);
- o->op_private &= OPpLVAL_INTRO;
- goto do_next;
-
- case OP_NULL:
- if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
- goto badref;
- else if (!(o->op_flags & OPf_KIDS))
- goto do_next;
-
- /* the code formerly only recursed into the first child of
- * a non ex-list OP_NULL. if we ever encounter such a null op with
- * more than one child, need to decide whether its ok to process
- * *all* its kids or not */
- assert(o->op_targ == OP_LIST
- || !(OpHAS_SIBLING(cBINOPo->op_first)));
- /* FALLTHROUGH */
- case OP_LIST:
- o = cLISTOPo->op_first;
- continue;
-
- case OP_STUB:
- if (o->op_flags & OPf_PARENS)
- goto do_next;
- /* FALLTHROUGH */
- default:
- badref:
- /* diag_listed_as: Can't modify reference to %s in %s assignment */
- yyerror(Perl_form(aTHX_ "Can't modify reference to %s in %s",
- o->op_type == OP_NULL && o->op_flags & OPf_SPECIAL
- ? "do block"
- : OP_DESC(o),
- PL_op_desc[type]));
- goto do_next;
- }
-
- OpTYPE_set(o, OP_LVREF);
- o->op_private &=
- OPpLVAL_INTRO|OPpLVREF_ELEM|OPpLVREF_TYPE|OPpPAD_STATE;
- if (type == OP_ENTERLOOP)
- o->op_private |= OPpLVREF_ITER;
-
- do_next:
- while (1) {
- if (o == top_op)
- return; /* at top; no parents/siblings to try */
- if (OpHAS_SIBLING(o)) {
- o = o->op_sibparent;
- break;
- }
- o = o->op_sibparent; /*try parent's next sibling */
- }
- } /* while */
-}
-
-
-PERL_STATIC_INLINE bool
-S_potential_mod_type(I32 type)
-{
- /* Types that only potentially result in modification. */
- return type == OP_GREPSTART || type == OP_ENTERSUB
- || type == OP_REFGEN || type == OP_LEAVESUBLV;
-}
-
-
-/*
-=for apidoc op_lvalue
-
-Propagate lvalue ("modifiable") context to an op and its children.
-C<type> represents the context type, roughly based on the type of op that
-would do the modifying, although C<local()> is represented by C<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. For example, C<$x+1 = 2> would cause it to be
-called with an op of type C<OP_ADD> and a C<type> argument of C<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
-
-Perl_op_lvalue_flags() is a non-API lower-level interface to
-op_lvalue(). The flags param has these bits:
- OP_LVALUE_NO_CROAK: return rather than croaking on error
-
-*/
-
-OP *
-Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
-{
- dVAR;
- OP *top_op = o;
-
- if (!o || (PL_parser && PL_parser->error_count))
- return o;
-
- while (1) {
- OP *kid;
- /* -1 = error on localize, 0 = ignore localize, 1 = ok to localize */
- int localize = -1;
- OP *next_kid = NULL;
-
- if ((o->op_private & OPpTARGET_MY)
- && (PL_opargs[o->op_type] & OA_TARGLEX))/* OPp share the meaning */
- {
- goto do_next;
- }
-
- /* elements of a list might be in void context because the list is
- in scalar context or because they are attribute sub calls */
- if ((o->op_flags & OPf_WANT) == OPf_WANT_VOID)
- goto do_next;
-
- if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
-
- switch (o->op_type) {
- case OP_UNDEF:
- PL_modcount++;
- goto do_next;
-
- case OP_STUB:
- if ((o->op_flags & OPf_PARENS))
- break;
- goto nomod;
-
- case OP_ENTERSUB:
- if ((type == OP_UNDEF || type == OP_REFGEN || type == OP_LOCK) &&
- !(o->op_flags & OPf_STACKED)) {
- OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
- assert(cUNOPo->op_first->op_type == OP_NULL);
- op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
- break;
- }
- else { /* lvalue subroutine call */
- o->op_private |= OPpLVAL_INTRO;
- PL_modcount = RETURN_UNLIMITED_NUMBER;
- if (S_potential_mod_type(type)) {
- o->op_private |= OPpENTERSUB_INARGS;
- break;
- }
- else { /* Compile-time error message: */
- OP *kid = cUNOPo->op_first;
- CV *cv;
- GV *gv;
- SV *namesv;
-
- if (kid->op_type != OP_PUSHMARK) {
- if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
- Perl_croak(aTHX_
- "panic: unexpected lvalue entersub "
- "args: type/targ %ld:%" UVuf,
- (long)kid->op_type, (UV)kid->op_targ);
- kid = kLISTOP->op_first;
- }
- while (OpHAS_SIBLING(kid))
- kid = OpSIBLING(kid);
- if (!(kid->op_type == OP_NULL && kid->op_targ == OP_RV2CV)) {
- break; /* Postpone until runtime */
- }
-
- kid = kUNOP->op_first;
- if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
- kid = kUNOP->op_first;
- if (kid->op_type == OP_NULL)
- Perl_croak(aTHX_
- "Unexpected constant lvalue entersub "
- "entry via type/targ %ld:%" UVuf,
- (long)kid->op_type, (UV)kid->op_targ);
- if (kid->op_type != OP_GV) {
- break;
- }
-
- gv = kGVOP_gv;
- cv = isGV(gv)
- ? GvCV(gv)
- : SvROK(gv) && SvTYPE(SvRV(gv)) == SVt_PVCV
- ? MUTABLE_CV(SvRV(gv))
- : NULL;
- if (!cv)
- break;
- if (CvLVALUE(cv))
- break;
- if (flags & OP_LVALUE_NO_CROAK)
- return NULL;
-
- namesv = cv_name(cv, NULL, 0);
- yyerror_pv(Perl_form(aTHX_ "Can't modify non-lvalue "
- "subroutine call of &%" SVf " in %s",
- SVfARG(namesv), PL_op_desc[type]),
- SvUTF8(namesv));
- goto do_next;
- }
- }
- /* FALLTHROUGH */
- default:
- nomod:
- if (flags & OP_LVALUE_NO_CROAK) return NULL;
- /* grep, foreach, subcalls, refgen */
- if (S_potential_mod_type(type))
- break;
- yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
- (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
- ? "do block"
- : OP_DESC(o)),
- type ? PL_op_desc[type] : "local"));
- goto do_next;
-
- case OP_PREINC:
- case OP_PREDEC:
- case OP_POW:
- case OP_MULTIPLY:
- case OP_DIVIDE:
- case OP_MODULO:
- case OP_ADD:
- case OP_SUBTRACT:
- case OP_CONCAT:
- case OP_LEFT_SHIFT:
- case OP_RIGHT_SHIFT:
- case OP_BIT_AND:
- case OP_BIT_XOR:
- case OP_BIT_OR:
- case OP_I_MULTIPLY:
- case OP_I_DIVIDE:
- case OP_I_MODULO:
- case OP_I_ADD:
- case OP_I_SUBTRACT:
- if (!(o->op_flags & OPf_STACKED))
- goto nomod;
- PL_modcount++;
- break;
-
- case OP_REPEAT:
- if (o->op_flags & OPf_STACKED) {
- PL_modcount++;
- break;
- }
- if (!(o->op_private & OPpREPEAT_DOLIST))
- goto nomod;
- else {
- const I32 mods = PL_modcount;
- /* we recurse rather than iterate here because we need to
- * calculate and use the delta applied to PL_modcount by the
- * first child. So in something like
- * ($x, ($y) x 3) = split;
- * split knows that 4 elements are wanted
- */
- modkids(cBINOPo->op_first, type);
- if (type != OP_AASSIGN)
- goto nomod;
- kid = cBINOPo->op_last;
- if (kid->op_type == OP_CONST && SvIOK(kSVOP_sv)) {
- const IV iv = SvIV(kSVOP_sv);
- if (PL_modcount != RETURN_UNLIMITED_NUMBER)
- PL_modcount =
- mods + (PL_modcount - mods) * (iv < 0 ? 0 : iv);
- }
- else
- PL_modcount = RETURN_UNLIMITED_NUMBER;
- }
- break;
-
- case OP_COND_EXPR:
- localize = 1;
- next_kid = OpSIBLING(cUNOPo->op_first);
- break;
-
- case OP_RV2AV:
- case OP_RV2HV:
- if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
- PL_modcount = RETURN_UNLIMITED_NUMBER;
- /* Treat \(@foo) like ordinary list, but still mark it as modi-
- fiable since some contexts need to know. */
- o->op_flags |= OPf_MOD;
- goto do_next;
- }
- /* FALLTHROUGH */
- case OP_RV2GV:
- if (scalar_mod_type(o, type))
- goto nomod;
- ref(cUNOPo->op_first, o->op_type);
- /* FALLTHROUGH */
- case OP_ASLICE:
- case OP_HSLICE:
- localize = 1;
- /* FALLTHROUGH */
- case OP_AASSIGN:
- /* Do not apply the lvsub flag for rv2[ah]v in scalar context. */
- if (type == OP_LEAVESUBLV && (
- (o->op_type != OP_RV2AV && o->op_type != OP_RV2HV)
- || (o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
- ))
- o->op_private |= OPpMAYBE_LVSUB;
- /* FALLTHROUGH */
- case OP_NEXTSTATE:
- case OP_DBSTATE:
- PL_modcount = RETURN_UNLIMITED_NUMBER;
- break;
-
- case OP_KVHSLICE:
- case OP_KVASLICE:
- case OP_AKEYS:
- if (type == OP_LEAVESUBLV)
- o->op_private |= OPpMAYBE_LVSUB;
- goto nomod;
-
- case OP_AVHVSWITCH:
- if (type == OP_LEAVESUBLV
- && (o->op_private & OPpAVHVSWITCH_MASK) + OP_EACH == OP_KEYS)
- o->op_private |= OPpMAYBE_LVSUB;
- goto nomod;
-
- case OP_AV2ARYLEN:
- PL_hints |= HINT_BLOCK_SCOPE;
- if (type == OP_LEAVESUBLV)
- o->op_private |= OPpMAYBE_LVSUB;
- PL_modcount++;
- break;
-
- case OP_RV2SV:
- ref(cUNOPo->op_first, o->op_type);
- localize = 1;
- /* FALLTHROUGH */
- case OP_GV:
- PL_hints |= HINT_BLOCK_SCOPE;
- /* FALLTHROUGH */
- case OP_SASSIGN:
- case OP_ANDASSIGN:
- case OP_ORASSIGN:
- case OP_DORASSIGN:
- PL_modcount++;
- break;
-
- case OP_AELEMFAST:
- case OP_AELEMFAST_LEX:
- localize = -1;
- PL_modcount++;
- break;
-
- case OP_PADAV:
- case OP_PADHV:
- PL_modcount = RETURN_UNLIMITED_NUMBER;
- if (type == OP_REFGEN && o->op_flags & OPf_PARENS)
- {
- /* Treat \(@foo) like ordinary list, but still mark it as modi-
- fiable since some contexts need to know. */
- o->op_flags |= OPf_MOD;
- goto do_next;
- }
- if (scalar_mod_type(o, type))
- goto nomod;
- if ((o->op_flags & OPf_WANT) != OPf_WANT_SCALAR
- && type == OP_LEAVESUBLV)
- o->op_private |= OPpMAYBE_LVSUB;
- /* FALLTHROUGH */
- case OP_PADSV:
- PL_modcount++;
- if (!type) /* local() */
- Perl_croak(aTHX_ "Can't localize lexical variable %" PNf,
- PNfARG(PAD_COMPNAME(o->op_targ)));
- if (!(o->op_private & OPpLVAL_INTRO)
- || ( type != OP_SASSIGN && type != OP_AASSIGN
- && PadnameIsSTATE(PAD_COMPNAME_SV(o->op_targ)) ))
- S_mark_padname_lvalue(aTHX_ PAD_COMPNAME_SV(o->op_targ));
- break;
-
- case OP_PUSHMARK:
- localize = 0;
- break;
-
- case OP_KEYS:
- if (type != OP_LEAVESUBLV && !scalar_mod_type(NULL, type))
- goto nomod;
- goto lvalue_func;
- case OP_SUBSTR:
- if (o->op_private == 4) /* don't allow 4 arg substr as lvalue */
- goto nomod;
- /* FALLTHROUGH */
- case OP_POS:
- case OP_VEC:
- lvalue_func:
- if (type == OP_LEAVESUBLV)
- o->op_private |= OPpMAYBE_LVSUB;
- if (o->op_flags & OPf_KIDS && OpHAS_SIBLING(cBINOPo->op_first)) {
- /* we recurse rather than iterate here because the child
- * needs to be processed with a different 'type' parameter */
-
- /* substr and vec */
- /* If this op is in merely potential (non-fatal) modifiable
- context, then apply OP_ENTERSUB context to
- the kid op (to avoid croaking). Other-
- wise pass this op’s own type so the correct op is mentioned
- in error messages. */
- op_lvalue(OpSIBLING(cBINOPo->op_first),
- S_potential_mod_type(type)
- ? (I32)OP_ENTERSUB
- : o->op_type);
- }
- break;
-
- case OP_AELEM:
- case OP_HELEM:
- ref(cBINOPo->op_first, o->op_type);
- if (type == OP_ENTERSUB &&
- !(o->op_private & (OPpLVAL_INTRO | OPpDEREF)))
- o->op_private |= OPpLVAL_DEFER;
- if (type == OP_LEAVESUBLV)
- o->op_private |= OPpMAYBE_LVSUB;
- localize = 1;
- PL_modcount++;
- break;
-
- case OP_LEAVE:
- case OP_LEAVELOOP:
- o->op_private |= OPpLVALUE;
- /* FALLTHROUGH */
- case OP_SCOPE:
- case OP_ENTER:
- case OP_LINESEQ:
- localize = 0;
- if (o->op_flags & OPf_KIDS)
- next_kid = cLISTOPo->op_last;
- break;
-
- case OP_NULL:
- localize = 0;
- if (o->op_flags & OPf_SPECIAL) /* do BLOCK */
- goto nomod;
- else if (!(o->op_flags & OPf_KIDS))
- break;
-
- if (o->op_targ != OP_LIST) {
- OP *sib = OpSIBLING(cLISTOPo->op_first);
- /* OP_TRANS and OP_TRANSR with argument have a weird optree
- * that looks like
- *
- * null
- * arg
- * trans
- *
- * compared with things like OP_MATCH which have the argument
- * as a child:
- *
- * match
- * arg
- *
- * so handle specially to correctly get "Can't modify" croaks etc
- */
-
- if (sib && (sib->op_type == OP_TRANS || sib->op_type == OP_TRANSR))
- {
- /* this should trigger a "Can't modify transliteration" err */
- op_lvalue(sib, type);
- }
- next_kid = cBINOPo->op_first;
- /* we assume OP_NULLs which aren't ex-list have no more than 2
- * children. If this assumption is wrong, increase the scan
- * limit below */
- assert( !OpHAS_SIBLING(next_kid)
- || !OpHAS_SIBLING(OpSIBLING(next_kid)));
- break;
- }
- /* FALLTHROUGH */
- case OP_LIST:
- localize = 0;
- next_kid = cLISTOPo->op_first;
- break;
-
- case OP_COREARGS:
- goto do_next;
-
- case OP_AND:
- case OP_OR:
- if (type == OP_LEAVESUBLV
- || !S_vivifies(cLOGOPo->op_first->op_type))
- next_kid = cLOGOPo->op_first;
- else if (type == OP_LEAVESUBLV
- || !S_vivifies(OpSIBLING(cLOGOPo->op_first)->op_type))
- next_kid = OpSIBLING(cLOGOPo->op_first);
- goto nomod;
-
- case OP_SREFGEN:
- if (type == OP_NULL) { /* local */
- local_refgen:
- if (!FEATURE_MYREF_IS_ENABLED)
- Perl_croak(aTHX_ "The experimental declared_refs "
- "feature is not enabled");
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__DECLARED_REFS),
- "Declaring references is experimental");
- next_kid = cUNOPo->op_first;
- goto do_next;
- }
- if (type != OP_AASSIGN && type != OP_SASSIGN
- && type != OP_ENTERLOOP)
- goto nomod;
- /* Don’t bother applying lvalue context to the ex-list. */
- kid = cUNOPx(cUNOPo->op_first)->op_first;
- assert (!OpHAS_SIBLING(kid));
- goto kid_2lvref;
- case OP_REFGEN:
- if (type == OP_NULL) /* local */
- goto local_refgen;
- if (type != OP_AASSIGN) goto nomod;
- kid = cUNOPo->op_first;
- kid_2lvref:
- {
- const U8 ec = PL_parser ? PL_parser->error_count : 0;
- S_lvref(aTHX_ kid, type);
- if (!PL_parser || PL_parser->error_count == ec) {
- if (!FEATURE_REFALIASING_IS_ENABLED)
- Perl_croak(aTHX_
- "Experimental aliasing via reference not enabled");
- Perl_ck_warner_d(aTHX_
- packWARN(WARN_EXPERIMENTAL__REFALIASING),
- "Aliasing via reference is experimental");
- }
- }
- if (o->op_type == OP_REFGEN)
- op_null(cUNOPx(cUNOPo->op_first)->op_first); /* pushmark */
- op_null(o);
- goto do_next;
-
- case OP_SPLIT:
- if ((o->op_private & OPpSPLIT_ASSIGN)) {
- /* This is actually @array = split. */
- PL_modcount = RETURN_UNLIMITED_NUMBER;
- break;
- }
- goto nomod;
-
- case OP_SCALAR:
- op_lvalue(cUNOPo->op_first, OP_ENTERSUB);
- goto nomod;
- }
-
- /* [20011101.069 (#7861)] File test operators interpret OPf_REF to mean that
- their argument is a filehandle; thus \stat(".") should not set
- it. AMS 20011102 */
- if (type == OP_REFGEN && OP_IS_STAT(o->op_type))
- goto do_next;
-
- if (type != OP_LEAVESUBLV)
- o->op_flags |= OPf_MOD;
-
- if (type == OP_AASSIGN || type == OP_SASSIGN)
- o->op_flags |= OPf_SPECIAL
- |(o->op_type == OP_ENTERSUB ? 0 : OPf_REF);
- else if (!type) { /* local() */
- switch (localize) {
- case 1:
- o->op_private |= OPpLVAL_INTRO;
- o->op_flags &= ~OPf_SPECIAL;
- PL_hints |= HINT_BLOCK_SCOPE;
- break;
- case 0:
- break;
- case -1:
- Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX),
- "Useless localization of %s", OP_DESC(o));
- }
- }
- else if (type != OP_GREPSTART && type != OP_ENTERSUB
- && type != OP_LEAVESUBLV && o->op_type != OP_ENTERSUB)
- o->op_flags |= OPf_REF;
-
- do_next:
- while (!next_kid) {
- if (o == top_op)
- return top_op; /* at top; no parents/siblings to try */
- if (OpHAS_SIBLING(o)) {
- next_kid = o->op_sibparent;
- if (!OpHAS_SIBLING(next_kid)) {
- /* a few node types don't recurse into their second child */
- OP *parent = next_kid->op_sibparent;
- I32 ptype = parent->op_type;
- if ( (ptype == OP_NULL && parent->op_targ != OP_LIST)
- || ( (ptype == OP_AND || ptype == OP_OR)
- && (type != OP_LEAVESUBLV
- && S_vivifies(next_kid->op_type))
- )
- ) {
- /*try parent's next sibling */
- o = parent;
- next_kid = NULL;
- }
- }
- }
- else
- o = o->op_sibparent; /*try parent's next sibling */
-
- }
- o = next_kid;
-
- } /* while */
-
-}
-
-
-STATIC bool
-S_scalar_mod_type(const OP *o, I32 type)
-{
- switch (type) {
- case OP_POS:
- case OP_SASSIGN:
- if (o && o->op_type == OP_RV2GV)
- return FALSE;
- /* FALLTHROUGH */
- case OP_PREINC:
- case OP_PREDEC:
- case OP_POSTINC:
- case OP_POSTDEC:
- case OP_I_PREINC:
- case OP_I_PREDEC:
- case OP_I_POSTINC:
- case OP_I_POSTDEC:
- case OP_POW:
- case OP_MULTIPLY:
- case OP_DIVIDE:
- case OP_MODULO:
- case OP_REPEAT:
- case OP_ADD:
- case OP_SUBTRACT:
- case OP_I_MULTIPLY:
- case OP_I_DIVIDE:
- case OP_I_MODULO:
- case OP_I_ADD:
- case OP_I_SUBTRACT:
- case OP_LEFT_SHIFT:
- case OP_RIGHT_SHIFT:
- case OP_BIT_AND:
- case OP_BIT_XOR:
- case OP_BIT_OR:
- case OP_NBIT_AND:
- case OP_NBIT_XOR:
- case OP_NBIT_OR:
- case OP_SBIT_AND:
- case OP_SBIT_XOR:
- case OP_SBIT_OR:
- case OP_CONCAT:
- case OP_SUBST:
- case OP_TRANS:
- case OP_TRANSR:
- case OP_READ:
- case OP_SYSREAD:
- case OP_RECV:
- case OP_ANDASSIGN:
- case OP_ORASSIGN:
- case OP_DORASSIGN:
- case OP_VEC:
- case OP_SUBSTR:
- return TRUE;
- default:
- return FALSE;
- }
-}
-
-STATIC bool
-S_is_handle_constructor(const OP *o, I32 numargs)
-{
- PERL_ARGS_ASSERT_IS_HANDLE_CONSTRUCTOR;
-
- switch (o->op_type) {
- case OP_PIPE_OP:
- case OP_SOCKPAIR:
- if (numargs == 2)
- return TRUE;
- /* FALLTHROUGH */
- case OP_SYSOPEN:
- case OP_OPEN:
- case OP_SELECT: /* XXX c.f. SelectSaver.pm */
- case OP_SOCKET:
- case OP_OPEN_DIR:
- case OP_ACCEPT:
- if (numargs == 1)
- return TRUE;
- /* FALLTHROUGH */
- default:
- return FALSE;
- }
-}
-
-static OP *
-S_refkids(pTHX_ OP *o, I32 type)
-{
- if (o && o->op_flags & OPf_KIDS) {
- OP *kid;
- for (kid = cLISTOPo->op_first; kid; kid = OpSIBLING(kid))
- ref(kid, type);
- }
- return o;
-}
-
-
-/* Apply reference (autovivification) context to the subtree at o.
- * For example in
- * push @{expression}, ....;
- * o will be the head of 'expression' and type will be OP_RV2AV.
- * It marks the op o (or a suitable child) as autovivifying, e.g. by
- * setting OPf_MOD.
- * For OP_RV2AV/OP_PADAV and OP_RV2HV/OP_PADHV sets OPf_REF too if
- * set_op_ref is true.
- *
- * Also calls scalar(o).
- */
-
-OP *
-Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
-{
- dVAR;
- OP * top_op = o;
-
- PERL_ARGS_ASSERT_DOREF;
-
- if (PL_parser && PL_parser->error_count)
- return o;
-
- while (1) {
- switch (o->op_type) {
- case OP_ENTERSUB:
- if ((type == OP_EXISTS || type == OP_DEFINED) &&
- !(o->op_flags & OPf_STACKED)) {
- OpTYPE_set(o, OP_RV2CV); /* entersub => rv2cv */
- assert(cUNOPo->op_first->op_type == OP_NULL);
- /* disable pushmark */
- op_null(((LISTOP*)cUNOPo->op_first)->op_first);
- o->op_flags |= OPf_SPECIAL;
- }
- else if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV){
- o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
- : type == OP_RV2HV ? OPpDEREF_HV
- : OPpDEREF_SV);
- o->op_flags |= OPf_MOD;
- }
-
- break;
-
- case OP_COND_EXPR:
- o = OpSIBLING(cUNOPo->op_first);
- continue;
-
- case OP_RV2SV:
- if (type == OP_DEFINED)
- o->op_flags |= OPf_SPECIAL; /* don't create GV */
- /* FALLTHROUGH */
- case OP_PADSV:
- if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
- o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
- : type == OP_RV2HV ? OPpDEREF_HV
- : OPpDEREF_SV);
- o->op_flags |= OPf_MOD;
- }
- if (o->op_flags & OPf_KIDS) {
- type = o->op_type;
- o = cUNOPo->op_first;
- continue;
- }
- break;
-
- case OP_RV2AV:
- case OP_RV2HV:
- if (set_op_ref)
- o->op_flags |= OPf_REF;
- /* FALLTHROUGH */
- case OP_RV2GV:
- if (type == OP_DEFINED)
- o->op_flags |= OPf_SPECIAL; /* don't create GV */
- type = o->op_type;
- o = cUNOPo->op_first;
- continue;
-
- case OP_PADAV:
- case OP_PADHV:
- if (set_op_ref)
- o->op_flags |= OPf_REF;
- break;
-
- case OP_SCALAR:
- case OP_NULL:
- if (!(o->op_flags & OPf_KIDS) || type == OP_DEFINED)
- break;
- o = cBINOPo->op_first;
- continue;
-
- case OP_AELEM:
- case OP_HELEM:
- if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
- o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
- : type == OP_RV2HV ? OPpDEREF_HV
- : OPpDEREF_SV);
- o->op_flags |= OPf_MOD;
- }
- type = o->op_type;
- o = cBINOPo->op_first;
- continue;;
-
- case OP_SCOPE:
- case OP_LEAVE:
- set_op_ref = FALSE;
- /* FALLTHROUGH */
- case OP_ENTER:
- case OP_LIST:
- if (!(o->op_flags & OPf_KIDS))
- break;
- o = cLISTOPo->op_last;
- continue;
-
- default:
- break;
- } /* switch */
-
- while (1) {
- if (o == top_op)
- return scalar(top_op); /* at top; no parents/siblings to try */
- if (OpHAS_SIBLING(o)) {
- o = o->op_sibparent;
- /* Normally skip all siblings and go straight to the parent;
- * the only op that requires two children to be processed
- * is OP_COND_EXPR */
- if (!OpHAS_SIBLING(o)
- && o->op_sibparent->op_type == OP_COND_EXPR)
- break;
- continue;
- }
- o = o->op_sibparent; /*try parent's next sibling */
- }
- } /* while */
-}
-
-
-STATIC OP *
-S_dup_attrlist(pTHX_ OP *o)
-{
- OP *rop;
-
- PERL_ARGS_ASSERT_DUP_ATTRLIST;
-
- /* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
- * where the first kid is OP_PUSHMARK and the remaining ones
- * are OP_CONST. We need to push the OP_CONST values.
- */
- if (o->op_type == OP_CONST)
- rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
- else {
- assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
- rop = NULL;
- for (o = cLISTOPo->op_first; o; o = OpSIBLING(o)) {
- if (o->op_type == OP_CONST)
- rop = op_append_elem(OP_LIST, rop,
- newSVOP(OP_CONST, o->op_flags,
- SvREFCNT_inc_NN(cSVOPo->op_sv)));
- }
- }
- return rop;
-}
-
-STATIC void
-S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
-{
- PERL_ARGS_ASSERT_APPLY_ATTRS;
- {
- SV * const stashsv = newSVhek(HvNAME_HEK(stash));
-
- /* fake up C<use attributes $pkg,$rv,@attrs> */
-
-#define ATTRSMODULE "attributes"
-#define ATTRSMODULE_PM "attributes.pm"
-
- Perl_load_module(
- aTHX_ PERL_LOADMOD_IMPORT_OPS,
- newSVpvs(ATTRSMODULE),
- NULL,
- op_prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0, stashsv),
- op_prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0,
- newRV(target)),
- dup_attrlist(attrs))));
- }
-}
-
-STATIC void
-S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
-{
- OP *pack, *imop, *arg;
- SV *meth, *stashsv, **svp;
-
- PERL_ARGS_ASSERT_APPLY_ATTRS_MY;
-
- if (!attrs)
- return;
-
- assert(target->op_type == OP_PADSV ||
- target->op_type == OP_PADHV ||
- target->op_type == OP_PADAV);
-
- /* Ensure that attributes.pm is loaded. */
- /* Don't force the C<use> if we don't need it. */
- svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
- if (svp && *svp != &PL_sv_undef)
- NOOP; /* already in %INC */
- else
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvs(ATTRSMODULE), NULL);
-
- /* Need package name for method call. */
- pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
-
- /* Build up the real arg-list. */
- stashsv = newSVhek(HvNAME_HEK(stash));
-
- arg = newOP(OP_PADSV, 0);
- arg->op_targ = target->op_targ;
- arg = op_prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0, stashsv),
- op_prepend_elem(OP_LIST,
- newUNOP(OP_REFGEN, 0,
- arg),
- dup_attrlist(attrs)));
-
- /* Fake up a method call to import */
- meth = newSVpvs_share("import");
- imop = op_convert_list(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
- op_append_elem(OP_LIST,
- op_prepend_elem(OP_LIST, pack, arg),
- newMETHOP_named(OP_METHOD_NAMED, 0, meth)));
-
- /* Combine the ops. */
- *imopsp = op_append_elem(OP_LIST, *imopsp, imop);
-}
-
-/*
-=notfor apidoc apply_attrs_string
-
-Attempts to apply a list of attributes specified by the C<attrstr> and
-C<len> arguments to the subroutine identified by the C<cv> argument which
-is expected to be associated with the package identified by the C<stashpv>
-argument (see L<attributes>). It gets this wrong, though, in that it
-does not correctly identify the boundaries of the individual attribute
-specifications within C<attrstr>. This is not really intended for the
-public API, but has to be listed here for systems such as AIX which
-need an explicit export list for symbols. (It's called from XS code
-in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
-to respect attribute syntax properly would be welcome.
-
-=cut
-*/
-
-void
-Perl_apply_attrs_string(pTHX_ const char *stashpv, CV *cv,
- const char *attrstr, STRLEN len)
-{
- OP *attrs = NULL;
-
- PERL_ARGS_ASSERT_APPLY_ATTRS_STRING;
-
- if (!len) {
- len = strlen(attrstr);
- }
-
- while (len) {
- for (; isSPACE(*attrstr) && len; --len, ++attrstr) ;
- if (len) {
- const char * const sstr = attrstr;
- for (; !isSPACE(*attrstr) && len; --len, ++attrstr) ;
- attrs = op_append_elem(OP_LIST, attrs,
- newSVOP(OP_CONST, 0,
- newSVpvn(sstr, attrstr-sstr)));
- }
- }
-
- Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
- newSVpvs(ATTRSMODULE),
- NULL, op_prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
- op_prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0,
- newRV(MUTABLE_SV(cv))),
- attrs)));
https://perl5.git.perl.org / perl5.git / blobdiff