#include "perl.h"
#include "keywords.h"
-#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
-#define CALL_OPFREEHOOK(o) if (PL_opfreehook) CALL_FPTR(PL_opfreehook)(aTHX_ o)
+#define CALL_PEEP(o) PL_peepp(aTHX_ o)
+#define CALL_RPEEP(o) PL_rpeepp(aTHX_ o)
+#define CALL_OPFREEHOOK(o) if (PL_opfreehook) PL_opfreehook(aTHX_ o)
#if defined(PL_OP_SLAB_ALLOC)
? ( op_free((OP*)o), \
Perl_croak(aTHX_ "'%s' trapped by operation mask", PL_op_desc[type]), \
(OP*)0 ) \
- : CALL_FPTR(PL_check[type])(aTHX_ (OP*)o))
+ : PL_check[type](aTHX_ (OP*)o))
#define RETURN_UNLIMITED_NUMBER (PERL_INT_MAX / 2)
o->op_targ = 0;
goto retry;
}
+ case OP_ENTERTRY:
case OP_ENTEREVAL: /* Was holding hints. */
o->op_targ = 0;
break;
case OP_LEAVETRY:
kid = cLISTOPo->op_first;
scalar(kid);
- while ((kid = kid->op_sibling)) {
- if (kid->op_sibling)
- scalarvoid(kid);
- else
+ kid = kid->op_sibling;
+ do_kids:
+ while (kid) {
+ OP *sib = kid->op_sibling;
+ if (sib && kid->op_type != OP_LEAVEWHEN) {
+ if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
+ scalar(kid);
+ scalarvoid(sib);
+ break;
+ } else
+ scalarvoid(kid);
+ } else
scalar(kid);
+ kid = sib;
}
PL_curcop = &PL_compiling;
break;
case OP_SCOPE:
case OP_LINESEQ:
case OP_LIST:
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
- if (kid->op_sibling)
- scalarvoid(kid);
- else
- scalar(kid);
- }
- PL_curcop = &PL_compiling;
- break;
+ kid = cLISTOPo->op_first;
+ goto do_kids;
case OP_SORT:
Perl_ck_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
break;
want = o->op_flags & OPf_WANT;
if ((want && want != OPf_WANT_SCALAR)
|| (PL_parser && PL_parser->error_count)
- || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE)
+ || o->op_type == OP_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
{
return o;
}
useless = "negative pattern binding (!~)";
break;
+ case OP_SUBST:
+ if (cPMOPo->op_pmflags & PMf_NONDESTRUCT)
+ useless = "Non-destructive substitution (s///r)";
+ break;
+
case OP_RV2GV:
case OP_RV2SV:
case OP_RV2AV:
case OP_LEAVETRY:
kid = cLISTOPo->op_first;
list(kid);
- while ((kid = kid->op_sibling)) {
- if (kid->op_sibling)
- scalarvoid(kid);
- else
+ kid = kid->op_sibling;
+ do_kids:
+ while (kid) {
+ OP *sib = kid->op_sibling;
+ if (sib && kid->op_type != OP_LEAVEWHEN) {
+ if (sib->op_type == OP_BREAK && sib->op_flags & OPf_SPECIAL) {
+ list(kid);
+ scalarvoid(sib);
+ break;
+ } else
+ scalarvoid(kid);
+ } else
list(kid);
+ kid = sib;
}
PL_curcop = &PL_compiling;
break;
case OP_SCOPE:
case OP_LINESEQ:
- for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling) {
- if (kid->op_sibling)
- scalarvoid(kid);
- else
- list(kid);
- }
- PL_curcop = &PL_compiling;
- break;
+ kid = cLISTOPo->op_first;
+ goto do_kids;
}
return o;
}
no_bareword_allowed(right);
}
+ /* !~ doesn't make sense with s///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");
+
ismatchop = rtype == OP_MATCH ||
rtype == OP_SUBST ||
rtype == OP_TRANS;
right->op_flags |= OPf_STACKED;
if (rtype != OP_MATCH &&
! (rtype == OP_TRANS &&
- right->op_private & OPpTRANS_IDENTICAL))
+ right->op_private & OPpTRANS_IDENTICAL) &&
+ ! (rtype == OP_SUBST &&
+ (cPMOPx(right)->op_pmflags & PMf_NONDESTRUCT)))
newleft = mod(left, rtype);
else
newleft = left;
}
return o;
}
-
+
int
Perl_block_start(pTHX_ int full)
{
dVAR;
const int retval = PL_savestack_ix;
+
pad_block_start(full);
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
SAVECOMPILEWARNINGS();
PL_compiling.cop_warnings = DUP_WARNINGS(PL_compiling.cop_warnings);
+
+ CALL_BLOCK_HOOKS(start, full);
+
return retval;
}
{
dVAR;
const int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
- OP* const retval = scalarseq(seq);
+ OP* retval = scalarseq(seq);
+
+ CALL_BLOCK_HOOKS(pre_end, &retval);
+
LEAVE_SCOPE(floor);
CopHINTS_set(&PL_compiling, PL_hints);
if (needblockscope)
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
pad_leavemy();
+
+ CALL_BLOCK_HOOKS(post_end, &retval);
+
return retval;
}
+/*
+=head1 Compile-time scope hooks
+
+=for apidoc Ao||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">.
+
+=cut
+*/
+
+void
+Perl_blockhook_register(pTHX_ BHK *hk)
+{
+ PERL_ARGS_ASSERT_BLOCKHOOK_REGISTER;
+
+ Perl_av_create_and_push(aTHX_ &PL_blockhooks, newSViv(PTR2IV(hk)));
+}
+
STATIC OP *
S_newDEFSVOP(pTHX)
{
o->op_ppaddr = PL_ppaddr[OP_RV2AV];
o->op_flags &= ~OPf_REF; /* treat \(1..2) like an ordinary list */
o->op_flags |= OPf_PARENS; /* and flatten \(1..2,3) */
- o->op_opt = 0; /* needs to be revisited in peep() */
+ o->op_opt = 0; /* needs to be revisited in rpeep() */
curop = ((UNOP*)o)->op_first;
((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc_NN(*PL_stack_sp--));
#ifdef PERL_MAD
#endif
+/*
+=head1 Optree construction
+
+=for apidoc Am|OP *|newNULLLIST
+
+Constructs, checks, and returns a new C<stub> op, which represents an
+empty list expression.
+
+=cut
+*/
+
OP *
Perl_newNULLLIST(pTHX)
{
return o;
}
+/*
+=for apidoc Am|OP *|newLISTOP|I32 type|I32 flags|OP *first|OP *last
+
+Constructs, checks, and returns an op of any list type. I<type> is
+the opcode. I<flags> gives the eight bits of C<op_flags>, except that
+C<OPf_KIDS> will be set automatically if required. I<first> and I<last>
+supply up to two ops to be direct children of the list op; they are
+consumed by this function and become part of the constructed op tree.
+
+=cut
+*/
+
OP *
Perl_newLISTOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
{
return CHECKOP(type, listop);
}
+/*
+=for apidoc Am|OP *|newOP|I32 type|I32 flags
+
+Constructs, checks, and returns an op of any base type (any type that
+has no extra fields). I<type> is the opcode. I<flags> gives the
+eight bits of C<op_flags>, and, shifted up eight bits, the eight bits
+of C<op_private>.
+
+=cut
+*/
+
OP *
Perl_newOP(pTHX_ I32 type, I32 flags)
{
return CHECKOP(type, o);
}
+/*
+=for apidoc Am|OP *|newUNOP|I32 type|I32 flags|OP *first
+
+Constructs, checks, and returns an op of any unary type. I<type> is
+the opcode. I<flags> gives the eight bits of C<op_flags>, except that
+C<OPf_KIDS> will be set automatically if required, and, shifted up eight
+bits, the eight bits of C<op_private>, except that the bit with value 1
+is automatically set. I<first> supplies an optional op to be the direct
+child of the unary op; it is consumed by this function and become part
+of the constructed op tree.
+
+=cut
+*/
+
OP *
Perl_newUNOP(pTHX_ I32 type, I32 flags, OP *first)
{
return fold_constants((OP *) unop);
}
+/*
+=for apidoc Am|OP *|newBINOP|I32 type|I32 flags|OP *first|OP *last
+
+Constructs, checks, and returns an op of any binary type. I<type>
+is the opcode. I<flags> gives the eight bits of C<op_flags>, except
+that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
+the eight bits of C<op_private>, except that the bit with value 1 or
+2 is automatically set as required. I<first> and I<last> supply up to
+two ops to be the direct children of the binary op; they are consumed
+by this function and become part of the constructed op tree.
+
+=cut
+*/
+
OP *
Perl_newBINOP(pTHX_ I32 type, I32 flags, OP *first, OP *last)
{
return o;
}
+/*
+=for apidoc Am|OP *|newPMOP|I32 type|I32 flags
+
+Constructs, checks, and returns an op of any pattern matching type.
+I<type> is the opcode. I<flags> gives the eight bits of C<op_flags>
+and, shifted up eight bits, the eight bits of C<op_private>.
+
+=cut
+*/
+
OP *
Perl_newPMOP(pTHX_ I32 type, I32 flags)
{
return (OP*)pm;
}
+/*
+=for apidoc Am|OP *|newSVOP|I32 type|I32 flags|SV *sv
+
+Constructs, checks, and returns an op of any type that involves an
+embedded SV. I<type> is the opcode. I<flags> gives the eight bits
+of C<op_flags>. I<sv> gives the SV to embed in the op; this function
+takes ownership of one reference to it.
+
+=cut
+*/
+
OP *
Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv)
{
}
#ifdef USE_ITHREADS
+
+/*
+=for apidoc Am|OP *|newPADOP|I32 type|I32 flags|SV *sv
+
+Constructs, checks, and returns an op of any type that involves a
+reference to a pad element. I<type> is the opcode. I<flags> gives the
+eight bits of C<op_flags>. A pad slot is automatically allocated, and
+is populated with I<sv>; this function takes ownership of one reference
+to it.
+
+This function only exists if Perl has been compiled to use ithreads.
+
+=cut
+*/
+
OP *
Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv)
{
padop->op_targ = pad_alloc(type, SVs_PADTMP);
return CHECKOP(type, padop);
}
-#endif
+
+#endif /* !USE_ITHREADS */
+
+/*
+=for apidoc Am|OP *|newGVOP|I32 type|I32 flags|GV *gv
+
+Constructs, checks, and returns an op of any type that involves an
+embedded reference to a GV. I<type> is the opcode. I<flags> gives the
+eight bits of C<op_flags>. I<gv> identifies the GV that the op should
+reference; calling this function does not transfer ownership of any
+reference to it.
+
+=cut
+*/
OP *
Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv)
#endif
}
+/*
+=for apidoc Am|OP *|newPVOP|I32 type|I32 flags|char *pv
+
+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
+be freed when the op is destroyed.
+
+=cut
+*/
+
OP *
Perl_newPVOP(pTHX_ I32 type, I32 flags, char *pv)
{
return doop;
}
+/*
+=head1 Optree construction
+
+=for apidoc Am|OP *|newSLICEOP|I32 flags|OP *subscript|OP *listval
+
+Constructs, checks, and returns an C<lslice> (list slice) op. I<flags>
+gives the eight bits of C<op_flags>, except that C<OPf_KIDS> will
+be set automatically, and, shifted up eight bits, the eight bits of
+C<op_private>, except that the bit with value 1 or 2 is automatically
+set as required. I<listval> and I<subscript> supply the parameters of
+the slice; they are consumed by this function and become part of the
+constructed op tree.
+
+=cut
+*/
+
OP *
Perl_newSLICEOP(pTHX_ I32 flags, OP *subscript, OP *listval)
{
return FALSE;
}
+/*
+=for apidoc Am|OP *|newASSIGNOP|I32 flags|OP *left|I32 optype|OP *right
+
+Constructs, checks, and returns an assignment op. I<left> and I<right>
+supply the parameters of the assignment; they are consumed by this
+function and become part of the constructed op tree.
+
+If I<optype> is C<OP_ANDASSIGN>, C<OP_ORASSIGN>, or C<OP_DORASSIGN>, then
+a suitable conditional optree is constructed. If I<optype> is the opcode
+of a binary operator, such as C<OP_BIT_OR>, then an op is constructed that
+performs the binary operation and assigns the result to the left argument.
+Either way, if I<optype> is non-zero then I<flags> has no effect.
+
+If I<optype> is zero, then a plain scalar or list assignment is
+constructed. Which type of assignment it is is automatically determined.
+I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
+will be set automatically, and, shifted up eight bits, the eight bits
+of C<op_private>, except that the bit with value 1 or 2 is automatically
+set as required.
+
+=cut
+*/
+
OP *
Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right)
{
if (PL_eval_start)
PL_eval_start = 0;
else if (left->op_type == OP_CONST) {
+ deprecate("assignment to $[");
/* FIXME for MAD */
/* Result of assignment is always 1 (or we'd be dead already) */
return newSVOP(OP_CONST, 0, newSViv(1));
return o;
}
+/*
+=for apidoc Am|OP *|newSTATEOP|I32 flags|char *label|OP *o
+
+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>).
+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>
+for the state op.
+
+If I<o> is null, the state op is returned. Otherwise the state op is
+combined with I<o> into a C<lineseq> list op, which is returned. I<o>
+is consumed by this function and becomes part of the returned op tree.
+
+=cut
+*/
+
OP *
Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o)
{
HINTS_REFCNT_UNLOCK;
}
if (label) {
- cop->cop_hints_hash
- = Perl_store_cop_label(aTHX_ cop->cop_hints_hash, label);
+ Perl_store_cop_label(aTHX_ cop, label, strlen(label), 0);
PL_hints |= HINT_BLOCK_SCOPE;
/* It seems that we need to defer freeing this pointer, as other parts
return prepend_elem(OP_LINESEQ, (OP*)cop, o);
}
+/*
+=for apidoc Am|OP *|newLOGOP|I32 type|I32 flags|OP *first|OP *other
+
+Constructs, checks, and returns a logical (flow control) op. I<type>
+is the opcode. I<flags> gives the eight bits of C<op_flags>, except
+that C<OPf_KIDS> will be set automatically, and, shifted up eight bits,
+the eight bits of C<op_private>, except that the bit with value 1 is
+automatically set. I<first> supplies the expression controlling the
+flow, and I<other> supplies the side (alternate) chain of ops; they are
+consumed by this function and become part of the constructed op tree.
+
+=cut
+*/
OP *
Perl_newLOGOP(pTHX_ I32 type, I32 flags, OP *first, OP *other)
return o;
}
+/*
+=for apidoc Am|OP *|newCONDOP|I32 flags|OP *first|OP *trueop|OP *falseop
+
+Constructs, checks, and returns a conditional-expression (C<cond_expr>)
+op. I<flags> gives the eight bits of C<op_flags>, except that C<OPf_KIDS>
+will be set automatically, and, shifted up eight bits, the eight bits of
+C<op_private>, except that the bit with value 1 is automatically set.
+I<first> supplies the expression selecting between the two branches,
+and I<trueop> and I<falseop> supply the branches; they are consumed by
+this function and become part of the constructed op tree.
+
+=cut
+*/
+
OP *
Perl_newCONDOP(pTHX_ I32 flags, OP *first, OP *trueop, OP *falseop)
{
return o;
}
+/*
+=for apidoc Am|OP *|newRANGE|I32 flags|OP *left|OP *right
+
+Constructs and returns a C<range> op, with subordinate C<flip> and
+C<flop> ops. I<flags> gives the eight bits of C<op_flags> for the
+C<flip> op and, shifted up eight bits, the eight bits of C<op_private>
+for both the C<flip> and C<range> ops, except that the bit with value
+1 is automatically set. I<left> and I<right> supply the expressions
+controlling the endpoints of the range; they are consumed by this function
+and become part of the constructed op tree.
+
+=cut
+*/
+
OP *
Perl_newRANGE(pTHX_ I32 flags, OP *left, OP *right)
{
return o;
}
+/*
+=for apidoc Am|OP *|newLOOPOP|I32 flags|I32 debuggable|OP *expr|OP *block
+
+Constructs, checks, and returns an op tree expressing a loop. This is
+only a loop in the control flow through the op tree; it does not have
+the heavyweight loop structure that allows exiting the loop by C<last>
+and suchlike. I<flags> gives the eight bits of C<op_flags> for the
+top-level op, except that some bits will be set automatically as required.
+I<expr> supplies the expression controlling loop iteration, and I<block>
+supplies the body of the loop; they are consumed by this function and
+become part of the constructed op tree. I<debuggable> is currently
+unused and should always be 1.
+
+=cut
+*/
+
OP *
Perl_newLOOPOP(pTHX_ I32 flags, I32 debuggable, OP *expr, OP *block)
{
return o;
}
+/*
+=for apidoc Am|OP *|newWHILEOP|I32 flags|I32 debuggable|LOOP *loop|I32 whileline|OP *expr|OP *block|OP *cont|I32 has_my
+
+Constructs, checks, and returns an op tree expressing a C<while> loop.
+This is a heavyweight loop, with structure that allows exiting the loop
+by C<last> and suchlike.
+
+I<loop> is an optional preconstructed C<enterloop> op to use in the
+loop; if it is null then a suitable op will be constructed automatically.
+I<expr> supplies the loop's controlling expression. I<block> supplies the
+main body of the loop, and I<cont> optionally supplies a C<continue> block
+that operates as a second half of the body. All of these optree inputs
+are consumed by this function and become part of the constructed op tree.
+
+I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
+op and, shifted up eight bits, the eight bits of C<op_private> for
+the C<leaveloop> op, except that (in both cases) some bits will be set
+automatically. I<debuggable> is currently unused and should always be 1.
+I<whileline> is the line number that should be attributed to the loop's
+controlling expression. I<has_my> can be supplied as true to force the
+loop body to be enclosed in its own scope.
+
+=cut
+*/
+
OP *
Perl_newWHILEOP(pTHX_ I32 flags, I32 debuggable, LOOP *loop, I32
whileline, OP *expr, OP *block, OP *cont, I32 has_my)
return o;
}
+/*
+=for apidoc Am|OP *|newFOROP|I32 flags|char *label|line_t forline|OP *sv|OP *expr|OP *block|OP *cont
+
+Constructs, checks, and returns an op tree expressing a C<foreach>
+loop (iteration through a list of values). This is a heavyweight loop,
+with structure that allows exiting the loop by C<last> and suchlike.
+
+I<sv> optionally supplies the variable that will be aliased to each
+item in turn; if null, it defaults to C<$_> (either lexical or global).
+I<expr> supplies the list of values to iterate over. I<block> supplies
+the main body of the loop, and I<cont> optionally supplies a C<continue>
+block that operates as a second half of the body. All of these optree
+inputs are consumed by this function and become part of the constructed
+op tree.
+
+I<flags> gives the eight bits of C<op_flags> for the C<leaveloop>
+op and, shifted up eight bits, the eight bits of C<op_private> for
+the C<leaveloop> op, except that (in both cases) some bits will be set
+automatically. I<forline> is the line number that should be attributed
+to the loop's list expression. If I<label> is non-null, it supplies
+the name of a label to attach to the state op at the start of the loop;
+this function takes ownership of the memory pointed at by I<label>,
+and will free it.
+
+=cut
+*/
+
OP *
Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP *block, OP *cont)
{
return newSTATEOP(0, label, wop);
}
+/*
+=for apidoc Am|OP *|newLOOPEX|I32 type|OP *label
+
+Constructs, checks, and returns a loop-exiting op (such as C<goto>
+or C<last>). I<type> is the opcode. I<label> supplies the parameter
+determining the target of the op; it is consumed by this function and
+become part of the constructed op tree.
+
+=cut
+*/
+
OP*
Perl_newLOOPEX(pTHX_ I32 type, OP *label)
{
&& looks_like_bool(cLOGOPo->op_first->op_sibling));
case OP_NULL:
+ case OP_SCALAR:
return (
o->op_flags & OPf_KIDS
&& looks_like_bool(cUNOPo->op_first));
- case OP_SCALAR:
- return looks_like_bool(cUNOPo->op_first);
-
-
case OP_ENTERSUB:
case OP_NOT: case OP_XOR:
}
}
+/*
+=for apidoc Am|OP *|newGIVENOP|OP *cond|OP *block|PADOFFSET defsv_off
+
+Constructs, checks, and returns an op tree expressing a C<given> block.
+I<cond> supplies the expression that will be locally assigned to a lexical
+variable, and I<block> supplies the body of the C<given> construct; they
+are consumed by this function and become part of the constructed op tree.
+I<defsv_off> is the pad offset of the scalar lexical variable that will
+be affected.
+
+=cut
+*/
+
OP *
Perl_newGIVENOP(pTHX_ OP *cond, OP *block, PADOFFSET defsv_off)
{
defsv_off);
}
-/* If cond is null, this is a default {} block */
+/*
+=for apidoc Am|OP *|newWHENOP|OP *cond|OP *block
+
+Constructs, checks, and returns an op tree expressing a C<when> block.
+I<cond> supplies the test expression, and I<block> supplies the block
+that will be executed if the test evaluates to true; they are consumed
+by this function and become part of the constructed op tree. I<cond>
+will be interpreted DWIMically, often as a comparison against C<$_>,
+and may be null to generate a C<default> block.
+
+=cut
+*/
+
OP *
Perl_newWHENOP(pTHX_ OP *cond, OP *block)
{
}
/*
+=head1 Embedding Functions
+
=for apidoc cv_undef
Clear out all the active components of a CV. This can happen either
LEAVE;
}
SvPOK_off(MUTABLE_SV(cv)); /* forget prototype */
- CvGV(cv) = NULL;
+ CvGV_set(cv, NULL);
pad_undef(cv);
if (CvISXSUB(cv) && CvXSUB(cv)) {
CvXSUB(cv) = NULL;
}
- /* delete all flags except WEAKOUTSIDE */
- CvFLAGS(cv) &= CVf_WEAKOUTSIDE;
+ /* 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
dVAR;
GV *gv;
const char *ps;
- STRLEN ps_len;
+ STRLEN ps_len = 0; /* init it to avoid false uninit warning from icc */
register CV *cv = NULL;
SV *const_sv;
/* If the subroutine has no body, no attributes, and no builtin attributes
pad_fixup_inner_anons(CvPADLIST(cv), PL_compcv, cv);
if (PERLDB_INTER)/* Advice debugger on the new sub. */
++PL_sub_generation;
+ if (CvSTASH(cv))
+ sv_del_backref(MUTABLE_SV(CvSTASH(cv)), MUTABLE_SV(cv));
}
else {
/* Might have had built-in attributes applied -- propagate them. */
}
}
if (!CvGV(cv)) {
- CvGV(cv) = gv;
+ CvGV_set(cv, gv);
CvFILE_set_from_cop(cv, PL_curcop);
CvSTASH(cv) = PL_curstash;
+ if (PL_curstash)
+ Perl_sv_add_backref(aTHX_ MUTABLE_SV(PL_curstash), MUTABLE_SV(cv));
}
if (attrs) {
/* Need to do a C<use attributes $stash_of_cv,\&cv,@attrs>. */
if (has_name) {
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
- SV * const sv = newSV(0);
SV * const tmpstr = sv_newmortal();
GV * const db_postponed = gv_fetchpvs("DB::postponed",
GV_ADDMULTI, SVt_PVHV);
HV *hv;
-
- Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld",
- CopFILE(PL_curcop),
- (long)PL_subline, (long)CopLINE(PL_curcop));
+ SV * const sv = Perl_newSVpvf(aTHX_ "%s:%ld-%ld",
+ CopFILE(PL_curcop),
+ (long)PL_subline,
+ (long)CopLINE(PL_curcop));
gv_efullname3(tmpstr, gv, NULL);
(void)hv_store(GvHV(PL_DBsub), SvPVX_const(tmpstr),
SvCUR(tmpstr), sv, 0);
hv = GvHVn(db_postponed);
- if (HvFILL(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
+ if (HvTOTALKEYS(hv) > 0 && hv_exists(hv, SvPVX_const(tmpstr), SvCUR(tmpstr))) {
CV * const pcv = GvCV(db_postponed);
if (pcv) {
dSP;
mro_method_changed_in(GvSTASH(gv)); /* newXS */
}
}
- CvGV(cv) = gv;
+ if (!name)
+ CvANON_on(cv);
+ CvGV_set(cv, gv);
(void)gv_fetchfile(filename);
CvFILE(cv) = (char *)filename; /* NOTE: not copied, as it is expected to be
an external constant string */
if (name)
process_special_blocks(name, gv, cv);
- else
- CvANON_on(cv);
return cv;
}
}
cv = PL_compcv;
GvFORM(gv) = cv;
- CvGV(cv) = gv;
+ CvGV_set(cv, gv);
CvFILE_set_from_cop(cv, PL_curcop);
Perl_croak(aTHX_ "Constant is not %s reference", badtype);
return o;
}
- else if ((o->op_type == OP_RV2HV || o->op_type == OP_RV2SV) &&
- (PL_hints & HINT_STRICT_REFS) && SvPOK(kidsv)) {
- /* If this is an access to a stash, disable "strict refs", because
- * stashes aren't auto-vivified at compile-time (unless we store
- * symbols in them), and we don't want to produce a run-time
- * stricture error when auto-vivifying the stash. */
- const char *s = SvPV_nolen(kidsv);
- const STRLEN l = SvCUR(kidsv);
- if (l > 1 && s[l-1] == ':' && s[l-2] == ':')
- o->op_private &= ~HINT_STRICT_REFS;
- }
if ((o->op_private & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
const char *badthing;
switch (o->op_type) {
ENTER;
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
newSVpvs("File::Glob"), NULL, NULL, NULL);
- gv = gv_fetchpvs("CORE::GLOBAL::glob", 0, SVt_PVCV);
- glob_gv = gv_fetchpvs("File::Glob::csh_glob", 0, SVt_PVCV);
- GvCV(gv) = GvCV(glob_gv);
- SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
- GvIMPORTED_CV_on(gv);
+ 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);
+ SvREFCNT_inc_void(MUTABLE_SV(GvCV(gv)));
+ GvIMPORTED_CV_on(gv);
+ }
LEAVE;
}
#endif /* PERL_EXTERNAL_GLOB */
PERL_ARGS_ASSERT_CK_SHIFT;
if (!(o->op_flags & OPf_KIDS)) {
- OP *argop = newUNOP(OP_RV2AV, 0,
- scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
+ OP *argop;
+
+ if (!CvUNIQUE(PL_compcv)) {
+ o->op_flags |= OPf_SPECIAL;
+ return o;
+ }
+
+ argop = newUNOP(OP_RV2AV, 0, scalar(newGVOP(OP_GV, 0, PL_argvgv)));
#ifdef PERL_MAD
OP * const oldo = o;
o = newUNOP(type, 0, scalar(argop));
* peep() is called */
void
-Perl_peep(pTHX_ register OP *o)
+Perl_rpeep(pTHX_ register OP *o)
{
dVAR;
register OP* oldop = NULL;
o->op_opt = 1;
PL_op = o;
switch (o->op_type) {
- case OP_NEXTSTATE:
case OP_DBSTATE:
PL_curcop = ((COP*)o); /* for warnings */
break;
+ case OP_NEXTSTATE:
+ PL_curcop = ((COP*)o); /* for warnings */
+
+ /* 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)) {
+ OP *nextop = o->op_next;
+ while (nextop && nextop->op_type == OP_NULL)
+ nextop = nextop->op_next;
+
+ if (nextop && (nextop->op_type == OP_NEXTSTATE)) {
+ COP *firstcop = (COP *)o;
+ COP *secondcop = (COP *)nextop;
+ /* We want the COP pointed to by o (and anything else) to
+ become the next COP down the line. */
+ cop_free(firstcop);
+
+ firstcop->op_next = secondcop->op_next;
+
+ /* Now steal all its pointers, and duplicate the other
+ data. */
+ firstcop->cop_line = secondcop->cop_line;
+#ifdef USE_ITHREADS
+ firstcop->cop_stashpv = secondcop->cop_stashpv;
+ firstcop->cop_file = secondcop->cop_file;
+#else
+ firstcop->cop_stash = secondcop->cop_stash;
+ firstcop->cop_filegv = secondcop->cop_filegv;
+#endif
+ firstcop->cop_hints = secondcop->cop_hints;
+ firstcop->cop_seq = secondcop->cop_seq;
+ firstcop->cop_warnings = secondcop->cop_warnings;
+ firstcop->cop_hints_hash = secondcop->cop_hints_hash;
+
+#ifdef USE_ITHREADS
+ secondcop->cop_stashpv = NULL;
+ secondcop->cop_file = NULL;
+#else
+ secondcop->cop_stash = NULL;
+ secondcop->cop_filegv = NULL;
+#endif
+ secondcop->cop_warnings = NULL;
+ secondcop->cop_hints_hash = NULL;
+
+ /* If we use op_null(), and hence leave an ex-COP, some
+ warnings are misreported. For example, the compile-time
+ error in 'use strict; no strict refs;' */
+ secondcop->op_type = OP_NULL;
+ secondcop->op_ppaddr = PL_ppaddr[OP_NULL];
+ }
+ }
+ break;
case OP_CONST:
if (cSVOPo->op_private & OPpCONST_STRICT)
PL_curcop = ((COP*)o);
}
/* XXX: We avoid setting op_seq here to prevent later calls
- to peep() from mistakenly concluding that optimisation
+ to rpeep() from mistakenly concluding that optimisation
has already occurred. This doesn't fix the real problem,
though (See 20010220.007). AMS 20010719 */
/* op_seq functionality is now replaced by op_opt */
sop = fop->op_sibling;
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
- peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
+ CALL_RPEEP(cLOGOP->op_other);
stitch_keys:
o->op_opt = 1;
case OP_ONCE:
while (cLOGOP->op_other->op_type == OP_NULL)
cLOGOP->op_other = cLOGOP->op_other->op_next;
- peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
+ CALL_RPEEP(cLOGOP->op_other);
break;
case OP_ENTERLOOP:
case OP_ENTERITER:
while (cLOOP->op_redoop->op_type == OP_NULL)
cLOOP->op_redoop = cLOOP->op_redoop->op_next;
- peep(cLOOP->op_redoop);
+ CALL_RPEEP(cLOOP->op_redoop);
while (cLOOP->op_nextop->op_type == OP_NULL)
cLOOP->op_nextop = cLOOP->op_nextop->op_next;
- peep(cLOOP->op_nextop);
+ CALL_RPEEP(cLOOP->op_nextop);
while (cLOOP->op_lastop->op_type == OP_NULL)
cLOOP->op_lastop = cLOOP->op_lastop->op_next;
- peep(cLOOP->op_lastop);
+ CALL_RPEEP(cLOOP->op_lastop);
break;
case OP_SUBST:
cPMOP->op_pmstashstartu.op_pmreplstart->op_type == OP_NULL)
cPMOP->op_pmstashstartu.op_pmreplstart
= cPMOP->op_pmstashstartu.op_pmreplstart->op_next;
- peep(cPMOP->op_pmstashstartu.op_pmreplstart);
+ CALL_RPEEP(cPMOP->op_pmstashstartu.op_pmreplstart);
break;
case OP_EXEC:
}
break;
}
+ case OP_RV2SV:
+ case OP_RV2AV:
+ case OP_RV2HV:
+ 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)
+ ) {
+ o->op_private |= OPpDEREFed;
+ }
case OP_SORT: {
/* will point to RV2AV or PADAV op on LHS/RHS of assign */
LEAVE;
}
+void
+Perl_peep(pTHX_ register OP *o)
+{
+ CALL_RPEEP(o);
+}
+
const char*
Perl_custom_op_name(pTHX_ const OP* o)
{
https://perl5.git.perl.org / perl5.git / blobdiff