/* op.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
case OP_CONST:
SvREFCNT_dec(cSVOPo->op_sv);
cSVOPo->op_sv = Nullsv;
+#ifdef USE_ITHREADS
+ /** Bug #15654
+ Even if op_clear does a pad_free for the target of the op,
+ pad_free doesn't actually remove the sv that exists in the bad
+ instead it lives on. This results in that it could be reused as
+ a target later on when the pad was reallocated.
+ **/
+ if(o->op_targ) {
+ pad_swipe(o->op_targ,1);
+ o->op_targ = 0;
+ }
+#endif
break;
case OP_GOTO:
case OP_NEXT:
case OP_RV2AV:
case OP_RV2HV:
- if (!type && cUNOPo->op_first->op_type != OP_GV)
- Perl_croak(aTHX_ "Can't localize through a reference");
if (type == OP_REFGEN && o->op_flags & OPf_PARENS) {
PL_modcount = RETURN_UNLIMITED_NUMBER;
return o; /* Treat \(@foo) like ordinary list. */
PL_modcount = RETURN_UNLIMITED_NUMBER;
break;
case OP_RV2SV:
- if (!type && cUNOPo->op_first->op_type != OP_GV)
- Perl_croak(aTHX_ "Can't localize through a reference");
ref(cUNOPo->op_first, o->op_type);
/* FALL THROUGH */
case OP_GV:
o->op_type = OP_LEAVE;
o->op_ppaddr = PL_ppaddr[OP_LEAVE];
}
- else {
- if (o->op_type == OP_LINESEQ) {
- OP *kid;
- o->op_type = OP_SCOPE;
- o->op_ppaddr = PL_ppaddr[OP_SCOPE];
- kid = ((LISTOP*)o)->op_first;
- if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
- op_null(kid);
- }
- else
- o = newLISTOP(OP_SCOPE, 0, o, Nullop);
+ else if (o->op_type == OP_LINESEQ) {
+ OP *kid;
+ o->op_type = OP_SCOPE;
+ o->op_ppaddr = PL_ppaddr[OP_SCOPE];
+ kid = ((LISTOP*)o)->op_first;
+ if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE)
+ op_null(kid);
}
+ else
+ o = newLISTOP(OP_SCOPE, 0, o, Nullop);
}
return o;
}
Perl_block_end(pTHX_ I32 floor, OP *seq)
{
int needblockscope = PL_hints & HINT_BLOCK_SCOPE;
- line_t copline = PL_copline;
OP* retval = scalarseq(seq);
/* If there were syntax errors, don't try to close a block */
if (PL_yynerrs) return retval;
- if (!seq) {
- /* scalarseq() gave us an OP_STUB */
- retval->op_flags |= OPf_PARENS;
- /* there should be a nextstate in every block */
- retval = newSTATEOP(0, Nullch, retval);
- PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
- }
LEAVE_SCOPE(floor);
PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
if (needblockscope)
CALL_PEEP(PL_eval_start);
}
else {
- if (!o)
+ if (o->op_type == OP_STUB)
return;
PL_main_root = scope(sawparens(scalarvoid(o)));
PL_curcop = &PL_compiling;
&& PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
{
char *s = PL_bufptr;
+ int sigil = 0;
- while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
+ /* some heuristics to detect a potential error */
+ while (*s && (strchr(", \t\n", *s)
+ || (strchr("@$%*", *s) && ++sigil) ))
s++;
-
- if (*s == ';' || *s == '=')
- Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
- "Parentheses missing around \"%s\" list",
- lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
+ if (sigil) {
+ while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s)
+ || strchr("@$%*, \t\n", *s)))
+ s++;
+
+ if (*s == ';' || *s == '=')
+ Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
+ "Parentheses missing around \"%s\" list",
+ lex ? (PL_in_my == KEY_our ? "our" : "my")
+ : "local");
+ }
}
}
if (lex)
op_free(o);
if (type == OP_RV2GV)
return newGVOP(OP_GV, 0, (GV*)sv);
- else {
- /* try to smush double to int, but don't smush -2.0 to -2 */
- if ((SvFLAGS(sv) & (SVf_IOK|SVf_NOK|SVf_POK)) == SVf_NOK &&
- type != OP_NEGATE)
- {
-#ifdef PERL_PRESERVE_IVUV
- /* Only bother to attempt to fold to IV if
- most operators will benefit */
- SvIV_please(sv);
-#endif
- }
- return newSVOP(OP_CONST, 0, sv);
- }
+ return newSVOP(OP_CONST, 0, sv);
nope:
return o;
if (curop->op_type == OP_GV) {
GV *gv = cGVOPx_gv(curop);
repl_has_vars = 1;
- if (strchr("&`'123456789+", *GvENAME(gv)))
+ if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
break;
}
else if (curop->op_type == OP_RV2CV)
}
void
-Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
+Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *idop, OP *arg)
{
OP *pack;
OP *imop;
OP *veop;
- if (id->op_type != OP_CONST)
+ if (idop->op_type != OP_CONST)
Perl_croak(aTHX_ "Module name must be constant");
veop = Nullop;
if (version->op_type != OP_CONST || !SvNIOKp(vesv))
Perl_croak(aTHX_ "Version number must be constant number");
- /* Make copy of id so we don't free it twice */
- pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
+ /* Make copy of idop so we don't free it twice */
+ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
/* Fake up a method call to VERSION */
meth = newSVpvn("VERSION",7);
/* Fake up an import/unimport */
if (arg && arg->op_type == OP_STUB)
imop = arg; /* no import on explicit () */
- else if (SvNIOKp(((SVOP*)id)->op_sv)) {
+ else if (SvNIOKp(((SVOP*)idop)->op_sv)) {
imop = Nullop; /* use 5.0; */
}
else {
SV *meth;
- /* Make copy of id so we don't free it twice */
- pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
+ /* Make copy of idop so we don't free it twice */
+ pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
/* Fake up a method call to import/unimport */
meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
Nullop,
append_elem(OP_LINESEQ,
append_elem(OP_LINESEQ,
- newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, id)),
+ newSTATEOP(0, Nullch, newUNOP(OP_REQUIRE, 0, idop)),
newSTATEOP(0, Nullch, veop)),
newSTATEOP(0, Nullch, imop) ));
}
{
line_t ocopline = PL_copline;
+ COP *ocurcop = PL_curcop;
int oexpect = PL_expect;
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
veop, modname, imop);
PL_expect = oexpect;
PL_copline = ocopline;
+ PL_curcop = ocurcop;
}
}
if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I')
goto done;
- if (strEQ(s, "BEGIN")) {
+ if (strEQ(s, "BEGIN") && !PL_error_count) {
I32 oldscope = PL_scopestack_ix;
ENTER;
SAVECOPFILE(&PL_compiling);
CopSTASH_set(PL_curcop,stash);
}
- cv = newXS(name, const_sv_xsub, __FILE__);
+ cv = newXS(name, const_sv_xsub, savepv(CopFILE(PL_curcop)));
CvXSUBANY(cv).any_ptr = sv;
CvCONST_on(cv);
sv_setpv((SV*)cv, ""); /* prototype is "" */
|| o->op_type == OP_BIT_AND
|| o->op_type == OP_BIT_XOR)
{
- OPCODE typfirst = cBINOPo->op_first->op_type;
- OPCODE typlast = cBINOPo->op_first->op_sibling->op_type;
- if (OP_IS_NUMCOMPARE(typfirst) || OP_IS_NUMCOMPARE(typlast))
+ OP * left = cBINOPo->op_first;
+ OP * right = left->op_sibling;
+ if ((OP_IS_NUMCOMPARE(left->op_type) &&
+ (left->op_flags & OPf_PARENS) == 0) ||
+ (OP_IS_NUMCOMPARE(right->op_type) &&
+ (right->op_flags & OPf_PARENS) == 0))
if (ckWARN(WARN_PRECEDENCE))
Perl_warner(aTHX_ packWARN(WARN_PRECEDENCE),
"Possible precedence problem on bitwise %c operator",
if (o->op_flags & OPf_KIDS) {
if (cLISTOPo->op_first->op_type == OP_STUB) {
op_free(o);
- o = newUNOP(type, OPf_SPECIAL,
- newGVOP(OP_GV, 0, gv_fetchpv("main::ARGV", TRUE, SVt_PVAV)));
+ o = newUNOP(type, OPf_SPECIAL, newGVOP(OP_GV, 0, PL_argvgv));
}
return ck_fun(o);
}
o->op_flags &= ~OPf_KIDS;
op_null(o);
}
- else if (kid->op_type == OP_LINESEQ) {
+ else if (kid->op_type == OP_LINESEQ || kid->op_type == OP_STUB) {
LOGOP *enter;
- kid->op_next = o->op_next;
cUNOPo->op_first = 0;
op_free(o);
op_free(o);
o = newop;
}
+ else {
+ if ((PL_hints & HINT_FILETEST_ACCESS) &&
+ OP_IS_FILETEST_ACCESS(o))
+ o->op_private |= OPpFT_ACCESS;
+ }
}
else {
op_free(o);
if (type == OP_FTTTY)
- o = newGVOP(type, OPf_REF, gv_fetchpv("main::STDIN", TRUE,
- SVt_PVIO));
+ o = newGVOP(type, OPf_REF, PL_stdingv);
else
o = newUNOP(type, 0, newDEFSVOP());
}
else if (kid->op_type == OP_AELEM
|| kid->op_type == OP_HELEM)
{
- name = "__ANONIO__";
- len = 10;
- mod(kid,type);
+ OP *op;
+
+ name = 0;
+ if ((op = ((BINOP*)kid)->op_first)) {
+ SV *tmpstr = Nullsv;
+ char *a =
+ kid->op_type == OP_AELEM ?
+ "[]" : "{}";
+ if (((op->op_type == OP_RV2AV) ||
+ (op->op_type == OP_RV2HV)) &&
+ (op = ((UNOP*)op)->op_first) &&
+ (op->op_type == OP_GV)) {
+ /* packagevar $a[] or $h{} */
+ GV *gv = cGVOPx_gv(op);
+ if (gv)
+ tmpstr =
+ Perl_newSVpvf(aTHX_
+ "%s%c...%c",
+ GvNAME(gv),
+ a[0], a[1]);
+ }
+ else if (op->op_type == OP_PADAV
+ || op->op_type == OP_PADHV) {
+ /* lexicalvar $a[] or $h{} */
+ char *padname =
+ PAD_COMPNAME_PV(op->op_targ);
+ if (padname)
+ tmpstr =
+ Perl_newSVpvf(aTHX_
+ "%s%c...%c",
+ padname + 1,
+ a[0], a[1]);
+
+ }
+ if (tmpstr) {
+ name = savepv(SvPVX(tmpstr));
+ len = strlen(name);
+ sv_2mortal(tmpstr);
+ }
+ }
+ if (!name) {
+ name = "__ANONIO__";
+ len = 10;
+ }
+ mod(kid, type);
}
if (name) {
SV *namesv;
}
if (o->op_type == OP_BACKTICK)
return o;
+ {
+ /* In case of three-arg dup open remove strictness
+ * from the last arg if it is a bareword. */
+ OP *first = cLISTOPx(o)->op_first; /* The pushmark. */
+ OP *last = cLISTOPx(o)->op_last; /* The bareword. */
+ OP *oa;
+ char *mode;
+
+ if ((last->op_type == OP_CONST) && /* The bareword. */
+ (last->op_private & OPpCONST_BARE) &&
+ (last->op_private & OPpCONST_STRICT) &&
+ (oa = first->op_sibling) && /* The fh. */
+ (oa = oa->op_sibling) && /* The mode. */
+ SvPOK(((SVOP*)oa)->op_sv) &&
+ (mode = SvPVX(((SVOP*)oa)->op_sv)) &&
+ mode[0] == '>' && mode[1] == '&' && /* A dup open. */
+ (last == oa->op_sibling)) /* The bareword. */
+ last->op_private &= ~OPpCONST_STRICT;
+ }
return ck_fun(o);
}
op_free(o);
argop = newUNOP(OP_RV2AV, 0,
- scalar(newGVOP(OP_GV, 0, !CvUNIQUE(PL_compcv) ?
- PL_defgv : gv_fetchpv("ARGV", TRUE, SVt_PVAV))));
+ scalar(newGVOP(OP_GV, 0, CvUNIQUE(PL_compcv) ? PL_argvgv : PL_defgv)));
return newUNOP(type, 0, scalar(argop));
}
return scalar(modkids(ck_fun(o), type));
I32 contextclass = 0;
char *e = 0;
STRLEN n_a;
+ bool delete=0;
o->op_private |= OPpENTERSUB_HASTARG;
for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
cv = GvCVu(gv);
if (!cv)
tmpop->op_private |= OPpEARLY_CV;
- else if (SvPOK(cv)) {
- namegv = CvANON(cv) ? gv : CvGV(cv);
- proto = SvPV((SV*)cv, n_a);
+ else {
+ if (SvPOK(cv)) {
+ namegv = CvANON(cv) ? gv : CvGV(cv);
+ proto = SvPV((SV*)cv, n_a);
+ }
+ if (CvASSERTION(cv)) {
+ if (PL_hints & HINT_ASSERTING) {
+ if (PERLDB_ASSERTION && PL_curstash != PL_debstash)
+ o->op_private |= OPpENTERSUB_DB;
+ }
+ else {
+ delete=1;
+ if (ckWARN(WARN_ASSERTIONS) && !(PL_hints & HINT_ASSERTIONSSEEN)) {
+ Perl_warner(aTHX_ packWARN(WARN_ASSERTIONS),
+ "Impossible to activate assertion call");
+ }
+ }
+ }
}
}
}
if (proto && !optional &&
(*proto && *proto != '@' && *proto != '%' && *proto != ';'))
return too_few_arguments(o, gv_ename(namegv));
+ if(delete) {
+ op_free(o);
+ o=newSVOP(OP_CONST, 0, newSViv(0));
+ }
return o;
}
for (; o; o = o->op_next) {
if (o->op_seq)
break;
- if (!PL_op_seqmax)
- PL_op_seqmax++;
+ /* The special value -1 is used by the B::C compiler backend to indicate
+ * that an op is statically defined and should not be freed */
+ if (!PL_op_seqmax || PL_op_seqmax == (U16)-1)
+ PL_op_seqmax = 1;
PL_op = o;
switch (o->op_type) {
case OP_SETSTATE:
if (cSVOPo->op_private & OPpCONST_STRICT)
no_bareword_allowed(o);
#ifdef USE_ITHREADS
+ case OP_METHOD_NAMED:
/* Relocate sv to the pad for thread safety.
* Despite being a "constant", the SV is written to,
* for reference counts, sv_upgrade() etc. */
if (cSVOP->op_sv) {
PADOFFSET ix = pad_alloc(OP_CONST, SVs_PADTMP);
- if (SvPADTMP(cSVOPo->op_sv)) {
+ if (o->op_type == OP_CONST && SvPADTMP(cSVOPo->op_sv)) {
/* If op_sv is already a PADTMP then it is being used by
* some pad, so make a copy. */
sv_setsv(PAD_SVl(ix),cSVOPo->op_sv);
https://perl5.git.perl.org / perl5.git / blobdiff