X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/b464bac0b70c4876af1296864220315edde8461d..a604c751b769c876d14b294d4befb68cd86e52be:/sv.c

diff --git a/sv.c b/sv.c
index aa07053..dd2c876 100644
--- a/sv.c
+++ b/sv.c
@@ -4443,10 +4443,8 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
 	(void)SvPOK_only(dstr);
 
 	if (
-#ifdef PERL_COPY_ON_WRITE
             (sflags & (SVf_FAKE | SVf_READONLY)) != (SVf_FAKE | SVf_READONLY)
             &&
-#endif
             !(isSwipe =
                  (sflags & SVs_TEMP) &&   /* slated for free anyway? */
                  !(sflags & SVf_OOK) &&   /* and not involved in OOK hack? */
@@ -4472,7 +4470,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
         } else {
             /* If PERL_COPY_ON_WRITE is not defined, then isSwipe will always
                be true in here.  */
-#ifdef PERL_COPY_ON_WRITE
             /* Either it's a shared hash key, or it's suitable for
                copy-on-write or we can swipe the string.  */
             if (DEBUG_C_TEST) {
@@ -4480,6 +4477,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
                 sv_dump(sstr);
                 sv_dump(dstr);
             }
+#ifdef PERL_COPY_ON_WRITE
             if (!isSwipe) {
                 /* I believe I should acquire a global SV mutex if
                    it's a COW sv (not a shared hash key) to stop
@@ -4507,19 +4505,21 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
 		    Safefree(SvPVX_const(dstr));
 	    }
 
-#ifdef PERL_COPY_ON_WRITE
             if (!isSwipe) {
                 /* making another shared SV.  */
                 STRLEN cur = SvCUR(sstr);
                 STRLEN len = SvLEN(sstr);
 		assert (SvTYPE(dstr) >= SVt_PVIV);
+#ifdef PERL_COPY_ON_WRITE
                 if (len) {
                     /* SvIsCOW_normal */
                     /* splice us in between source and next-after-source.  */
                     SV_COW_NEXT_SV_SET(dstr, SV_COW_NEXT_SV(sstr));
                     SV_COW_NEXT_SV_SET(sstr, dstr);
                     SvPV_set(dstr, SvPVX(sstr));
-                } else {
+                } else
+#endif
+		{
                     /* SvIsCOW_shared_hash */
                     UV hash = SvUVX(sstr);
                     DEBUG_C(PerlIO_printf(Perl_debug_log,
@@ -4536,7 +4536,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
                 /* Relesase a global SV mutex.  */
             }
             else
-#endif
                 {	/* Passes the swipe test.  */
                 SvPV_set(dstr, SvPVX(sstr));
                 SvLEN_set(dstr, SvLEN(sstr));
@@ -4956,7 +4955,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
 #else
     if (SvREADONLY(sv)) {
 	if (SvFAKE(sv)) {
-	    char *pvx = SvPVX_const(sv);
+	    const char *pvx = SvPVX_const(sv);
 	    const int is_utf8 = SvUTF8(sv);
 	    STRLEN len = SvCUR(sv);
             U32 hash   = SvUVX(sv);
@@ -7601,6 +7600,61 @@ Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
     return sv;
 }
 
+
+/*
+=for apidoc newSVpv_hek
+
+Creates a new SV from the hash key structure.  It will generate scalars that
+point to the shared string table where possible. Returns a new (undefined)
+SV if the hek is NULL.
+
+=cut
+*/
+
+SV *
+Perl_newSVhek(pTHX_ const HEK *hek)
+{
+    if (!hek) {
+	SV *sv;
+
+	new_SV(sv);
+	return sv;
+    }
+
+    if (HEK_LEN(hek) == HEf_SVKEY) {
+	return newSVsv(*(SV**)HEK_KEY(hek));
+    } else {
+	const int flags = HEK_FLAGS(hek);
+	if (flags & HVhek_WASUTF8) {
+	    /* Trouble :-)
+	       Andreas would like keys he put in as utf8 to come back as utf8
+	    */
+	    STRLEN utf8_len = HEK_LEN(hek);
+	    U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len);
+	    SV *sv = newSVpvn ((char*)as_utf8, utf8_len);
+
+	    SvUTF8_on (sv);
+	    Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */
+	    return sv;
+	} else if (flags & HVhek_REHASH) {
+	    /* We don't have a pointer to the hv, so we have to replicate the
+	       flag into every HEK. This hv is using custom a hasing
+	       algorithm. Hence we can't return a shared string scalar, as
+	       that would contain the (wrong) hash value, and might get passed
+	       into an hv routine with a regular hash  */
+
+	    SV *sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek));
+	    if (HEK_UTF8(hek))
+		SvUTF8_on (sv);
+	    return sv;
+	}
+	/* This will be overwhelminly the most common case.  */
+	return newSVpvn_share(HEK_KEY(hek),
+			      (HEK_UTF8(hek) ? -HEK_LEN(hek) : HEK_LEN(hek)),
+			      HEK_HASH(hek));
+    }
+}
+
 /*
 =for apidoc newSVpvn_share
 
@@ -11472,10 +11526,9 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param)
 static void
 do_mark_cloneable_stash(pTHX_ SV *sv)
 {
-    const char *hvname = HvNAME_get((HV*)sv);
+    const HEK *hvname = HvNAME_HEK((HV*)sv);
     if (hvname) {
 	GV* cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0);
-	STRLEN len = HvNAMELEN_get((HV*)sv);
 	SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */
 	if (cloner && GvCV(cloner)) {
 	    dSP;
@@ -11484,7 +11537,7 @@ do_mark_cloneable_stash(pTHX_ SV *sv)
 	    ENTER;
 	    SAVETMPS;
 	    PUSHMARK(SP);
-	    XPUSHs(sv_2mortal(newSVpvn(hvname, len)));
+	    XPUSHs(sv_2mortal(newSVhek(hvname)));
 	    PUTBACK;
 	    call_sv((SV*)GvCV(cloner), G_SCALAR);
 	    SPAGAIN;
@@ -11577,6 +11630,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
      * constants; they need to be allocated as common memory and just
      * their pointers copied. */
 
+    IV i;
     CLONE_PARAMS clone_params;
     CLONE_PARAMS* param = &clone_params;
 
@@ -12334,7 +12388,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 	    ENTER;
 	    SAVETMPS;
 	    PUSHMARK(SP);
-	    XPUSHs(sv_2mortal(newSVpvn(HvNAME_get(stash), HvNAMELEN_get(stash))));
+	    XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash))));
 	    PUTBACK;
 	    call_sv((SV*)GvCV(cloner), G_DISCARD);
 	    FREETMPS;