backward in the execution order. (The bottom-up parser builds that
part of the execution order it knows about, but if you follow the "next"
links around, you'll find it's actually a closed loop through the
-top level node.
+top level node.)
Whenever the bottom-up parser gets to a node that supplies context to
its components, it invokes that portion of the top-down pass that applies
#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)
#if defined(PL_OP_SLAB_ALLOC)
/* check for duplicate declaration */
pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
- if (PL_parser->in_my_stash && *name != '$') {
- yyerror(Perl_form(aTHX_
- "Can't declare class for non-scalar %s in \"%s\"",
- name,
- is_our ? "our"
- : PL_parser->in_my == KEY_state ? "state" : "my"));
- }
-
/* allocate a spare slot and store the name in that slot */
off = pad_add_name(name,
}
}
+ /* Call the op_free hook if it has been set. Do it now so that it's called
+ * at the right time for refcounted ops, but still before all of the kids
+ * are freed. */
+ CALL_OPFREEHOOK(o);
+
if (o->op_flags & OPf_KIDS) {
register OP *kid, *nextkid;
for (kid = cUNOPo->op_first; kid; kid = nextkid) {
/* Register with debugger */
if (PERLDB_INTER) {
- CV * const cv
- = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0);
+ CV * const cv = get_cvs("DB::postponed", 0);
if (cv) {
dSP;
PUSHMARK(SP);
SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix));
PAD_SETSV(cPADOPo->op_padix, swash);
SvPADTMP_on(swash);
+ SvREADONLY_on(swash);
#else
cSVOPo->op_sv = swash;
#endif
SV *meth;
if (version->op_type != OP_CONST || !SvNIOKp(vesv))
- Perl_croak(aTHX_ "Version number must be constant number");
+ Perl_croak(aTHX_ "Version number must be a constant number");
/* Make copy of idop so we don't free it twice */
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
((LISTOP*)right)->op_last->op_type == OP_CONST)
{
SV *sv = ((SVOP*)((LISTOP*)right)->op_last)->op_sv;
- if (SvIVX(sv) == 0)
+ if (SvIOK(sv) && SvIVX(sv) == 0)
sv_setiv(sv, PL_modcount+1);
}
}
PL_eval_start = 0;
else {
if (!PL_madskills) { /* assignment to $[ is ignored when making a mad dump */
+ deprecate("assignment to $[");
op_free(o);
o = newSVOP(OP_CONST, 0, newSViv(CopARYBASE_get(&PL_compiling)));
o->op_private |= OPpCONST_ARYBASE;
return newop;
}
op_free(first);
+ if (other->op_type == OP_LEAVE)
+ other = newUNOP(OP_NULL, OPf_SPECIAL, other);
return other;
}
else {
op_free(first);
op_free(dead);
}
+ if (live->op_type == OP_LEAVE)
+ live = newUNOP(OP_NULL, OPf_SPECIAL, live);
return live;
}
NewOp(1101, logop, 1, LOGOP);
switch(o->op_type) {
case OP_OR:
+ case OP_DOR:
return looks_like_bool(cLOGOPo->op_first);
case OP_AND:
case OP_ENTERSUB:
case OP_NOT: case OP_XOR:
- /* Note that OP_DOR is not here */
case OP_EQ: case OP_NE: case OP_LT:
case OP_GT: case OP_LE: case OP_GE:
case OP_DEFINED: case OP_EXISTS:
case OP_MATCH: case OP_EOF:
+ case OP_FLOP:
+
return TRUE;
case OP_CONST:
|| cSVOPo->op_sv == &PL_sv_no)
return TRUE;
-
+ else
+ return FALSE;
+
/* FALL THROUGH */
default:
return FALSE;
cv = (!name || GvCVGEN(gv)) ? NULL : GvCV(gv);
-#ifdef GV_UNIQUE_CHECK
- if (cv && GvUNIQUE(gv) && SvREADONLY(cv)) {
- Perl_croak(aTHX_ "Can't define subroutine %s (GV is unique)", name);
- }
-#endif
-
if (!block || !ps || *ps || attrs
|| (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS)
#ifdef PERL_MAD
if (cv) {
const bool exists = CvROOT(cv) || CvXSUB(cv);
-#ifdef GV_UNIQUE_CHECK
- if (exists && GvUNIQUE(gv)) {
- Perl_croak(aTHX_ "Can't redefine unique subroutine %s", name);
- }
-#endif
-
/* if the subroutine doesn't exist and wasn't pre-declared
* with a prototype, assume it will be AUTOLOADed,
* skipping the prototype check
Creates a constant sub equivalent to Perl C<sub FOO () { 123 }> which is
eligible for inlining at compile-time.
+Passing NULL for SV creates a constant sub equivalent to C<sub BAR () {}>,
+which won't be called if used as a destructor, but will suppress the overhead
+of a call to C<AUTOLOAD>. (This form, however, isn't eligible for inlining at
+compile time.)
+
=cut
*/
? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
: gv_fetchpvs("STDOUT", GV_ADD|GV_NOTQUAL, SVt_PVFM);
-#ifdef GV_UNIQUE_CHECK
- if (GvUNIQUE(gv)) {
- Perl_croak(aTHX_ "Bad symbol for form (GV is unique)");
- }
-#endif
GvMULTI_on(gv);
if ((cv = GvFORM(gv))) {
if (ckWARN(WARN_REDEFINE)) {
const line_t oldline = CopLINE(PL_curcop);
if (PL_parser && PL_parser->copline != NOLINE)
CopLINE_set(PL_curcop, PL_parser->copline);
- Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
- o ? "Format %"SVf" redefined"
- : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv));
+ if (o) {
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ "Format %"SVf" redefined", SVfARG(cSVOPo->op_sv));
+ } else {
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
+ "Format STDOUT redefined");
+ }
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
Perl_croak(aTHX_ "%s argument is not a HASH or ARRAY element or slice",
OP_DESC(o));
}
+ if (kid->op_private & OPpLVAL_INTRO)
+ o->op_private |= OPpLVAL_INTRO;
op_null(kid);
}
return o;
/* establish postfix order */
enter->op_next = (OP*)enter;
+ CHECKOP(OP_ENTERTRY, enter);
+
o = prepend_elem(OP_LINESEQ, (OP*)enter, (OP*)kid);
o->op_type = OP_LEAVETRY;
o->op_ppaddr = PL_ppaddr[OP_LEAVETRY];
/* Make the CONST have a shared SV */
svp = cSVOPx_svp(((BINOP*)o)->op_last);
- if ((!SvFAKE(sv = *svp) || !SvREADONLY(sv)) && !IS_PADCONST(sv)) {
+ if (!SvFAKE(sv = *svp) || !SvREADONLY(sv)) {
key = SvPV_const(sv, keylen);
lexname = newSVpvn_share(key,
SvUTF8(sv) ? -(I32)keylen : (I32)keylen,
{
dVAR;
dXSARGS;
+ SV *const sv = MUTABLE_SV(XSANY.any_ptr);
if (items != 0) {
NOOP;
#if 0
+ /* diag_listed_as: SKIPME */
Perl_croak(aTHX_ "usage: %s::%s()",
HvNAME_get(GvSTASH(CvGV(cv))), GvNAME(CvGV(cv)));
#endif
}
+ if (!sv) {
+ XSRETURN(0);
+ }
EXTEND(sp, 1);
- ST(0) = MUTABLE_SV(XSANY.any_ptr);
+ ST(0) = sv;
XSRETURN(1);
}
projects / p5sagit/p5-mst-13.2.git / blobdiff