Retract #14985, #14899, and #14990, following the principles

[perl5.git] / sv.c

diff --git a/sv.c b/sv.c
index 7311e5f..27150d6 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1584,6 +1584,9 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
                SvREADONLY_off(sv);
            }
            New(703, s, newlen, char);
+           if (SvPVX(sv) && SvCUR(sv)) {
+               Move(SvPVX(sv), s, SvCUR(sv), char);
+           }
        }
        SvPV_set(sv, s);
         SvLEN_set(sv, newlen);
@@ -3145,6 +3148,45 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
 }
 
 /*
+=for apidoc sv_copypv
+
+Copies a stringified representation of the source SV into the
+destination SV.  Automatically performs any necessary mg_get and
+coercion of numeric values into strings.  Guaranteed to preserve 
+UTF-8 flag even from overloaded objects.  Similar in nature to
+sv_2pv[_flags] but operates directly on an SV instead of just the 
+string.  Mostly uses sv_2pv_flags to do its work, except when that 
+would lose the UTF-8'ness of the PV.
+
+=cut
+*/
+
+void
+Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv)
+{
+    SV *tmpsv = sv_newmortal();
+
+    if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) ) {
+       tmpsv = AMG_CALLun(ssv,string);
+       if (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(ssv))) {
+           SvSetSV(dsv,tmpsv);
+           return;
+       }
+    }
+    {
+       STRLEN len;
+       char *s;
+       s = SvPV(ssv,len);
+       sv_setpvn(tmpsv,s,len);
+       if (SvUTF8(ssv))
+           SvUTF8_on(tmpsv);
+       else
+           SvUTF8_off(tmpsv);
+       SvSetSV(dsv,tmpsv);
+    }
+}
+
+/*
 =for apidoc sv_2pvbyte_nolen
 
 Return a pointer to the byte-encoded representation of the SV.
@@ -3749,8 +3791,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
                                        GvENAME((GV*)dstr));
                                }
                            }
-                           cv_ckproto(cv, (GV*)dstr,
-                                      SvPOK(sref) ? SvPVX(sref) : Nullch);
+                           if (!intro)
+                               cv_ckproto(cv, (GV*)dstr,
+                                       SvPOK(sref) ? SvPVX(sref) : Nullch);
                        }
                        GvCV(dstr) = (CV*)sref;
                        GvCVGEN(dstr) = 0; /* Switch off cacheness. */
@@ -4396,17 +4439,16 @@ Perl_newSV(pTHX_ STRLEN len)
 /*
 =for apidoc sv_magicext
 
-Adds magic to an SV, upgrading it if necessary. Applies the 
+Adds magic to an SV, upgrading it if necessary. Applies the
 supplied vtable and returns pointer to the magic added.
 
 Note that sv_magicext will allow things that sv_magic will not.
-In particular you can add magic to SvREADONLY SVs and and more than 
+In particular you can add magic to SvREADONLY SVs and and more than
 one instance of the same 'how'
 
 I C<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
-(if C<name> is NULL then namelen bytes are allocated and Zero()-ed),
-if C<namelen> is zero then C<name> is stored as-is and - as another special 
-case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain 
+if C<namelen> is zero then C<name> is stored as-is and - as another special
+case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
 an C<SV*> and has its REFCNT incremented
 
 (This is now used as a subroutine by sv_magic.)
@@ -4418,7 +4460,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
                 const char* name, I32 namlen)
 {
     MAGIC* mg;
-    
+
     if (SvTYPE(sv) < SVt_PVMG) {
        (void)SvUPGRADE(sv, SVt_PVMG);
     }
@@ -4451,11 +4493,11 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable,
            mg->mg_ptr = savepvn(name, namlen);
        else if (namlen == HEf_SVKEY)
            mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
-       else 
+       else
            mg->mg_ptr = (char *) name;
     }
     mg->mg_virtual = vtable;
-    
+
     mg_magical(sv);
     if (SvGMAGICAL(sv))
        SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
@@ -4473,7 +4515,7 @@ then adds a new magic item of type C<how> to the head of the magic list.
 
 void
 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
-{ 
+{
     MAGIC* mg;
     MGVTBL *vtable = 0;
 
@@ -4490,15 +4532,15 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     }
     if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
        if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
-           /* sv_magic() refuses to add a magic of the same 'how' as an 
-              existing one 
+           /* sv_magic() refuses to add a magic of the same 'how' as an
+              existing one
             */
            if (how == PERL_MAGIC_taint)
                mg->mg_len |= 1;
            return;
        }
     }
-        
+
     switch (how) {
     case PERL_MAGIC_sv:
        vtable = &PL_vtbl_sv;
@@ -4610,10 +4652,10 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     default:
        Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
     }
-    
+
     /* Rest of work is done else where */
     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
-    
+
     switch (how) {
     case PERL_MAGIC_taint:
        mg->mg_len = 1;
@@ -8680,7 +8722,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
        nmg->mg_len     = mg->mg_len;
        nmg->mg_ptr     = mg->mg_ptr;   /* XXX random ptr? */
        if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
-           if (mg->mg_len >= 0) {
+           if (mg->mg_len > 0) {
                nmg->mg_ptr     = SAVEPVN(mg->mg_ptr, mg->mg_len);
                if (mg->mg_type == PERL_MAGIC_overload_table &&
                        AMT_AMAGIC((AMT*)mg->mg_ptr))
@@ -8696,6 +8738,9 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param)
            else if (mg->mg_len == HEf_SVKEY)
                nmg->mg_ptr     = (char*)sv_dup_inc((SV*)mg->mg_ptr, param);
        }
+       if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) {
+           CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param);
+       }
        mgprev = nmg;
     }
     return mgret;
@@ -8916,9 +8961,9 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
     else if (SvPVX(sstr)) {
        /* Has something there */
        if (SvLEN(sstr)) {
-           /* Normal PV - clone whole allocated space */ 
+           /* Normal PV - clone whole allocated space */
            SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
-       }  
+       }
        else {
            /* Special case - not normally malloced for some reason */
            if (SvREADONLY(sstr) && SvFAKE(sstr)) {
@@ -10472,3 +10517,4 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
      return SvPVX(sv);
 }
 
+