/* op.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
{
dVAR;
OP *kid;
- const char* useless = 0;
+ const char* useless = NULL;
SV* sv;
U8 want;
if ((type == OP_UNDEF || type == OP_REFGEN) &&
!(o->op_flags & OPf_STACKED)) {
o->op_type = OP_RV2CV; /* entersub => rv2cv */
+ /* The default is to set op_private to the number of children,
+ which for a UNOP such as RV2CV is always 1. And w're using
+ the bit for a flag in RV2CV, so we need it clear. */
+ o->op_private &= ~1;
o->op_ppaddr = PL_ppaddr[OP_RV2CV];
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
newop->op_next = (OP*)newop;
kid->op_sibling = (OP*)newop;
newop->op_private |= OPpLVAL_INTRO;
+ newop->op_private &= ~1;
break;
}
okid->op_targ = 0;
okid->op_ppaddr = PL_ppaddr[OP_RV2CV];
okid->op_private |= OPpLVAL_INTRO;
+ okid->op_private &= ~1;
break;
}
/* FALL THROUGH */
default:
nomod:
- /* grep, foreach, subcalls, refgen */
- if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN)
+ /* grep, foreach, subcalls, refgen, m//g */
+ if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN
+ || type == OP_MATCH)
break;
yyerror(Perl_form(aTHX_ "Can't modify %s in %s",
(o->op_type == OP_NULL && (o->op_flags & OPf_SPECIAL)
assert(cUNOPo->op_first->op_type == OP_NULL);
op_null(((LISTOP*)cUNOPo->op_first)->op_first); /* disable pushmark */
o->op_flags |= OPf_SPECIAL;
+ o->op_private &= ~1;
}
break;
dup_attrlist(attrs)));
/* Fake up a method call to import */
- meth = newSVpvn_share("import", 6, 0);
+ meth = newSVpvs_share("import");
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(arg)),
}
if (!(right->op_flags & OPf_STACKED) && ismatchop) {
right->op_flags |= OPf_STACKED;
- if (right->op_type != OP_MATCH &&
- ! (right->op_type == OP_TRANS &&
- right->op_private & OPpTRANS_IDENTICAL))
+ /* s/// and tr/// modify their arg.
+ * m//g also indirectly modifies the arg by setting pos magic on it */
+ if ( (right->op_type == OP_MATCH &&
+ (cPMOPx(right)->op_pmflags & PMf_GLOBAL))
+ || (right->op_type == OP_SUBST)
+ || (right->op_type == OP_TRANS &&
+ ! (right->op_private & OPpTRANS_IDENTICAL))
+ )
left = mod(left, right->op_type);
if (right->op_type == OP_TRANS)
o = newBINOP(OP_NULL, OPf_STACKED, scalar(left), right);
{
if (o->op_type == OP_LIST) {
OP *o2;
- o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
+ o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", GV_ADD, SVt_PV))),
o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
}
return o;
o->op_private |= OPpTRANS_TO_UTF;
if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
- SV* const listsv = newSVpvn("# comment\n",10);
- SV* transv = 0;
+ SV* const listsv = newSVpvs("# comment\n");
+ SV* transv = NULL;
const U8* tend = t + tlen;
const U8* rend = r + rlen;
STRLEN ulen;
UV nextmin = 0;
Newx(cp, 2*tlen, UV);
i = 0;
- transv = newSVpvn("",0);
+ transv = newSVpvs("");
while (t < tend) {
cp[2*i] = utf8n_to_uvuni(t, tend-t, &ulen, 0);
t += ulen;
else if (repl->op_type == OP_CONST)
curop = repl;
else {
- OP *lastop = 0;
+ OP *lastop = NULL;
for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
if (curop->op_type == OP_GV) {
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
/* Fake up a method call to VERSION */
- meth = newSVpvn_share("VERSION", 7, 0);
+ meth = newSVpvs_share("VERSION");
veop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(version)),
/* Fake up a method call to import/unimport */
meth = aver
- ? newSVpvn_share("import",6, 0) : newSVpvn_share("unimport", 8, 0);
+ ? newSVpvs_share("import") : newSVpvs_share("unimport");
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(arg)),
/* Fake up the BEGIN {}, which does its thing immediately. */
newATTRSUB(floor,
- newSVOP(OP_CONST, 0, newSVpvn_share("BEGIN", 5, 0)),
+ newSVOP(OP_CONST, 0, newSVpvs_share("BEGIN")),
Nullop,
Nullop,
append_elem(OP_LINESEQ,
GV *gv = Nullgv;
if (!force_builtin) {
- gv = gv_fetchpv("do", FALSE, SVt_PVCV);
+ gv = gv_fetchpv("do", 0, SVt_PVCV);
if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
gv = gvp ? *gvp : Nullgv;
CopSTASH_set(cop, PL_curstash);
if (PERLDB_LINE && PL_curstash != PL_debstash) {
- SV * const * const svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
+ SV * const * const svp = av_fetch(CopFILEAVx(PL_curcop), (I32)CopLINE(cop), FALSE);
if (svp && *svp != &PL_sv_undef ) {
(void)SvIOK_on(*svp);
SvIV_set(*svp, PTR2IV(cop));
{
dVAR;
OP *redo;
- OP *next = 0;
+ OP *next = NULL;
OP *listop;
OP *o;
U8 loopflags = 0;
if (SvPOK(cv))
Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (const SV *)cv);
else
- Perl_sv_catpv(aTHX_ msg, ": none");
- sv_catpv(msg, " vs ");
+ sv_catpvs(msg, ": none");
+ sv_catpvs(msg, " vs ");
if (p)
Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
else
- sv_catpv(msg, "none");
+ sv_catpvs(msg, "none");
Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
}
}
SV *
Perl_cv_const_sv(pTHX_ CV *cv)
{
- if (!cv || !CvCONST(cv))
- return Nullsv;
- return (SV*)CvXSUBANY(cv).any_ptr;
+ if (!cv)
+ return NULL;
+ if (!(SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM))
+ return NULL;
+ return CvCONST(cv) ? (SV*)CvXSUBANY(cv).any_ptr : NULL;
}
/* op_const_sv: examine an optree to determine whether it's in-lineable.
GV *gv;
const char *ps;
STRLEN ps_len;
- register CV *cv=0;
+ register CV *cv = NULL;
SV *const_sv;
- I32 gv_fetch_flags;
-
+ /* If the subroutine has no body, no attributes, and no builtin attributes
+ then it's just a sub declaration, and we may be able to get away with
+ storing with a placeholder scalar in the symbol table, rather than a
+ full GV and CV. If anything is present then it will take a full CV to
+ store it. */
+ const I32 gv_fetch_flags
+ = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
+ ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
const char * const name = o ? SvPVx_nolen_const(cSVOPo->op_sv) : Nullch;
if (proto) {
else
aname = Nullch;
- gv_fetch_flags = (block || attrs || (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS))
- ? GV_ADDMULTI : GV_ADDMULTI | GV_NOINIT;
gv = name ? gv_fetchsv(cSVOPo->op_sv, gv_fetch_flags, SVt_PVCV)
: gv_fetchpv(aname ? aname
: (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
register CV *cv;
GV * const gv = o
- ? gv_fetchsv(cSVOPo->op_sv, TRUE, SVt_PVFM)
- : gv_fetchpv("STDOUT", TRUE, SVt_PVFM);
+ ? gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM)
+ : gv_fetchpv("STDOUT", GV_ADD, SVt_PVFM);
#ifdef GV_UNIQUE_CHECK
if (GvUNIQUE(gv)) {
o = newUNOP(OP_ENTEREVAL, 0, newDEFSVOP());
}
o->op_targ = (PADOFFSET)PL_hints;
- if ((PL_hints & HINT_HH_FOR_EVAL) != 0 && GvHV(PL_hintgv))
- {
+ if ((PL_hints & HINT_LOCALIZE_HH) != 0 && GvHV(PL_hintgv)) {
/* Store a copy of %^H that pp_entereval can pick up */
OP *hhop = newSVOP(OP_CONST, 0, (SV*)newHVhv(GvHV(PL_hintgv)));
cUNOPo->op_first->op_sibling = hhop;
SVOP * const kid = (SVOP*)cUNOPo->op_first;
o->op_private |= (PL_hints & HINT_STRICT_REFS);
+ if (o->op_type == OP_RV2CV)
+ o->op_private &= ~1;
+
if (kid->op_type == OP_CONST) {
int iscv;
GV *gv;
Perl_croak(aTHX_ "Constant is not %s reference", badtype);
return o;
}
- if ((PL_hints & HINT_STRICT_REFS) && (kid->op_private & OPpCONST_BARE)) {
+ 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 = Nullch;
switch (o->op_type) {
case OP_RV2SV:
if (kid->op_type == OP_CONST && (kid->op_private & OPpCONST_BARE)) {
OP * const newop = newGVOP(type, OPf_REF,
- gv_fetchsv(kid->op_sv, TRUE, SVt_PVIO));
+ gv_fetchsv(kid->op_sv, GV_ADD, SVt_PVIO));
op_free(o);
o = newop;
return o;
(kid->op_private & OPpCONST_BARE))
{
OP * const newop = newAVREF(newGVOP(OP_GV, 0,
- gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVAV) ));
+ gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVAV) ));
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Array @%"SVf" missing the @ in argument %"IVdf" of %s()",
(kid->op_private & OPpCONST_BARE))
{
OP * const newop = newHVREF(newGVOP(OP_GV, 0,
- gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVHV) ));
+ gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVHV) ));
if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()",
(kid->op_private & OPpCONST_BARE))
{
OP * const newop = newGVOP(OP_GV, 0,
- gv_fetchsv(((SVOP*)kid)->op_sv, TRUE, SVt_PVIO) );
+ gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
if (!(o->op_private & 1) && /* if not unop */
kid == cLISTOPo->op_last)
cLISTOPo->op_last = newop;
if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
append_elem(OP_GLOB, o, newDEFSVOP());
- if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
+ if (!((gv = gv_fetchpv("glob", 0, SVt_PVCV))
&& GvCVu(gv) && GvIMPORTED_CV(gv)))
{
- gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
+ gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
}
#if !defined(PERL_EXTERNAL_GLOB)
GV *glob_gv;
ENTER;
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvn("File::Glob", 10), Nullsv, Nullsv, Nullsv);
- gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
- glob_gv = gv_fetchpv("File::Glob::csh_glob", FALSE, SVt_PVCV);
+ newSVpvs("File::Glob"), Nullsv, Nullsv, Nullsv);
+ gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
+ glob_gv = gv_fetchpv("File::Glob::csh_glob", 0, SVt_PVCV);
GvCV(gv) = GvCV(glob_gv);
(void)SvREFCNT_inc((SV*)GvCV(gv));
GvIMPORTED_CV_on(gv);
o = ck_listiob(o);
o->op_type = OP_PRINT;
cLISTOPo->op_last = cLISTOPo->op_last->op_sibling
- = newSVOP(OP_CONST, 0, newSVpvn("\n", 1));
+ = newSVOP(OP_CONST, 0, newSVpvs("\n"));
return o;
}
SvCUR_set(sv, SvCUR(sv) - 1);
}
}
- sv_catpvn(sv, ".pm", 3);
+ sv_catpvs(sv, ".pm");
SvFLAGS(sv) |= was_readonly;
}
}
if (!(o->op_flags & OPf_SPECIAL)) { /* Wasn't written as CORE::require */
/* handle override, if any */
- gv = gv_fetchpv("require", FALSE, SVt_PVCV);
+ gv = gv_fetchpv("require", 0, SVt_PVCV);
if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
GV * const * const gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
gv = gvp ? *gvp : Nullgv;
{
OP *firstkid;
+ if (o->op_type == OP_SORT && (PL_hints & HINT_LOCALIZE_HH) != 0)
+ {
+ HV *hinthv = GvHV(PL_hintgv);
+ if (hinthv) {
+ SV **svp = hv_fetch(hinthv, "sort", 4, 0);
+ if (svp) {
+ I32 sorthints = (I32)SvIV(*svp);
+ if ((sorthints & HINT_SORT_QUICKSORT) != 0)
+ o->op_private |= OPpSORT_QSORT;
+ if ((sorthints & HINT_SORT_STABLE) != 0)
+ o->op_private |= OPpSORT_STABLE;
+ }
+ }
+ }
+
if (o->op_type == OP_SORT && o->op_flags & OPf_STACKED)
simplify_sort(o);
firstkid = cLISTOPo->op_first->op_sibling; /* get past pushmark */
const char *gvname;
if (!(o->op_flags & OPf_STACKED))
return;
- GvMULTI_on(gv_fetchpv("a", TRUE, SVt_PV));
- GvMULTI_on(gv_fetchpv("b", TRUE, SVt_PV));
+ GvMULTI_on(gv_fetchpv("a", GV_ADD, SVt_PV));
+ GvMULTI_on(gv_fetchpv("b", GV_ADD, SVt_PV));
kid = kUNOP->op_first; /* get past null */
if (kid->op_type != OP_SCOPE)
return;
op_free(cLISTOPo->op_first);
cLISTOPo->op_first = kid;
if (!kid) {
- cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvn(" ", 1));
+ cLISTOPo->op_first = kid = newSVOP(OP_CONST, 0, newSVpvs(" "));
cLISTOPo->op_last = kid; /* There was only one element previously */
}
? cUNOPo : ((UNOP*)cUNOPo->op_first))->op_first;
OP *o2 = prev->op_sibling;
OP *cvop;
- char *proto = 0;
- CV *cv = 0;
- GV *namegv = 0;
+ char *proto = NULL;
+ CV *cv = NULL;
+ GV *namegv = NULL;
int optional = 0;
I32 arg = 0;
I32 contextclass = 0;
- char *e = 0;
+ char *e = NULL;
bool delete_op = 0;
o->op_private |= OPpENTERSUB_HASTARG;
{
GV * const gv = cGVOPx_gv(gvop);
OP * const sibling = o2->op_sibling;
- SV * const n = newSVpvn("",0);
+ SV * const n = newSVpvs("");
op_free(o2);
gv_fullname4(n, gv, "", FALSE);
o2 = newSVOP(OP_CONST, 0, n);
Perl_peep(pTHX_ register OP *o)
{
dVAR;
- register OP* oldop = 0;
+ register OP* oldop = NULL;
if (!o || o->op_opt)
return;
SvREADONLY_on(PAD_SVl(ix));
SvREFCNT_dec(cSVOPo->op_sv);
}
+ else if (o->op_type == OP_CONST
+ && cSVOPo->op_sv == &PL_sv_undef) {
+ /* PL_sv_undef is hack - it's unsafe to store it in the
+ AV that is the pad, because av_fetch treats values of
+ PL_sv_undef as a "free" AV entry and will merrily
+ replace them with a new SV, causing pad_alloc to think
+ that this pad slot is free. (When, clearly, it is not)
+ */
+ SvOK_off(PAD_SVl(ix));
+ SvPADTMP_on(PAD_SVl(ix));
+ SvREADONLY_on(PAD_SVl(ix));
+ }
else {
SvREFCNT_dec(PAD_SVl(ix));
SvPADTMP_on(cSVOPo->op_sv);
break;
}
+
+ case OP_SASSIGN: {
+ OP *rv2gv;
+ UNOP *refgen, *rv2cv;
+ LISTOP *exlist;
+
+ /* I do not understand this, but if o->op_opt isn't set to 1,
+ various tests in ext/B/t/bytecode.t fail with no readily
+ apparent cause. */
+
+ o->op_opt = 1;
+
+
+ if ((o->op_flags && OPf_WANT) != OPf_WANT_VOID)
+ break;
+
+ if ((o->op_private & ~OPpASSIGN_BACKWARDS) != 2)
+ break;
+
+ rv2gv = ((BINOP *)o)->op_last;
+ if (!rv2gv || rv2gv->op_type != OP_RV2GV)
+ break;
+
+ refgen = (UNOP *)((BINOP *)o)->op_first;
+
+ if (!refgen || refgen->op_type != OP_REFGEN)
+ break;
+
+ exlist = (LISTOP *)refgen->op_first;
+ if (!exlist || exlist->op_type != OP_NULL
+ || exlist->op_targ != OP_LIST)
+ break;
+
+ if (exlist->op_first->op_type != OP_PUSHMARK)
+ break;
+
+ rv2cv = (UNOP*)exlist->op_last;
+
+ if (rv2cv->op_type != OP_RV2CV)
+ break;
+
+ assert ((rv2gv->op_private & OPpDONT_INIT_GV) == 0);
+ assert ((o->op_private & OPpASSIGN_CV_TO_GV) == 0);
+ assert ((rv2cv->op_private & OPpMAY_RETURN_CONSTANT) == 0);
+
+ o->op_private |= OPpASSIGN_CV_TO_GV;
+ rv2gv->op_private |= OPpDONT_INIT_GV;
+ rv2cv->op_private |= OPpMAY_RETURN_CONSTANT;
+
+ break;
+ }
+
default:
o->op_opt = 1;
projects / p5sagit/p5-mst-13.2.git / blobdiff