X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=c755d1142ef04aaf6837752e96c0a83236fdf3e0;hb=eae1b76ba3ec9dc0fc5d6f1630cae5bff9a78c81;hp=e68e4317fdabf87bb6a18f4f32dce9ba3ee444cf;hpb=9e53291561fb0b9587025e8b98535441b489e207;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index e68e431..c755d11 100644 --- a/op.c +++ b/op.c @@ -45,8 +45,8 @@ S_Slab_Alloc(pTHX_ int m, size_t sz) */ 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 **); @@ -82,7 +82,11 @@ S_Slab_Free(pTHX_ void *op) 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; } @@ -199,7 +203,7 @@ Perl_pad_allocmy(pTHX_ char *name) || ((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, @@ -216,9 +220,9 @@ Perl_pad_allocmy(pTHX_ char *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; } @@ -359,7 +363,7 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, 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); } @@ -372,7 +376,7 @@ S_pad_findlex(pTHX_ char *name, PADOFFSET newoff, U32 seq, CV* startcv, 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); } } @@ -509,7 +513,7 @@ Perl_pad_leavemy(pTHX_ I32 fill) 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. */ @@ -925,9 +929,11 @@ S_cop_free(pTHX_ COP* cop) 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 @@ -993,7 +999,7 @@ S_scalarboolean(pTHX_ OP *o) 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); } } @@ -1027,7 +1033,7 @@ Perl_scalar(pTHX_ OP *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 @_"); } /* FALL THROUGH */ case OP_MATCH: @@ -1065,7 +1071,7 @@ Perl_scalar(pTHX_ OP *o) 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; } @@ -1274,12 +1280,12 @@ Perl_scalarvoid(pTHX_ OP *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; } @@ -1487,7 +1493,7 @@ Perl_mod(pTHX_ OP *o, I32 type) || kid->op_type == OP_METHOD) { UNOP *newop; - + NewOp(1101, newop, 1, UNOP); newop->op_type = OP_RV2CV; newop->op_ppaddr = PL_ppaddr[OP_RV2CV]; @@ -1497,7 +1503,7 @@ Perl_mod(pTHX_ OP *o, I32 type) newop->op_private |= OPpLVAL_INTRO; break; } - + if (kid->op_type != OP_RV2CV) Perl_croak(aTHX_ "panic: unexpected lvalue entersub " @@ -1506,12 +1512,12 @@ Perl_mod(pTHX_ OP *o, I32 type) 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, @@ -1531,7 +1537,7 @@ Perl_mod(pTHX_ OP *o, I32 type) okid->op_private |= OPpLVAL_INTRO; break; } - + cv = GvCV(kGVOP_gv); if (!cv) goto restore_2cv; @@ -1578,7 +1584,7 @@ Perl_mod(pTHX_ OP *o, I32 type) goto nomod; PL_modcount++; break; - + case OP_COND_EXPR: for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) mod(kid, type); @@ -1649,7 +1655,7 @@ Perl_mod(pTHX_ OP *o, I32 type) case OP_PUSHMARK: break; - + case OP_KEYS: if (type != OP_SASSIGN) goto nomod; @@ -2184,7 +2190,7 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right) 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); } @@ -2380,7 +2386,7 @@ Perl_localize(pTHX_ OP *o, I32 lex) 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"); } @@ -2498,30 +2504,6 @@ Perl_fold_constants(pTHX_ register OP *o) } 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; } @@ -2546,6 +2528,7 @@ Perl_gen_constant_list(pTHX_ register OP *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); @@ -3474,11 +3457,22 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg) 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); } @@ -3714,7 +3708,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (gv == PL_defgv || SvCUR(gv) == PL_generation) break; SvCUR(gv) = PL_generation; - } + } } else break; @@ -3908,7 +3902,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) } 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; @@ -3955,7 +3949,7 @@ S_new_logop(pTHX_ I32 type, I32 flags, OP** firstp, OP** otherp) 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) @@ -4365,10 +4359,6 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) 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)); @@ -4404,14 +4394,13 @@ Perl_cv_undef(pTHX_ CV *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); @@ -4420,38 +4409,10 @@ Perl_cv_undef(pTHX_ CV *cv) 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) == '&') - { - 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) @@ -4466,8 +4427,6 @@ Perl_cv_undef(pTHX_ CV *cv) } CvPADLIST(cv) = Nullav; } - else if (freecv) - SvREFCNT_dec(freecv); if (CvXSUB(cv)) { CvXSUB(cv) = 0; } @@ -4698,7 +4657,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) 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); } } @@ -4813,13 +4772,15 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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); @@ -4836,7 +4797,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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); } @@ -4896,7 +4857,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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); @@ -5164,7 +5125,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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 */ @@ -5174,7 +5135,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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 */ } @@ -5237,7 +5198,9 @@ Used by C to hook up XSUBs as Perl subs. 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))) { @@ -5253,7 +5216,7 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) 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); @@ -5313,7 +5276,7 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) 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 */ @@ -5322,7 +5285,7 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) 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 */ } @@ -5359,7 +5322,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) 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); @@ -5421,7 +5384,7 @@ Perl_oopsAV(pTHX_ OP *o) 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]; @@ -5430,7 +5393,7 @@ Perl_oopsAV(pTHX_ OP *o) default: if (ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV"); + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "oops: oopsAV"); break; } return o; @@ -5455,7 +5418,7 @@ Perl_oopsHV(pTHX_ OP *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; @@ -5471,7 +5434,7 @@ Perl_newAVREF(pTHX_ OP *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)); @@ -5495,7 +5458,7 @@ Perl_newHVREF(pTHX_ OP *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)); @@ -5582,7 +5545,7 @@ Perl_ck_spair(pTHX_ OP *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); @@ -5946,18 +5909,18 @@ Perl_ck_fun(pTHX_ OP *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); @@ -5976,8 +5939,8 @@ Perl_ck_fun(pTHX_ OP *o) 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); @@ -6234,7 +6197,7 @@ Perl_ck_lfun(pTHX_ OP *o) 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 @@ -6244,9 +6207,9 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ 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: @@ -6256,9 +6219,9 @@ Perl_ck_defined(pTHX_ OP *o) /* 19990527 MJD */ */ 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: @@ -6299,7 +6262,7 @@ Perl_ck_listiob(pTHX_ OP *o) kid = kid->op_sibling; } } - + if (!kid) append_elem(o->op_type, o, newDEFSVOP()); @@ -6507,7 +6470,7 @@ Perl_ck_shift(pTHX_ OP *o) if (!(o->op_flags & OPf_KIDS)) { OP *argop; - + op_free(o); #ifdef USE_5005THREADS if (!CvUNIQUE(PL_compcv)) { @@ -6716,7 +6679,7 @@ Perl_ck_join(pTHX_ OP *o) 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); } @@ -7131,7 +7094,7 @@ Perl_peep(pTHX_ register OP *o) /* 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)); } @@ -7200,15 +7163,15 @@ Perl_peep(pTHX_ register OP *o) 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; @@ -7217,7 +7180,7 @@ Perl_peep(pTHX_ register OP *o) I32 ind; char *key = NULL; STRLEN keylen; - + o->op_seq = PL_op_seqmax++; if (((BINOP*)o)->op_last->op_type != OP_CONST) @@ -7269,7 +7232,7 @@ Perl_peep(pTHX_ register OP *o) *svp = sv; break; } - + case OP_HSLICE: { UNOP *rop; SV *lexname; @@ -7399,4 +7362,3 @@ const_sv_xsub(pTHX_ CV* cv) ST(0) = (SV*)XSANY.any_ptr; XSRETURN(1); } -