Reinstate "regcomp.c: Move 2 hdr inversion fields to SV hdr"

[perl5.git] / mg.c

diff --git a/mg.c b/mg.c
index 7ff78c1..0dd23f6 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -90,13 +90,13 @@ struct magic_state {
 /* MGS is typedef'ed to struct magic_state in perl.h */
 
 STATIC void
-S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
+S_save_magic_flags(pTHX_ I32 mgs_ix, SV *sv, U32 flags)
 {
     dVAR;
     MGS* mgs;
     bool bumped = FALSE;
 
-    PERL_ARGS_ASSERT_SAVE_MAGIC;
+    PERL_ARGS_ASSERT_SAVE_MAGIC_FLAGS;
 
     assert(SvMAGICAL(sv));
 
@@ -120,12 +120,14 @@ S_save_magic(pTHX_ I32 mgs_ix, SV *sv)
     mgs->mgs_ss_ix = PL_savestack_ix;   /* points after the saved destructor */
     mgs->mgs_bumped = bumped;
 
-    SvMAGICAL_off(sv);
+    SvFLAGS(sv) &= ~flags;
     /* Turning READONLY off for a copy-on-write scalar (including shared
        hash keys) is a bad idea.  */
     if (!SvIsCOW(sv)) SvREADONLY_off(sv);
 }
 
+#define save_magic(a,b) save_magic_flags(a,b,SVs_GMG|SVs_SMG|SVs_RMG)
+
 /*
 =for apidoc mg_magical
 
@@ -263,7 +265,7 @@ Perl_mg_set(pTHX_ SV *sv)
 
     if (PL_localizing == 2 && sv == DEFSV) return 0;
 
-    save_magic(mgs_ix, sv);
+    save_magic_flags(mgs_ix, sv, SVs_GMG|SVs_SMG); /* leave SVs_RMG on */
 
     for (mg = SvMAGIC(sv); mg; mg = nextmg) {
         const MGVTBL* vtbl = mg->mg_virtual;
@@ -434,6 +436,21 @@ Perl_mg_findext(pTHX_ const SV *sv, int type, const MGVTBL *vtbl)
     return S_mg_findext_flags(aTHX_ sv, type, vtbl, 1);
 }
 
+MAGIC *
+Perl_mg_find_mglob(pTHX_ SV *sv)
+{
+    PERL_ARGS_ASSERT_MG_FIND_MGLOB;
+    if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') {
+        /* This sv is only a delegate.  //g magic must be attached to
+           its target. */
+        vivify_defelem(sv);
+        sv = LvTARG(sv);
+    }
+    if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
+        return S_mg_findext_flags(aTHX_ sv, PERL_MAGIC_regex_global, 0, 0);
+    return NULL;
+}
+
 /*
 =for apidoc mg_copy
 
@@ -1043,7 +1060,35 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
            sv_setpv(sv, os2error(Perl_rc));
        else
 #endif
-       sv_setpv(sv, errno ? Strerror(errno) : "");
+       if (! errno) {
+            sv_setpvs(sv, "");
+        }
+        else {
+
+            /* Strerror can return NULL on some platforms, which will result in
+             * 'sv' not being considered SvOK.  The SvNOK_on() below will cause
+             * just the number part to be valid */
+            sv_setpv(sv, Strerror(errno));
+
+            /* In some locales the error string may come back as UTF-8, in
+             * which case we should turn on that flag.  This didn't use to
+             * happen, and to avoid any possible backward compatibility issues,
+             * we don't turn on the flag unless we have to.  So the flag stays
+             * off for an entirely ASCII string.  We assume that if the string
+             * looks like UTF-8, it really is UTF-8:  "text in any other
+             * encoding that uses bytes with the high bit set is extremely
+             * unlikely to pass a UTF-8 validity test"
+             * (http://en.wikipedia.org/wiki/Charset_detection).  There is a
+             * potential that we will get it wrong however, especially on short
+             * error message text.  (If it turns out to be necessary, we could
+             * also keep track if the current LC_MESSAGES locale is UTF-8) */
+            if (SvOK(sv)    /* It could be that Strerror returned invalid */
+                && ! is_ascii_string((U8*) SvPVX_const(sv), SvCUR(sv))
+                && is_utf8_string((U8*) SvPVX_const(sv), SvCUR(sv)))
+            {
+                SvUTF8_on(sv);
+            }
+        }
        RESTORE_ERRNO;
        }
 
@@ -2046,19 +2091,17 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;
     SV* const lsv = LvTARG(sv);
+    MAGIC * const found = mg_find_mglob(lsv);
 
     PERL_ARGS_ASSERT_MAGIC_GETPOS;
     PERL_UNUSED_ARG(mg);
 
-    if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv)) {
-       MAGIC * const found = mg_find(lsv, PERL_MAGIC_regex_global);
-       if (found && found->mg_len >= 0) {
+    if (found && found->mg_len >= 0) {
            I32 i = found->mg_len;
            if (DO_UTF8(lsv))
                sv_pos_b2u(lsv, &i);
            sv_setiv(sv, i);
            return 0;
-       }
     }
     SvOK_off(sv);
     return 0;
@@ -2078,19 +2121,11 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
     PERL_ARGS_ASSERT_MAGIC_SETPOS;
     PERL_UNUSED_ARG(mg);
 
-    if (SvTYPE(lsv) >= SVt_PVMG && SvMAGIC(lsv))
-       found = mg_find(lsv, PERL_MAGIC_regex_global);
-    else
-       found = NULL;
+    found = mg_find_mglob(lsv);
     if (!found) {
        if (!SvOK(sv))
            return 0;
-#ifdef PERL_OLD_COPY_ON_WRITE
-    if (SvIsCOW(lsv))
-        sv_force_normal_flags(lsv, 0);
-#endif
-       found = sv_magicext(lsv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
-                           NULL, 0);
+       found = sv_magicext_mglob(lsv);
     }
     else if (!SvOK(sv)) {
        found->mg_len = -1;
@@ -2266,14 +2301,14 @@ Perl_magic_setvec(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
-int
-Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
+SV *
+Perl_defelem_target(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;
     SV *targ = NULL;
-
-    PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
-
+    PERL_ARGS_ASSERT_DEFELEM_TARGET;
+    if (!mg) mg = mg_find(sv, PERL_MAGIC_defelem);
+    assert(mg);
     if (LvTARGLEN(sv)) {
        if (mg->mg_obj) {
            SV * const ahv = LvTARG(sv);
@@ -2295,10 +2330,18 @@ Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
            mg->mg_obj = NULL;
            mg->mg_flags &= ~MGf_REFCOUNTED;
        }
+       return targ;
     }
     else
-       targ = LvTARG(sv);
-    sv_setsv(sv, targ ? targ : &PL_sv_undef);
+       return LvTARG(sv);
+}
+
+int
+Perl_magic_getdefelem(pTHX_ SV *sv, MAGIC *mg)
+{
+    PERL_ARGS_ASSERT_MAGIC_GETDEFELEM;
+
+    sv_setsv(sv, defelem_target(sv, mg));
     return 0;
 }