X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7e5d8ed22a9e0983529873e07602c1b147b8b5b8..d83b45b8c7dee4b7dac02b1eec4a66c2e793cd90:/op.c diff --git a/op.c b/op.c index 6422ff1..7c649fc 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; @@ -1551,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) @@ -2060,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); @@ -2833,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)) @@ -3026,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) @@ -3082,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]; @@ -3235,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) { @@ -3259,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 @@ -3400,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) { @@ -3411,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) @@ -3421,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 } @@ -3461,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 @@ -3470,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; @@ -4500,7 +4521,15 @@ Perl_newFOROP(pTHX_ I32 flags, char *label, line_t forline, OP *sv, OP *expr, OP iterpflags = sv->op_private & OPpOUR_INTRO; /* for our $x () */ sv->op_type = OP_RV2GV; sv->op_ppaddr = PL_ppaddr[OP_RV2GV]; - if (cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv) + + /* The op_type check is needed to prevent a possible segfault + * if the loop variable is undeclared and 'strict vars' is in + * effect. This is illegal but is nonetheless parsed, so we + * may reach this point with an OP_CONST where we're expecting + * an OP_GV. + */ + if (cUNOPx(sv)->op_first->op_type == OP_GV + && cGVOPx_gv(cUNOPx(sv)->op_first) == PL_defgv) iterpflags |= OPpITER_DEF; } else if (sv->op_type == OP_PADSV) { /* private variable */ @@ -4514,17 +4543,6 @@ 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) { @@ -4622,7 +4640,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) : "")); } @@ -4889,11 +4907,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 "); @@ -4901,7 +4919,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)); } } @@ -5312,7 +5330,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)); } } } @@ -5358,9 +5376,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(); @@ -5386,24 +5401,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; +} - if (strEQ(s, "BEGIN") && !PL_error_count) { +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 (*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); @@ -5411,51 +5434,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 @@ -5615,8 +5634,7 @@ Perl_newXS(pTHX_ const char *name, XSUBADDR_t subaddr, const char *filename) if (cv) /* must reuse cv if autoloaded */ cv_undef(cv); else { - cv = (CV*)newSV(0); - sv_upgrade((SV *)cv, SVt_PVCV); + cv = (CV*)newSV_type(SVt_PVCV); if (name) { GvCV(gv) = cv; GvCVGEN(gv) = 0; @@ -5630,51 +5648,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; } @@ -5708,7 +5686,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); @@ -5872,10 +5850,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)); } @@ -6213,7 +6187,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 @@ -6371,7 +6345,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 @@ -6394,7 +6368,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 @@ -7325,9 +7299,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\"", + (int)len, pmstr, (int)len, pmstr); } } return ck_fun(o); @@ -7529,8 +7504,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); @@ -7574,7 +7548,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 @@ -7851,7 +7825,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