Stop pos() from being confused by changing utf8ness

The value of pos() is stored as a byte offset.  If it is stored on a
tied variable or a reference (or glob), then the stringification could
change, resulting in pos() now pointing to a different character off-
set or pointing to the middle of a character:

$ ./perl -Ilib -le '$x = bless [], chr 256; pos $x=1; bless $x, a; print pos $x'
2
$ ./perl -Ilib -le '$x = bless [], chr 256; pos $x=1; bless $x, "\x{1000}"; print pos $x'
Malformed UTF-8 character (unexpected end of string) in match position at -e line 1.
0

So pos() should be stored as a character offset.

The regular expression engine expects byte offsets always, so allow it
to store bytes when possible (a pure non-magical string) but use char-
acters otherwise.

This does result in more complexity than I should like, but the alter-
native (always storing a character offset) would slow down regular
expressions, which is a big no-no.

diff --git a/dump.c b/dump.c
index 01a9e8b..0126bb5 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1262,6 +1262,9 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, const MAGIC *mg, I32 nest, I32
                Perl_dump_indent(aTHX_ level, file, "      DUP\n");
            if (mg->mg_flags & MGf_LOCAL)
                Perl_dump_indent(aTHX_ level, file, "      LOCAL\n");
+           if (mg->mg_type == PERL_MAGIC_regex_global &&
+               mg->mg_flags & MGf_BYTES)
+               Perl_dump_indent(aTHX_ level, file, "      BYTES\n");
         }
        if (mg->mg_obj) {
            Perl_dump_indent(aTHX_ level, file, "    MG_OBJ = 0x%"UVxf"\n",

diff --git a/embed.fnc b/embed.fnc
index f92ba8e..73951d9 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2665,4 +2665,9 @@ op        |void   |populate_isa   |NN const char *name|STRLEN len|...
 Xop    |bool   |feature_is_enabled|NN const char *const name \
                |STRLEN namelen
 
+: Some static inline functions need predeclaration because they are used
+: inside other static inline functions.
+Ei     |STRLEN |sv_or_pv_pos_u2b|NN SV *sv|NN const char *pv|STRLEN pos \
+                                |NULLOK STRLEN *lenp
+
 : ex: set ts=8 sts=4 sw=4 noet:

diff --git a/embed.h b/embed.h
index 4c62a83..49700ca 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -872,6 +872,7 @@
 #define regprop(a,b,c)         Perl_regprop(aTHX_ a,b,c)
 #define report_uninit(a)       Perl_report_uninit(aTHX_ a)
 #define sv_magicext_mglob(a)   Perl_sv_magicext_mglob(aTHX_ a)
+#define sv_or_pv_pos_u2b(a,b,c,d)      S_sv_or_pv_pos_u2b(aTHX_ a,b,c,d)
 #define validate_proto(a,b,c)  Perl_validate_proto(aTHX_ a,b,c)
 #define vivify_defelem(a)      Perl_vivify_defelem(aTHX_ a)
 #define yylex()                        Perl_yylex(aTHX)

diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t
index e275526..929ce79 100644 (file)
--- a/ext/Devel-Peek/t/Peek.t
+++ b/ext/Devel-Peek/t/Peek.t
@@ -605,8 +605,11 @@ do_test('scalar with pos magic',
   MAGIC = $ADDR
     MG_VIRTUAL = &PL_vtbl_mglob
     MG_TYPE = PERL_MAGIC_regex_global\\(g\\)
-    MG_FLAGS = 0x01
-      MINMATCH');
+    MG_FLAGS = 0x01                                    # $] < 5.019003
+    MG_FLAGS = 0x41                                    # $] >=5.019003
+      MINMATCH
+      BYTES                                            # $] >=5.019003
+');
 
 #
 # TAINTEDDIR is not set on: OS2, AMIGAOS, WIN32, MSDOS

diff --git a/inline.h b/inline.h
index 48cc187..b33cd3f 100644 (file)
--- a/inline.h
+++ b/inline.h
@@ -62,6 +62,26 @@ S_strip_spaces(pTHX_ const char * orig, STRLEN * const len)
 }
 #endif
 
+/* ------------------------------- mg.h ------------------------------- */
+
+#if defined(PERL_CORE) || defined(PERL_EXT)
+/* assumes get-magic and stringification have already occurred */
+PERL_STATIC_INLINE STRLEN
+S_MgBYTEPOS(pTHX_ MAGIC *mg, SV *sv, const char *s, STRLEN len)
+{
+    assert(mg->mg_type == PERL_MAGIC_regex_global);
+    assert(mg->mg_len != -1);
+    if (mg->mg_flags & MGf_BYTES || !DO_UTF8(sv))
+       return (STRLEN)mg->mg_len;
+    else {
+       const STRLEN pos = (STRLEN)mg->mg_len;
+       /* Without this check, we may read past the end of the buffer: */
+       if (pos > sv_or_pv_len_utf8(sv, s, len)) return len+1;
+       return sv_or_pv_pos_u2b(sv, s, pos, NULL);
+    }
+}
+#endif
+
 /* ----------------------------- regexp.h ----------------------------- */
 
 PERL_STATIC_INLINE struct regexp *
@@ -151,10 +171,11 @@ S_SvPADSTALE_off(SV *sv)
     assert(SvFLAGS(sv) & SVs_PADMY);
     return SvFLAGS(sv) &= ~SVs_PADSTALE;
 }
-#ifdef PERL_CORE
+#if defined(PERL_CORE) || defined (PERL_EXT)
 PERL_STATIC_INLINE STRLEN
 S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
 {
+    PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B;
     if (SvGAMAGIC(sv)) {
        U8 *hopped = utf8_hop((U8 *)pv, pos);
        if (lenp) *lenp = (STRLEN)(utf8_hop(hopped, *lenp) - hopped);

diff --git a/mg.c b/mg.c
index f18a98a..c2d2186 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -2098,7 +2098,7 @@ Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
 
     if (found && found->mg_len != -1) {
            STRLEN i = found->mg_len;
-           if (DO_UTF8(lsv))
+           if (found->mg_flags & MGf_BYTES && DO_UTF8(lsv))
                i = sv_pos_b2u_flags(lsv, i, SV_GMAGIC|SV_CONST_RETURN);
            sv_setuv(sv, i);
            return 0;
@@ -2149,12 +2149,8 @@ Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
     else if (pos > (SSize_t)len)
        pos = len;
 
-    if (ulen) {
-       pos = sv_or_pv_pos_u2b(lsv, s, pos, 0);
-    }
-
     found->mg_len = pos;
-    found->mg_flags &= ~MGf_MINMATCH;
+    found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
 
     return 0;
 }

diff --git a/mg.h b/mg.h
index de673d4..29e339f 100644 (file)
--- a/mg.h
+++ b/mg.h
@@ -38,6 +38,7 @@ struct magic {
 #define MGf_COPY       8       /* has an svt_copy  MGVTBL entry */
 #define MGf_DUP     0x10       /* has an svt_dup   MGVTBL entry */
 #define MGf_LOCAL   0x20       /* has an svt_local MGVTBL entry */
+#define MGf_BYTES   0x40        /* PERL_MAGIC_regex_global only */
 
 #define MgTAINTEDDIR(mg)       (mg->mg_flags & MGf_TAINTEDDIR)
 #define MgTAINTEDDIR_on(mg)    (mg->mg_flags |= MGf_TAINTEDDIR)
@@ -57,6 +58,19 @@ struct magic {
 #define SvTIED_obj(sv,mg) \
     ((mg)->mg_obj ? (mg)->mg_obj : sv_2mortal(newRV(sv)))
 
+#if defined(PERL_CORE) || defined(PERL_EXT)
+# define MgBYTEPOS(mg,sv,pv,len) S_MgBYTEPOS(aTHX_ mg,sv,pv,len)
+/* assumes get-magic and stringification have already occurred */
+# define MgBYTEPOS_set(mg,sv,pv,off) (                  \
+    assert_((mg)->mg_type == PERL_MAGIC_regex_global)    \
+    SvPOK(sv) && !SvGMAGICAL(sv)                          \
+       ? (mg)->mg_len = (off), (mg)->mg_flags |= MGf_BYTES \
+       : ((mg)->mg_len = DO_UTF8(sv)                        \
+           ? utf8_length((U8 *)(pv), (U8 *)(pv)+(off))       \
+           : (off),                                           \
+          (mg)->mg_flags &= ~MGf_BYTES))
+#endif
+
 #define whichsig(pv) whichsig_pv(pv)
 
 /*

diff --git a/pp.c b/pp.c
index 46294b3..032b939 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -446,7 +446,7 @@ PP(pp_pos)
            if (mg && mg->mg_len != -1) {
                dTARGET;
                STRLEN i = mg->mg_len;
-               if (DO_UTF8(sv))
+               if (mg->mg_flags & MGf_BYTES && DO_UTF8(sv))
                    i = sv_pos_b2u_flags(sv, i, SV_GMAGIC|SV_CONST_RETURN);
                PUSHu(i);
                RETURN;

diff --git a/pp_ctl.c b/pp_ctl.c
index 6cb26bd..b71648c 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -321,7 +321,8 @@ PP(pp_substcont)
        if (!(mg = mg_find_mglob(sv))) {
            mg = sv_magicext_mglob(sv);
        }
-       mg->mg_len = m - orig;
+       assert(SvPOK(dstr));
+       MgBYTEPOS_set(mg, sv, SvPVX(dstr), m - orig);
     }
     if (old != rx)
        (void)ReREFCNT_inc(rx);

diff --git a/pp_hot.c b/pp_hot.c
index 6068d21..afecce8 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1392,7 +1392,7 @@ PP(pp_match)
     if (global) {
         mg = mg_find_mglob(TARG);
         if (mg && mg->mg_len >= 0) {
-            curpos = mg->mg_len;
+            curpos = MgBYTEPOS(mg, TARG, truebase, len);
             /* last time pos() was set, it was zero-length match */
             if (mg->mg_flags & MGf_MINMATCH)
                 had_zerolen = 1;
@@ -1448,7 +1448,7 @@ PP(pp_match)
     if (global && (gimme != G_ARRAY || (dynpm->op_pmflags & PMf_CONTINUE))) {
         if (!mg)
             mg = sv_magicext_mglob(TARG);
-        mg->mg_len = RX_OFFS(rx)[0].end;
+        MgBYTEPOS_set(mg, TARG, truebase, RX_OFFS(rx)[0].end);
         if (RX_ZERO_LEN(rx))
             mg->mg_flags |= MGf_MINMATCH;
         else

diff --git a/proto.h b/proto.h
index 5c06505..7326fb8 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4159,6 +4159,12 @@ PERL_CALLCONV NV Perl_sv_nv(pTHX_ SV* sv)
 #define PERL_ARGS_ASSERT_SV_NV \
        assert(sv)
 
+PERL_STATIC_INLINE STRLEN      S_sv_or_pv_pos_u2b(pTHX_ SV *sv, const char *pv, STRLEN pos, STRLEN *lenp)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_SV_OR_PV_POS_U2B      \
+       assert(sv); assert(pv)
+
 PERL_CALLCONV char*    Perl_sv_peek(pTHX_ SV* sv);
 PERL_CALLCONV void     Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp)
                        __attribute__nonnull__(pTHX_2);

diff --git a/regexec.c b/regexec.c
index d207d0d..44690b3 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -2256,7 +2256,8 @@ Perl_regexec_flags(pTHX_ REGEXP * const rx, char *stringarg, char *strend,
             (flags & REXEC_IGNOREPOS)
             ? stringarg /* use start pos rather than pos() */
             : (sv && (mg = mg_find_mglob(sv)) && mg->mg_len >= 0)
-            ? strbeg + mg->mg_len /* Defined pos() */
+              /* Defined pos(): */
+            ? strbeg + MgBYTEPOS(mg, sv, strbeg, strend-strbeg)
             : strbeg; /* pos() not defined; use start of string */
 
         DEBUG_GPOS_r(PerlIO_printf(Perl_debug_log,
@@ -5027,8 +5028,9 @@ S_regmatch(pTHX_ regmatch_info *reginfo, char *startpos, regnode *prog)
 
                rex->offs[0].end = locinput - reginfo->strbeg;
                 if (reginfo->info_aux_eval->pos_magic)
-                        reginfo->info_aux_eval->pos_magic->mg_len
-                                        = locinput - reginfo->strbeg;
+                    MgBYTEPOS_set(reginfo->info_aux_eval->pos_magic,
+                                  reginfo->sv, reginfo->strbeg,
+                                  locinput - reginfo->strbeg);
 
                 if (sv_yes_mark) {
                     SV *sv_mrk = get_sv("REGMARK", 1);
@@ -7648,6 +7650,7 @@ S_setup_eval_state(pTHX_ regmatch_info *const reginfo)
         }
         eval_state->pos_magic = mg;
         eval_state->pos       = mg->mg_len;
+        eval_state->pos_flags = mg->mg_flags;
     }
     else
         eval_state->pos_magic = NULL;
@@ -7722,7 +7725,12 @@ S_cleanup_regmatch_info_aux(pTHX_ void *arg)
             RXp_MATCH_COPIED_on(rex);
         }
         if (eval_state->pos_magic)
+        {
             eval_state->pos_magic->mg_len = eval_state->pos;
+            eval_state->pos_magic->mg_flags =
+                 (eval_state->pos_magic->mg_flags & ~MGf_BYTES)
+               | (eval_state->pos_flags & MGf_BYTES);
+        }
 
         PL_curpm = eval_state->curpm;
     }

diff --git a/regexp.h b/regexp.h
index 9c8fd30..fd6425f 100644 (file)
--- a/regexp.h
+++ b/regexp.h
@@ -606,6 +606,7 @@ typedef struct {
     STRLEN  subcoffset; /* saved subcoffset field from rex */
     MAGIC   *pos_magic; /* pos() magic attached to $_ */
     I32     pos;        /* the original value of pos() in pos_magic */
+    U8      pos_flags;  /* flags to be restored; currently only MGf_BYTES*/
 } regmatch_info_aux_eval;
 
 

diff --git a/sv.c b/sv.c
index 4e4a917..3945ab9 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3487,21 +3487,13 @@ must_be_utf8:
            if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
                /* Update pos. We do it at the end rather than during
                 * the upgrade, to avoid slowing down the common case
-                * (upgrade without pos) */
+                * (upgrade without pos).
+                * pos can be stored as either bytes or characters.  Since
+                * this was previously a byte string we can just turn off
+                * the bytes flag. */
                MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
                if (mg) {
-                   I32 pos = mg->mg_len;
-                   if (pos > 0 && (U32)pos > invariant_head) {
-                       U8 *d = (U8*) SvPVX(sv) + invariant_head;
-                       STRLEN n = (U32)pos - invariant_head;
-                       while (n > 0) {
-                           if (UTF8_IS_START(*d))
-                               d++;
-                           d++;
-                           n--;
-                       }
-                       mg->mg_len  = d - (U8*)SvPVX(sv);
-                   }
+                   mg->mg_flags &= ~MGf_BYTES;
                }
                if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
                    magic_setutf8(sv,mg); /* clear UTF8 cache */
@@ -3548,13 +3540,10 @@ Perl_sv_utf8_downgrade(pTHX_ SV *const sv, const bool fail_ok)
            if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
                /* update pos */
                MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
-               if (mg) {
-                   I32 pos = mg->mg_len;
-                   if (pos > 0) {
-                       sv_pos_b2u(sv, &pos);
+               if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) {
+                       mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len,
+                                               SV_GMAGIC|SV_CONST_RETURN);
                        mg_flags = 0; /* sv_pos_b2u does get magic */
-                       mg->mg_len  = pos;
-                   }
                }
                if ((mg = mg_find(sv, PERL_MAGIC_utf8)))
                    magic_setutf8(sv,mg); /* clear UTF8 cache */
@@ -3643,6 +3632,9 @@ Perl_sv_utf8_decode(pTHX_ SV *const sv)
            }
         }
        if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+           /* XXX Is this dead code?  XS_utf8_decode calls SvSETMAGIC
+                  after this, clearing pos.  Does anything on CPAN
+                  need this? */
            /* adjust pos to the start of a UTF8 char sequence */
            MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global);
            if (mg) {
@@ -5538,6 +5530,16 @@ Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how,
        }
     }
 
