/* op.c
*
- * Copyright (c) 1991-2001, Larry Wall
+ * Copyright (c) 1991-2002, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
* either way, as the saying is, if you follow me." --the Gaffer
*/
+
#include "EXTERN.h"
#define PERL_IN_OP_C
#include "perl.h"
#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
-/* #define PL_OP_SLAB_ALLOC */
+#if defined(PL_OP_SLAB_ALLOC)
-#ifdef PL_OP_SLAB_ALLOC
-#define SLAB_SIZE 8192
-static char *PL_OpPtr = NULL;
-static int PL_OpSpace = 0;
-#define NewOp(m,var,c,type) do { if ((PL_OpSpace -= c*sizeof(type)) >= 0) \
- var = (type *)(PL_OpPtr -= c*sizeof(type)); \
- else \
- var = (type *) Slab_Alloc(m,c*sizeof(type)); \
- } while (0)
+#ifndef PERL_SLAB_SIZE
+#define PERL_SLAB_SIZE 2048
+#endif
+
+#define NewOp(m,var,c,type) \
+ STMT_START { var = (type *) Slab_Alloc(m,c*sizeof(type)); } STMT_END
+
+#define FreeOp(p) Slab_Free(p)
STATIC void *
S_Slab_Alloc(pTHX_ int m, size_t sz)
{
- Newz(m,PL_OpPtr,SLAB_SIZE,char);
- PL_OpSpace = SLAB_SIZE - sz;
- return PL_OpPtr += PL_OpSpace;
+ /*
+ * To make incrementing use count easy PL_OpSlab is an I32 *
+ * To make inserting the link to slab PL_OpPtr is I32 **
+ * So compute size in units of sizeof(I32 *) as that is how Pl_OpPtr increments
+ * Add an overhead for pointer to slab and round up as a number of pointers
+ */
+ sz = (sz + 2*sizeof(I32 *) -1)/sizeof(I32 *);
+ if ((PL_OpSpace -= sz) < 0) {
+ PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
+ if (!PL_OpPtr) {
+ return NULL;
+ }
+ Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
+ /* We reserve the 0'th I32 sized chunk as a use count */
+ PL_OpSlab = (I32 *) PL_OpPtr;
+ /* Reduce size by the use count word, and by the size we need.
+ * Latter is to mimic the '-=' in the if() above
+ */
+ PL_OpSpace = PERL_SLAB_SIZE - (sizeof(I32)+sizeof(I32 **)-1)/sizeof(I32 **) - sz;
+ /* Allocation pointer starts at the top.
+ Theory: because we build leaves before trunk allocating at end
+ means that at run time access is cache friendly upward
+ */
+ PL_OpPtr += PERL_SLAB_SIZE;
+ }
+ assert( PL_OpSpace >= 0 );
+ /* Move the allocation pointer down */
+ PL_OpPtr -= sz;
+ assert( PL_OpPtr > (I32 **) PL_OpSlab );
+ *PL_OpPtr = PL_OpSlab; /* Note which slab it belongs to */
+ (*PL_OpSlab)++; /* Increment use count of slab */
+ assert( PL_OpPtr+sz <= ((I32 **) PL_OpSlab + PERL_SLAB_SIZE) );
+ assert( *PL_OpSlab > 0 );
+ return (void *)(PL_OpPtr + 1);
+}
+
+STATIC void
+S_Slab_Free(pTHX_ void *op)
+{
+ I32 **ptr = (I32 **) op;
+ I32 *slab = ptr[-1];
+ assert( ptr-1 > (I32 **) slab );
+ assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
+ assert( *slab > 0 );
+ if (--(*slab) == 0) {
+ #ifdef NETWARE
+ #define PerlMemShared PerlMem
+ #endif
+
+ PerlMemShared_free(slab);
+ if (slab == PL_OpSlab) {
+ PL_OpSpace = 0;
+ }
+ }
}
#else
#define NewOp(m, var, c, type) Newz(m, var, c, type)
+#define FreeOp(p) Safefree(p)
#endif
/*
* In the following definition, the ", Nullop" is just to make the compiler
SV **svp = AvARRAY(PL_comppad_name);
HV *ourstash = (PL_curstash ? PL_curstash : PL_defstash);
PADOFFSET top = AvFILLp(PL_comppad_name);
- for (off = top; off > PL_comppad_name_floor; off--) {
+ for (off = top; (I32)off > PL_comppad_name_floor; off--) {
if ((sv = svp[off])
&& sv != &PL_sv_undef
&& (SvIVX(sv) == PAD_MAX || SvIVX(sv) == 0)
|| ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash))
&& strEQ(name, SvPVX(sv)))
{
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"\"%s\" variable %s masks earlier declaration in same %s",
(PL_in_my == KEY_our ? "our" : "my"),
name,
&& ((SvFLAGS(sv) & SVpad_OUR) && GvSTASH(sv) == ourstash)
&& strEQ(name, SvPVX(sv)))
{
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"\"our\" variable %s redeclared", name);
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"\t(Did you mean \"local\" instead of \"our\"?)\n");
break;
}
for (off = AvFILLp(curname); off > 0; off--) {
if ((sv = svp[off]) &&
sv != &PL_sv_undef &&
- seq <= SvIVX(sv) &&
- seq > I_32(SvNVX(sv)) &&
+ seq <= (U32)SvIVX(sv) &&
+ seq > (U32)I_32(SvNVX(sv)) &&
strEQ(SvPVX(sv), name))
{
I32 depth;
if (ckWARN(WARN_CLOSURE)
&& !CvUNIQUE(bcv) && !CvUNIQUE(cv))
{
- Perl_warner(aTHX_ WARN_CLOSURE,
+ Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%s\" may be unavailable",
name);
}
if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv)
&& !(SvFLAGS(sv) & SVpad_OUR))
{
- Perl_warner(aTHX_ WARN_CLOSURE,
+ Perl_warner(aTHX_ packWARN(WARN_CLOSURE),
"Variable \"%s\" will not stay shared", name);
}
}
if ((sv = svp[off]) &&
sv != &PL_sv_undef &&
(!SvIVX(sv) ||
- (seq <= SvIVX(sv) &&
- seq > I_32(SvNVX(sv)))) &&
+ (seq <= (U32)SvIVX(sv) &&
+ seq > (U32)I_32(SvNVX(sv)))) &&
strEQ(SvPVX(sv), name))
{
if (SvIVX(sv) || SvFLAGS(sv) & SVpad_OUR)
if (PL_min_intro_pending && fill < PL_min_intro_pending) {
for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) {
if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv));
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "%s never introduced", SvPVX(sv));
}
}
/* "Deintroduce" my variables that are leaving with this scope. */
}
type = o->op_type;
if (type == OP_NULL)
- type = o->op_targ;
+ type = (OPCODE)o->op_targ;
/* COP* is not cleared by op_clear() so that we may track line
* numbers etc even after null() */
cop_free((COP*)o);
op_clear(o);
-
-#ifdef PL_OP_SLAB_ALLOC
- if ((char *) o == PL_OpPtr)
- {
- }
-#else
- Safefree(o);
-#endif
+ FreeOp(o);
}
void
goto clear_pmop;
case OP_PUSHRE:
#ifdef USE_ITHREADS
- if ((PADOFFSET)cPMOPo->op_pmreplroot) {
+ if (INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)) {
if (PL_curpad) {
- GV *gv = (GV*)PL_curpad[(PADOFFSET)cPMOPo->op_pmreplroot];
- pad_swipe((PADOFFSET)cPMOPo->op_pmreplroot);
+ GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot)];
+ pad_swipe(INT2PTR(PADOFFSET, cPMOPo->op_pmreplroot));
/* No GvIN_PAD_off(gv) here, because other references may still
* exist on the pad */
SvREFCNT_dec(gv);
pmop = pmop->op_pmnext;
}
}
-#ifdef USE_ITHREADS
- Safefree(PmopSTASHPV(cPMOPo));
-#else
- /* NOTE: PMOP.op_pmstash is not refcounted */
-#endif
+ PmopSTASH_free(cPMOPo);
}
cPMOPo->op_pmreplroot = Nullop;
/* we use the "SAFE" version of the PM_ macros here
SvREPADTMP_on(PL_regex_pad[(cPMOPo)->op_pmoffset]);
PM_SETRE(cPMOPo, (cPMOPo)->op_pmoffset);
}
-#endif
+#endif
break;
}
STATIC void
S_cop_free(pTHX_ COP* cop)
{
- Safefree(cop->cop_label);
-#ifdef USE_ITHREADS
- Safefree(CopFILE(cop)); /* XXX share in a pvtable? */
- Safefree(CopSTASHPV(cop)); /* XXX share in a pvtable? */
-#else
- /* NOTE: COP.cop_stash is not refcounted */
- SvREFCNT_dec(CopFILEGV(cop));
-#endif
+ Safefree(cop->cop_label); /* FIXME: treaddead ??? */
+ CopFILE_free(cop);
+ CopSTASH_free(cop);
if (! specialWARN(cop->cop_warnings))
SvREFCNT_dec(cop->cop_warnings);
- if (! specialCopIO(cop->cop_io))
+ if (! specialCopIO(cop->cop_io)) {
+#ifdef USE_ITHREADS
+#if 0
+ STRLEN len;
+ char *s = SvPV(cop->cop_io,len);
+ Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
+#endif
+#else
SvREFCNT_dec(cop->cop_io);
+#endif
+ }
}
void
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ WARN_SYNTAX, "Found = in conditional, should be ==");
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX), "Found = in conditional, should be ==");
CopLINE_set(PL_curcop, oldline);
}
}
case OP_SPLIT:
if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
if (!kPMOP->op_pmreplroot)
- deprecate("implicit split to @_");
+ deprecate_old("implicit split to @_");
}
/* FALL THROUGH */
case OP_MATCH:
}
WITH_THR(PL_curcop = &PL_compiling);
break;
+ case OP_SORT:
+ if (ckWARN(WARN_VOID))
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
}
return o;
}
case OP_SPLIT:
if ((kid = cLISTOPo->op_first) && kid->op_type == OP_PUSHRE) {
if (!kPMOP->op_pmreplroot)
- deprecate("implicit split to @_");
+ deprecate_old("implicit split to @_");
}
break;
}
if (useless && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ WARN_VOID, "Useless use of %s in void context", useless);
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of %s in void context", useless);
return o;
}
op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
break;
}
+ else if (o->op_private & OPpENTERSUB_NOMOD)
+ return o;
else { /* lvalue subroutine call */
o->op_private |= OPpLVAL_INTRO;
PL_modcount = RETURN_UNLIMITED_NUMBER;
if (kid->op_type != OP_NULL || kid->op_targ != OP_LIST)
Perl_croak(aTHX_
"panic: unexpected lvalue entersub "
- "args: type/targ %ld:%ld",
- (long)kid->op_type,kid->op_targ);
+ "args: type/targ %ld:%"UVuf,
+ (long)kid->op_type, (UV)kid->op_targ);
kid = kLISTOP->op_first;
skip_kids:
while (kid->op_sibling)
{
UNOP *newop;
- if (kid->op_sibling || kid->op_next != kid) {
- yyerror("panic: unexpected optree near method call");
- break;
- }
-
NewOp(1101, newop, 1, UNOP);
newop->op_type = OP_RV2CV;
newop->op_ppaddr = PL_ppaddr[OP_RV2CV];
newop->op_private |= OPpLVAL_INTRO;
break;
}
-
+
if (kid->op_type != OP_RV2CV)
Perl_croak(aTHX_
"panic: unexpected lvalue entersub "
- "entry via type/targ %ld:%ld",
- (long)kid->op_type,kid->op_targ);
+ "entry via type/targ %ld:%"UVuf,
+ (long)kid->op_type, (UV)kid->op_targ);
kid->op_private |= OPpLVAL_INTRO;
break; /* Postpone until runtime */
}
-
- okid = kid;
+
+ okid = kid;
kid = kUNOP->op_first;
if (kid->op_type == OP_NULL && kid->op_targ == OP_RV2SV)
kid = kUNOP->op_first;
- if (kid->op_type == OP_NULL)
+ if (kid->op_type == OP_NULL)
Perl_croak(aTHX_
"Unexpected constant lvalue entersub "
- "entry via type/targ %ld:%ld",
- (long)kid->op_type,kid->op_targ);
+ "entry via type/targ %ld:%"UVuf,
+ (long)kid->op_type, (UV)kid->op_targ);
if (kid->op_type != OP_GV) {
/* Restore RV2CV to check lvalueness */
restore_2cv:
okid->op_private |= OPpLVAL_INTRO;
break;
}
-
+
cv = GvCV(kGVOP_gv);
if (!cv)
goto restore_2cv;
goto nomod;
PL_modcount++;
break;
-
+
case OP_COND_EXPR:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
mod(kid, type);
case OP_PUSHMARK:
break;
-
+
case OP_KEYS:
if (type != OP_SASSIGN)
goto nomod;
goto nomod;
break; /* mod()ing was handled by ck_return() */
}
+
+ /* [20011101.069] File test operators interpret OPf_REF to mean that
+ their argument is a filehandle; thus \stat(".") should not set
+ it. AMS 20011102 */
+ if (type == OP_REFGEN &&
+ PL_check[o->op_type] == MEMBER_TO_FPTR(Perl_ck_ftst))
+ return o;
+
if (type != OP_LEAVESUBLV)
o->op_flags |= OPf_MOD;
}
STATIC void
-S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
+S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
{
SV *stashsv;
stashsv = &PL_sv_no;
#define ATTRSMODULE "attributes"
+#define ATTRSMODULE_PM "attributes.pm"
- Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
- newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
- Nullsv,
- prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0, stashsv),
- prepend_elem(OP_LIST,
- newSVOP(OP_CONST, 0,
- newRV(target)),
- dup_attrlist(attrs))));
+ if (for_my) {
+ SV **svp;
+ /* Don't force the C<use> if we don't need it. */
+ svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
+ sizeof(ATTRSMODULE_PM)-1, 0);
+ if (svp && *svp != &PL_sv_undef)
+ ; /* already in %INC */
+ else
+ Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+ newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+ Nullsv);
+ }
+ else {
+ Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
+ newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+ Nullsv,
+ prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0, stashsv),
+ prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0,
+ newRV(target)),
+ dup_attrlist(attrs))));
+ }
LEAVE;
}
+STATIC void
+S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
+{
+ OP *pack, *imop, *arg;
+ SV *meth, *stashsv;
+
+ if (!attrs)
+ return;
+
+ assert(target->op_type == OP_PADSV ||
+ target->op_type == OP_PADHV ||
+ target->op_type == OP_PADAV);
+
+ /* Ensure that attributes.pm is loaded. */
+ 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));
+
+ /* Build up the real arg-list. */
+ if (stash)
+ stashsv = newSVpv(HvNAME(stash), 0);
+ else
+ stashsv = &PL_sv_no;
+ arg = newOP(OP_PADSV, 0);
+ arg->op_targ = target->op_targ;
+ arg = prepend_elem(OP_LIST,
+ newSVOP(OP_CONST, 0, stashsv),
+ prepend_elem(OP_LIST,
+ newUNOP(OP_REFGEN, 0,
+ mod(arg, OP_REFGEN)),
+ dup_attrlist(attrs)));
+
+ /* Fake up a method call to import */
+ meth = newSVpvn("import", 6);
+ (void)SvUPGRADE(meth, SVt_PVIV);
+ (void)SvIOK_on(meth);
+ PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
+ imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
+ append_elem(OP_LIST,
+ prepend_elem(OP_LIST, pack, list(arg)),
+ newSVOP(OP_METHOD_NAMED, 0, meth)));
+ imop->op_private |= OPpENTERSUB_NOMOD;
+
+ /* Combine the ops. */
+ *imopsp = append_elem(OP_LIST, *imopsp, imop);
+}
+
+/*
+=notfor apidoc apply_attrs_string
+
+Attempts to apply a list of attributes specified by the C<attrstr> and
+C<len> arguments to the subroutine identified by the C<cv> argument which
+is expected to be associated with the package identified by the C<stashpv>
+argument (see L<attributes>). It gets this wrong, though, in that it
+does not correctly identify the boundaries of the individual attribute
+specifications within C<attrstr>. This is not really intended for the
+public API, but has to be listed here for systems such as AIX which
+need an explicit export list for symbols. (It's called from XS code
+in support of the C<ATTRS:> keyword from F<xsubpp>.) Patches to fix it
+to respect attribute syntax properly would be welcome.
+
+=cut
+*/
+
void
Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
char *attrstr, STRLEN len)
}
STATIC OP *
-S_my_kid(pTHX_ OP *o, OP *attrs)
+S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
{
OP *kid;
I32 type;
type = o->op_type;
if (type == OP_LIST) {
for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
- my_kid(kid, attrs);
+ my_kid(kid, attrs, imopsp);
} else if (type == OP_UNDEF) {
return o;
} else if (type == OP_RV2SV || /* "our" declaration */
type == OP_RV2AV ||
type == OP_RV2HV) { /* XXX does this let anything illegal in? */
+ if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
+ yyerror(Perl_form(aTHX_ "Can't declare %s in my", OP_DESC(o)));
+ }
if (attrs) {
GV *gv = cGVOPx_gv(cUNOPo->op_first);
PL_in_my = FALSE;
(type == OP_RV2SV ? GvSV(gv) :
type == OP_RV2AV ? (SV*)GvAV(gv) :
type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
- attrs);
+ attrs, FALSE);
}
o->op_private |= OPpOUR_INTRO;
return o;
- } else if (type != OP_PADSV &&
+ }
+ else if (type != OP_PADSV &&
type != OP_PADAV &&
type != OP_PADHV &&
type != OP_PUSHMARK)
}
else if (attrs && type != OP_PUSHMARK) {
HV *stash;
- SV *padsv;
SV **namesvp;
PL_in_my = FALSE;
stash = SvSTASH(*namesvp);
else
stash = PL_curstash;
- padsv = PAD_SV(o->op_targ);
- apply_attrs(stash, padsv, attrs);
+ apply_attrs_my(stash, o, attrs, imopsp);
}
o->op_flags |= OPf_MOD;
o->op_private |= OPpLVAL_INTRO;
OP *
Perl_my_attrs(pTHX_ OP *o, OP *attrs)
{
+ OP *rops = Nullop;
+ int maybe_scalar = 0;
+
if (o->op_flags & OPf_PARENS)
list(o);
+ else
+ maybe_scalar = 1;
if (attrs)
SAVEFREEOP(attrs);
- o = my_kid(o, attrs);
+ o = my_kid(o, attrs, &rops);
+ if (rops) {
+ if (maybe_scalar && o->op_type == OP_PADSV) {
+ o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
+ o->op_private |= OPpLVAL_INTRO;
+ }
+ else
+ o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
+ }
PL_in_my = FALSE;
PL_in_my_stash = Nullhv;
return o;
OP *
Perl_my(pTHX_ OP *o)
{
- return my_kid(o, Nullop);
+ return my_attrs(o, Nullop);
}
OP *
const char *sample = ((left->op_type == OP_RV2AV ||
left->op_type == OP_PADAV)
? "@array" : "%hash");
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"Applying %s to %s will act on scalar(%s)",
desc, sample, sample);
}
+ if (right->op_type == OP_CONST &&
+ cSVOPx(right)->op_private & OPpCONST_BARE &&
+ cSVOPx(right)->op_private & OPpCONST_STRICT)
+ {
+ no_bareword_allowed(right);
+ }
+
if (!(right->op_flags & OPf_STACKED) &&
(right->op_type == OP_MATCH ||
right->op_type == OP_SUBST ||
right->op_type == OP_TRANS)) {
right->op_flags |= OPf_STACKED;
- if ((right->op_type != OP_MATCH &&
- ! (right->op_type == OP_TRANS &&
- right->op_private & OPpTRANS_IDENTICAL)) ||
- /* if SV has magic, then match on original SV, not on its copy.
- see note in pp_helem() */
- (right->op_type == OP_MATCH &&
- (left->op_type == OP_AELEM ||
- left->op_type == OP_HELEM ||
- left->op_type == OP_AELEMFAST)))
+ if (right->op_type != OP_MATCH &&
+ ! (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);
PL_copline = copline; /* XXX newSTATEOP may reset PL_copline */
LEAVE_SCOPE(floor);
PL_pad_reset_pending = FALSE;
- PL_compiling.op_private = PL_hints;
+ PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
if (needblockscope)
PL_hints |= HINT_BLOCK_SCOPE; /* propagate out */
pad_leavemy(PL_comppad_name_fill);
s++;
if (*s == ';' || *s == '=')
- Perl_warner(aTHX_ WARN_PARENTHESIS,
+ Perl_warner(aTHX_ packWARN(WARN_PARENTHESIS),
"Parentheses missing around \"%s\" list",
lex ? (PL_in_my == KEY_our ? "our" : "my") : "local");
}
}
nope:
- if (!(PL_opargs[type] & OA_OTHERINT))
- return o;
-
- if (!(PL_hints & HINT_INTEGER)) {
- if (type == OP_MODULO
- || type == OP_DIVIDE
- || !(o->op_flags & OPf_KIDS))
- {
- return o;
- }
-
- for (curop = ((UNOP*)o)->op_first; curop; curop = curop->op_sibling) {
- if (curop->op_type == OP_CONST) {
- if (SvIOK(((SVOP*)curop)->op_sv))
- continue;
- return o;
- }
- if (PL_opargs[curop->op_type] & OA_RETINTEGER)
- continue;
- return o;
- }
- o->op_ppaddr = PL_ppaddr[++(o->op_type)];
- }
-
return o;
}
o->op_type = OP_RV2AV;
o->op_ppaddr = PL_ppaddr[OP_RV2AV];
+ o->op_seq = 0; /* needs to be revisited in peep() */
curop = ((UNOP*)o)->op_first;
((UNOP*)o)->op_first = newSVOP(OP_CONST, 0, SvREFCNT_inc(*PL_stack_sp--));
op_free(curop);
if (!(PL_opargs[type] & OA_MARK))
op_null(cLISTOPo->op_first);
- o->op_type = type;
+ o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
o->op_flags |= flags;
first->op_last = last->op_last;
first->op_flags |= (last->op_flags & OPf_KIDS);
-#ifdef PL_OP_SLAB_ALLOC
-#else
- Safefree(last);
-#endif
+ FreeOp(last);
+
return (OP*)first;
}
NewOp(1101, listop, 1, LISTOP);
- listop->op_type = type;
+ listop->op_type = (OPCODE)type;
listop->op_ppaddr = PL_ppaddr[type];
if (first || last)
flags |= OPf_KIDS;
- listop->op_flags = flags;
+ listop->op_flags = (U8)flags;
if (!last && first)
last = first;
{
OP *o;
NewOp(1101, o, 1, OP);
- o->op_type = type;
+ o->op_type = (OPCODE)type;
o->op_ppaddr = PL_ppaddr[type];
- o->op_flags = flags;
+ o->op_flags = (U8)flags;
o->op_next = o;
- o->op_private = 0 + (flags >> 8);
+ o->op_private = (U8)(0 | (flags >> 8));
if (PL_opargs[type] & OA_RETSCALAR)
scalar(o);
if (PL_opargs[type] & OA_TARGET)
first = force_list(first);
NewOp(1101, unop, 1, UNOP);
- unop->op_type = type;
+ unop->op_type = (OPCODE)type;
unop->op_ppaddr = PL_ppaddr[type];
unop->op_first = first;
unop->op_flags = flags | OPf_KIDS;
- unop->op_private = 1 | (flags >> 8);
+ unop->op_private = (U8)(1 | (flags >> 8));
unop = (UNOP*) CHECKOP(type, unop);
if (unop->op_next)
return (OP*)unop;
if (!first)
first = newOP(OP_NULL, 0);
- binop->op_type = type;
+ binop->op_type = (OPCODE)type;
binop->op_ppaddr = PL_ppaddr[type];
binop->op_first = first;
binop->op_flags = flags | OPf_KIDS;
if (!last) {
last = first;
- binop->op_private = 1 | (flags >> 8);
+ binop->op_private = (U8)(1 | (flags >> 8));
}
else {
- binop->op_private = 2 | (flags >> 8);
+ binop->op_private = (U8)(2 | (flags >> 8));
first->op_sibling = last;
}
binop = (BINOP*)CHECKOP(type, binop);
- if (binop->op_next || binop->op_type != type)
+ if (binop->op_next || binop->op_type != (OPCODE)type)
return (OP*)binop;
binop->op_last = binop->op_first->op_sibling;
U8 range_mark = UTF_TO_NATIVE(0xff);
sv_catpvn(transv, (char *)&range_mark, 1);
}
- t = uvuni_to_utf8(tmpbuf, 0x7fffffff);
+ t = uvuni_to_utf8_flags(tmpbuf, 0x7fffffff,
+ UNICODE_ALLOW_SUPER);
sv_catpvn(transv, (char*)tmpbuf, t - tmpbuf);
t = (U8*)SvPVX(transv);
tlen = SvCUR(transv);
tbl = (short*)cPVOPo->op_pv;
if (complement) {
Zero(tbl, 256, short);
- for (i = 0; i < tlen; i++)
+ for (i = 0; i < (I32)tlen; i++)
tbl[t[i]] = -1;
for (i = 0, j = 0; i < 256; i++) {
if (!tbl[i]) {
- if (j >= rlen) {
+ if (j >= (I32)rlen) {
if (del)
tbl[i] = -2;
else if (rlen)
tbl[i] = r[j-1];
else
- tbl[i] = i;
+ tbl[i] = (short)i;
}
else {
if (i < 128 && r[j] >= 128)
if (!squash)
o->op_private |= OPpTRANS_IDENTICAL;
}
- else if (j >= rlen)
+ else if (j >= (I32)rlen)
j = rlen - 1;
else
cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short);
tbl[0x100] = rlen - j;
- for (i=0; i < rlen - j; i++)
+ for (i=0; i < (I32)rlen - j; i++)
tbl[0x101+i] = r[j+i];
}
}
if (!squash)
o->op_private |= OPpTRANS_IDENTICAL;
}
+ else if (!squash && rlen == tlen && memEQ((char*)t, (char*)r, tlen)) {
+ o->op_private |= OPpTRANS_IDENTICAL;
+ }
for (i = 0; i < 256; i++)
tbl[i] = -1;
- for (i = 0, j = 0; i < tlen; i++,j++) {
- if (j >= rlen) {
+ for (i = 0, j = 0; i < (I32)tlen; i++,j++) {
+ if (j >= (I32)rlen) {
if (del) {
if (tbl[t[i]] == -1)
tbl[t[i]] = -2;
PMOP *pmop;
NewOp(1101, pmop, 1, PMOP);
- pmop->op_type = type;
+ pmop->op_type = (OPCODE)type;
pmop->op_ppaddr = PL_ppaddr[type];
- pmop->op_flags = flags;
- pmop->op_private = 0 | (flags >> 8);
+ pmop->op_flags = (U8)flags;
+ pmop->op_private = (U8)(0 | (flags >> 8));
if (PL_hints & HINT_RE_TAINT)
pmop->op_pmpermflags |= PMf_RETAINT;
pmop->op_pmoffset = SvIV(repointer);
SvREPADTMP_off(repointer);
sv_setiv(repointer,0);
- } else {
+ } else {
repointer = newSViv(0);
av_push(PL_regex_padav,SvREFCNT_inc(repointer));
pmop->op_pmoffset = av_len(PL_regex_padav);
}
}
#endif
-
+
/* link into pm list */
if (type != OP_TRANS && PL_curstash) {
pmop->op_pmnext = HvPMROOT(PL_curstash);
p = SvPV(pat, plen);
pm->op_pmflags |= PMf_SKIPWHITE;
}
+ if (DO_UTF8(pat))
+ pm->op_pmdynflags |= PMdf_UTF8;
PM_SETRE(pm, CALLREGCOMP(aTHX_ p, p + plen, pm));
if (strEQ("\\s+", PM_GETRE(pm)->precomp))
pm->op_pmflags |= PMf_WHITE;
if (pm->op_pmflags & PMf_EVAL) {
curop = 0;
if (CopLINE(PL_curcop) < PL_multi_end)
- CopLINE_set(PL_curcop, PL_multi_end);
+ CopLINE_set(PL_curcop, (line_t)PL_multi_end);
}
#ifdef USE_5005THREADS
else if (repl->op_type == OP_THREADSV
{
SVOP *svop;
NewOp(1101, svop, 1, SVOP);
- svop->op_type = type;
+ svop->op_type = (OPCODE)type;
svop->op_ppaddr = PL_ppaddr[type];
svop->op_sv = sv;
svop->op_next = (OP*)svop;
- svop->op_flags = flags;
+ svop->op_flags = (U8)flags;
if (PL_opargs[type] & OA_RETSCALAR)
scalar((OP*)svop);
if (PL_opargs[type] & OA_TARGET)
{
PADOP *padop;
NewOp(1101, padop, 1, PADOP);
- padop->op_type = type;
+ padop->op_type = (OPCODE)type;
padop->op_ppaddr = PL_ppaddr[type];
padop->op_padix = pad_alloc(type, SVs_PADTMP);
SvREFCNT_dec(PL_curpad[padop->op_padix]);
PL_curpad[padop->op_padix] = sv;
SvPADTMP_on(sv);
padop->op_next = (OP*)padop;
- padop->op_flags = flags;
+ padop->op_flags = (U8)flags;
if (PL_opargs[type] & OA_RETSCALAR)
scalar((OP*)padop);
if (PL_opargs[type] & OA_TARGET)
{
PVOP *pvop;
NewOp(1101, pvop, 1, PVOP);
- pvop->op_type = type;
+ pvop->op_type = (OPCODE)type;
pvop->op_ppaddr = PL_ppaddr[type];
pvop->op_pv = pv;
pvop->op_next = (OP*)pvop;
- pvop->op_flags = flags;
+ pvop->op_flags = (U8)flags;
if (PL_opargs[type] & OA_RETSCALAR)
scalar((OP*)pvop);
if (PL_opargs[type] & OA_TARGET)
OP *pack;
OP *imop;
OP *veop;
- char *packname = Nullch;
- STRLEN packlen = 0;
- SV *packsv;
if (id->op_type != OP_CONST)
Perl_croak(aTHX_ "Module name must be constant");
pack = newSVOP(OP_CONST, 0, newSVsv(((SVOP*)id)->op_sv));
/* Fake up a method call to import/unimport */
- meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);;
- sv_upgrade(meth, SVt_PVIV);
+ meth = aver ? newSVpvn("import",6) : newSVpvn("unimport", 8);
+ (void)SvUPGRADE(meth, SVt_PVIV);
(void)SvIOK_on(meth);
PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL,
newSVOP(OP_METHOD_NAMED, 0, meth)));
}
- if (ckWARN(WARN_MISC) &&
- imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
- SvPOK(packsv = ((SVOP*)id)->op_sv))
- {
- /* BEGIN will free the ops, so we need to make a copy */
- packlen = SvCUR(packsv);
- packname = savepvn(SvPVX(packsv), packlen);
- }
-
/* Fake up the BEGIN {}, which does its thing immediately. */
newATTRSUB(floor,
newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
newSTATEOP(0, Nullch, veop)),
newSTATEOP(0, Nullch, imop) ));
- if (packname) {
- if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
- Perl_warner(aTHX_ WARN_MISC,
- "Package `%s' not found "
- "(did you use the incorrect case?)", packname);
- }
- safefree(packname);
- }
+ /* The "did you use incorrect case?" warning used to be here.
+ * The problem is that on case-insensitive filesystems one
+ * might get false positives for "use" (and "require"):
+ * "use Strict" or "require CARP" will work. This causes
+ * portability problems for the script: in case-strict
+ * filesystems the script will stop working.
+ *
+ * The "incorrect case" warning checked whether "use Foo"
+ * imported "Foo" to your namespace, but that is wrong, too:
+ * there is no requirement nor promise in the language that
+ * a Foo.pm should or would contain anything in package "Foo".
+ *
+ * There is very little Configure-wise that can be done, either:
+ * the case-sensitivity of the build filesystem of Perl does not
+ * help in guessing the case-sensitivity of the runtime environment.
+ */
PL_hints |= HINT_BLOCK_SCOPE;
PL_copline = NOLINE;
}
/*
+=head1 Embedding Functions
+
=for apidoc load_module
Loads the module whose name is pointed to by the string part of name.
GV *gv;
gv = gv_fetchpv("do", FALSE, SVt_PVCV);
- if (!(gv && GvIMPORTED_CV(gv)))
+ if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
gv = gv_fetchpv("CORE::GLOBAL::do", FALSE, SVt_PVCV);
- if (gv && GvIMPORTED_CV(gv)) {
+ if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
doop = ck_subr(newUNOP(OP_ENTERSUB, OPf_STACKED,
append_elem(OP_LIST, term,
scalar(newUNOP(OP_RV2CV, 0,
return FALSE;
}
+ if (o->op_type == OP_LIST &&
+ (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
+ o->op_private & OPpLVAL_INTRO)
+ return FALSE;
+
if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
}
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
- o->op_private = 0 | (flags >> 8);
+ o->op_private = (U8)(0 | (flags >> 8));
for (curop = ((LISTOP*)curop)->op_first;
curop; curop = curop->op_sibling)
{
if (PL_opargs[curop->op_type] & OA_DANGEROUS) {
if (curop->op_type == OP_GV) {
GV *gv = cGVOPx_gv(curop);
- if (gv == PL_defgv || SvCUR(gv) == PL_generation)
+ if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
break;
SvCUR(gv) = PL_generation;
}
curop->op_type == OP_PADANY) {
SV **svp = AvARRAY(PL_comppad_name);
SV *sv = svp[curop->op_targ];
- if (SvCUR(sv) == PL_generation)
+ if ((int)SvCUR(sv) == PL_generation)
break;
SvCUR(sv) = PL_generation; /* (SvCUR not used any more) */
}
else if (curop->op_type == OP_PUSHRE) {
if (((PMOP*)curop)->op_pmreplroot) {
#ifdef USE_ITHREADS
- GV *gv = (GV*)PL_curpad[(PADOFFSET)((PMOP*)curop)->op_pmreplroot];
+ GV *gv = (GV*)PL_curpad[INT2PTR(PADOFFSET,((PMOP*)curop)->op_pmreplroot)];
#else
GV *gv = (GV*)((PMOP*)curop)->op_pmreplroot;
#endif
- if (gv == PL_defgv || SvCUR(gv) == PL_generation)
+ if (gv == PL_defgv || (int)SvCUR(gv) == PL_generation)
break;
SvCUR(gv) = PL_generation;
- }
+ }
}
else
break;
tmpop = ((UNOP*)left)->op_first;
if (tmpop->op_type == OP_GV && !pm->op_pmreplroot) {
#ifdef USE_ITHREADS
- pm->op_pmreplroot = (OP*)cPADOPx(tmpop)->op_padix;
+ pm->op_pmreplroot = INT2PTR(OP*, cPADOPx(tmpop)->op_padix);
cPADOPx(tmpop)->op_padix = 0; /* steal it */
#else
pm->op_pmreplroot = (OP*)cSVOPx(tmpop)->op_sv;
cop->op_type = OP_NEXTSTATE;
cop->op_ppaddr = PL_ppaddr[ OP_NEXTSTATE ];
}
- cop->op_flags = flags;
- cop->op_private = (PL_hints & HINT_PRIVATE_MASK);
+ cop->op_flags = (U8)flags;
+ cop->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
#ifdef NATIVE_HINTS
cop->op_private |= NATIVE_HINTS;
#endif
if (PERLDB_LINE && PL_curstash != PL_debstash) {
SV **svp = av_fetch(CopFILEAV(PL_curcop), (I32)CopLINE(cop), FALSE);
- if (svp && *svp != &PL_sv_undef && !SvIOK(*svp)) {
- (void)SvIOK_on(*svp);
+ if (svp && *svp != &PL_sv_undef ) {
+ (void)SvIOK_on(*svp);
SvIVX(*svp) = PTR2IV(cop);
}
}
}
if (first->op_type == OP_CONST) {
if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
- Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
+ Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
op_free(first);
*firstp = Nullop;
}
}
else if (first->op_type == OP_WANTARRAY) {
+ /* XXX true only if this result will be returned, else should
+ propagate outer context */
if (type == OP_AND)
list(other);
else
|| k1->op_type == OP_EACH)
{
warnop = ((k1->op_type == OP_NULL)
- ? k1->op_targ : k1->op_type);
+ ? (OPCODE)k1->op_targ : k1->op_type);
}
break;
}
if (warnop) {
line_t oldline = CopLINE(PL_curcop);
CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ WARN_MISC,
+ Perl_warner(aTHX_ packWARN(WARN_MISC),
"Value of %s%s can be \"0\"; test with defined()",
PL_op_desc[warnop],
((warnop == OP_READLINE || warnop == OP_GLOB)
NewOp(1101, logop, 1, LOGOP);
- logop->op_type = type;
+ logop->op_type = (OPCODE)type;
logop->op_ppaddr = PL_ppaddr[type];
logop->op_first = first;
logop->op_flags = flags | OPf_KIDS;
logop->op_other = LINKLIST(other);
- logop->op_private = 1 | (flags >> 8);
+ logop->op_private = (U8)(1 | (flags >> 8));
/* establish postfix order */
logop->op_next = LINKLIST(first);
}
}
else if (first->op_type == OP_WANTARRAY) {
+ /* XXX true only if this result will be returned, else should
+ propagate outer context */
list(trueop);
scalar(falseop);
}
logop->op_ppaddr = PL_ppaddr[OP_COND_EXPR];
logop->op_first = first;
logop->op_flags = flags | OPf_KIDS;
- logop->op_private = 1 | (flags >> 8);
+ logop->op_private = (U8)(1 | (flags >> 8));
logop->op_other = LINKLIST(trueop);
logop->op_next = LINKLIST(falseop);
range->op_flags = OPf_KIDS;
leftstart = LINKLIST(left);
range->op_other = LINKLIST(right);
- range->op_private = 1 | (flags >> 8);
+ range->op_private = (U8)(1 | (flags >> 8));
left->op_sibling = right;
case OP_SASSIGN:
if (k1->op_type == OP_READDIR
|| k1->op_type == OP_GLOB
- || (k1->op_type == OP_NULL && k1->op_targ == OP_NULL)
+ || (k1->op_type == OP_NULL && k1->op_targ == OP_GLOB)
|| k1->op_type == OP_EACH)
expr = newUNOP(OP_DEFINED, 0, expr);
break;
next = unstack;
cont = append_elem(OP_LINESEQ, cont, unstack);
if ((line_t)whileline != NOLINE) {
- PL_copline = whileline;
+ PL_copline = (line_t)whileline;
cont = append_elem(OP_LINESEQ, cont,
newSTATEOP(0, Nullch, Nullop));
}
redo = LINKLIST(listop);
if (expr) {
- PL_copline = whileline;
+ PL_copline = (line_t)whileline;
scalar(listop);
o = new_logop(OP_AND, 0, &expr, &listop);
if (o == expr && o->op_type == OP_CONST && !SvTRUE(cSVOPo->op_sv)) {
{
LOOP *loop;
OP *wop;
- int padoff = 0;
+ PADOFFSET padoff = 0;
I32 iterflags = 0;
if (sv) {
LOOP *tmp;
NewOp(1234,tmp,1,LOOP);
Copy(loop,tmp,1,LOOP);
+ FreeOp(loop);
loop = tmp;
}
#else
* CV, they don't hold a refcount on the outside CV. This avoids
* the refcount loop between the outer CV (which keeps a refcount to
* the closure prototype in the pad entry for pp_anoncode()) and the
- * closure prototype, and the ensuing memory leak. This does not
- * apply to closures generated within eval"", since eval"" CVs are
- * ephemeral. --GSAR */
- if (!CvANON(cv) || CvCLONED(cv)
- || (CvOUTSIDE(cv) && SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
- && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
- {
+ * closure prototype, and the ensuing memory leak. --GSAR */
+ if (!CvANON(cv) || CvCLONED(cv))
SvREFCNT_dec(CvOUTSIDE(cv));
- }
CvOUTSIDE(cv) = Nullcv;
if (CvCONST(cv)) {
SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
else
sv_catpv(msg, "none");
- Perl_warner(aTHX_ WARN_PROTOTYPE, "%"SVf, msg);
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, msg);
}
}
static void const_sv_xsub(pTHX_ CV* cv);
/*
+
+=head1 Optree Manipulation Functions
+
=for apidoc cv_const_sv
If C<cv> is a constant sub eligible for inlining. returns the constant
name = o ? SvPVx(cSVOPo->op_sv, n_a) : Nullch;
if (!name && PERLDB_NAMEANON && CopLINE(PL_curcop)) {
SV *sv = sv_newmortal();
- Perl_sv_setpvf(aTHX_ sv, "__ANON__[%s:%"IVdf"]",
+ Perl_sv_setpvf(aTHX_ sv, "%s[%s:%"IVdf"]",
+ PL_curstash ? "__ANON__" : "__ANON__::__ANON__",
CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
aname = SvPVX(sv);
}
else
aname = Nullch;
- gv = gv_fetchpv(name ? name : (aname ? aname : "__ANON__"),
+ gv = gv_fetchpv(name ? name : (aname ? aname :
+ (PL_curstash ? "__ANON__" : "__ANON__::__ANON__")),
GV_ADDMULTI | ((block || attrs) ? 0 : GV_NOINIT),
SVt_PVCV);
if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)
&& ckWARN_d(WARN_PROTOTYPE))
{
- Perl_warner(aTHX_ WARN_PROTOTYPE, "Runaway prototype");
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "Runaway prototype");
}
cv_ckproto((CV*)gv, NULL, ps);
}
/* already defined (or promised)? */
if (exists || GvASSUMECV(gv)) {
if (!block && !attrs) {
+ if (CvFLAGS(PL_compcv)) {
+ /* might have had built-in attrs applied */
+ CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
+ }
/* just a "sub foo;" when &foo is already defined */
SAVEFREESV(PL_compcv);
goto done;
line_t oldline = CopLINE(PL_curcop);
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ WARN_REDEFINE,
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
CvCONST(cv) ? "Constant subroutine %s redefined"
: "Subroutine %s redefined", name);
CopLINE_set(PL_curcop, oldline);
*/
if (cv && !block) {
rcv = (SV*)cv;
+ /* Might have had built-in attributes applied -- propagate them. */
+ CvFLAGS(cv) |= (CvFLAGS(PL_compcv) & CVf_BUILTIN_ATTRS);
if (CvGV(cv) && GvSTASH(CvGV(cv)))
stash = GvSTASH(CvGV(cv));
else if (CvSTASH(cv))
else
stash = PL_curstash;
}
- apply_attrs(stash, rcv, attrs);
+ apply_attrs(stash, rcv, attrs, FALSE);
}
if (cv) { /* must reuse cv if autoloaded */
if (!block) {
}
}
- /* If a potential closure prototype, don't keep a refcount on
- * outer CV, unless the latter happens to be a passing eval"".
+ /* If a potential closure prototype, don't keep a refcount on outer CV.
* This is okay as the lifetime of the prototype is tied to the
* lifetime of the outer CV. Avoids memory leak due to reference
* loop. --GSAR */
- if (!name && CvOUTSIDE(cv)
- && !(SvTYPE(CvOUTSIDE(cv)) == SVt_PVCV
- && CvEVAL(CvOUTSIDE(cv)) && !CvGV(CvOUTSIDE(cv))))
- {
+ if (!name)
SvREFCNT_dec(CvOUTSIDE(cv));
- }
if (name || aname) {
char *s;
ENTER;
SAVECOPFILE(&PL_compiling);
SAVECOPLINE(&PL_compiling);
- save_svref(&PL_rs);
- sv_setsv(PL_rs, PL_nrs);
if (!PL_beginav)
PL_beginav = newAV();
call_list(oldscope, PL_beginav);
PL_curcop = &PL_compiling;
- PL_compiling.op_private = PL_hints;
+ PL_compiling.op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
LEAVE;
}
else if (strEQ(s, "END") && !PL_error_count) {
PL_checkav = newAV();
DEBUG_x( dump_sub(gv) );
if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
av_unshift(PL_checkav, 1);
av_store(PL_checkav, 0, (SV*)cv);
GvCV(gv) = 0; /* cv has been hijacked */
PL_initav = newAV();
DEBUG_x( dump_sub(gv) );
if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
av_push(PL_initav, (SV*)cv);
GvCV(gv) = 0; /* cv has been hijacked */
}
SAVESPTR(PL_curstash);
SAVECOPSTASH(PL_curcop);
PL_curstash = stash;
-#ifdef USE_ITHREADS
- CopSTASHPV(PL_curcop) = stash ? HvNAME(stash) : Nullch;
-#else
- CopSTASH(PL_curcop) = stash;
-#endif
+ CopSTASH_set(PL_curcop,stash);
}
cv = newXS(name, const_sv_xsub, __FILE__);
CV *
Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename)
{
- GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV);
+ GV *gv = gv_fetchpv(name ? name :
+ (PL_curstash ? "__ANON__" : "__ANON__::__ANON__"),
+ GV_ADDMULTI, SVt_PVCV);
register CV *cv;
if ((cv = (name ? GvCV(gv) : Nullcv))) {
line_t oldline = CopLINE(PL_curcop);
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ WARN_REDEFINE,
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
CvCONST(cv) ? "Constant subroutine %s redefined"
: "Subroutine %s redefined"
,name);
if (!PL_checkav)
PL_checkav = newAV();
if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ WARN_VOID, "Too late to run CHECK block");
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run CHECK block");
av_unshift(PL_checkav, 1);
av_store(PL_checkav, 0, (SV*)cv);
GvCV(gv) = 0; /* cv has been hijacked */
if (!PL_initav)
PL_initav = newAV();
if (PL_main_start && ckWARN(WARN_VOID))
- Perl_warner(aTHX_ WARN_VOID, "Too late to run INIT block");
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "Too late to run INIT block");
av_push(PL_initav, (SV*)cv);
GvCV(gv) = 0; /* cv has been hijacked */
}
line_t oldline = CopLINE(PL_curcop);
if (PL_copline != NOLINE)
CopLINE_set(PL_curcop, PL_copline);
- Perl_warner(aTHX_ WARN_REDEFINE, "Format %s redefined",name);
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE), "Format %s redefined",name);
CopLINE_set(PL_curcop, oldline);
}
SvREFCNT_dec(cv);
o->op_type = OP_PADAV;
o->op_ppaddr = PL_ppaddr[OP_PADAV];
return ref(o, OP_RV2AV);
-
+
case OP_RV2SV:
o->op_type = OP_RV2AV;
o->op_ppaddr = PL_ppaddr[OP_RV2AV];
default:
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV");
break;
}
return o;
default:
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsHV");
break;
}
return o;
}
else if ((o->op_type == OP_RV2AV || o->op_type == OP_PADAV)
&& ckWARN(WARN_DEPRECATED)) {
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
"Using an array as a reference is deprecated");
}
return newUNOP(OP_RV2AV, 0, scalar(o));
}
else if ((o->op_type == OP_RV2HV || o->op_type == OP_PADHV)
&& ckWARN(WARN_DEPRECATED)) {
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ Perl_warner(aTHX_ packWARN(WARN_DEPRECATED),
"Using a hash as a reference is deprecated");
}
return newUNOP(OP_RV2HV, 0, scalar(o));
OP *
Perl_ck_bitop(pTHX_ OP *o)
{
- o->op_private = PL_hints;
+ o->op_private = (U8)(PL_hints & HINT_PRIVATE_MASK);
return o;
}
!(PL_opargs[newop->op_type] & OA_RETSCALAR) ||
newop->op_type == OP_PADAV || newop->op_type == OP_PADHV ||
newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) {
-
+
return o;
}
op_free(kUNOP->op_first);
}
OP *
+Perl_ck_die(pTHX_ OP *o)
+{
+#ifdef VMS
+ if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
+#endif
+ return ck_fun(o);
+}
+
+OP *
Perl_ck_eof(pTHX_ OP *o)
{
I32 type = o->op_type;
if (svp && *svp && SvTRUE(*svp))
o->op_private |= OPpEXIT_VMSISH;
}
+ if (VMSISH_HUSHED) o->op_private |= OPpHUSH_VMSISH;
#endif
return ck_fun(o);
}
case OA_AVREF:
if ((type == OP_PUSH || type == OP_UNSHIFT)
&& !kid->op_sibling && ckWARN(WARN_SYNTAX))
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"Useless use of %s with no values",
PL_op_desc[type]);
-
+
if (kid->op_type == OP_CONST &&
(kid->op_private & OPpCONST_BARE))
{
char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
OP *newop = newAVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVAV) ));
- if (ckWARN(WARN_DEPRECATED))
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Array @%s missing the @ in argument %"IVdf" of %s()",
name, (IV)numargs, PL_op_desc[type]);
op_free(kid);
char *name = SvPVx(((SVOP*)kid)->op_sv, n_a);
OP *newop = newHVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVHV) ));
- if (ckWARN(WARN_DEPRECATED))
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX))
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"Hash %%%s missing the %% in argument %"IVdf" of %s()",
name, (IV)numargs, PL_op_desc[type]);
op_free(kid);
OP *newop = newGVOP(OP_GV, 0,
gv_fetchpv(SvPVx(((SVOP*)kid)->op_sv, n_a), TRUE,
SVt_PVIO) );
+ if (!(o->op_private & 1) && /* if not unop */
+ kid == cLISTOPo->op_last)
+ cLISTOPo->op_last = newop;
op_free(kid);
kid = 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)) && GvIMPORTED_CV(gv)))
+ if (!((gv = gv_fetchpv("glob", FALSE, SVt_PVCV))
+ && GvCVu(gv) && GvIMPORTED_CV(gv)))
+ {
gv = gv_fetchpv("CORE::GLOBAL::glob", FALSE, SVt_PVCV);
+ }
#if !defined(PERL_EXTERNAL_GLOB)
/* XXX this can be tightened up and made more failsafe. */
if (!gv) {
GV *glob_gv;
ENTER;
- Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn("File::Glob", 10), Nullsv,
- Nullsv, Nullsv);
+ 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);
GvCV(gv) = GvCV(glob_gv);
}
#endif /* PERL_EXTERNAL_GLOB */
- if (gv && GvIMPORTED_CV(gv)) {
+ if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
append_elem(OP_GLOB, o,
newSVOP(OP_CONST, 0, newSViv(PL_glob_index++)));
o->op_type = OP_LIST;
OP *
Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */
{
- if ((o->op_flags & OPf_KIDS) && ckWARN(WARN_DEPRECATED)) {
+ if ((o->op_flags & OPf_KIDS) && ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) {
switch (cUNOPo->op_first->op_type) {
case OP_RV2AV:
/* This is needed for
break; /* Globals via GV can be undef */
case OP_PADAV:
case OP_AASSIGN: /* Is this a good idea? */
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"defined(@array) is deprecated");
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"\t(Maybe you should just omit the defined()?)\n");
break;
case OP_RV2HV:
*/
break; /* Globals via GV can be undef */
case OP_PADHV:
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"defined(%%hash) is deprecated");
- Perl_warner(aTHX_ WARN_DEPRECATED,
+ Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX),
"\t(Maybe you should just omit the defined()?)\n");
break;
default:
kid = kid->op_sibling;
}
}
-
+
if (!kid)
append_elem(o->op_type, o, newDEFSVOP());
/* handle override, if any */
gv = gv_fetchpv("require", FALSE, SVt_PVCV);
- if (!(gv && GvIMPORTED_CV(gv)))
+ if (!(gv && GvCVu(gv) && GvIMPORTED_CV(gv)))
gv = gv_fetchpv("CORE::GLOBAL::require", FALSE, SVt_PVCV);
- if (gv && GvIMPORTED_CV(gv)) {
+ if (gv && GvCVu(gv) && GvIMPORTED_CV(gv)) {
OP *kid = cUNOPo->op_first;
cUNOPo->op_first = 0;
op_free(o);
if (!(o->op_flags & OPf_KIDS)) {
OP *argop;
-
+
op_free(o);
#ifdef USE_5005THREADS
if (!CvUNIQUE(PL_compcv)) {
kid->op_type = OP_PUSHRE;
kid->op_ppaddr = PL_ppaddr[OP_PUSHRE];
scalar(kid);
+ if (ckWARN(WARN_REGEXP) && ((PMOP *)kid)->op_pmflags & PMf_GLOBAL) {
+ Perl_warner(aTHX_ packWARN(WARN_REGEXP),
+ "Use of /g modifier is meaningless in split");
+ }
if (!kid->op_sibling)
append_elem(OP_SPLIT, o, newDEFSVOP());
char *pmstr = "STRING";
if (PM_GETRE(kPMOP))
pmstr = PM_GETRE(kPMOP)->precomp;
- Perl_warner(aTHX_ WARN_SYNTAX,
+ Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
"/%s/ should probably be written as \"%s\"",
pmstr, pmstr);
}
int optional = 0;
I32 arg = 0;
I32 contextclass = 0;
- char *e;
+ char *e = 0;
STRLEN n_a;
o->op_private |= OPpENTERSUB_HASTARG;
goto again;
break;
case ']':
- if (contextclass)
- contextclass = 0;
- else
+ if (contextclass) {
+ char *p = proto;
+ char s = *p;
+ contextclass = 0;
+ *p = '\0';
+ while (*--p != '[');
+ bad_type(arg, Perl_form(aTHX_ "one of %s", p),
+ gv_ename(namegv), o2);
+ *proto = s;
+ } else
goto oops;
break;
case '*':
else if (o->op_next->op_type == OP_RV2AV) {
OP* pop = o->op_next->op_next;
IV i;
- if (pop->op_type == OP_CONST &&
+ if (pop && pop->op_type == OP_CONST &&
(PL_op = pop->op_next) &&
pop->op_next->op_type == OP_AELEM &&
!(pop->op_next->op_private &
/* XXX could check prototype here instead of just carping */
SV *sv = sv_newmortal();
gv_efullname3(sv, gv, Nullch);
- Perl_warner(aTHX_ WARN_PROTOTYPE,
+ Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE),
"%s() called too early to check prototype",
SvPV_nolen(sv));
}
&& o->op_next->op_next->op_type == OP_CONCAT
&& (o->op_next->op_next->op_flags & OPf_STACKED))
{
- /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010811 */
- o->op_next->op_type = OP_RCATLINE;
- o->op_next->op_flags |= OPf_STACKED;
+ /* Turn "$a .= <FH>" into an OP_RCATLINE. AMS 20010917 */
+ o->op_type = OP_RCATLINE;
+ o->op_flags |= OPf_STACKED;
+ o->op_ppaddr = PL_ppaddr[OP_RCATLINE];
op_null(o->op_next->op_next);
+ op_null(o->op_next);
}
o->op_seq = PL_op_seqmax++;
line_t oldline = CopLINE(PL_curcop);
CopLINE_set(PL_curcop, CopLINE((COP*)o->op_next));
- Perl_warner(aTHX_ WARN_EXEC,
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
"Statement unlikely to be reached");
- Perl_warner(aTHX_ WARN_EXEC,
+ Perl_warner(aTHX_ packWARN(WARN_EXEC),
"\t(Maybe you meant system() when you said exec()?)\n");
CopLINE_set(PL_curcop, oldline);
}
}
break;
-
+
case OP_HELEM: {
UNOP *rop;
SV *lexname;
I32 ind;
char *key = NULL;
STRLEN keylen;
-
+
o->op_seq = PL_op_seqmax++;
if (((BINOP*)o)->op_last->op_type != OP_CONST)
*svp = sv;
break;
}
-
+
case OP_HSLICE: {
UNOP *rop;
SV *lexname;
LEAVE;
}
-#ifdef PERL_CUSTOM_OPS
-char* custom_op_name(pTHX_ OP* o)
+
+
+char* Perl_custom_op_name(pTHX_ OP* o)
{
IV index = PTR2IV(o->op_ppaddr);
SV* keysv;
return SvPV_nolen(HeVAL(he));
}
-char* custom_op_desc(pTHX_ OP* o)
+char* Perl_custom_op_desc(pTHX_ OP* o)
{
IV index = PTR2IV(o->op_ppaddr);
SV* keysv;
return SvPV_nolen(HeVAL(he));
}
-#endif
+
#include "XSUB.h"
ST(0) = (SV*)XSANY.any_ptr;
XSRETURN(1);
}
-
https://perl5.git.perl.org / perl5.git / blobdiff