/* 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)
+
+#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
-#if defined(PL_OP_SLAB_ALLOC) && !defined(PERL_IMPLICIT_CONTEXT)
-#define SLAB_SIZE 8192
-static char *PL_OpPtr = NULL; /* XXX threadead */
-static int PL_OpSpace = 0; /* XXX threadead */
-#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)
+#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. */
if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) {
SvPADTMP_off(PL_curpad[po]);
#ifdef USE_ITHREADS
- SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
+#ifdef PERL_COPY_ON_WRITE
+ if (SvIsCOW(PL_curpad[po])) {
+ sv_force_normal_flags(PL_curpad[po], SV_COW_DROP_PV);
+ } else
+#endif
+ SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */
#endif
}
if ((I32)po < PL_padix)
}
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
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:
break;
case OP_SORT:
if (ckWARN(WARN_VOID))
- Perl_warner(aTHX_ WARN_VOID, "Useless use of sort in scalar context");
+ Perl_warner(aTHX_ packWARN(WARN_VOID), "Useless use of sort in scalar context");
}
return o;
}
case OP_OR:
case OP_AND:
+ case OP_DOR:
case OP_COND_EXPR:
for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling)
scalarvoid(kid);
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;
}
|| kid->op_type == OP_METHOD)
{
UNOP *newop;
-
+
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 "
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:%"UVuf,
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_AASSIGN:
case OP_NEXTSTATE:
case OP_DBSTATE:
- case OP_CHOMP:
PL_modcount = RETURN_UNLIMITED_NUMBER;
break;
case OP_RV2SV:
case OP_SASSIGN:
case OP_ANDASSIGN:
case OP_ORASSIGN:
+ case OP_DORASSIGN:
case OP_AELEMFAST:
PL_modcount++;
break;
case OP_PUSHMARK:
break;
-
+
case OP_KEYS:
if (type != OP_SASSIGN)
goto nomod;
} 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;
- PL_in_my_stash = Nullhv;
- apply_attrs(GvSTASH(gv),
- (type == OP_RV2SV ? GvSV(gv) :
- type == OP_RV2AV ? (SV*)GvAV(gv) :
- type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
- attrs, FALSE);
- }
+ if (cUNOPo->op_first->op_type != OP_GV) { /* MJD 20011224 */
+ yyerror(Perl_form(aTHX_ "Can't declare %s in %s",
+ OP_DESC(o), PL_in_my == KEY_our ? "our" : "my"));
+ } else if (attrs) {
+ GV *gv = cGVOPx_gv(cUNOPo->op_first);
+ PL_in_my = FALSE;
+ PL_in_my_stash = Nullhv;
+ apply_attrs(GvSTASH(gv),
+ (type == OP_RV2SV ? GvSV(gv) :
+ type == OP_RV2AV ? (SV*)GvAV(gv) :
+ type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
+ attrs, FALSE);
+ }
o->op_private |= OPpOUR_INTRO;
return o;
}
OP *rops = Nullop;
int maybe_scalar = 0;
+/* [perl #17376]: this appears to be premature, and results in code such as
+ C< my(%x); > executing in list mode rather than void mode */
+#if 0
if (o->op_flags & OPf_PARENS)
list(o);
else
maybe_scalar = 1;
+#else
+ maybe_scalar = 1;
+#endif
if (attrs)
SAVEFREEOP(attrs);
o = my_kid(o, attrs, &rops);
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);
}
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);
Perl_localize(pTHX_ OP *o, I32 lex)
{
if (o->op_flags & OPf_PARENS)
+/* [perl #17376]: this appears to be premature, and results in code such as
+ C< our(%x); > executing in list mode rather than void mode */
+#if 0
list(o);
+#else
+ ;
+#endif
else {
if (ckWARN(WARN_PARENTHESIS)
&& PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
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;
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];
}
}
}
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) || (PL_hints & HINT_UTF8))
+ 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))
op_free(expr);
}
else {
- if (PL_hints & HINT_UTF8)
- pm->op_pmdynflags |= PMdf_UTF8;
if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL))
expr = newUNOP((!(PL_hints & HINT_RE_EVAL)
? OP_REGCRESET
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)
void
Perl_package(pTHX_ OP *o)
{
- SV *sv;
+ char *name;
+ STRLEN len;
save_hptr(&PL_curstash);
save_item(PL_curstname);
- if (o) {
- STRLEN len;
- char *name;
- sv = cSVOPo->op_sv;
- name = SvPV(sv, len);
- PL_curstash = gv_stashpvn(name,len,TRUE);
- sv_setpvn(PL_curstname, name, len);
- op_free(o);
- }
- else {
- deprecate("\"package\" with no arguments");
- sv_setpv(PL_curstname,"<none>");
- PL_curstash = Nullhv;
- }
+
+ name = SvPV(cSVOPo->op_sv, len);
+ PL_curstash = gv_stashpvn(name, len, TRUE);
+ sv_setpvn(PL_curstname, name, len);
+ op_free(o);
+
PL_hints |= HINT_BLOCK_SCOPE;
PL_copline = NOLINE;
PL_expect = XSTATE;
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);;
+ 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));
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.
OP *o;
if (optype) {
- if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN) {
+ if (optype == OP_ANDASSIGN || optype == OP_ORASSIGN || optype == OP_DORASSIGN) {
return newLOGOP(optype, 0,
mod(scalar(left), optype),
newUNOP(OP_SASSIGN, 0, scalar(right)));
}
curop = list(force_list(left));
o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop);
- o->op_private = 0 | (flags >> 8);
- for (curop = ((LISTOP*)curop)->op_first;
- curop; curop = curop->op_sibling)
- {
- if (curop->op_type == OP_RV2HV &&
- ((UNOP*)curop)->op_first->op_type != OP_GV) {
- o->op_private |= OPpASSIGN_HASH;
- break;
- }
- }
+ o->op_private = (U8)(0 | (flags >> 8));
if (!(left->op_private & OPpLVAL_INTRO)) {
OP *lastop = o;
PL_generation++;
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
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;
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 ) {
+ if (svp && *svp != &PL_sv_undef ) {
(void)SvIOK_on(*svp);
SvIVX(*svp) = PTR2IV(cop);
- }
+ }
}
return prepend_elem(OP_LINESEQ, (OP*)cop, o);
}
}
if (first->op_type == OP_CONST) {
- if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE))
- Perl_warner(aTHX_ WARN_BAREWORD, "Bareword found in conditional");
+ if (ckWARN(WARN_BAREWORD) && (first->op_private & OPpCONST_BARE)) {
+ if (first->op_private & OPpCONST_STRICT)
+ no_bareword_allowed(first);
+ else
+ Perl_warner(aTHX_ packWARN(WARN_BAREWORD), "Bareword found in conditional");
+ }
if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
op_free(first);
*firstp = Nullop;
return first;
}
}
- else if (first->op_type == OP_WANTARRAY) {
- if (type == OP_AND)
- list(other);
- else
- scalar(other);
- }
else if (ckWARN(WARN_MISC) && (first->op_flags & OPf_KIDS)) {
OP *k1 = ((UNOP*)first)->op_first;
OP *k2 = k1->op_sibling;
|| 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)
if (!other)
return first;
- if (type == OP_ANDASSIGN || type == OP_ORASSIGN)
+ if (type == OP_ANDASSIGN || type == OP_ORASSIGN || type == OP_DORASSIGN)
other->op_private |= OPpASSIGN_BACKWARDS; /* other is an OP_SASSIGN */
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);
scalarboolean(first);
if (first->op_type == OP_CONST) {
+ if (first->op_private & OPpCONST_BARE &&
+ first->op_private & OPpCONST_STRICT) {
+ no_bareword_allowed(first);
+ }
if (SvTRUE(((SVOP*)first)->op_sv)) {
op_free(first);
op_free(falseop);
return falseop;
}
}
- else if (first->op_type == OP_WANTARRAY) {
- list(trueop);
- scalar(falseop);
- }
NewOp(1101, logop, 1, LOGOP);
logop->op_type = OP_COND_EXPR;
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;
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
void
Perl_cv_undef(pTHX_ CV *cv)
{
+ CV *outsidecv;
+ CV *freecv = Nullcv;
+ bool is_eval = CvEVAL(cv) && !CvGV(cv); /* is this eval"" ? */
+
#ifdef USE_5005THREADS
if (CvMUTEXP(cv)) {
MUTEX_DESTROY(CvMUTEXP(cv));
}
SvPOK_off((SV*)cv); /* forget prototype */
CvGV(cv) = Nullgv;
+ outsidecv = CvOUTSIDE(cv);
/* Since closure prototypes have the same lifetime as the containing
* 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. --GSAR */
if (!CvANON(cv) || CvCLONED(cv))
- SvREFCNT_dec(CvOUTSIDE(cv));
+ freecv = outsidecv;
CvOUTSIDE(cv) = Nullcv;
if (CvCONST(cv)) {
SvREFCNT_dec((SV*)CvXSUBANY(cv).any_ptr);
if (CvPADLIST(cv)) {
/* may be during global destruction */
if (SvREFCNT(CvPADLIST(cv))) {
- I32 i = AvFILLp(CvPADLIST(cv));
- while (i >= 0) {
- SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
- SV* sv = svp ? *svp : Nullsv;
+ AV *padlist = CvPADLIST(cv);
+ I32 ix;
+ /* pads may be cleared out already during global destruction */
+ if ((is_eval && !PL_dirty) || CvSPECIAL(cv)) {
+ /* inner references to eval's cv must be fixed up */
+ AV *comppad_name = (AV*)AvARRAY(padlist)[0];
+ AV *comppad = (AV*)AvARRAY(padlist)[1];
+ SV **namepad = AvARRAY(comppad_name);
+ SV **curpad = AvARRAY(comppad);
+ for (ix = AvFILLp(comppad_name); ix > 0; ix--) {
+ SV *namesv = namepad[ix];
+ if (namesv && namesv != &PL_sv_undef
+ && *SvPVX(namesv) == '&'
+ && ix <= AvFILLp(comppad))
+ {
+ CV *innercv = (CV*)curpad[ix];
+ if (innercv && SvTYPE(innercv) == SVt_PVCV
+ && CvOUTSIDE(innercv) == cv)
+ {
+ CvOUTSIDE(innercv) = outsidecv;
+ if (!CvANON(innercv) || CvCLONED(innercv)) {
+ (void)SvREFCNT_inc(outsidecv);
+ if (SvREFCNT(cv))
+ SvREFCNT_dec(cv);
+ }
+ }
+ }
+ }
+ }
+ if (freecv)
+ SvREFCNT_dec(freecv);
+ ix = AvFILLp(padlist);
+ while (ix >= 0) {
+ SV* sv = AvARRAY(padlist)[ix--];
if (!sv)
continue;
if (sv == (SV*)PL_comppad_name)
}
CvPADLIST(cv) = Nullav;
}
+ else if (freecv)
+ SvREFCNT_dec(freecv);
if (CvXSUB(cv)) {
CvXSUB(cv) = 0;
}
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))
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 (!subaddr)
+ Perl_croak(aTHX_ "panic: no address for '%s' in '%s'", name, filename);
+
if ((cv = (name ? GvCV(gv) : Nullcv))) {
if (GvCVGEN(gv)) {
/* just a cached method */
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);
badtype = "an ARRAY";
break;
case OP_RV2HV:
- if (svtype != SVt_PVHV) {
- if (svtype == SVt_PVAV) { /* pseudohash? */
- SV **ksv = av_fetch((AV*)rsv, 0, FALSE);
- if (ksv && SvROK(*ksv)
- && SvTYPE(SvRV(*ksv)) == SVt_PVHV)
- {
- break;
- }
- }
+ if (svtype != SVt_PVHV)
badtype = "a HASH";
- }
break;
case OP_RV2CV:
if (svtype != SVt_PVCV)
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 (!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);
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());
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);
}
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 '*':
Perl_peep(pTHX_ register OP *o)
{
register OP* oldop = 0;
- STRLEN n_a;
if (!o || o->op_seq)
return;
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));
}
case OP_GREPWHILE:
case OP_AND:
case OP_OR:
+ case OP_DOR:
case OP_ANDASSIGN:
case OP_ORASSIGN:
+ case OP_DORASSIGN:
case OP_COND_EXPR:
case OP_RANGE:
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;
- GV **fields;
- SV **svp, **indsvp, *sv;
- I32 ind;
+ SV *lexname;
+ SV **svp, *sv;
char *key = NULL;
STRLEN keylen;
-
+
o->op_seq = PL_op_seqmax++;
if (((BINOP*)o)->op_last->op_type != OP_CONST)
SvREFCNT_dec(sv);
*svp = lexname;
}
-
- if ((o->op_private & (OPpLVAL_INTRO)))
- break;
-
- rop = (UNOP*)((BINOP*)o)->op_first;
- if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
- break;
- 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);
- if (!fields || !GvHV(*fields))
- break;
- key = SvPV(*svp, keylen);
- indsvp = hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
- if (!indsvp) {
- Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" in variable %s of type %s",
- key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
- }
- ind = SvIV(*indsvp);
- if (ind < 1)
- Perl_croak(aTHX_ "Bad index while coercing array into hash");
- rop->op_type = OP_RV2AV;
- rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
- o->op_type = OP_AELEM;
- o->op_ppaddr = PL_ppaddr[OP_AELEM];
- sv = newSViv(ind);
- if (SvREADONLY(*svp))
- SvREADONLY_on(sv);
- SvFLAGS(sv) |= (SvFLAGS(*svp)
- & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
- SvREFCNT_dec(*svp);
- *svp = sv;
- break;
- }
-
- case OP_HSLICE: {
- UNOP *rop;
- SV *lexname;
- GV **fields;
- SV **svp, **indsvp, *sv;
- I32 ind;
- char *key;
- STRLEN keylen;
- SVOP *first_key_op, *key_op;
-
- o->op_seq = PL_op_seqmax++;
- if ((o->op_private & (OPpLVAL_INTRO))
- /* I bet there's always a pushmark... */
- || ((LISTOP*)o)->op_first->op_sibling->op_type != OP_LIST)
- /* hmmm, no optimization if list contains only one key. */
- break;
- rop = (UNOP*)((LISTOP*)o)->op_last;
- if (rop->op_type != OP_RV2HV || rop->op_first->op_type != OP_PADSV)
- break;
- 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);
- if (!fields || !GvHV(*fields))
- break;
- /* Again guessing that the pushmark can be jumped over.... */
- first_key_op = (SVOP*)((LISTOP*)((LISTOP*)o)->op_first->op_sibling)
- ->op_first->op_sibling;
- /* Check that the key list contains only constants. */
- for (key_op = first_key_op; key_op;
- key_op = (SVOP*)key_op->op_sibling)
- if (key_op->op_type != OP_CONST)
- break;
- if (key_op)
- break;
- rop->op_type = OP_RV2AV;
- rop->op_ppaddr = PL_ppaddr[OP_RV2AV];
- o->op_type = OP_ASLICE;
- o->op_ppaddr = PL_ppaddr[OP_ASLICE];
- for (key_op = first_key_op; key_op;
- key_op = (SVOP*)key_op->op_sibling) {
- svp = cSVOPx_svp(key_op);
- key = SvPV(*svp, keylen);
- indsvp = hv_fetch(GvHV(*fields), key,
- SvUTF8(*svp) ? -(I32)keylen : keylen, FALSE);
- if (!indsvp) {
- Perl_croak(aTHX_ "No such pseudo-hash field \"%s\" "
- "in variable %s of type %s",
- key, SvPV(lexname, n_a), HvNAME(SvSTASH(lexname)));
- }
- ind = SvIV(*indsvp);
- if (ind < 1)
- Perl_croak(aTHX_ "Bad index while coercing array into hash");
- sv = newSViv(ind);
- if (SvREADONLY(*svp))
- SvREADONLY_on(sv);
- SvFLAGS(sv) |= (SvFLAGS(*svp)
- & (SVs_PADBUSY|SVs_PADTMP|SVs_PADMY));
- SvREFCNT_dec(*svp);
- *svp = sv;
- }
- break;
- }
+ break;
+ }
default:
o->op_seq = PL_op_seqmax++;
ST(0) = (SV*)XSANY.any_ptr;
XSRETURN(1);
}
-
https://perl5.git.perl.org / perl5.git / blobdiff