+    /* Force pos to be stored as characters, not bytes. */
+    if (SvMAGICAL(sv) && DO_UTF8(sv)
+      && (mg = mg_find(sv, PERL_MAGIC_regex_global))
+      && mg->mg_len != -1
+      && mg->mg_flags & MGf_BYTES) {
+       mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len,
+                                              SV_CONST_RETURN);
+       mg->mg_flags &= ~MGf_BYTES;
+    }
+
     /* Rest of work is done else where */
     mg = sv_magicext(sv,obj,how,vtable,name,namlen);
 

diff --git a/sv.h b/sv.h
index 6d8a40e..2f0eabc 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -1976,12 +1976,11 @@ mg.c:1024: warning: left-hand operand of comma expression has no effect
 #define sv_catpvn_nomg_maybeutf8(dsv, sstr, slen, is_utf8) \
        sv_catpvn_flags(dsv, sstr, slen, (is_utf8)?SV_CATUTF8:SV_CATBYTES)
 
-#ifdef PERL_CORE
+#if defined(PERL_CORE) || defined(PERL_EXT)
 # define sv_or_pv_len_utf8(sv, pv, bytelen)          \
     (SvGAMAGIC(sv)                                    \
        ? utf8_length((U8 *)(pv), (U8 *)(pv)+(bytelen)) \
        : sv_len_utf8(sv))
