+#line 2 "op.c"
/* op.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
/* "register" allocation */
PADOFFSET
-Perl_allocmy(pTHX_ const char *const name)
+Perl_allocmy(pTHX_ const char *const name, const STRLEN len, const U32 flags)
{
dVAR;
PADOFFSET off;
PERL_ARGS_ASSERT_ALLOCMY;
+ if (flags)
+ Perl_croak(aTHX_ "panic: allocmy illegal flag bits 0x%" UVxf,
+ (UV)flags);
+
+ /* Until we're using the length for real, cross check that we're being
+ told the truth. */
+ assert(strlen(name) == len);
+
/* complain about "my $<special_var>" etc etc */
- if (*name &&
+ if (len &&
!(is_our ||
isALPHA(name[1]) ||
(USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
- (name[1] == '_' && (*name == '$' || name[2]))))
+ (name[1] == '_' && (*name == '$' || len > 2))))
{
/* name[2] is true if strlen(name) > 2 */
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
- yyerror(Perl_form(aTHX_ "Can't use global %c^%c%s in \"%s\"",
- name[0], toCTRL(name[1]), name + 2,
+ yyerror(Perl_form(aTHX_ "Can't use global %c^%c%.*s in \"%s\"",
+ name[0], toCTRL(name[1]), (int)(len - 2), name + 2,
PL_parser->in_my == KEY_state ? "state" : "my"));
} else {
- yyerror(Perl_form(aTHX_ "Can't use global %s in \"%s\"",name,
+ yyerror(Perl_form(aTHX_ "Can't use global %.*s in \"%s\"", (int) len, name,
PL_parser->in_my == KEY_state ? "state" : "my"));
}
}
- /* check for duplicate declaration */
- pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
-
/* allocate a spare slot and store the name in that slot */
- off = pad_add_name(name,
+ off = pad_add_name(name, len,
+ is_our ? padadd_OUR :
+ PL_parser->in_my == KEY_state ? padadd_STATE : 0,
PL_parser->in_my_stash,
(is_our
/* $_ is always in main::, even with our */
? (PL_curstash && !strEQ(name,"$_") ? PL_curstash : PL_defstash)
: NULL
- ),
- 0, /* not fake */
- PL_parser->in_my == KEY_state
+ )
);
/* anon sub prototypes contains state vars should always be cloned,
* otherwise the state var would be shared between anon subs */
o->op_targ = 0;
goto retry;
}
+ case OP_ENTERTRY:
case OP_ENTEREVAL: /* Was holding hints. */
o->op_targ = 0;
break;
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
+#endif
+ ? cGVOPo_gv : NULL;
+ /* It's possible during global destruction that the GV is freed
+ before the optree. Whilst the SvREFCNT_inc is happy to bump from
+ 0 to 1 on a freed SV, the corresponding SvREFCNT_dec from 1 to 0
+ will trigger an assertion failure, because the entry to sv_clear
+ checks that the scalar is not already freed. A check of for
+ !SvIS_FREED(gv) turns out to be invalid, because during global
+ destruction the reference count can be forced down to zero
+ (with SVf_BREAK set). In which case raising to 1 and then
+ dropping to 0 triggers cleanup before it should happen. I
+ *think* that this might actually be a general, systematic,
+ weakness of the whole idea of SVf_BREAK, in that code *is*
+ allowed to raise and lower references during global destruction,
+ so any *valid* code that happens to do this during global
+ destruction might well trigger premature cleanup. */
+ bool still_valid = gv && SvREFCNT(gv);
+
+ if (still_valid)
+ SvREFCNT_inc_simple_void(gv);
#ifdef USE_ITHREADS
if (cPADOPo->op_padix > 0) {
/* No GvIN_PAD_off(cGVOPo_gv) here, because other references
SvREFCNT_dec(cSVOPo->op_sv);
cSVOPo->op_sv = NULL;
#endif
+ if (still_valid) {
+ int try_downgrade = SvREFCNT(gv) == 2;
+ SvREFCNT_dec(gv);
+ if (try_downgrade)
+ gv_try_downgrade(gv);
+ }
}
break;
case OP_METHOD_NAMED:
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_RETURN || o->op_type == OP_REQUIRE || o->op_type == OP_LEAVEWHEN)
{
return o;
}
useless = OP_DESC(o);
break;
+ case OP_SPLIT:
+ kid = cLISTOPo->op_first;
+ if (kid && kid->op_type == OP_PUSHRE
+#ifdef USE_ITHREADS
+ && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetoff)
+#else
+ && !((PMOP*)kid)->op_pmreplrootu.op_pmtargetgv)
+#endif
+ useless = OP_DESC(o);
+ break;
+
case OP_NOT:
kid = cUNOPo->op_first;
if (kid->op_type != OP_MATCH && kid->op_type != OP_SUBST &&
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_ENTEREVAL:
scalarkids(o);
break;
- case OP_REQUIRE:
- /* all requires must return a boolean value */
- o->op_flags &= ~OPf_WANT;
- /* FALL THROUGH */
case OP_SCALAR:
return scalar(o);
}
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;
- case OP_REQUIRE:
- /* all requires must return a boolean value */
- o->op_flags &= ~OPf_WANT;
- return scalar(o);
+ kid = cLISTOPo->op_first;
+ goto do_kids;
}
return o;
}
case OP_DBSTATE:
PL_modcount = RETURN_UNLIMITED_NUMBER;
break;
+ 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;
/* FALL THROUGH */
case OP_GV:
- case OP_AV2ARYLEN:
PL_hints |= HINT_BLOCK_SCOPE;
case OP_SASSIGN:
case OP_ANDASSIGN:
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)
{
dVAR;
- const PADOFFSET offset = pad_findmy("$_");
+ const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
}
dVAR;
LISTOP *listop;
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LISTOP);
+
NewOp(1101, listop, 1, LISTOP);
listop->op_type = (OPCODE)type;
{
dVAR;
OP *o;
+
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
+
NewOp(1101, o, 1, OP);
o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
dVAR;
UNOP *unop;
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_UNOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_BASEOP_OR_UNOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP
+ || type == OP_SASSIGN
+ || type == OP_ENTERTRY
+ || type == OP_NULL );
+
if (!first)
first = newOP(OP_STUB, 0);
if (PL_opargs[type] & OA_MARK)
{
dVAR;
BINOP *binop;
+
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_BINOP
+ || type == OP_SASSIGN || type == OP_NULL );
+
NewOp(1101, binop, 1, BINOP);
if (!first)
dVAR;
PMOP *pmop;
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PMOP);
+
NewOp(1101, pmop, 1, PMOP);
pmop->op_type = (OPCODE)type;
pmop->op_ppaddr = PL_ppaddr[type];
PERL_ARGS_ASSERT_NEWSVOP;
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
+
NewOp(1101, svop, 1, SVOP);
svop->op_type = (OPCODE)type;
svop->op_ppaddr = PL_ppaddr[type];
PERL_ARGS_ASSERT_NEWPADOP;
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_SVOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_FILESTATOP);
+
NewOp(1101, padop, 1, PADOP);
padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
{
dVAR;
PVOP *pvop;
+
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_PVOP_OR_SVOP
+ || (PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
+
NewOp(1101, pvop, 1, PVOP);
pvop->op_type = (OPCODE)type;
pvop->op_ppaddr = PL_ppaddr[type];
|| left->op_type == OP_PADHV
|| left->op_type == OP_PADANY))
{
- maybe_common_vars = FALSE;
+ if (left->op_type == OP_PADSV) maybe_common_vars = FALSE;
if (left->op_private & OPpPAD_STATE) {
/* All single variable list context state assignments, hence
state ($a) = ...
if (type == OP_XOR) /* Not short circuit, but here by precedence. */
return newBINOP(type, flags, scalar(first), scalar(other));
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOGOP);
+
scalarboolean(first);
/* optimize AND and OR ops that have NOTs as children */
if (first->op_type == OP_NOT
&& o2->op_private & OPpLVAL_INTRO
&& !(o2->op_private & OPpPAD_STATE))
{
- Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
- "Deprecated use of my() in false conditional");
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
+ "Deprecated use of my() in false conditional");
}
*otherp = NULL;
if (expr) {
if (once && expr->op_type == OP_CONST && !SvTRUE(((SVOP*)expr)->op_sv))
return block; /* do {} while 0 does once */
- if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
+ if (expr->op_type == OP_READLINE
+ || expr->op_type == OP_READDIR
+ || expr->op_type == OP_GLOB
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
const OP * const k2 = k1 ? k1->op_sibling : NULL;
switch (expr->op_type) {
case OP_NULL:
- if (k2 && k2->op_type == OP_READLINE
+ if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
&& (k2->op_flags & OPf_STACKED)
&& ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
expr = newUNOP(OP_DEFINED, 0, expr);
PERL_UNUSED_ARG(debuggable);
if (expr) {
- if (expr->op_type == OP_READLINE || expr->op_type == OP_GLOB
+ if (expr->op_type == OP_READLINE
+ || expr->op_type == OP_READDIR
+ || expr->op_type == OP_GLOB
|| (expr->op_type == OP_NULL && expr->op_targ == OP_GLOB)) {
expr = newUNOP(OP_DEFINED, 0,
newASSIGNOP(0, newDEFSVOP(), 0, expr) );
const OP * const k2 = (k1) ? k1->op_sibling : NULL;
switch (expr->op_type) {
case OP_NULL:
- if (k2 && k2->op_type == OP_READLINE
+ if (k2 && (k2->op_type == OP_READLINE || k2->op_type == OP_READDIR)
&& (k2->op_flags & OPf_STACKED)
&& ((k1->op_flags & OPf_WANT) == OPf_WANT_SCALAR))
expr = newUNOP(OP_DEFINED, 0, expr);
}
}
else {
- const PADOFFSET offset = pad_findmy("$_");
+ const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS_isOUR(offset)) {
sv = newGVOP(OP_GV, 0, PL_defgv);
}
PERL_ARGS_ASSERT_NEWLOOPEX;
+ assert((PL_opargs[type] & OA_CLASS_MASK) == OA_LOOPEXOP);
+
if (type != OP_GOTO || label->op_type == OP_CONST) {
/* "last()" means "last" */
if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS))
&& 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:
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
)&& !attrs) {
if (CvFLAGS(PL_compcv)) {
/* might have had built-in attrs applied */
- CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
+ if (CvLVALUE(PL_compcv) && ! CvLVALUE(cv) && 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);
}
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
&& block->op_type != OP_NULL
#endif
) {
+ cv_flags_t existing_builtin_attrs = CvFLAGS(cv) & CVf_BUILTIN_ATTRS;
cv_undef(cv);
- CvFLAGS(cv) = CvFLAGS(PL_compcv);
+ CvFLAGS(cv) = CvFLAGS(PL_compcv) | existing_builtin_attrs;
if (!CvWEAKOUTSIDE(cv))
SvREFCNT_dec(CvOUTSIDE(cv));
CvOUTSIDE(cv) = CvOUTSIDE(PL_compcv);
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 (PL_madskills) {
if (strEQ(name, "import")) {
PL_formfeed = MUTABLE_SV(cv);
- Perl_warner(aTHX_ packWARN(WARN_VOID), "%lx\n", (long)cv);
+ /* diag_listed_as: SKIPME */
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "0x%"UVxf"\n", PTR2UV(cv));
}
}
GvCVGEN(gv) = 0;
}
}
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);
return o;
}
else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)) {
- Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
"Using an array as a reference is deprecated");
}
return newUNOP(OP_RV2AV, 0, scalar(o));
return o;
}
else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)) {
- Perl_ck_warner(aTHX_ packWARN(WARN_DEPRECATED),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
"Using a hash as a reference is deprecated");
}
return newUNOP(OP_RV2HV, 0, scalar(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];
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) {
{
OP * const newop = newAVREF(newGVOP(OP_GV, 0,
gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
- Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
"Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
{
OP * const newop = newHVREF(newGVOP(OP_GV, 0,
gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
- Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
"Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]);
#ifdef PERL_MAD
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 */
if (o->op_flags & OPf_STACKED) {
OP* k;
o = ck_sort(o);
- kid = cLISTOPo->op_first->op_sibling;
- if (!cUNOPx(kid)->op_next)
- Perl_croak(aTHX_ "panic: ck_grep");
- for (k = cUNOPx(kid)->op_first; k; k = k->op_next) {
+ kid = cUNOPx(cLISTOPo->op_first->op_sibling)->op_first;
+ if (kid->op_type != OP_SCOPE && kid->op_type != OP_LEAVE)
+ return no_fh_allowed(o);
+ for (k = kid; k; k = k->op_next) {
kid = k;
}
NewOp(1101, gwop, 1, LOGOP);
gwop->op_flags |= OPf_KIDS;
gwop->op_other = LINKLIST(kid);
kid->op_next = (OP*)gwop;
- offset = pad_findmy("$_");
+ offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 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);
break; /* Globals via GV can be undef */
case OP_PADAV:
case OP_AASSIGN: /* Is this a good idea? */
- Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
"defined(@array) is deprecated");
- Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
"\t(Maybe you should just omit the defined()?)\n");
break;
case OP_RV2HV:
- /* This is needed for
- if (defined %stash::)
- to work. Do not break Tk.
- */
- break; /* Globals via GV can be undef */
case OP_PADHV:
- Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
"defined(%%hash) is deprecated");
- Perl_ck_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
+ Perl_ck_warner_d(aTHX_ packWARN(WARN_DEPRECATED),
"\t(Maybe you should just omit the defined()?)\n");
break;
default:
PERL_ARGS_ASSERT_CK_MATCH;
if (o->op_type != OP_QR && PL_compcv) {
- const PADOFFSET offset = pad_findmy("$_");
+ const PADOFFSET offset = Perl_pad_findmy(aTHX_ STR_WITH_LEN("$_"), 0);
if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS_isOUR(offset))) {
o->op_targ = offset;
o->op_private |= OPpTARGET_MY;
return newop;
}
- return ck_fun(o);
+ return scalar(ck_fun(o));
}
OP *
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));
o->op_private |= OPpENTERSUB_HASTARG;
for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
if (cvop->op_type == OP_RV2CV) {
- SVOP* tmpop;
o->op_private |= (cvop->op_private & OPpENTERSUB_AMPER);
op_null(cvop); /* disable rv2cv */
- tmpop = (SVOP*)((UNOP*)cvop)->op_first;
- if (tmpop->op_type == OP_GV && !(o->op_private & OPpENTERSUB_AMPER)) {
- GV *gv = cGVOPx_gv(tmpop);
- cv = GvCVu(gv);
- if (!cv)
- tmpop->op_private |= OPpEARLY_CV;
- else {
- if (SvPOK(cv)) {
- STRLEN len;
- namegv = CvANON(cv) ? gv : CvGV(cv);
- proto = SvPV(MUTABLE_SV(cv), len);
- proto_end = proto + len;
- }
+ if (!(o->op_private & OPpENTERSUB_AMPER)) {
+ SVOP *tmpop = (SVOP*)((UNOP*)cvop)->op_first;
+ GV *gv = NULL;
+ switch (tmpop->op_type) {
+ case OP_GV: {
+ gv = cGVOPx_gv(tmpop);
+ cv = GvCVu(gv);
+ if (!cv)
+ tmpop->op_private |= OPpEARLY_CV;
+ } break;
+ case OP_CONST: {
+ SV *sv = cSVOPx_sv(tmpop);
+ if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV)
+ cv = (CV*)SvRV(sv);
+ } break;
+ }
+ if (cv && SvPOK(cv)) {
+ STRLEN len;
+ namegv = gv && CvANON(cv) ? gv : CvGV(cv);
+ proto = SvPV(MUTABLE_SV(cv), len);
+ proto_end = proto + len;
}
}
}
return ck_fun(o);
}
+/* caller is supposed to assign the return to the
+ container of the rep_op var */
+STATIC OP *
+S_opt_scalarhv(pTHX_ OP *rep_op) {
+ dVAR;
+ UNOP *unop;
+
+ PERL_ARGS_ASSERT_OPT_SCALARHV;
+
+ NewOp(1101, unop, 1, UNOP);
+ unop->op_type = (OPCODE)OP_BOOLKEYS;
+ unop->op_ppaddr = PL_ppaddr[OP_BOOLKEYS];
+ unop->op_flags = (U8)(OPf_WANT_SCALAR | OPf_KIDS );
+ unop->op_private = (U8)(1 | ((OPf_WANT_SCALAR | OPf_KIDS) >> 8));
+ unop->op_first = rep_op;
+ unop->op_next = rep_op->op_next;
+ rep_op->op_next = (OP*)unop;
+ rep_op->op_flags|=(OPf_REF | OPf_MOD);
+ unop->op_sibling = rep_op->op_sibling;
+ rep_op->op_sibling = NULL;
+ /* unop->op_targ = pad_alloc(OP_BOOLKEYS, SVs_PADTMP); */
+ if (rep_op->op_type == OP_PADHV) {
+ rep_op->op_flags &= ~OPf_WANT_SCALAR;
+ rep_op->op_flags |= OPf_WANT_LIST;
+ }
+ return (OP*)unop;
+}
+
+/* Checks if o acts as an in-place operator on an array. oright points to the
+ * beginning of the right-hand side. Returns the left-hand side of the
+ * assignment if o acts in-place, or NULL otherwise. */
+
+STATIC OP *
+S_is_inplace_av(pTHX_ OP *o, OP *oright) {
+ OP *o2;
+ OP *oleft = NULL;
+
+ PERL_ARGS_ASSERT_IS_INPLACE_AV;
+
+ if (!oright ||
+ (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
+ || oright->op_next != o
+ || (oright->op_private & OPpLVAL_INTRO)
+ )
+ return NULL;
+
+ /* o2 follows the chain of op_nexts through the LHS of the
+ * assign (if any) to the aassign op itself */
+ o2 = o->op_next;
+ if (!o2 || o2->op_type != OP_NULL)
+ return NULL;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_PUSHMARK)
+ return NULL;
+ o2 = o2->op_next;
+ if (o2 && o2->op_type == OP_GV)
+ o2 = o2->op_next;
+ if (!o2
+ || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
+ || (o2->op_private & OPpLVAL_INTRO)
+ )
+ return NULL;
+ oleft = o2;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_NULL)
+ return NULL;
+ o2 = o2->op_next;
+ if (!o2 || o2->op_type != OP_AASSIGN
+ || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
+ return NULL;
+
+ /* check that the sort is the first arg on RHS of assign */
+
+ o2 = cUNOPx(o2)->op_first;
+ if (!o2 || o2->op_type != OP_NULL)
+ return NULL;
+ o2 = cUNOPx(o2)->op_first;
+ if (!o2 || o2->op_type != OP_PUSHMARK)
+ return NULL;
+ if (o2->op_sibling != o)
+ return NULL;
+
+ /* check the array is the same on both sides */
+ if (oleft->op_type == OP_RV2AV) {
+ if (oright->op_type != OP_RV2AV
+ || !cUNOPx(oright)->op_first
+ || cUNOPx(oright)->op_first->op_type != OP_GV
+ || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
+ cGVOPx_gv(cUNOPx(oright)->op_first)
+ )
+ return NULL;
+ }
+ else if (oright->op_type != OP_PADAV
+ || oright->op_targ != oleft->op_targ
+ )
+ return NULL;
+
+ return oleft;
+}
+
/* A peephole optimizer. We visit the ops in the order they're to execute.
* See the comments at the top of this file for more details about when
* peep() is called */
}
break;
+
+ {
+ OP *fop;
+ OP *sop;
+
+ case OP_NOT:
+ fop = cUNOP->op_first;
+ sop = NULL;
+ goto stitch_keys;
+ break;
- case OP_MAPWHILE:
- case OP_GREPWHILE:
- case OP_AND:
+ case OP_AND:
case OP_OR:
case OP_DOR:
+ fop = cLOGOP->op_first;
+ 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 */
+
+ stitch_keys:
+ o->op_opt = 1;
+ if ((fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
+ || ( sop &&
+ (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV)
+ )
+ ){
+ OP * nop = o;
+ OP * lop = o;
+ if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
+ while (nop && nop->op_next) {
+ switch (nop->op_next->op_type) {
+ case OP_NOT:
+ case OP_AND:
+ case OP_OR:
+ case OP_DOR:
+ lop = nop = nop->op_next;
+ break;
+ case OP_NULL:
+ nop = nop->op_next;
+ break;
+ default:
+ nop = NULL;
+ break;
+ }
+ }
+ }
+ if ((lop->op_flags & OPf_WANT) == OPf_WANT_VOID) {
+ if (fop->op_type == OP_PADHV || fop->op_type == OP_RV2HV)
+ cLOGOP->op_first = opt_scalarhv(fop);
+ if (sop && (sop->op_type == OP_PADHV || sop->op_type == OP_RV2HV))
+ cLOGOP->op_first->op_sibling = opt_scalarhv(sop);
+ }
+ }
+
+
+ break;
+ }
+
+ case OP_MAPWHILE:
+ case OP_GREPWHILE:
case OP_ANDASSIGN:
case OP_ORASSIGN:
case OP_DORASSIGN:
}
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 */
oright = cUNOPx(oright)->op_sibling;
}
- if (!oright ||
- (oright->op_type != OP_RV2AV && oright->op_type != OP_PADAV)
- || oright->op_next != o
- || (oright->op_private & OPpLVAL_INTRO)
- )
- break;
-
- /* o2 follows the chain of op_nexts through the LHS of the
- * assign (if any) to the aassign op itself */
- o2 = o->op_next;
- if (!o2 || o2->op_type != OP_NULL)
- break;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_PUSHMARK)
- break;
- o2 = o2->op_next;
- if (o2 && o2->op_type == OP_GV)
- o2 = o2->op_next;
- if (!o2
- || (o2->op_type != OP_PADAV && o2->op_type != OP_RV2AV)
- || (o2->op_private & OPpLVAL_INTRO)
- )
- break;
- oleft = o2;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_NULL)
- break;
- o2 = o2->op_next;
- if (!o2 || o2->op_type != OP_AASSIGN
- || (o2->op_flags & OPf_WANT) != OPf_WANT_VOID)
- break;
-
- /* check that the sort is the first arg on RHS of assign */
-
- o2 = cUNOPx(o2)->op_first;
- if (!o2 || o2->op_type != OP_NULL)
- break;
- o2 = cUNOPx(o2)->op_first;
- if (!o2 || o2->op_type != OP_PUSHMARK)
- break;
- if (o2->op_sibling != o)
- break;
-
- /* check the array is the same on both sides */
- if (oleft->op_type == OP_RV2AV) {
- if (oright->op_type != OP_RV2AV
- || !cUNOPx(oright)->op_first
- || cUNOPx(oright)->op_first->op_type != OP_GV
- || cGVOPx_gv(cUNOPx(oleft)->op_first) !=
- cGVOPx_gv(cUNOPx(oright)->op_first)
- )
- break;
- }
- else if (oright->op_type != OP_PADAV
- || oright->op_targ != oleft->op_targ
- )
+ oleft = is_inplace_av(o, oright);
+ if (!oleft)
break;
/* transfer MODishness etc from LHS arg to RHS arg */
case OP_REVERSE: {
OP *ourmark, *theirmark, *ourlast, *iter, *expushmark, *rv2av;
OP *gvop = NULL;
+ OP *oleft, *oright;
LISTOP *enter, *exlist;
+ /* @a = reverse @a */
+ if ((oright = cLISTOPo->op_first)
+ && (oright->op_type == OP_PUSHMARK)
+ && (oright = oright->op_sibling)
+ && (oleft = is_inplace_av(o, oright))) {
+ OP *o2;
+
+ /* transfer MODishness etc from LHS arg to RHS arg */
+ oright->op_flags = oleft->op_flags;
+ o->op_private |= OPpREVERSE_INPLACE;
+
+ /* excise push->gv->rv2av->null->aassign */
+ o2 = o->op_next->op_next;
+ op_null(o2); /* PUSHMARK */
+ o2 = o2->op_next;
+ if (o2->op_type == OP_GV) {
+ op_null(o2); /* GV */
+ o2 = o2->op_next;
+ }
+ op_null(o2); /* RV2AV or PADAV */
+ o2 = o2->op_next->op_next;
+ op_null(o2); /* AASSIGN */
+
+ o->op_next = o2->op_next;
+ break;
+ }
+
enter = (LISTOP *) o->op_next;
if (!enter)
break;
https://perl5.git.perl.org / perl5.git / blobdiff