-/* op.c
+ /* op.c
*
* Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
* 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others
Perl_allocmy(pTHX_ char *name)
{
PADOFFSET off;
+ const bool is_our = (PL_in_my == KEY_our);
/* complain about "my $_" etc etc */
- if (!(PL_in_my == KEY_our ||
+ if (*name &&
+ !(is_our ||
isALPHA(name[1]) ||
(USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
- (name[1] == '_' && (int)strlen(name) > 2)))
+ (name[1] == '_' && name[2])))
{
+ /* name[2] is true if strlen(name) > 2 */
if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
/* 1999-02-27 mjd@plover.com */
char *p;
p = strchr(name, '\0');
/* The next block assumes the buffer is at least 205 chars
long. At present, it's always at least 256 chars. */
- if (p-name > 200) {
- strcpy(name+200, "...");
- p = name+199;
+ if (p - name > 200) {
+#ifdef HAS_STRLCPY
+ strlcpy(name + 200, "...", 4);
+#else
+ strcpy(name + 200, "...");
+#endif
+ p = name + 199;
}
else {
p[1] = '\0';
yyerror(Perl_form(aTHX_ "Can't use global %s in \"my\"",name));
}
/* check for duplicate declaration */
- pad_check_dup(name,
- (bool)(PL_in_my == KEY_our),
- (PL_curstash ? PL_curstash : PL_defstash)
- );
+ pad_check_dup(name, is_our, (PL_curstash ? PL_curstash : PL_defstash));
if (PL_in_my_stash && *name != '$') {
yyerror(Perl_form(aTHX_
"Can't declare class for non-scalar %s in \"%s\"",
- name, PL_in_my == KEY_our ? "our" : "my"));
+ name, is_our ? "our" : "my"));
}
/* allocate a spare slot and store the name in that slot */
off = pad_add_name(name,
PL_in_my_stash,
- (PL_in_my == KEY_our
+ (is_our
? (PL_curstash ? PL_curstash : PL_defstash)
: NULL
),
if (svp)
MUTEX_UNLOCK(&thr->mutex);
else {
- SV *sv = NEWSV(0, 0);
+ SV *sv = newSV(0);
av_store(thr->threadsv, key, sv);
thr->threadsvp = AvARRAY(thr->threadsv);
MUTEX_UNLOCK(&thr->mutex);
clear_pmop:
{
HV * const pmstash = PmopSTASH(cPMOPo);
- if (pmstash && SvREFCNT(pmstash)) {
+ if (pmstash && !SvIS_FREED(pmstash)) {
PMOP *pmop = HvPMROOT(pmstash);
PMOP *lastpmop = NULL;
while (pmop) {
SvREFCNT_dec(cop->cop_io);
#endif
}
+ if (PL_curcop == cop)
+ PL_curcop = NULL;
}
void
OP *
Perl_linklist(pTHX_ OP *o)
{
+ OP *first;
if (o->op_next)
return o->op_next;
/* establish postfix order */
- if (cUNOPo->op_first) {
+ first = cUNOPo->op_first;
+ if (first) {
register OP *kid;
- o->op_next = LINKLIST(cUNOPo->op_first);
- for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
- if (kid->op_sibling)
+ o->op_next = LINKLIST(first);
+ kid = first;
+ for (;;) {
+ if (kid->op_sibling) {
kid->op_next = LINKLIST(kid->op_sibling);
- else
+ kid = kid->op_sibling;
+ } else {
kid->op_next = o;
+ break;
+ }
}
}
else
Perl_scalarvoid(pTHX_ OP *o)
{
OP *kid;
- const char* useless = 0;
+ const char* useless = NULL;
SV* sv;
U8 want;
built upon these three nroff macros being used in
void context. The pink camel has the details in
the script wrapman near page 319. */
- if (strnEQ(SvPVX_const(sv), "di", 2) ||
- strnEQ(SvPVX_const(sv), "ds", 2) ||
- strnEQ(SvPVX_const(sv), "ig", 2))
+ const char * const maybe_macro = SvPVX_const(sv);
+ if (strnEQ(maybe_macro, "di", 2) ||
+ strnEQ(maybe_macro, "ds", 2) ||
+ strnEQ(maybe_macro, "ig", 2))
useless = 0;
}
}
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;
}
}
OP *
-Perl_ref(pTHX_ OP *o, I32 type)
+Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref)
{
OP *kid;
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;
case OP_COND_EXPR:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
- ref(kid, type);
+ doref(kid, type, set_op_ref);
break;
case OP_RV2SV:
if (type == OP_DEFINED)
o->op_flags |= OPf_SPECIAL; /* don't create GV */
- ref(cUNOPo->op_first, o->op_type);
+ doref(cUNOPo->op_first, o->op_type, set_op_ref);
/* FALL THROUGH */
case OP_PADSV:
if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
}
break;
+#ifdef USE_5005THREADS
case OP_THREADSV:
o->op_flags |= OPf_MOD; /* XXX ??? */
break;
+#endif
case OP_RV2AV:
case OP_RV2HV:
- o->op_flags |= OPf_REF;
+ if (set_op_ref)
+ o->op_flags |= OPf_REF;
/* FALL THROUGH */
case OP_RV2GV:
if (type == OP_DEFINED)
o->op_flags |= OPf_SPECIAL; /* don't create GV */
- ref(cUNOPo->op_first, o->op_type);
+ doref(cUNOPo->op_first, o->op_type, set_op_ref);
break;
case OP_PADAV:
case OP_PADHV:
- o->op_flags |= OPf_REF;
+ if (set_op_ref)
+ o->op_flags |= OPf_REF;
break;
case OP_SCALAR:
case OP_NULL:
if (!(o->op_flags & OPf_KIDS))
break;
- ref(cBINOPo->op_first, type);
+ doref(cBINOPo->op_first, type, set_op_ref);
break;
case OP_AELEM:
case OP_HELEM:
- ref(cBINOPo->op_first, o->op_type);
+ doref(cBINOPo->op_first, o->op_type, set_op_ref);
if (type == OP_RV2SV || type == OP_RV2AV || type == OP_RV2HV) {
o->op_private |= (type == OP_RV2AV ? OPpDEREF_AV
: type == OP_RV2HV ? OPpDEREF_HV
case OP_SCOPE:
case OP_LEAVE:
+ set_op_ref = FALSE;
+ /* FALL THROUGH */
case OP_ENTER:
case OP_LIST:
if (!(o->op_flags & OPf_KIDS))
break;
- ref(cLISTOPo->op_last, type);
+ doref(cLISTOPo->op_last, type, set_op_ref);
break;
default:
break;
STATIC OP *
S_dup_attrlist(pTHX_ OP *o)
{
- OP *rop = Nullop;
+ OP *rop;
/* An attrlist is either a simple OP_CONST or an OP_LIST with kids,
* where the first kid is OP_PUSHMARK and the remaining ones
rop = newSVOP(OP_CONST, o->op_flags, SvREFCNT_inc_NN(cSVOPo->op_sv));
else {
assert((o->op_type == OP_LIST) && (o->op_flags & OPf_KIDS));
+ rop = Nullop;
for (o = cLISTOPo->op_first; o; o=o->op_sibling) {
if (o->op_type == OP_CONST)
rop = append_elem(OP_LIST, rop,
if (for_my) {
/* Don't force the C<use> if we don't need it. */
- SV * const * const svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
- sizeof(ATTRSMODULE_PM)-1, 0);
+ SV * const * const svp = hv_fetchs(GvHVn(PL_incgv), ATTRSMODULE_PM, FALSE);
if (svp && *svp != &PL_sv_undef)
; /* already in %INC */
else
Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
- newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
- Nullsv);
+ newSVpvs(ATTRSMODULE), NULL);
}
else {
Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
- newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
- Nullsv,
+ newSVpvs(ATTRSMODULE),
+ NULL,
prepend_elem(OP_LIST,
newSVOP(OP_CONST, 0, stashsv),
prepend_elem(OP_LIST,
apply_attrs(stash, PAD_SV(target->op_targ), attrs, TRUE);
/* Need package name for method call. */
- pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
+ pack = newSVOP(OP_CONST, 0, newSVpvs(ATTRSMODULE));
/* Build up the real arg-list. */
if (stash)
dup_attrlist(attrs)));
/* Fake up a method call to import */
- meth = newSVpvn("import", 6);
- (void)SvUPGRADE(meth, SVt_PVIV);
- (void)SvIOK_on(meth);
- {
- U32 hash;
- PERL_HASH(hash, SvPVX_const(meth), SvCUR(meth));
- SvUV_set(meth, hash);
- }
+ meth = newSVpvs("import");
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
append_elem(OP_LIST,
prepend_elem(OP_LIST, pack, list(arg)),
}
Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
- newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+ newSVpvs(ATTRSMODULE),
NULL, prepend_elem(OP_LIST,
newSVOP(OP_CONST, 0, newSVpv(stashpv,0)),
prepend_elem(OP_LIST,
OP *
Perl_my_attrs(pTHX_ OP *o, OP *attrs)
{
- OP *rops = Nullop;
+ OP *rops;
int maybe_scalar = 0;
/* [perl #17376]: this appears to be premature, and results in code such as
#endif
if (attrs)
SAVEFREEOP(attrs);
+ rops = Nullop;
o = my_kid(o, attrs, &rops);
if (rops) {
if (maybe_scalar && o->op_type == OP_PADSV) {
Perl_jmaybe(pTHX_ OP *o)
{
if (o->op_type == OP_LIST) {
- OP *o2;
#ifdef USE_5005THREADS
- o2 = newOP(OP_THREADSV, 0);
+ OP * const o2 = newOP(OP_THREADSV, 0);
o2->op_targ = find_threadsv(";");
#else
- o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", GV_ADD, SVt_PV))),
+ OP * const o2
+ = newSVREF(newGVOP(OP_GV, 0, gv_fetchpvs(";", GV_ADD|GV_NOTQUAL,
+ SVt_PV)));
#endif /* USE_5005THREADS */
o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
}
pp_pushmark();
CALLRUNOPS(aTHX);
PL_op = curop;
+ assert (!(curop->op_flags & OPf_SPECIAL));
+ assert(curop->op_type == OP_RANGE);
pp_anonlist();
PL_tmps_floor = oldtmps_floor;
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((U8 *)t, tend-t, &ulen, 0);
t += ulen;
if (expr->op_type == OP_CONST) {
STRLEN plen;
- SV *pat = ((SVOP*)expr)->op_sv;
+ SV * const pat = ((SVOP*)expr)->op_sv;
const char *p = SvPV_const(pat, plen);
if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) {
U32 was_readonly = SvREADONLY(pat);
if (repl) {
OP *curop;
if (pm->op_pmflags & PMf_EVAL) {
- curop = 0;
+ curop = NULL;
if (CopLINE(PL_curcop) < (line_t)PL_multi_end)
CopLINE_set(PL_curcop, (line_t)PL_multi_end);
}
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) {
#ifdef USE_5005THREADS
}
#else
if (curop->op_type == OP_GV) {
- GV *gv = cGVOPx_gv(curop);
+ GV * const gv = cGVOPx_gv(curop);
repl_has_vars = 1;
if (strchr("&`'123456789+-\016\022", *GvENAME(gv)))
break;
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)idop)->op_sv));
/* Fake up a method call to VERSION */
- meth = newSVpvn("VERSION",7);
+ meth = newSVpvs("VERSION");
sv_upgrade(meth, SVt_PVIV);
(void)SvIOK_on(meth);
{
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);
+ meth = aver ? newSVpvs("import") : newSVpvs("unimport");
(void)SvUPGRADE(meth, SVt_PVIV);
(void)SvIOK_on(meth);
{
/* Fake up the BEGIN {}, which does its thing immediately. */
newATTRSUB(floor,
- newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
+ newSVOP(OP_CONST, 0, newSVpvs("BEGIN")),
Nullop,
Nullop,
append_elem(OP_LINESEQ,
GV *gv = Nullgv;
if (!force_builtin) {
- gv = gv_fetchpv("do", 0, SVt_PVCV);
+ gv = gv_fetchpvs("do", GV_NOTQUAL, SVt_PVCV);
if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
- GV **gvp = (GV**)hv_fetch(PL_globalstash, "do", 2, FALSE);
- if (gvp) gv = *gvp; else gv = Nullgv;
+ GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "do", 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));
whileline, OP *expr, OP *block, OP *cont, I32 has_my)
{
OP *redo;
- OP *next = 0;
+ OP *next = NULL;
OP *listop;
OP *o;
U8 loopflags = 0;
op_free(sv);
sv = Nullop;
}
+#ifdef USE_5005THREADS
else if (sv->op_type == OP_THREADSV) { /* per-thread variable */
padoff = sv->op_targ;
sv->op_targ = 0;
op_free(sv);
sv = Nullop;
}
+#endif
else
Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]);
}
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;
}
SV *
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) : NULL;
if (proto) {
aname = NULL;
/* There may be future conflict here as change 23766 is not yet merged. */
- 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__"),
SAVEFREESV(PL_compcv);
goto done;
}
- /* ahem, death to those who redefine active sort subs */
- if (PL_curstackinfo->si_type == PERLSI_SORT && PL_sortcop == CvSTART(cv))
- Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", name);
if (block) {
if (ckWARN(WARN_REDEFINE)
|| (CvCONST(cv)
if (name || aname) {
const char *s;
- const char *tname = (name ? name : aname);
+ const char * const tname = (name ? name : aname);
if (PERLDB_SUBLINE && PL_curstash != PL_debstash) {
- SV *sv = NEWSV(0,0);
- SV *tmpstr = sv_newmortal();
- GV *db_postponed = gv_fetchpv("DB::postponed", GV_ADDMULTI, SVt_PVHV);
+ 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",
CvCONST_on(cv);
sv_setpvn((SV*)cv, "", 0); /* prototype is "" */
+#ifdef USE_ITHREADS
if (stash)
CopSTASH_free(PL_curcop);
-
+#endif
LEAVE;
return cv;
if (cv) /* must reuse cv if autoloaded */
cv_undef(cv);
else {
- cv = (CV*)NEWSV(1105,0);
+ cv = (CV*)newSV(0);
sv_upgrade((SV *)cv, SVt_PVCV);
if (name) {
GvCV(gv) = cv;
Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
{
register CV *cv;
- GV *gv;
- if (o)
- gv = gv_fetchsv(cSVOPo->op_sv, GV_ADD, SVt_PVFM);
- else
- gv = gv_fetchpv("STDOUT", GV_ADD, SVt_PVFM);
-
+ GV * const gv = o
+ ? gv_fetchsv(cSVOPo->op_sv, TRUE, 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)");
OP *
Perl_newANONLIST(pTHX_ OP *o)
{
- return newUNOP(OP_REFGEN, 0,
- mod(list(convert(OP_ANONLIST, 0, o)), OP_REFGEN));
+ return convert(OP_ANONLIST, OPf_SPECIAL, o);
}
OP *
Perl_newANONHASH(pTHX_ OP *o)
{
- return newUNOP(OP_REFGEN, 0,
- mod(list(convert(OP_ANONHASH, 0, o)), OP_REFGEN));
+ return convert(OP_ANONHASH, OPf_SPECIAL, o);
}
OP *
o->op_ppaddr = PL_ppaddr[OP_PADSV];
return o;
}
+#ifdef USE_5005THREADS
else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) {
o->op_flags |= OPpDONE_SVREF;
return o;
}
+#endif
return newUNOP(OP_RV2SV, 0, scalar(o));
}
OP *
Perl_ck_concat(pTHX_ OP *o)
{
- const OP *kid = cUNOPo->op_first;
+ const OP * const kid = cUNOPo->op_first;
if (kid->op_type == OP_CONCAT && !(kid->op_private & OPpTARGET_MY) &&
!(kUNOP->op_first->op_flags & OPf_MOD))
o->op_flags |= OPf_STACKED;
#ifdef VMS
HV * const table = GvHV(PL_hintgv);
if (table) {
- SV * const * const svp = hv_fetch(table, "vmsish_exit", 11, FALSE);
+ SV * const * const svp = hv_fetchs(table, "vmsish_exit", FALSE);
if (svp && *svp && SvTRUE(*svp))
o->op_private |= OPpEXIT_VMSISH;
}
OP *
Perl_ck_rvconst(pTHX_ register OP *o)
{
- SVOP *kid = (SVOP*)cUNOPo->op_first;
+ 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;
/* Is it a constant from cv_const_sv()? */
if (SvROK(kidsv) && SvREADONLY(kidsv)) {
- SV *rsv = SvRV(kidsv);
+ SV * const rsv = SvRV(kidsv);
const int svtype = SvTYPE(rsv);
const char *badtype = NULL;
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
- OP *newop = newGVOP(OP_GV, 0,
+ OP * const newop = newGVOP(OP_GV, 0,
gv_fetchsv(((SVOP*)kid)->op_sv, GV_ADD, SVt_PVIO));
if (!(o->op_private & 1) && /* if not unop */
kid == cLISTOPo->op_last)
else if (kid->op_type == OP_RV2SV
&& kUNOP->op_first->op_type == OP_GV)
{
- GV *gv = cGVOPx_gv(kUNOP->op_first);
+ GV * const gv = cGVOPx_gv(kUNOP->op_first);
name = GvNAME(gv);
len = GvNAMELEN(gv);
}
|| kid->op_type == OP_HELEM)
{
OP *op = ((BINOP*)kid)->op_first;
- name = 0;
+ name = NULL;
if (op) {
SV *tmpstr = NULL;
const char * const a =
if ((o->op_flags & OPf_KIDS) && !cLISTOPo->op_first->op_sibling)
append_elem(OP_GLOB, o, newDEFSVOP());
- if (!((gv = gv_fetchpv("glob", 0, SVt_PVCV))
+ if (!((gv = gv_fetchpvs("glob", GV_NOTQUAL, SVt_PVCV))
&& GvCVu(gv) && GvIMPORTED_CV(gv)))
{
- gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
+ gv = gv_fetchpvs("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), NULL, NULL, NULL);
- gv = gv_fetchpv("CORE::GLOBAL::glob", 0, SVt_PVCV);
- glob_gv = gv_fetchpv("File::Glob::csh_glob", 0, SVt_PVCV);
+ 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((SV*)GvCV(gv));
GvIMPORTED_CV_on(gv);
OP * const kid = cUNOPo->op_first;
if (kid->op_type == OP_CONST) {
SV* sv = kSVOP->op_sv;
- if (!(strchr(SvPVX_const(sv), ':') || strchr(SvPVX_const(sv), '\''))) {
+ const char * const method = SvPVX_const(sv);
+ if (!(strchr(method, ':') || strchr(method, '\''))) {
OP *cmop;
if (!SvREADONLY(sv) || !SvFAKE(sv)) {
- sv = newSVpvn_share(SvPVX_const(sv), SvCUR(sv), 0);
+ sv = newSVpvn_share(method, SvCUR(sv), 0);
}
else {
kSVOP->op_sv = NULL;
{
HV * const table = GvHV(PL_hintgv);
if (table) {
- SV **svp = hv_fetch(table, "open_IN", 7, FALSE);
+ SV **svp = hv_fetchs(table, "open_IN", FALSE);
if (svp && *svp) {
const I32 mode = mode_from_discipline(*svp);
if (mode & O_BINARY)
o->op_private |= OPpOPEN_IN_CRLF;
}
- svp = hv_fetch(table, "open_OUT", 8, FALSE);
+ svp = hv_fetchs(table, "open_OUT", FALSE);
if (svp && *svp) {
const I32 mode = mode_from_discipline(*svp);
if (mode & O_BINARY)
for (s = SvPVX(sv); *s; s++) {
if (*s == ':' && s[1] == ':') {
+ const STRLEN len = strlen(s+2)+1;
*s = '/';
- Move(s+2, s+1, strlen(s+2)+1, char);
+ Move(s+2, s+1, len, char);
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", 0, SVt_PVCV);
+ gv = gv_fetchpvs("require", GV_NOTQUAL, SVt_PVCV);
if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv))) {
- GV **gvp = (GV**)hv_fetch(PL_globalstash, "require", 7, FALSE);
- if (gvp) gv = *gvp; else gv = Nullgv;
+ GV * const * const gvp = (GV**)hv_fetchs(PL_globalstash, "require", FALSE);
+ gv = gvp ? *gvp : Nullgv;
}
}
const char *gvname;
if (!(o->op_flags & OPf_STACKED))
return;
- GvMULTI_on(gv_fetchpv("a", GV_ADD, SVt_PV));
- GvMULTI_on(gv_fetchpv("b", GV_ADD, SVt_PV));
+ GvMULTI_on(gv_fetchpvs("a", GV_ADD|GV_NOTQUAL, SVt_PV));
+ GvMULTI_on(gv_fetchpvs("b", GV_ADD|GV_NOTQUAL, 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;
o->op_private |= OPpENTERSUB_HASTARG;
for (cvop = o2; cvop->op_sibling; cvop = cvop->op_sibling) ;
{
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);
break;
case ']':
if (contextclass) {
+ /* XXX We shouldn't be modifying proto, so we can const proto */
char *p = proto;
const char s = *p;
contextclass = 0;
if (o2->op_type == OP_RV2SV ||
o2->op_type == OP_PADSV ||
o2->op_type == OP_HELEM ||
- o2->op_type == OP_AELEM ||
- o2->op_type == OP_THREADSV)
+ o2->op_type == OP_AELEM
+#ifdef USE_5005THREADS
+ || o2->op_type == OP_THREADSV
+#endif
+ )
goto wrapref;
if (!contextclass)
bad_type(arg, "scalar", gv_ename(namegv), o2);
void
Perl_peep(pTHX_ register OP *o)
{
- register OP* oldop = 0;
+ register OP* oldop = NULL;
STRLEN n_a;
if (!o || o->op_seq)
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);
case OP_PADAV:
case OP_GV:
if (o->op_type == OP_PADAV || o->op_next->op_type == OP_RV2AV) {
- OP* pop = (o->op_type == OP_PADAV) ?
+ OP* const pop = (o->op_type == OP_PADAV) ?
o->op_next : o->op_next->op_next;
IV i;
if (pop && pop->op_type == OP_CONST &&
lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
if (!(SvFLAGS(lexname) & SVpad_TYPED))
break;
- fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+ fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
if (!fields || !GvHV(*fields))
break;
key = SvPV_const(*svp, keylen);
lexname = *av_fetch(PL_comppad_name, rop->op_first->op_targ, TRUE);
if (!(SvFLAGS(lexname) & SVpad_TYPED))
break;
- fields = (GV**)hv_fetch(SvSTASH(lexname), "FIELDS", 6, FALSE);
+ fields = (GV**)hv_fetchs(SvSTASH(lexname), "FIELDS", FALSE);
if (!fields || !GvHV(*fields))
break;
/* Again guessing that the pushmark can be jumped over.... */
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. */
+ /* Converted from op_opt to op_seq for 5.8.x. */
+
+ o->op_seq = PL_op_seqmax++;
+
+
+ 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_seq = PL_op_seqmax++;
https://perl5.git.perl.org / perl5.git / blobdiff