Don't install Safe in arch directory if this is a core build or if we're >= 5.11.0

[p5sagit/p5-mst-13.2.git] / sv.c

diff --git a/sv.c b/sv.c
index 5057f0d..a53669a 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1185,13 +1185,22 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
 
     PERL_ARGS_ASSERT_SV_UPGRADE;
 
+    if (old_type == new_type)
+       return;
+
+    /* This clause was purposefully added ahead of the early return above to
+       the shared string hackery for (sort {$a <=> $b} keys %hash), with the
+       inference by Nick I-S that it would fix other troublesome cases. See
+       changes 7162, 7163 (f130fd4589cf5fbb24149cd4db4137c8326f49c1 and parent)
+
+       Given that shared hash key scalars are no longer PVIV, but PV, there is
+       no longer need to unshare so as to free up the IVX slot for its proper
+       purpose. So it's safe to move the early return earlier.  */
+
     if (new_type != SVt_PV && SvIsCOW(sv)) {
        sv_force_normal_flags(sv, 0);
     }
 
-    if (old_type == new_type)
-       return;
-
     old_body = SvANY(sv);
 
     /* Copying structures onto other structures that have been neatly zeroed
@@ -1421,8 +1430,22 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
            SvNV_set(sv, 0);
 #endif
 
-       if (new_type == SVt_PVIO)
+       if (new_type == SVt_PVIO) {
+           IO * const io = MUTABLE_IO(sv);
+           GV *iogv = gv_fetchpvs("FileHandle::", 0, SVt_PVHV);
+
+           SvOBJECT_on(io);
+           /* Clear the stashcache because a new IO could overrule a package
+              name */
+           hv_clear(PL_stashcache);
+
+           /* unless exists($main::{FileHandle}) and
+              defined(%main::FileHandle::) */
+           if (!(iogv && GvHV(iogv) && HvARRAY(GvHV(iogv))))
+               iogv = gv_fetchpvs("IO::Handle::", GV_ADD, SVt_PVHV);
+           SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
            IoPAGE_LEN(sv) = 60;
+       }
        if (old_type < SVt_PV) {
            /* referant will be NULL unless the old type was SVt_IV emulating
               SVt_RV */
@@ -3656,6 +3679,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
     SV **location;
     U8 import_flag = 0;
     const U32 stype = SvTYPE(sref);
+    bool mro_changes = FALSE;
 
     PERL_ARGS_ASSERT_GLOB_ASSIGN_REF;
 
@@ -3676,6 +3700,8 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
        goto common;
     case SVt_PVAV:
        location = (SV **) &GvAV(dstr);
+        if (strEQ(GvNAME((GV*)dstr), "ISA"))
+           mro_changes = TRUE;
        import_flag = GVf_IMPORTED_AV;
        goto common;
     case SVt_PVIO:
@@ -3754,6 +3780,7 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
     SvREFCNT_dec(dref);
     if (SvTAINTED(sstr))
        SvTAINT(dstr);
+    if (mro_changes) mro_isa_changed_in(GvSTASH(dstr));
     return;
 }
 
@@ -5069,8 +5096,6 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
     case PERL_MAGIC_qr:
        vtable = &PL_vtbl_regexp;
        break;
-    case PERL_MAGIC_hints:
-       /* As this vtable is all NULL, we can reuse it.  */
     case PERL_MAGIC_sig:
        vtable = &PL_vtbl_sig;
        break;
@@ -5113,6 +5138,9 @@ Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how,
     case PERL_MAGIC_hintselem:
        vtable = &PL_vtbl_hintselem;
        break;
+    case PERL_MAGIC_hints:
+       vtable = &PL_vtbl_hints;
+       break;
     case PERL_MAGIC_ext:
        /* Reserved for use by extensions not perl internals.           */
        /* Useful for attaching extension internal data to perl vars.   */
@@ -7270,7 +7298,7 @@ Perl_sv_inc(pTHX_ register SV *const sv)
     d = SvPVX(sv);
     while (isALPHA(*d)) d++;
     while (isDIGIT(*d)) d++;
-    if (*d) {
+    if (d < SvEND(sv)) {
 #ifdef PERL_PRESERVE_IVUV
        /* Got to punt this as an integer if needs be, but we don't issue
           warnings. Probably ought to make the sv_iv_please() that does
@@ -10422,6 +10450,10 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
     Copy(proto->nexttype, parser->nexttype, 5, I32);
     parser->nexttoke   = proto->nexttoke;
 #endif
+
+    /* XXX should clone saved_curcop here, but we aren't passed
+     * proto_perl; so do it in perl_clone_using instead */
+
     return parser;
 }
 
@@ -12080,6 +12112,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     PL_parser          = parser_dup(proto_perl->Iparser, param);
 
+    /* XXX this only works if the saved cop has already been cloned */
+    if (proto_perl->Iparser) {
+       PL_parser->saved_curcop = (COP*)any_dup(
+                                   proto_perl->Iparser->saved_curcop,
+                                   proto_perl);
+    }
+
     PL_subline         = proto_perl->Isubline;
     PL_subname         = sv_dup_inc(proto_perl->Isubname, param);
 
@@ -12334,11 +12373,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     PL_registered_mros  = hv_dup_inc(proto_perl->Iregistered_mros, param);
 
-    if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
-        ptr_table_free(PL_ptr_table);
-        PL_ptr_table = NULL;
-    }
-
     /* Call the ->CLONE method, if it exists, for each of the stashes
        identified by sv_dup() above.
     */
@@ -12358,6 +12392,12 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
        }
     }
 
+    if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
+        ptr_table_free(PL_ptr_table);
+        PL_ptr_table = NULL;
+    }
+
+
     SvREFCNT_dec(param->stashes);
 
     /* orphaned? eg threads->new inside BEGIN or use */