X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=op.c;h=92d0cfc6d020ba31579607921ff1234e51fbf675;hb=0aad8255c36187d555361d7ba536faee2da84e34;hp=03f54b131188c74a6c133da85aeea96a543a80fb;hpb=bfafaa29cebb5be440c3a86e7390b639134c6e78;p=p5sagit%2Fp5-mst-13.2.git diff --git a/op.c b/op.c index 03f54b1..92d0cfc 100644 --- a/op.c +++ b/op.c @@ -1,7 +1,7 @@ /* op.c * * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, by Larry Wall and others + * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -224,7 +224,7 @@ S_no_bareword_allowed(pTHX_ const OP *o) return; /* various ok barewords are hidden in extra OP_NULL */ qerror(Perl_mess(aTHX_ "Bareword \"%"SVf"\" not allowed while \"strict subs\" in use", - (void*)cSVOPo_sv)); + SVfARG(cSVOPo_sv))); } /* "register" allocation */ @@ -438,11 +438,18 @@ Perl_op_clear(pTHX_ OP *o) /* FALL THROUGH */ case OP_TRANS: if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) { +#ifdef USE_ITHREADS + if (cPADOPo->op_padix > 0) { + pad_swipe(cPADOPo->op_padix, TRUE); + cPADOPo->op_padix = 0; + } +#else SvREFCNT_dec(cSVOPo->op_sv); cSVOPo->op_sv = NULL; +#endif } else { - Safefree(cPVOPo->op_pv); + PerlMemShared_free(cPVOPo->op_pv); cPVOPo->op_pv = NULL; } break; @@ -514,19 +521,7 @@ clear_pmop: STATIC void S_cop_free(pTHX_ COP* cop) { - if (cop->cop_label) { -#ifdef PERL_TRACK_MEMPOOL - Malloc_t ptr = (Malloc_t)(cop->cop_label - sTHX); - struct perl_memory_debug_header *const header - = (struct perl_memory_debug_header *)ptr; - /* Only the thread that allocated us can free us. */ - if (header->interpreter == aTHX) -#endif - { - Safefree(cop->cop_label); - cop->cop_label = NULL; - } - } + CopLABEL_free(cop); CopFILE_free(cop); CopSTASH_free(cop); if (! specialWARN(cop->cop_warnings)) @@ -1563,10 +1558,6 @@ Perl_doref(pTHX_ OP *o, I32 type, bool set_op_ref) } break; - case OP_THREADSV: - o->op_flags |= OPf_MOD; /* XXX ??? */ - break; - case OP_RV2AV: case OP_RV2HV: if (set_op_ref) @@ -2072,7 +2063,8 @@ Perl_newPROG(pTHX_ OP *o) /* Register with debugger */ if (PERLDB_INTER) { - CV * const cv = get_cv("DB::postponed", FALSE); + CV * const cv + = Perl_get_cvn_flags(aTHX_ STR_WITH_LEN("DB::postponed"), 0); if (cv) { dSP; PUSHMARK(SP); @@ -2738,6 +2730,7 @@ Perl_newOP(pTHX_ I32 type, I32 flags) o->op_flags = (U8)flags; o->op_latefree = 0; o->op_latefreed = 0; + o->op_attached = 0; o->op_next = o; o->op_private = (U8)(0 | (flags >> 8)); @@ -2826,9 +2819,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) { dVAR; SV * const tstr = ((SVOP*)expr)->op_sv; - SV * const rstr = (repl->op_type == OP_NULL) - ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv - : ((SVOP*)repl)->op_sv; + SV * const rstr = +#ifdef PERL_MAD + (repl->op_type == OP_NULL) + ? ((SVOP*)((LISTOP*)repl)->op_first)->op_sv : +#endif + ((SVOP*)repl)->op_sv; STRLEN tlen; STRLEN rlen; const U8 *t = (U8*)SvPV_const(tstr, tlen); @@ -2841,6 +2837,7 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) const I32 complement = o->op_private & OPpTRANS_COMPLEMENT; const I32 squash = o->op_private & OPpTRANS_SQUASH; I32 del = o->op_private & OPpTRANS_DELETE; + SV* swash; PL_hints |= HINT_BLOCK_SCOPE; if (SvUTF8(tstr)) @@ -3034,14 +3031,23 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) else bits = 8; - Safefree(cPVOPo->op_pv); + PerlMemShared_free(cPVOPo->op_pv); cPVOPo->op_pv = NULL; - cSVOPo->op_sv = (SV*)swash_init("utf8", "", listsv, bits, none); + + swash = (SV*)swash_init("utf8", "", listsv, bits, none); +#ifdef USE_ITHREADS + cPADOPo->op_padix = pad_alloc(OP_TRANS, SVs_PADTMP); + SvREFCNT_dec(PAD_SVl(cPADOPo->op_padix)); + PAD_SETSV(cPADOPo->op_padix, swash); + SvPADTMP_on(swash); +#else + cSVOPo->op_sv = swash; +#endif SvREFCNT_dec(listsv); SvREFCNT_dec(transv); if (!del && havefinal && rlen) - (void)hv_store((HV*)SvRV((cSVOPo->op_sv)), "FINAL", 5, + (void)hv_store((HV*)SvRV(swash), "FINAL", 5, newSVuv((UV)final), 0); if (grows) @@ -3090,8 +3096,13 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl) } else if (j >= (I32)rlen) j = rlen - 1; - else - cPVOPo->op_pv = (char*)Renew(tbl, 0x101+rlen-j, short); + else { + tbl = + (short *) + PerlMemShared_realloc(tbl, + (0x101+rlen-j) * sizeof(short)); + cPVOPo->op_pv = (char*)tbl; + } tbl[0x100] = (short)(rlen - j); for (i=0; i < (I32)rlen - j; i++) tbl[0x101+i] = r[j+i]; @@ -3243,7 +3254,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) STRLEN plen; SV * const pat = ((SVOP*)expr)->op_sv; const char *p = SvPV_const(pat, plen); - if ((o->op_flags & OPf_SPECIAL) && (*p == ' ' && p[1] == '\0')) { + if ((o->op_flags & OPf_SPECIAL) && (plen == 1 && *p == ' ')) { U32 was_readonly = SvREADONLY(pat); if (was_readonly) { @@ -3267,8 +3278,10 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) pm->op_pmdynflags |= PMdf_UTF8; /* FIXME - can we make this function take const char * args? */ PM_SETRE(pm, CALLREGCOMP((char*)p, (char*)p + plen, pm)); - if (strEQ("\\s+", PM_GETRE(pm)->precomp)) + if (PM_GETRE(pm)->extflags & RXf_WHITE) pm->op_pmflags |= PMf_WHITE; + else + pm->op_pmflags &= ~PMf_WHITE; #ifdef PERL_MAD op_getmad(expr,(OP*)pm,'e'); #else @@ -3322,7 +3335,9 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) else { OP *lastop = NULL; for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) { - if (PL_opargs[curop->op_type] & OA_DANGEROUS) { + if (curop->op_type == OP_SCOPE + || curop->op_type == OP_LEAVE + || (PL_opargs[curop->op_type] & OA_DANGEROUS)) { if (curop->op_type == OP_GV) { GV * const gv = cGVOPx_gv(curop); repl_has_vars = 1; @@ -3341,7 +3356,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) else if (curop->op_type == OP_PADSV || curop->op_type == OP_PADAV || curop->op_type == OP_PADHV || - curop->op_type == OP_PADANY) { + curop->op_type == OP_PADANY) + { repl_has_vars = 1; } else if (curop->op_type == OP_PUSHRE) @@ -3355,7 +3371,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) if (curop == repl && !(repl_has_vars && (!PM_GETRE(pm) - || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN))) { + || PM_GETRE(pm)->extflags & RXf_EVAL_SEEN))) + { pm->op_pmflags |= PMf_CONST; /* const for long enough */ pm->op_pmpermflags |= PMf_CONST; /* const for long enough */ prepend_elem(o->op_type, scalar(repl), o); @@ -3404,6 +3421,7 @@ Perl_newSVOP(pTHX_ I32 type, I32 flags, SV *sv) return CHECKOP(type, svop); } +#ifdef USE_ITHREADS OP * Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) { @@ -3415,8 +3433,8 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) padop->op_padix = pad_alloc(type, SVs_PADTMP); SvREFCNT_dec(PAD_SVl(padop->op_padix)); PAD_SETSV(padop->op_padix, sv); - if (sv) - SvPADTMP_on(sv); + assert(sv); + SvPADTMP_on(sv); padop->op_next = (OP*)padop; padop->op_flags = (U8)flags; if (PL_opargs[type] & OA_RETSCALAR) @@ -3425,17 +3443,18 @@ Perl_newPADOP(pTHX_ I32 type, I32 flags, SV *sv) padop->op_targ = pad_alloc(type, SVs_PADTMP); return CHECKOP(type, padop); } +#endif OP * Perl_newGVOP(pTHX_ I32 type, I32 flags, GV *gv) { dVAR; + assert(gv); #ifdef USE_ITHREADS - if (gv) - GvIN_PAD_on(gv); - return newPADOP(type, flags, SvREFCNT_inc_simple(gv)); + GvIN_PAD_on(gv); + return newPADOP(type, flags, SvREFCNT_inc_simple_NN(gv)); #else - return newSVOP(type, flags, SvREFCNT_inc_simple(gv)); + return newSVOP(type, flags, SvREFCNT_inc_simple_NN(gv)); #endif } @@ -3465,8 +3484,7 @@ void Perl_package(pTHX_ OP *o) { dVAR; - const char *name; - STRLEN len; + SV *const sv = cSVOPo->op_sv; #ifdef PERL_MAD OP *pegop; #endif @@ -3474,9 +3492,8 @@ Perl_package(pTHX_ OP *o) save_hptr(&PL_curstash); save_item(PL_curstname); - name = SvPV_const(cSVOPo->op_sv, len); - PL_curstash = gv_stashpvn(name, len, TRUE); - sv_setpvn(PL_curstname, name, len); + PL_curstash = gv_stashsv(sv, GV_ADD); + sv_setsv(PL_curstname, sv); PL_hints |= HINT_BLOCK_SCOPE; PL_copline = NOLINE; @@ -3823,7 +3840,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) * that value, we know we've got commonality. We could use a * single bit marker, but then we'd have to make 2 passes, first * to clear the flag, then to test and set it. To find somewhere - * to store these values, evil chicanery is done with SvCUR(). + * to store these values, evil chicanery is done with SvUVX(). */ { @@ -4001,7 +4018,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) cop->op_next = (OP*)cop; if (label) { - cop->cop_label = label; + CopLABEL_set(cop, label); PL_hints |= HINT_BLOCK_SCOPE; } cop->cop_seq = seq; @@ -4518,21 +4535,16 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP } sv = NULL; } - else if (sv->op_type == OP_THREADSV) { /* per-thread variable */ - padoff = sv->op_targ; - if (PL_madskills) - madsv = sv; - else { - sv->op_targ = 0; - iterflags |= OPf_SPECIAL; - op_free(sv); - } - sv = NULL; - } else Perl_croak(aTHX_ "Can't use %s for loop variable", PL_op_desc[sv->op_type]); - if (padoff && strEQ(PAD_COMPNAME_PV(padoff), "$_")) - iterpflags |= OPpITER_DEF; + if (padoff) { + SV *const namesv = PAD_COMPNAME_SV(padoff); + STRLEN len; + const char *const name = SvPV_const(namesv, len); + + if (len == 2 && name[0] == '$' && name[1] == '_') + iterpflags |= OPpITER_DEF; + } } else { const PADOFFSET offset = pad_findmy("$_"); @@ -4620,7 +4632,7 @@ Perl_newLOOPEX(pTHX_ I32 type, OP *label) if (label->op_type == OP_STUB && (label->op_flags & OPf_PARENS)) o = newOP(type, OPf_SPECIAL); else { - o = newPVOP(type, 0, savepv(label->op_type == OP_CONST + o = newPVOP(type, 0, savesharedpv(label->op_type == OP_CONST ? SvPVx_nolen_const(((SVOP*)label)->op_sv) : "")); } @@ -4887,11 +4899,11 @@ Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p, if (gv) gv_efullname3(name = sv_newmortal(), gv, NULL); - sv_setpv(msg, "Prototype mismatch:"); + sv_setpvs(msg, "Prototype mismatch:"); if (name) - Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, (void*)name); + Perl_sv_catpvf(aTHX_ msg, " sub %"SVf, SVfARG(name)); if (SvPOK(cv)) - Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", (void*)cv); + Perl_sv_catpvf(aTHX_ msg, " (%"SVf")", SVfARG(cv)); else sv_catpvs(msg, ": none"); sv_catpvs(msg, " vs "); @@ -4899,7 +4911,7 @@ Perl_cv_ckproto_len(pTHX_ const CV *cv, const GV *gv, const char *p, Perl_sv_catpvf(aTHX_ msg, "(%.*s)", (int) len, p); else sv_catpvs(msg, "none"); - Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, (void*)msg); + Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf, SVfARG(msg)); } } @@ -5310,7 +5322,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) else { /* force display of errors found but not reported */ sv_catpv(ERRSV, not_safe); - Perl_croak(aTHX_ "%"SVf, (void*)ERRSV); + Perl_croak(aTHX_ "%"SVf, SVfARG(ERRSV)); } } } @@ -5322,6 +5334,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (CvLVALUE(cv)) { CvROOT(cv) = newUNOP(OP_LEAVESUBLV, 0, mod(scalarseq(block), OP_LEAVESUBLV)); + block->op_attached = 1; } else { /* This makes sub {}; work as expected. */ @@ -5334,6 +5347,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) #endif block = newblock; } + else + block->op_attached = 1; CvROOT(cv) = newUNOP(OP_LEAVESUB, 0, scalarseq(block)); } CvROOT(cv)->op_private |= OPpREFCOUNTED; @@ -5353,9 +5368,6 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } if (name || aname) { - const char *s; - const char * const tname = (name ? name : aname); - if (PERLDB_SUBLINE && PL_curstash != PL_debstash) { SV * const sv = newSV(0); SV * const tmpstr = sv_newmortal(); @@ -5381,24 +5393,32 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) } } - if ((s = strrchr(tname,':'))) - s++; - else - s = tname; + if (name && !PL_error_count) + process_special_blocks(name, gv, cv); + } - if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I' && *s != 'U') - goto done; + done: + PL_copline = NOLINE; + LEAVE_SCOPE(floor); + return cv; +} + +STATIC void +S_process_special_blocks(pTHX_ const char *const fullname, GV *const gv, + CV *const cv) +{ + const char *const colon = strrchr(fullname,':'); + const char *const name = colon ? colon + 1 : fullname; - if (strEQ(s, "BEGIN") && !PL_error_count) { + if (*name == 'B') { + if (memEQ(name, "BEGIN", 5)) { const I32 oldscope = PL_scopestack_ix; ENTER; SAVECOPFILE(&PL_compiling); SAVECOPLINE(&PL_compiling); - if (!PL_beginav) - PL_beginav = newAV(); DEBUG_x( dump_sub(gv) ); - av_push(PL_beginav, (SV*)cv); + Perl_av_create_and_push(aTHX_ &PL_beginav, (SV*)cv); GvCV(gv) = 0; /* cv has been hijacked */ call_list(oldscope, PL_beginav); @@ -5406,51 +5426,47 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CopHINTS_set(&PL_compiling, PL_hints); LEAVE; } - else if (strEQ(s, "END") && !PL_error_count) { - if (!PL_endav) - PL_endav = newAV(); - DEBUG_x( dump_sub(gv) ); - av_unshift(PL_endav, 1); - av_store(PL_endav, 0, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - else if (strEQ(s, "UNITCHECK") && !PL_error_count) { - /* It's never too late to run a unitcheck block */ - if (!PL_unitcheckav) - PL_unitcheckav = newAV(); - DEBUG_x( dump_sub(gv) ); - av_unshift(PL_unitcheckav, 1); - av_store(PL_unitcheckav, 0, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - else if (strEQ(s, "CHECK") && !PL_error_count) { - if (!PL_checkav) - PL_checkav = newAV(); - DEBUG_x( dump_sub(gv) ); - if (PL_main_start && ckWARN(WARN_VOID)) - 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 */ - } - else if (strEQ(s, "INIT") && !PL_error_count) { - if (!PL_initav) - PL_initav = newAV(); - DEBUG_x( dump_sub(gv) ); - if (PL_main_start && ckWARN(WARN_VOID)) - 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 */ - } + else + return; + } else { + if (*name == 'E') { + if strEQ(name, "END") { + DEBUG_x( dump_sub(gv) ); + Perl_av_create_and_unshift_one(aTHX_ &PL_endav, (SV*)cv); + } else + return; + } else if (*name == 'U') { + if (strEQ(name, "UNITCHECK")) { + /* It's never too late to run a unitcheck block */ + Perl_av_create_and_unshift_one(aTHX_ &PL_unitcheckav, (SV*)cv); + } + else + return; + } else if (*name == 'C') { + if (strEQ(name, "CHECK")) { + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run CHECK block"); + Perl_av_create_and_unshift_one(aTHX_ &PL_checkav, (SV*)cv); + } + else + return; + } else if (*name == 'I') { + if (strEQ(name, "INIT")) { + if (PL_main_start && ckWARN(WARN_VOID)) + Perl_warner(aTHX_ packWARN(WARN_VOID), + "Too late to run INIT block"); + Perl_av_create_and_push(aTHX_ &PL_initav, (SV*)cv); + } + else + return; + } else + return; + DEBUG_x( dump_sub(gv) ); + GvCV(gv) = 0; /* cv has been hijacked */ } - - done: - PL_copline = NOLINE; - LEAVE_SCOPE(floor); - return cv; } -/* XXX unsafe for threads if eval_owner isn't held */ /* =for apidoc newCONSTSUB @@ -5625,51 +5641,11 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) CvISXSUB_on(cv); CvXSUB(cv) = subaddr; - if (name) { - const char *s = strrchr(name,':'); - if (s) - s++; - else - s = name; - - if (*s != 'B' && *s != 'E' && *s != 'C' && *s != 'I') - goto done; - - if (strEQ(s, "BEGIN")) { - if (!PL_beginav) - PL_beginav = newAV(); - av_push(PL_beginav, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - else if (strEQ(s, "END")) { - if (!PL_endav) - PL_endav = newAV(); - av_unshift(PL_endav, 1); - av_store(PL_endav, 0, (SV*)cv); - GvCV(gv) = 0; /* cv has been hijacked */ - } - else if (strEQ(s, "CHECK")) { - if (!PL_checkav) - PL_checkav = newAV(); - if (PL_main_start && ckWARN(WARN_VOID)) - 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 */ - } - else if (strEQ(s, "INIT")) { - if (!PL_initav) - PL_initav = newAV(); - if (PL_main_start && ckWARN(WARN_VOID)) - 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 */ - } - } + if (name) + process_special_blocks(name, gv, cv); else CvANON_on(cv); -done: return cv; } @@ -5703,7 +5679,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block) CopLINE_set(PL_curcop, PL_copline); Perl_warner(aTHX_ packWARN(WARN_REDEFINE), o ? "Format %"SVf" redefined" - : "Format STDOUT redefined", (void*)cSVOPo->op_sv); + : "Format STDOUT redefined", SVfARG(cSVOPo->op_sv)); CopLINE_set(PL_curcop, oldline); } SvREFCNT_dec(cv); @@ -5867,10 +5843,6 @@ Perl_newSVREF(pTHX_ OP *o) o->op_ppaddr = PL_ppaddr[OP_PADSV]; return o; } - else if (o->op_type == OP_THREADSV && !(o->op_flags & OPpDONE_SVREF)) { - o->op_flags |= OPpDONE_SVREF; - return o; - } return newUNOP(OP_RV2SV, 0, scalar(o)); } @@ -6208,7 +6180,7 @@ Perl_ck_rvconst(pTHX_ register OP *o) if (badthing) Perl_croak(aTHX_ "Can't use bareword (\"%"SVf"\") as %s ref while \"strict refs\" in use", - (void*)kidsv, badthing); + SVfARG(kidsv), badthing); } /* * This is a little tricky. We only want to add the symbol if we @@ -6366,7 +6338,7 @@ Perl_ck_fun(pTHX_ OP *o) if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Array @%"SVf" missing the @ in argument %"IVdf" of %s()", - (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]); + SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); #ifdef PERL_MAD op_getmad(kid,newop,'K'); #else @@ -6389,7 +6361,7 @@ Perl_ck_fun(pTHX_ OP *o) if (ckWARN2(WARN_DEPRECATED, WARN_SYNTAX)) Perl_warner(aTHX_ packWARN2(WARN_DEPRECATED, WARN_SYNTAX), "Hash %%%"SVf" missing the %% in argument %"IVdf" of %s()", - (void*)((SVOP*)kid)->op_sv, (IV)numargs, PL_op_desc[type]); + SVfARG(((SVOP*)kid)->op_sv), (IV)numargs, PL_op_desc[type]); #ifdef PERL_MAD op_getmad(kid,newop,'K'); #else @@ -6452,13 +6424,9 @@ Perl_ck_fun(pTHX_ OP *o) */ priv = OPpDEREF; if (kid->op_type == OP_PADSV) { - name = PAD_COMPNAME_PV(kid->op_targ); - /* SvCUR of a pad namesv can't be trusted - * (see PL_generation), so calc its length - * manually */ - if (name) - len = strlen(name); - + SV *const namesv + = PAD_COMPNAME_SV(kid->op_targ); + name = SvPV_const(namesv, len); } else if (kid->op_type == OP_RV2SV && kUNOP->op_first->op_type == OP_GV) @@ -7324,9 +7292,10 @@ Perl_ck_join(pTHX_ OP *o) if (ckWARN(WARN_SYNTAX)) { const REGEXP *re = PM_GETRE(kPMOP); const char *pmstr = re ? re->precomp : "STRING"; + const STRLEN len = re ? re->prelen : 6; Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "/%s/ should probably be written as \"%s\"", - pmstr, pmstr); + "/%.*s/ should probably be written as \"%.*s\"", + len, pmstr, len, pmstr); } } return ck_fun(o); @@ -7528,8 +7497,7 @@ Perl_ck_subr(pTHX_ OP *o) if (o3->op_type == OP_RV2SV || o3->op_type == OP_PADSV || o3->op_type == OP_HELEM || - o3->op_type == OP_AELEM || - o3->op_type == OP_THREADSV) + o3->op_type == OP_AELEM) goto wrapref; if (!contextclass) bad_type(arg, "scalar", gv_ename(namegv), o3); @@ -7573,7 +7541,7 @@ Perl_ck_subr(pTHX_ OP *o) default: oops: Perl_croak(aTHX_ "Malformed prototype for %s: %"SVf, - gv_ename(namegv), (void*)cv); + gv_ename(namegv), SVfARG(cv)); } } else @@ -7850,7 +7818,7 @@ Perl_peep(pTHX_ register OP *o) gv_efullname3(sv, gv, NULL); Perl_warner(aTHX_ packWARN(WARN_PROTOTYPE), "%"SVf"() called too early to check prototype", - (void*)sv); + SVfARG(sv)); } } else if (o->op_next->op_type == OP_READLINE