X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=7f030e3f08ea2de9b01ee5b3cad91bb331f7e8f7;hb=5be5c7a687aa37f2ea9dec7988eb57cad1f1ec24;hp=2be876854b62d8f6a69c58643aa3e54e4d4920db;hpb=907b3e23950be4dd31c150e1902fbd26201355bd;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 2be8768..7f030e3 100644 --- a/sv.c +++ b/sv.c @@ -246,8 +246,13 @@ S_new_SV(pTHX) SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; - sv->sv_debug_line = (U16) ((PL_parser && PL_parser->copline == NOLINE) ? - (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_parser->copline); + sv->sv_debug_line = (U16) (PL_parser + ? PL_parser->copline == NOLINE + ? PL_curcop + ? CopLINE(PL_curcop) + : 0 + : PL_parser->copline + : 0); sv->sv_debug_inpad = 0; sv->sv_debug_cloned = 0; sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; @@ -462,7 +467,8 @@ do_clean_named_objs(pTHX_ SV *sv) SvOBJECT(GvSV(sv))) || (GvAV(sv) && SvOBJECT(GvAV(sv))) || (GvHV(sv) && SvOBJECT(GvHV(sv))) || - (GvIO(sv) && SvOBJECT(GvIO(sv))) || + /* In certain rare cases GvIOp(sv) can be NULL, which would make SvOBJECT(GvIO(sv)) dereference NULL. */ + (GvIO(sv) ? (SvFLAGS(GvIOp(sv)) & SVs_OBJECT) : 0) || (GvCV(sv) && SvOBJECT(GvCV(sv))) ) { DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv))); @@ -780,16 +786,16 @@ are used for this, except for arena_size. For the sv-types that have no bodies, arenas are not used, so those PL_body_roots[sv_type] are unused, and can be overloaded. In something of a special case, SVt_NULL is borrowed for HE arenas; -PL_body_roots[SVt_NULL] is filled by S_more_he, but the +PL_body_roots[HE_SVSLOT=SVt_NULL] is filled by S_more_he, but the bodies_by_type[SVt_NULL] slot is not used, as the table is not -available in hv.c, +available in hv.c. -PTEs also use arenas, but are never seen in Perl_sv_upgrade. -Nonetheless, they get their own slot in bodies_by_type[SVt_NULL], so -they can just use the same allocation semantics. At first, PTEs were -also overloaded to a non-body sv-type, but this yielded hard-to-find -malloc bugs, so was simplified by claiming a new slot. This choice -has no consequence at this time. +PTEs also use arenas, but are never seen in Perl_sv_upgrade. Nonetheless, +they get their own slot in bodies_by_type[PTE_SVSLOT =SVt_IV], so they can +just use the same allocation semantics. At first, PTEs were also +overloaded to a non-body sv-type, but this yielded hard-to-find malloc +bugs, so was simplified by claiming a new slot. This choice has no +consequence at this time. */ @@ -869,7 +875,7 @@ static const struct body_details bodies_by_type[] = { FALSE, NONV, NOARENA, FIT_ARENA(0, sizeof(HE)) }, /* The bind placeholder pretends to be an RV for now. - Also it's marked as "can't upgrade" top stop anyone using it before it's + Also it's marked as "can't upgrade" to stop anyone using it before it's implemented. */ { 0, 0, 0, SVt_BIND, TRUE, NONV, NOARENA, 0 }, @@ -2734,15 +2740,16 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) const U32 isUIOK = SvIsUV(sv); char buf[TYPE_CHARS(UV)]; char *ebuf, *ptr; + STRLEN len; if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); ptr = uiv_2buf(buf, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf); + len = ebuf - ptr; /* inlined from sv_setpvn */ - SvGROW_mutable(sv, (STRLEN)(ebuf - ptr + 1)); - Move(ptr,SvPVX_mutable(sv),ebuf - ptr,char); - SvCUR_set(sv, ebuf - ptr); - s = SvEND(sv); + s = SvGROW_mutable(sv, len + 1); + Move(ptr, s, len, char); + s += len; *s = '\0'; } else if (SvNOKp(sv)) { @@ -3616,9 +3623,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) /* and won't be needed again, potentially */ !(PL_op && PL_op->op_type == OP_AASSIGN)) #ifdef PERL_OLD_COPY_ON_WRITE - && !((sflags & CAN_COW_MASK) == CAN_COW_FLAGS - && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS - && SvTYPE(sstr) >= SVt_PVIV) + && ((flags & SV_COW_SHARED_HASH_KEYS) + ? (!((sflags & CAN_COW_MASK) == CAN_COW_FLAGS + && (SvFLAGS(dstr) & CAN_COW_MASK) == CAN_COW_FLAGS + && SvTYPE(sstr) >= SVt_PVIV)) + : 1) #endif ) { /* Failed the swipe test, and it's not a shared hash key either. @@ -3998,7 +4007,7 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) SvCUR_set(sv, len); SvLEN_set(sv, allocate); if (!(flags & SV_HAS_TRAILING_NUL)) { - *SvEND(sv) = '\0'; + ptr[len] = '\0'; } (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); @@ -4388,6 +4397,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, */ if (!obj || obj == sv || how == PERL_MAGIC_arylen || + how == PERL_MAGIC_isaelem || how == PERL_MAGIC_qr || how == PERL_MAGIC_symtab || (SvTYPE(obj) == SVt_PVGV && @@ -7612,7 +7622,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) SvGROW(sv, len + 1); Move(s,SvPVX(sv),len,char); SvCUR_set(sv, len); - *SvEND(sv) = '\0'; + SvPVX(sv)[len] = '\0'; } if (!SvPOK(sv)) { SvPOK_on(sv); /* validate pointer */ @@ -9572,6 +9582,7 @@ Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) parser->multi_close = proto->multi_close; parser->multi_open = proto->multi_open; parser->multi_start = proto->multi_start; + parser->multi_end = proto->multi_end; parser->pending_ident = proto->pending_ident; parser->preambled = proto->preambled; parser->sublex_info = proto->sublex_info; /* XXX not quite right */ @@ -9585,6 +9596,7 @@ Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) parser->rsfp_filters= av_dup_inc(proto->rsfp_filters, param); parser->in_my = proto->in_my; parser->in_my_stash = hv_dup(proto->in_my_stash, param); + parser->error_count = proto->error_count; parser->linestr = sv_dup_inc(proto->linestr, param); @@ -9609,6 +9621,8 @@ Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) parser->bufend = ls + SvCUR(parser->linestr); } + Copy(proto->tokenbuf, parser->tokenbuf, 256, char); + #ifdef PERL_MAD parser->endwhite = proto->endwhite; @@ -10893,6 +10907,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_savestack_ix = 0; PL_savestack_max = -1; PL_sig_pending = 0; + PL_parser = NULL; Zero(&PL_debug_pad, 1, struct perl_debug_pad); # else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); @@ -10927,6 +10942,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_savestack_ix = 0; PL_savestack_max = -1; PL_sig_pending = 0; + PL_parser = NULL; Zero(&PL_debug_pad, 1, struct perl_debug_pad); # else /* !DEBUGGING */ Zero(my_perl, 1, PerlInterpreter); @@ -11132,8 +11148,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_DBsingle = sv_dup(proto_perl->IDBsingle, param); PL_DBtrace = sv_dup(proto_perl->IDBtrace, param); PL_DBsignal = sv_dup(proto_perl->IDBsignal, param); - PL_DBassertion = sv_dup(proto_perl->IDBassertion, param); - PL_lineary = av_dup(proto_perl->Ilineary, param); PL_dbargs = av_dup(proto_perl->Idbargs, param); /* symbol tables */ @@ -11257,8 +11271,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_runops = proto_perl->Irunops; - Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char); - #ifdef CSH PL_cshlen = proto_perl->Icshlen; PL_cshname = proto_perl->Icshname; /* XXX never deallocated */ @@ -11266,9 +11278,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_parser = parser_dup(proto_perl->Iparser, param); - PL_multi_end = proto_perl->Imulti_end; - - PL_error_count = proto_perl->Ierror_count; PL_subline = proto_perl->Isubline; PL_subname = sv_dup_inc(proto_perl->Isubname, param); @@ -11344,9 +11353,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_unlockhook = proto_perl->Iunlockhook; PL_threadhook = proto_perl->Ithreadhook; - PL_runops_std = proto_perl->Irunops_std; - PL_runops_dbg = proto_perl->Irunops_dbg; - #ifdef THREADS_HAVE_PIDS PL_ppid = proto_perl->Ippid; #endif @@ -11779,8 +11785,7 @@ S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, } } else { - U32 unused; - CV * const cv = find_runcv(&unused); + CV * const cv = find_runcv(NULL); SV *sv; AV *av;