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 = 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_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)
{
|| (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)
|| 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) = ...
&& 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 (!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);
/* 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) {
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);
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));
container of the rep_op var */
STATIC OP *
S_opt_scalarhv(pTHX_ OP *rep_op) {
+ dVAR;
UNOP *unop;
PERL_ARGS_ASSERT_OPT_SCALARHV;
){
OP * nop = o;
OP * lop = o;
- if (!(nop->op_flags && OPf_WANT_VOID)) {
+ if (!((nop->op_flags & OPf_WANT) == OPf_WANT_VOID)) {
while (nop && nop->op_next) {
switch (nop->op_next->op_type) {
case OP_NOT:
}
}
}
- if (lop->op_flags && OPf_WANT_VOID) {
+ 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))
}
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 */
https://perl5.git.perl.org / perl5.git / blobdiff