Fix for ID 20010306.008, UTF-8 and \w without 'use utf8' coredump.

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

diff --git a/sv.c b/sv.c
index eeda889..fa3b29e 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -63,7 +63,7 @@ static void do_clean_all(pTHXo_ SV *sv);
 #define del_SV(p) \
     STMT_START {                                       \
        LOCK_SV_MUTEX;                                  \
-       if (PL_debug & 32768)                           \
+       if (DEBUG_D_TEST)                               \
            del_sv(p);                                  \
        else                                            \
            plant_SV(p);                                \
@@ -73,7 +73,7 @@ static void do_clean_all(pTHXo_ SV *sv);
 STATIC void
 S_del_sv(pTHX_ SV *p)
 {
-    if (PL_debug & 32768) {
+    if (DEBUG_D_TEST) {
        SV* sva;
        SV* sv;
        SV* svend;
@@ -2884,7 +2884,8 @@ Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
 char *
 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
 {
-    return sv_2pv(sv,lp);
+    sv_utf8_downgrade(sv,0);
+    return SvPV(sv,*lp);
 }
 
 char *
@@ -2943,18 +2944,27 @@ Perl_sv_2bool(pTHX_ register SV *sv)
 =for apidoc sv_utf8_upgrade
 
 Convert the PV of an SV to its UTF8-encoded form.
+Forces the SV to string form it it is not already.
+Always sets the SvUTF8 flag to avoid future validity checks even
+if all the bytes have hibit clear.
 
 =cut
 */
 
-void
+STRLEN
 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
 {
     char *s, *t, *e;
     int  hibit = 0;
 
-    if (!sv || !SvPOK(sv) || SvUTF8(sv))
-       return;
+    if (!sv)
+       return 0;
+
+    if (!SvPOK(sv))
+       (void) SvPV_nolen(sv);
+
+    if (SvUTF8(sv))
+       return SvCUR(sv);
 
     /* This function could be much more efficient if we had a FLAG in SVs
      * to signal if there are any hibit chars in the PV.
@@ -2981,8 +2991,10 @@ Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
        if (SvLEN(sv) != 0)
            Safefree(s); /* No longer using what was there before. */
        SvLEN(sv) = len; /* No longer know the real size. */
-       SvUTF8_on(sv);
     }
+    /* Mark as UTF-8 even if no hibit - saves scanning loop */
+    SvUTF8_on(sv);
+    return SvCUR(sv);
 }
 
 /*
@@ -3030,7 +3042,8 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
 =for apidoc sv_utf8_encode
 
 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
-flag so that it looks like bytes again. Nothing calls this.
+flag so that it looks like octets again. Used as a building block
+for encode_utf8 in Encode.xs
 
 =cut
 */
@@ -3038,10 +3051,22 @@ flag so that it looks like bytes again. Nothing calls this.
 void
 Perl_sv_utf8_encode(pTHX_ register SV *sv)
 {
-    sv_utf8_upgrade(sv);
+    (void) sv_utf8_upgrade(sv);
     SvUTF8_off(sv);
 }
 
+/*
+=for apidoc sv_utf8_decode
+
+Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
+turn of SvUTF8 if needed so that we see characters. Used as a building block
+for decode_utf8 in Encode.xs
+
+=cut
+*/
+
+
+
 bool
 Perl_sv_utf8_decode(pTHX_ register SV *sv)
 {
@@ -3049,6 +3074,7 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv)
         char *c;
         char *e;
 
+       /* The octets may have got themselves encoded - get them back as bytes */
         if (!sv_utf8_downgrade(sv, TRUE))
            return FALSE;
 
@@ -3946,10 +3972,20 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam
     }
     Newz(702,mg, 1, MAGIC);
     mg->mg_moremagic = SvMAGIC(sv);
-
     SvMAGIC(sv) = mg;
-    if (!obj || obj == sv || how == '#' || how == 'r')
+
+    /* Some magic sontains a reference loop, where the sv and object refer to
+       each other.  To prevent a avoid a reference loop that would prevent such
+       objects being freed, we look for such loops and if we find one we avoid
+       incrementing the object refcount. */
+    if (!obj || obj == sv || how == '#' || how == 'r' ||
+       (SvTYPE(obj) == SVt_PVGV &&
+           (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
+           GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
+           GvFORM(obj) == (CV*)sv)))
+    {
        mg->mg_obj = obj;
+    }
     else {
        mg->mg_obj = SvREFCNT_inc(obj);
        mg->mg_flags |= MGf_REFCOUNTED;
@@ -4334,7 +4370,7 @@ Perl_sv_clear(pTHX_ register SV *sv)
 
     if (SvOBJECT(sv)) {
        if (PL_defstash) {              /* Still have a symbol table? */
-           djSP;
+           dSP;
            CV* destructor;
            SV tmpref;
 
@@ -4669,8 +4705,8 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
     len = 0;
     while (s < send) {
        STRLEN n;
-
-       if (utf8_to_uv(s, UTF8SKIP(s), &n, 0)) {
+        /* We can use low level directly here as we are not looking at the values */
+       if (utf8n_to_uvuni(s, UTF8SKIP(s), &n, 0)) {
            s += n;
            len++;
        }
@@ -5620,8 +5656,12 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
         len = -len;
         is_utf8 = TRUE;
     }
-    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT))
-       src = (char*)bytes_from_utf8((U8*)src, (STRLEN*)&len, &is_utf8);
+    if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
+       STRLEN tmplen = len;
+       /* See the note in hv.c:hv_fetch() --jhi */
+       src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
+       len = tmplen;
+    }
     if (!hash)
        PERL_HASH(hash, src, len);
     new_SV(sv);
@@ -7059,7 +7099,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
            uv = args ? va_arg(*args, int) : SvIVx(argsv);
            if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
                eptr = (char*)utf8buf;
-               elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
+               elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
                is_utf = TRUE;
            }
            else {
@@ -7143,7 +7183,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                if (!veclen)
                    continue;
                if (vec_utf)
-                   iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
+                   iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
                else {
                    iv = *vecstr;
                    ulen = 1;
@@ -7223,7 +7263,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV
                if (!veclen)
                    continue;
                if (vec_utf)
-                   uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
+                   uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
                else {
                    uv = *vecstr;
                    ulen = 1;
@@ -7807,7 +7847,7 @@ S_gv_share(pTHX_ SV *sstr)
         return Nullsv;
     }
 
-    /* 
+    /*
      * write attempts will die with
      * "Modification of a read-only value attempted"
      */