diff options
| -rw-r--r-- | cop.h | 6 | ||||
| -rw-r--r-- | dump.c | 6 | ||||
| -rw-r--r-- | ext/Opcode/Opcode.xs | 2 | ||||
| -rw-r--r-- | gv.c | 7 | ||||
| -rw-r--r-- | op.c | 30 | ||||
| -rw-r--r-- | perl.c | 6 | ||||
| -rw-r--r-- | pp_ctl.c | 24 | ||||
| -rw-r--r-- | pp_sys.c | 2 | ||||
| -rw-r--r-- | sv.c | 31 | ||||
| -rw-r--r-- | toke.c | 8 | ||||
| -rw-r--r-- | util.c | 4 | ||||
| -rw-r--r-- | win32/perllib.c | 16 |
12 files changed, 85 insertions, 57 deletions
@@ -39,6 +39,10 @@ struct cop { # define CopSTASH(c) (CopSTASHPV(c) \ ? gv_stashpv(CopSTASHPV(c),GV_ADD) : Nullhv) # define CopSTASH_set(c,hv) CopSTASHPV_set(c, HvNAME(hv)) +# define CopSTASH_eq(c,hv) (hv \ + && (CopSTASHPV(c) == HvNAME(hv) \ + || (CopSTASHPV(c) && HvNAME(hv) \ + && strEQ(CopSTASHPV(c), HvNAME(hv))))) #else # define CopFILEGV(c) ((c)->cop_filegv) # define CopFILEGV_set(c,gv) ((c)->cop_filegv = gv) @@ -50,8 +54,10 @@ struct cop { # define CopSTASH_set(c,hv) ((c)->cop_stash = hv) # define CopSTASHPV(c) (CopSTASH(c) ? HvNAME(CopSTASH(c)) : Nullch) # define CopSTASHPV_set(c,pv) CopSTASH_set(c, gv_stashpv(pv,GV_ADD)) +# define CopSTASH_eq(c,hv) (CopSTASH(c) == hv) #endif /* USE_ITHREADS */ +#define CopSTASH_ne(c,hv) (!CopSTASH_eq(c,hv)) #define CopLINE(c) ((c)->cop_line) #define CopLINE_inc(c) (++CopLINE(c)) #define CopLINE_dec(c) (--CopLINE(c)) @@ -539,8 +539,12 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) case OP_DBSTATE: if (CopLINE(cCOPo)) Perl_dump_indent(aTHX_ level, file, "LINE = %d\n",CopLINE(cCOPo)); + if (CopSTASHPV(cCOPo)) + Perl_dump_indent(aTHX_ level, file, "PACKAGE = \"%s\"\n", + CopSTASHPV(cCOPo)); if (cCOPo->cop_label) - Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n",cCOPo->cop_label); + Perl_dump_indent(aTHX_ level, file, "LABEL = \"%s\"\n", + cCOPo->cop_label); break; case OP_ENTERLOOP: Perl_dump_indent(aTHX_ level, file, "REDO ===> "); diff --git a/ext/Opcode/Opcode.xs b/ext/Opcode/Opcode.xs index 9b6e016bb8..63ff8aa711 100644 --- a/ext/Opcode/Opcode.xs +++ b/ext/Opcode/Opcode.xs @@ -253,6 +253,8 @@ PPCODE: save_hptr(&PL_defstash); /* save current default stack */ /* the assignment to global defstash changes our sense of 'main' */ PL_defstash = gv_stashpv(Package, GV_ADDWARN); /* should exist already */ + save_hptr(&PL_curstash); + PL_curstash = PL_defstash; /* defstash must itself contain a main:: so we'll add that now */ /* take care with the ref counts (was cause of long standing bug) */ @@ -59,6 +59,9 @@ Perl_gv_fetchfile(pTHX_ const char *name) STRLEN tmplen; GV *gv; + if (!PL_defstash) + return Nullgv; + tmplen = strlen(name) + 2; if (tmplen < sizeof smallbuf) tmpbuf = smallbuf; @@ -445,8 +448,8 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) name++; for (namend = name; *namend; namend++) { - if ((*namend == '\'' && namend[1]) || - (*namend == ':' && namend[1] == ':')) + if ((*namend == ':' && namend[1] == ':') + || (*namend == '\'' && namend[1])) { if (!stash) stash = PL_defstash; @@ -4455,8 +4455,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) CV *cv; HV *hv; - Perl_sv_setpvf(aTHX_ sv, "%_:%ld-%ld", - CopFILESV(PL_curcop), + Perl_sv_setpvf(aTHX_ sv, "%s:%ld-%ld", + CopFILE(PL_curcop), (long)PL_subline, (long)CopLINE(PL_curcop)); gv_efullname3(tmpstr, gv, Nullch); hv_store(GvHV(PL_DBsub), SvPVX(tmpstr), SvCUR(tmpstr), sv, 0); @@ -4475,6 +4475,10 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) s++; else s = name; + + if (*s != 'B' && *s != 'E' && *s != 'S' && *s != 'I') + goto done; + if (strEQ(s, "BEGIN")) { I32 oldscope = PL_scopestack_ix; ENTER; @@ -4486,7 +4490,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) if (!PL_beginav) PL_beginav = newAV(); DEBUG_x( dump_sub(gv) ); - av_push(PL_beginav, (SV *)cv); + av_push(PL_beginav, SvREFCNT_inc(cv)); GvCV(gv) = 0; call_list(oldscope, PL_beginav); @@ -4497,20 +4501,23 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block) 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); + av_store(PL_endav, 0, SvREFCNT_inc(cv)); GvCV(gv) = 0; } else if (strEQ(s, "STOP") && !PL_error_count) { if (!PL_stopav) PL_stopav = newAV(); + DEBUG_x( dump_sub(gv) ); av_unshift(PL_stopav, 1); - av_store(PL_stopav, 0, (SV *)cv); + av_store(PL_stopav, 0, SvREFCNT_inc(cv)); GvCV(gv) = 0; } else if (strEQ(s, "INIT") && !PL_error_count) { if (!PL_initav) PL_initav = newAV(); + DEBUG_x( dump_sub(gv) ); av_push(PL_initav, SvREFCNT_inc(cv)); GvCV(gv) = 0; } @@ -4614,36 +4621,41 @@ Perl_newXS(pTHX_ char *name, XSUBADDR_t subaddr, char *filename) s++; else s = name; + + if (*s != 'B' && *s != 'E' && *s != 'S' && *s != 'I') + goto done; + if (strEQ(s, "BEGIN")) { if (!PL_beginav) PL_beginav = newAV(); - av_push(PL_beginav, (SV *)cv); + av_push(PL_beginav, SvREFCNT_inc(cv)); GvCV(gv) = 0; } else if (strEQ(s, "END")) { if (!PL_endav) PL_endav = newAV(); av_unshift(PL_endav, 1); - av_store(PL_endav, 0, (SV *)cv); + av_store(PL_endav, 0, SvREFCNT_inc(cv)); GvCV(gv) = 0; } else if (strEQ(s, "STOP")) { if (!PL_stopav) PL_stopav = newAV(); av_unshift(PL_stopav, 1); - av_store(PL_stopav, 0, (SV *)cv); + av_store(PL_stopav, 0, SvREFCNT_inc(cv)); GvCV(gv) = 0; } else if (strEQ(s, "INIT")) { if (!PL_initav) PL_initav = newAV(); - av_push(PL_initav, (SV *)cv); + av_push(PL_initav, SvREFCNT_inc(cv)); GvCV(gv) = 0; } } else CvANON_on(cv); +done: return cv; } @@ -1689,10 +1689,10 @@ Perl_moreswitches(pTHX_ char *s) my_setenv("PERL5DB", Perl_form(aTHX_ "use Devel::%s;", ++s)); s += strlen(s); } - if (!PL_perldb) + if (!PL_perldb) { PL_perldb = PERLDB_ALL; - if (!PL_debstash) init_debugger(); + } return s; case 'D': { @@ -2086,6 +2086,7 @@ S_init_main_stash(pTHX) sv_setpvn(ERRSV, "", 0); PL_curstash = PL_defstash; CopSTASH_set(&PL_compiling, PL_defstash); + PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); PL_globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV)); /* We must init $/ before switches are processed. */ sv_setpvn(get_sv("/", TRUE), "\n", 1); @@ -2644,7 +2645,6 @@ Perl_init_debugger(pTHX) dTHR; HV *ostash = PL_curstash; - PL_debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); PL_curstash = PL_debstash; PL_dbargs = GvAV(gv_AVadd((gv_fetchpv("args", GV_ADDMULTI, SVt_PVAV)))); AvREAL_off(PL_dbargs); @@ -1392,7 +1392,7 @@ PP(pp_caller) PERL_SI *top_si = PL_curstackinfo; I32 dbcxix; I32 gimme; - HV *hv; + char *stashname; SV *sv; I32 count = 0; @@ -1428,23 +1428,23 @@ PP(pp_caller) cx = &ccstack[dbcxix]; } - hv = CopSTASH(cx->blk_oldcop); + stashname = CopSTASHPV(cx->blk_oldcop); if (GIMME != G_ARRAY) { - if (!hv) + if (!stashname) PUSHs(&PL_sv_undef); else { dTARGET; - sv_setpv(TARG, HvNAME(hv)); + sv_setpv(TARG, stashname); PUSHs(TARG); } RETURN; } - if (!hv) + if (!stashname) PUSHs(&PL_sv_undef); else - PUSHs(sv_2mortal(newSVpv(HvNAME(hv), 0))); - PUSHs(sv_2mortal(newSVsv(CopFILESV(cx->blk_oldcop)))); + PUSHs(sv_2mortal(newSVpv(stashname, 0))); + PUSHs(sv_2mortal(newSVpv(CopFILE(cx->blk_oldcop), 0))); PUSHs(sv_2mortal(newSViv((I32)CopLINE(cx->blk_oldcop)))); if (!MAXARG) RETURN; @@ -1479,7 +1479,7 @@ PP(pp_caller) PUSHs(&PL_sv_undef); } if (CxTYPE(cx) == CXt_SUB && cx->blk_sub.hasargs - && CopSTASH(PL_curcop) == PL_debstash) + && CopSTASH_eq(PL_curcop, PL_debstash)) { AV *ary = cx->blk_sub.argarray; int off = AvARRAY(ary) - AvALLOC(ary); @@ -2538,7 +2538,6 @@ S_doeval(pTHX_ int gimme, OP** startop) { dSP; OP *saveop = PL_op; - HV *newstash; CV *caller; AV* comppadlist; I32 i; @@ -2604,10 +2603,9 @@ S_doeval(pTHX_ int gimme, OP** startop) /* make sure we compile in the right package */ - newstash = CopSTASH(PL_curcop); - if (PL_curstash != newstash) { + if (CopSTASH_ne(PL_curcop, PL_curstash)) { SAVESPTR(PL_curstash); - PL_curstash = newstash; + PL_curstash = CopSTASH(PL_curcop); } SAVESPTR(PL_beginav); PL_beginav = newAV(); @@ -2963,7 +2961,7 @@ PP(pp_require) /* Assume success here to prevent recursive requirement. */ (void)hv_store(GvHVn(PL_incgv), name, strlen(name), - newSVsv(CopFILESV(&PL_compiling)), 0 ); + newSVpv(CopFILE(&PL_compiling), 0), 0 ); ENTER; SAVETMPS; @@ -475,7 +475,7 @@ PP(pp_die) HV *stash = SvSTASH(SvRV(error)); GV *gv = gv_fetchmethod(stash, "PROPAGATE"); if (gv) { - SV *file = sv_2mortal(newSVsv(CopFILESV(PL_curcop))); + SV *file = sv_2mortal(newSVpv(CopFILE(PL_curcop),0)); SV *line = sv_2mortal(newSViv(CopLINE(PL_curcop))); EXTEND(SP, 3); PUSHMARK(SP); @@ -2370,7 +2370,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) sstr = SvRV(sstr); if (sstr == dstr) { if (GvIMPORTED(dstr) != GVf_IMPORTED - && CopSTASH(PL_curcop) != GvSTASH(dstr)) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_on(dstr); } @@ -2428,7 +2428,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) GvGP(dstr) = gp_ref(GvGP(sstr)); SvTAINT(dstr); if (GvIMPORTED(dstr) != GVf_IMPORTED - && CopSTASH(PL_curcop) != GvSTASH(dstr)) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_on(dstr); } @@ -2463,7 +2463,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) if (intro) { GP *gp; - GvGP(dstr)->gp_refcnt--; + gp_free((GV*)dstr); GvINTRO_off(dstr); /* one-shot flag */ Newz(602,gp, 1, GP); GvGP(dstr) = gp_ref(gp); @@ -2480,7 +2480,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) dref = (SV*)GvAV(dstr); GvAV(dstr) = (AV*)sref; if (GvIMPORTED_AV_off(dstr) - && CopSTASH(PL_curcop) != GvSTASH(dstr)) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_AV_on(dstr); } @@ -2492,7 +2492,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) dref = (SV*)GvHV(dstr); GvHV(dstr) = (HV*)sref; if (GvIMPORTED_HV_off(dstr) - && CopSTASH(PL_curcop) != GvSTASH(dstr)) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_HV_on(dstr); } @@ -2548,7 +2548,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) PL_sub_generation++; } if (GvIMPORTED_CV_off(dstr) - && CopSTASH(PL_curcop) != GvSTASH(dstr)) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_CV_on(dstr); } @@ -2567,7 +2567,7 @@ Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) dref = (SV*)GvSV(dstr); GvSV(dstr) = sref; if (GvIMPORTED_SV_off(dstr) - && CopSTASH(PL_curcop) != GvSTASH(dstr)) + && CopSTASH_ne(PL_curcop, GvSTASH(dstr))) { GvIMPORTED_SV_on(dstr); } @@ -5674,18 +5674,18 @@ Perl_gp_dup(pTHX_ GP *gp) sv_table_store(PL_sv_table, (SV*)gp, (SV*)ret); /* clone */ + ret->gp_refcnt = 0; /* must be before any other dups! */ ret->gp_sv = sv_dup_inc(gp->gp_sv); ret->gp_io = io_dup_inc(gp->gp_io); ret->gp_form = cv_dup_inc(gp->gp_form); ret->gp_av = av_dup_inc(gp->gp_av); ret->gp_hv = hv_dup_inc(gp->gp_hv); - ret->gp_egv = 0; + ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */ ret->gp_cv = cv_dup_inc(gp->gp_cv); ret->gp_cvgen = gp->gp_cvgen; ret->gp_flags = gp->gp_flags; ret->gp_line = gp->gp_line; ret->gp_file = gp->gp_file; /* points to COP.cop_file */ - ret->gp_refcnt = 0; return ret; } @@ -5847,7 +5847,7 @@ Perl_sv_dup(pTHX_ SV *sstr) /* clone */ SvFLAGS(dstr) = SvFLAGS(sstr); SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */ - SvREFCNT(dstr) = 0; + SvREFCNT(dstr) = 0; /* must be before any other dups! */ #ifdef DEBUGGING if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx) @@ -5979,10 +5979,6 @@ Perl_sv_dup(pTHX_ SV *sstr) GvFLAGS(dstr) = GvFLAGS(sstr); GvGP(dstr) = gp_dup(GvGP(sstr)); (void)GpREFCNT_inc(GvGP(dstr)); - if (GvEGV(sstr) == (GV*)sstr) - GvEGV(dstr) = (GV*)dstr; - else - GvEGV(dstr) = gv_dup_inc(GvEGV(sstr)); break; case SVt_PVIO: SvANY(dstr) = new_XPVIO(); @@ -6032,11 +6028,11 @@ Perl_sv_dup(pTHX_ SV *sstr) SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr)); AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr)); AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr); - if (AvALLOC((AV*)sstr)) { + if (AvARRAY((AV*)sstr)) { SV **dst_ary, **src_ary; SSize_t items = AvFILLp((AV*)sstr) + 1; - src_ary = AvALLOC((AV*)sstr); + src_ary = AvARRAY((AV*)sstr); Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*); SvPVX(dstr) = (char*)dst_ary; AvALLOC((AV*)dstr) = dst_ary; @@ -6105,6 +6101,7 @@ Perl_sv_dup(pTHX_ SV *sstr) break; case SVt_PVFM: SvANY(dstr) = new_XPVFM(); + FmLINES(dstr) = FmLINES(sstr); goto dup_pvcv; /* NOTREACHED */ case SVt_PVCV: @@ -6144,7 +6141,7 @@ dup_pvcv: break; } - if (SvOBJECT(dstr)) + if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO) ++PL_sv_objcount; return dstr; @@ -3729,7 +3729,7 @@ Perl_yylex(pTHX) case KEY___FILE__: yylval.opval = (OP*)newSVOP(OP_CONST, 0, - newSVsv(CopFILESV(PL_curcop))); + newSVpv(CopFILE(PL_curcop),0)); TERM(THING); case KEY___LINE__: @@ -6989,8 +6989,8 @@ Perl_yyerror(pTHX_ char *s) where = SvPVX(where_sv); } msg = sv_2mortal(newSVpv(s, 0)); - Perl_sv_catpvf(aTHX_ msg, " at %_ line %"IVdf", ", - CopFILESV(PL_curcop), (IV)CopLINE(PL_curcop)); + Perl_sv_catpvf(aTHX_ msg, " at %s line %"IVdf", ", + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); if (context) Perl_sv_catpvf(aTHX_ msg, "near \"%.*s\"\n", contlen, context); else @@ -7006,7 +7006,7 @@ Perl_yyerror(pTHX_ char *s) else qerror(msg); if (PL_error_count >= 10) - Perl_croak(aTHX_ "%_ has too many errors.\n", CopFILESV(PL_curcop)); + Perl_croak(aTHX_ "%s has too many errors.\n", CopFILE(PL_curcop)); PL_in_my = 0; PL_in_my_stash = Nullhv; return 0; @@ -1420,8 +1420,8 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { dTHR; if (CopLINE(PL_curcop)) - Perl_sv_catpvf(aTHX_ sv, " at %_ line %"IVdf, - CopFILESV(PL_curcop), (IV)CopLINE(PL_curcop)); + Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, + CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { bool line_mode = (RsSIMPLE(PL_rs) && SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); diff --git a/win32/perllib.c b/win32/perllib.c index 22ac61d489..2b4d778914 100644 --- a/win32/perllib.c +++ b/win32/perllib.c @@ -549,7 +549,7 @@ PerlLIOIsatty(struct IPerlLIO *I, int fd) } int -PerlLIOLink(struct IPerlLIO*, const char*oldname, const char *newname) +PerlLIOLink(struct IPerlLIO *I, const char*oldname, const char *newname) { return win32_link(oldname, newname); } @@ -1527,7 +1527,7 @@ EXTERN_C DllExport int RunPerl(int argc, char **argv, char **env) { int exitstatus; - PerlInterpreter *my_perl; + PerlInterpreter *my_perl, *new_perl = NULL; struct perl_thread *thr; #ifndef __BORLANDC__ @@ -1564,12 +1564,11 @@ RunPerl(int argc, char **argv, char **env) exitstatus = perl_parse(my_perl, xs_init, argc, argv, env); if (!exitstatus) { #ifdef USE_ITHREADS /* XXXXXX testing */ -extern PerlInterpreter * perl_clone(pTHXx_ IV flags); + extern PerlInterpreter * perl_clone(pTHXx_ IV flags); - PerlInterpreter *new_perl = perl_clone(my_perl, 0); + new_perl = perl_clone(my_perl, 0); Perl_push_scope(new_perl); /* ENTER; (hack in lieu of perl_destruct()) */ exitstatus = perl_run( new_perl ); - perl_destruct(new_perl); perl_free(new_perl); SetPerlInterpreter(my_perl); #else exitstatus = perl_run( my_perl ); @@ -1578,6 +1577,13 @@ extern PerlInterpreter * perl_clone(pTHXx_ IV flags); perl_destruct( my_perl ); perl_free( my_perl ); +#ifdef USE_ITHREADS + if (new_perl) { + SetPerlInterpreter(new_perl); + perl_destruct(new_perl); + perl_free(new_perl); + } +#endif PERL_SYS_TERM(); |