-# define sv_or_pv_pos_u2b(sv,s,p,lp) S_sv_or_pv_pos_u2b(aTHX_ sv,s,p,lp)
 #endif
 
 /*

diff --git a/t/op/pos.t b/t/op/pos.t
index b9691ad..e9c863b 100644 (file)
--- a/t/op/pos.t
+++ b/t/op/pos.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 22;
+plan tests => 28;
 
 $x='banana';
 $x=~/.a/g;
@@ -91,3 +91,34 @@ sub {
     pos $h{n} = 1;
     ok $_[3] =~ /\Ge/, '\G works with defelem scalars';
 }->($h{k}, $h{l}, $h{m}, $h{n});
+
+$x = bless [], chr 256;
+pos $x=1;
+bless $x, a;
+is pos($x), 1, 'pos is not affected by reference stringification changing';
+{
+    my $w;
+    local $SIG{__WARN__} = sub { $w .= shift };
+    $x = bless [], chr 256;
+    pos $x=1;
+    bless $x, "\x{1000}";
+    is pos $x, 1,
+       'pos unchanged after increasing size of chars in stringification';
+    is $w, undef, 'and no malformed utf8 warning';
+}
+$x = bless [], chr 256;
+$x =~ /.(?{
+     bless $x, a;
+     is pos($x), 1, 'pos unaffected by ref str changing (in re-eval)';
+})/;
+{
+    my $w;
+    local $SIG{__WARN__} = sub { $w .= shift };
+    $x = bless [], chr(256);
+    $x =~ /.(?{
+        bless $x, "\x{1000}";
+        is pos $x, 1,
+         'pos unchanged in re-eval after increasing size of chars in str';
+    })/;
+    is $w, undef, 'and no malformed utf8 warning';
+}