*/
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) {
+ PL_OpPtr = (I32 **) PerlMemShared_malloc(PERL_SLAB_SIZE*sizeof(I32*));
+ if (!PL_OpPtr) {
return NULL;
}
Zero(PL_OpPtr,PERL_SLAB_SIZE,I32 **);
assert( ptr < ( (I32 **) slab + PERL_SLAB_SIZE) );
assert( *slab > 0 );
if (--(*slab) == 0) {
- PerlMemShared_free(slab);
+ #ifdef NETWARE
+ #define PerlMemShared PerlMem
+ #endif
+
+ PerlMemShared_free(slab);
if (slab == PL_OpSlab) {
PL_OpSpace = 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;
}
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 (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. */
SvREFCNT_dec(cop->cop_warnings);
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);
+ Perl_warn(aTHX_ "io='%.*s'",(int) len,s); /* ??? --jhi */
+#endif
#else
SvREFCNT_dec(cop->cop_io);
#endif
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_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;
}
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);
}
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);
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);
- }
+ /* 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.
+ */
safefree(packname);
}
}
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;
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)
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))
- freecv = outsidecv;
+ SvREFCNT_dec(CvOUTSIDE(cv));
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))) {
- AV *padlist = CvPADLIST(cv);
- I32 ix;
- if (is_eval) {
- /* 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--];
+ I32 i = AvFILLp(CvPADLIST(cv));
+ while (i >= 0) {
+ SV** svp = av_fetch(CvPADLIST(cv), i--, FALSE);
+ SV* sv = svp ? *svp : Nullsv;
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);
}
}
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);
}
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);
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 */
}
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);
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));
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]);
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 *
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:
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);
}
/* 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));
}
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);
}
projects / p5sagit/p5-mst-13.2.git / blobdiff