Re: [perl #43357] *DESTROY = sub {} at runtime
[p5sagit/p5-mst-13.2.git] / sv.c
diff --git a/sv.c b/sv.c
index 2be8768..7f030e3 100644 (file)
--- 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;