X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9ae0115f0b854d654461d3c5bbcaa938516d0f4e..7cf4dd3e4ab14124f5e2946c4ccfba595dd9d760:/op.c diff --git a/op.c b/op.c index a08be2e..d8dfbd3 100644 --- a/op.c +++ b/op.c @@ -594,7 +594,7 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) !(is_our || isALPHA(name[1]) || ((flags & SVf_UTF8) && isIDFIRST_utf8((U8 *)name+1)) || - (name[1] == '_' && (*name == '$' || len > 2)))) + (name[1] == '_' && len > 2))) { if (!(flags & SVf_UTF8 && UTF8_IS_START(name[1])) && isASCII(name[1]) @@ -607,13 +607,6 @@ Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags) PL_parser->in_my == KEY_state ? "state" : "my"), flags & SVf_UTF8); } } - else if (len == 2 && name[1] == '_' && !is_our) - /* 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"); /* allocate a spare slot and store the name in that slot */ @@ -719,10 +712,23 @@ Perl_op_free(pTHX_ OP *o) type = o->op_type; /* an op should only ever acquire op_private flags that we know about. - * If this fails, you may need to fix something in regen/op_private */ - if (o->op_ppaddr == PL_ppaddr[o->op_type]) { + * If this fails, you may need to fix something in regen/op_private. + * Don't bother testing if: + * * the op_ppaddr doesn't match the op; someone may have + * overridden the op and be doing strange things with it; + * * we've errored, as op flags are often left in an + * inconsistent state then. Note that an error when + * compiling the main program leaves PL_parser NULL, so + * we can't spot faults in the main code, only + * evaled/required code */ +#ifdef DEBUGGING + if ( o->op_ppaddr == PL_ppaddr[o->op_type] + && PL_parser + && !PL_parser->error_count) + { assert(!(o->op_private & ~PL_op_private_valid[type])); } +#endif if (o->op_private & OPpREFCOUNTED) { switch (type) { @@ -1188,6 +1194,7 @@ Perl_op_null(pTHX_ OP *o) void Perl_op_refcnt_lock(pTHX) + PERL_TSA_ACQUIRE(PL_op_mutex) { #ifdef USE_ITHREADS dVAR; @@ -1198,6 +1205,7 @@ Perl_op_refcnt_lock(pTHX) void Perl_op_refcnt_unlock(pTHX) + PERL_TSA_RELEASE(PL_op_mutex) { #ifdef USE_ITHREADS dVAR; @@ -1211,7 +1219,7 @@ Perl_op_refcnt_unlock(pTHX) =for apidoc op_sibling_splice A general function for editing the structure of an existing chain of -op_sibling nodes. By analogy with the perl-level splice() function, allows +op_sibling nodes. By analogy with the perl-level C function, allows you to delete zero or more sequential nodes, replacing them with zero or more different nodes. Performs the necessary op_first/op_last housekeeping on the parent node and op_sibling manipulation on the @@ -1222,22 +1230,22 @@ Note that op_next is not manipulated, and nodes are not freed; that is the responsibility of the caller. It also won't create a new list op for an empty list etc; use higher-level functions like op_append_elem() for that. -parent is the parent node of the sibling chain. It may passed as NULL if +C is the parent node of the sibling chain. It may passed as C if the splicing doesn't affect the first or last op in the chain. -start is the node preceding the first node to be spliced. Node(s) +C is the node preceding the first node to be spliced. Node(s) following it will be deleted, and ops will be inserted after it. If it is -NULL, the first node onwards is deleted, and nodes are inserted at the +C, the first node onwards is deleted, and nodes are inserted at the beginning. -del_count is the number of nodes to delete. If zero, no nodes are deleted. +C is the number of nodes to delete. If zero, no nodes are deleted. If -1 or greater than or equal to the number of remaining kids, all remaining kids are deleted. -insert is the first of a chain of nodes to be inserted in place of the nodes. -If NULL, no nodes are inserted. +C is the first of a chain of nodes to be inserted in place of the nodes. +If C, no nodes are inserted. -The head of the chain of deleted ops is returned, or NULL if no ops were +The head of the chain of deleted ops is returned, or C if no ops were deleted. For example: @@ -1263,7 +1271,7 @@ For example: For lower-level direct manipulation of C and C, -see C, C, C. +see C>, C>, C>. =cut */ @@ -1362,7 +1370,7 @@ Perl_op_sibling_splice(OP *parent, OP *start, int del_count, OP* insert) /* =for apidoc op_parent -Returns the parent OP of o, if it has a parent. Returns NULL otherwise. +Returns the parent OP of C, if it has a parent. Returns C otherwise. This function is only available on perls built with C<-DPERL_OP_PARENT>. =cut @@ -2365,7 +2373,7 @@ S_check_hash_fields_and_hekify(pTHX_ UNOP *rop, SVOP *key_op) This function finalizes the optree. Should be called directly after the complete optree is built. It does some additional -checking which can't be done in the normal ck_xxx functions and makes +checking which can't be done in the normal Cxxx functions and makes the tree thread-safe. =cut @@ -2585,13 +2593,13 @@ S_finalize_op(pTHX_ OP* o) Propagate lvalue ("modifiable") context to an op and its children. C represents the context type, roughly based on the type of op that -would do the modifying, although C is represented by OP_NULL, +would do the modifying, although C is represented by C, 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 OP_ADD and a C argument of OP_SASSIGN. +called with an op of type C and a C argument of C. 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>. @@ -2799,6 +2807,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) 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) @@ -2836,6 +2845,15 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) 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)); + return o; } } /* FALLTHROUGH */ @@ -2849,9 +2867,7 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) yyerror(Perl_form(aTHX_ "Can't modify %s in %s", (o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL) ? "do block" - : (o->op_type == OP_ENTERSUB - ? "non-lvalue subroutine call" - : OP_DESC(o))), + : OP_DESC(o)), type ? PL_op_desc[type] : "local")); return o; @@ -4140,7 +4156,8 @@ Perl_localize(pTHX_ OP *o, I32 lex) s++; while (1) { - if (*s && strchr("@$%*", *s) && *++s + if (*s && (strchr("@$%", *s) || (!lex && *s == '*')) + && *++s && (isWORDCHAR(*s) || UTF8_IS_CONTINUED(*s))) { s++; sigil = TRUE; @@ -4673,7 +4690,7 @@ consumed by this function and become part of the constructed op tree. For most list operators, the check function expects all the kid ops to be present already, so calling C (e.g.) is not appropriate. What you want to do in that case is create an op of type -OP_LIST, append more children to it, and then call L. +C, append more children to it, and then call L. See L for more information. @@ -4816,8 +4833,8 @@ Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first) /* =for apidoc newUNOP_AUX -Similar to C, but creates an UNOP_AUX struct instead, with op_aux -initialised to aux +Similar to C, but creates an C struct instead, with C +initialised to C =cut */ @@ -4857,7 +4874,7 @@ and, shifted up eight bits, the eight bits of C, except that the bit with value 1 is automatically set. C supplies an op which evaluates method name; it is consumed by this function and become part of the constructed op tree. -Supported optypes: OP_METHOD. +Supported optypes: C. =cut */ @@ -4912,7 +4929,7 @@ method name. C is the opcode. C gives the eight bits of C, and, shifted up eight bits, the eight bits of C. C supplies a constant method name; it must be a shared COW string. -Supported optypes: OP_METHOD_NAMED. +Supported optypes: C. =cut */ @@ -5193,7 +5210,7 @@ S_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) max = rfirst + diff; if (!grows) grows = (tfirst < rfirst && - UNISKIP(tfirst) < UNISKIP(rfirst + diff)); + UVCHR_SKIP(tfirst) < UVCHR_SKIP(rfirst + diff)); rfirst += diff + 1; } tfirst += diff + 1; @@ -5809,9 +5826,7 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) /* =for apidoc Am|OP *|newDEFSVOP| -Constructs and returns an op to access C<$_>, either as a lexical -variable (if declared as C) in the current scope, or the -global C<$_>. +Constructs and returns an op to access C<$_>. =cut */ @@ -5819,15 +5834,7 @@ global C<$_>. OP * Perl_newDEFSVOP(pTHX) { - const PADOFFSET offset = pad_findmy_pvs("$_", 0); - if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { return newSVREF(newGVOP(OP_GV, 0, PL_defgv)); - } - else { - OP * const o = newOP(OP_PADSV, 0); - o->op_targ = offset; - return o; - } } #ifdef USE_ITHREADS @@ -6105,15 +6112,15 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg) Loads the module whose name is pointed to by the string part of name. Note that the actual module name, not its filename, should be given. Eg, "Foo::Bar" instead of "Foo/Bar.pm". flags can be any of -PERL_LOADMOD_DENY, PERL_LOADMOD_NOIMPORT, or PERL_LOADMOD_IMPORT_OPS +C, C, or C (or 0 for no flags). ver, if specified and not NULL, provides version semantics similar to C. The optional trailing SV* -arguments can be used to specify arguments to the module's import() +arguments can be used to specify arguments to the module's C method, similar to C. They must be -terminated with a final NULL pointer. Note that this list can only -be omitted when the PERL_LOADMOD_NOIMPORT flag has been used. -Otherwise at least a single NULL pointer to designate the default +terminated with a final C pointer. Note that this list can only +be omitted when the C flag has been used. +Otherwise at least a single C pointer to designate the default import list is required. The reference count for each specified C parameter is decremented. @@ -7224,7 +7231,7 @@ loop (iteration through a list of values). This is a heavyweight loop, with structure that allows exiting the loop by C and suchlike. C optionally supplies the variable that will be aliased to each -item in turn; if null, it defaults to C<$_> (either lexical or global). +item in turn; if null, it defaults to C<$_>. C supplies the list of values to iterate over. C supplies the main body of the loop, and C optionally supplies a C block that operates as a second half of the body. All of these optree @@ -7287,13 +7294,7 @@ Perl_newFOROP(pTHX_ I32 flags, OP *sv, OP *expr, OP *block, OP *cont) } } else { - const PADOFFSET offset = pad_findmy_pvs("$_", 0); - if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { - sv = newGVOP(OP_GV, 0, PL_defgv); - } - else { - padoff = offset; - } + sv = newGVOP(OP_GV, 0, PL_defgv); iterpflags |= OPpITER_DEF; } @@ -7475,9 +7476,10 @@ S_newGIVWHENOP(pTHX_ OP *cond, OP *block, OP *o; PERL_ARGS_ASSERT_NEWGIVWHENOP; + PERL_UNUSED_ARG(entertarg); /* used to indicate targ of lexical $_ */ enterop = S_alloc_LOGOP(aTHX_ enter_opcode, block, NULL); - enterop->op_targ = ((entertarg == NOT_IN_PAD) ? 0 : entertarg); + enterop->op_targ = 0; enterop->op_private = 0; o = newUNOP(leave_opcode, 0, (OP *) enterop); @@ -7596,8 +7598,7 @@ Constructs, checks, and returns an op tree expressing a C block. C supplies the expression that will be locally assigned to a lexical variable, and C supplies the body of the C construct; they are consumed by this function and become part of the constructed op tree. -C is the pad offset of the scalar lexical variable that will -be affected. If it is 0, the global $_ will be used. +C must be zero (it used to identity the pad slot of lexical $_). =cut */ @@ -7606,11 +7607,14 @@ OP * Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off) { PERL_ARGS_ASSERT_NEWGIVENOP; + PERL_UNUSED_ARG(defsv_off); + + assert(!defsv_off); return newGIVWHENOP( ref_array_or_hash(cond), block, OP_ENTERGIVEN, OP_LEAVEGIVEN, - defsv_off); + 0); } /* @@ -7733,7 +7737,7 @@ static void const_av_xsub(pTHX_ CV* cv); =for apidoc cv_const_sv If C is a constant sub eligible for inlining, returns the constant -value returned by the sub. Otherwise, returns NULL. +value returned by the sub. Otherwise, returns C. Constant subs can be created with C or as described in L. @@ -8394,7 +8398,8 @@ Perl_newATTRSUB_x(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, block->op_next = 0; if (ps && !*ps && !attrs && !CvLVALUE(PL_compcv)) const_sv = - S_op_const_sv(aTHX_ start, PL_compcv, CvCLONE(PL_compcv)); + S_op_const_sv(aTHX_ start, PL_compcv, + cBOOL(CvCLONE(PL_compcv))); else const_sv = NULL; } @@ -8800,15 +8805,15 @@ Perl_newCONSTSUB(pTHX_ HV *stash, const char *name, SV *sv) /* =for apidoc newCONSTSUB_flags -Creates a constant sub equivalent to Perl C which is +Creates a constant sub equivalent to Perl S> which is eligible for inlining at compile-time. -Currently, the only useful value for C is SVf_UTF8. +Currently, the only useful value for C is C. The newly created subroutine takes ownership of a reference to the passed in SV. -Passing NULL for SV creates a constant sub equivalent to C, +Passing C for SV creates a constant sub equivalent to S>, which won't be called if used as a destructor, but will suppress the overhead of a call to C. (This form, however, isn't eligible for inlining at compile time.) @@ -9710,6 +9715,7 @@ Perl_ck_ftst(pTHX_ OP *o) op_free(o); return newop; } + scalar((OP *) kid); if ((PL_hints & HINT_FILETEST_ACCESS) && OP_IS_FILETEST_ACCESS(o->op_type)) o->op_private |= OPpFT_ACCESS; if (type != OP_STAT && type != OP_LSTAT @@ -10046,7 +10052,6 @@ Perl_ck_grep(pTHX_ OP *o) LOGOP *gwop; OP *kid; const OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE; - PADOFFSET offset; PERL_ARGS_ASSERT_CK_GREP; @@ -10073,15 +10078,8 @@ Perl_ck_grep(pTHX_ OP *o) gwop = S_alloc_LOGOP(aTHX_ type, o, LINKLIST(kid)); kid->op_next = (OP*)gwop; - offset = pad_findmy_pvs("$_", 0); - if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) { - o->op_private = gwop->op_private = 0; - gwop->op_targ = pad_alloc(type, SVs_PADTMP); - } - else { - o->op_private = gwop->op_private = OPpGREP_LEX; - gwop->op_targ = o->op_targ = offset; - } + o->op_private = gwop->op_private = 0; + gwop->op_targ = pad_alloc(type, SVs_PADTMP); kid = OpSIBLING(cLISTOPo->op_first); for (kid = OpSIBLING(kid); kid; kid = OpSIBLING(kid)) @@ -10332,15 +10330,9 @@ Perl_ck_sassign(pTHX_ OP *o) OP * Perl_ck_match(pTHX_ OP *o) { + PERL_UNUSED_CONTEXT; PERL_ARGS_ASSERT_CK_MATCH; - if (o->op_type != OP_QR && PL_compcv) { - const PADOFFSET offset = pad_findmy_pvs("$_", 0); - if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) { - o->op_targ = offset; - o->op_private |= OPpTARGET_MY; - } - } if (o->op_type == OP_MATCH || o->op_type == OP_QR) o->op_private |= OPpRUNTIME; return o; @@ -11167,11 +11159,20 @@ OP * Perl_ck_entersub_args_list(pTHX_ OP *entersubop) { OP *aop; + PERL_ARGS_ASSERT_CK_ENTERSUB_ARGS_LIST; + aop = cUNOPx(entersubop)->op_first; if (!OpHAS_SIBLING(aop)) aop = cUNOPx(aop)->op_first; for (aop = OpSIBLING(aop); OpHAS_SIBLING(aop); aop = OpSIBLING(aop)) { + /* skip the extra attributes->import() call implicitly added in + * something like foo(my $x : bar) + */ + if ( aop->op_type == OP_ENTERSUB + && (aop->op_flags & OPf_WANT) == OPf_WANT_VOID + ) + continue; list(aop); op_lvalue(aop, OP_ENTERSUB); } @@ -12194,7 +12195,7 @@ enum { that's flagged OA_DANGEROUS */ AAS_SAFE_SCALAR = 0x100, /* produces at least one scalar SV that's not in any of the categories above */ - AAS_DEFAV = 0x200, /* contains just a single '@_' on RHS */ + AAS_DEFAV = 0x200 /* contains just a single '@_' on RHS */ }; @@ -13661,9 +13662,17 @@ Perl_rpeep(pTHX_ OP *o) break; /* there's a biggest base we can fit into a - * SAVEt_CLEARPADRANGE in pp_padrange */ - if (intro && base > - (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT))) + * SAVEt_CLEARPADRANGE in pp_padrange. + * (The sizeof() stuff will be constant-folded, and is + * intended to avoid getting "comparison is always false" + * compiler warnings) + */ + if ( intro + && (8*sizeof(base) > + 8*sizeof(UV)-OPpPADRANGE_COUNTSHIFT-SAVE_TIGHT_SHIFT + ? base : 0) > + (UV_MAX >> (OPpPADRANGE_COUNTSHIFT+SAVE_TIGHT_SHIFT)) + ) break; /* Success! We've got another valid pad op to optimise away */ @@ -14342,7 +14351,7 @@ Perl_peep(pTHX_ OP *o) =for apidoc Ao||custom_op_xop Return the XOP structure for a given custom op. This macro should be -considered internal to OP_NAME and the other access macros: use them instead. +considered internal to C and the other access macros: use them instead. This macro does call a function. Prior to 5.19.6, this was implemented as a function. @@ -14479,8 +14488,8 @@ Perl_custom_op_register(pTHX_ Perl_ppaddr_t ppaddr, const XOP *xop) =for apidoc core_prototype This function assigns the prototype of the named core function to C, or -to a new mortal SV if C is NULL. It returns the modified C, or -NULL if the core function has no prototype. C is a code as returned +to a new mortal SV if C is C. It returns the modified C, or +C if the core function has no prototype. C is a code as returned by C. It must not be equal to 0. =cut