Added sv_regex_global_pos_set() and _clear()

embed.fnc

@@ -3374,8 +3374,13 @@ AMTdip	|void	|SvREFCNT_inc_void					\
 ARdp	|const char *|sv_reftype|NN const SV * const sv 		\
 				|const int ob
 
+Adp	|void	|sv_regex_global_pos_clear				\
+				|NN SV *sv
 Adp	|STRLEN |sv_regex_global_pos_get				\
 				|NN SV *sv
+Adp	|void	|sv_regex_global_pos_set				\
+				|NN SV *sv				\
+				|STRLEN pos
 Adp	|void	|sv_replace	|NN SV * const sv			\
 				|NN SV * const nsv
 Adp	|void	|sv_report_used

embed.h

@@ -778,7 +778,9 @@
 # define sv_recode_to_utf8(a,b)                 Perl_sv_recode_to_utf8(aTHX_ a,b)
 # define sv_ref(a,b,c)                          Perl_sv_ref(aTHX_ a,b,c)
 # define sv_reftype(a,b)                        Perl_sv_reftype(aTHX_ a,b)
+# define sv_regex_global_pos_clear(a)           Perl_sv_regex_global_pos_clear(aTHX_ a)
 # define sv_regex_global_pos_get(a)             Perl_sv_regex_global_pos_get(aTHX_ a)
+# define sv_regex_global_pos_set(a,b)           Perl_sv_regex_global_pos_set(aTHX_ a,b)
 # define sv_replace(a,b)                        Perl_sv_replace(aTHX_ a,b)
 # define sv_report_used()                       Perl_sv_report_used(aTHX)
 # define sv_reset(a,b)                          Perl_sv_reset(aTHX_ a,b)

ext/XS-APItest/APItest.xs

@@ -4970,6 +4970,12 @@ sv_regex_global_pos_get(SV *sv)
     OUTPUT:
         RETVAL
 
+void
+sv_regex_global_pos_set(SV *sv, STRLEN pos)
+
+void
+sv_regex_global_pos_clear(SV *sv)
+
 MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
 
 int

ext/XS-APItest/t/regex_global_pos.t

@@ -22,4 +22,24 @@ use XS::APItest;
     is(sv_regex_global_pos_get($sv), 5, 'pos_get returns count in chars');
 }
 
+# set
+{
+    my $sv = "hello";
+    sv_regex_global_pos_set($sv, 2);
+    is(pos($sv), 2, 'pos() after pos_set');
+
+    $sv =~ m/(.)/gc;
+    is($1, "l", 'regexp match after pos_set');
+    is(pos($sv), 3, 'pos() updated after match');
+
+    sv_regex_global_pos_set($sv, -1);
+    is(pos($sv), 4, 'pos() after pos_set to -1');
+    $sv =~ m/(.)/gc;
+    is($1, "o", 'regexp match after pos_set to -1');
+
+    sv_regex_global_pos_clear($sv);
+    $sv =~ m/(.)/gc;
+    is($1, "h", 'regexp match after pos clear');
+}
+
 done_testing;

mg.c

@@ -2456,44 +2456,14 @@ int
 Perl_magic_setpos(pTHX_ SV *sv, MAGIC *mg)
 {
     SV* const lsv = LvTARG(sv);
-    SSize_t pos;
-    STRLEN len;
-    MAGIC* found;
-    const char *s;
 
     PERL_ARGS_ASSERT_MAGIC_SETPOS;
     PERL_UNUSED_ARG(mg);
 
-    found = mg_find_mglob(lsv);
-    if (!found) {
-        if (!SvOK(sv))
-            return 0;
-        found = sv_magicext_mglob(lsv);
-    }
-    else if (!SvOK(sv)) {
-        found->mg_len = -1;
-        return 0;
-    }
-    s = SvPV_const(lsv, len);
-
-    pos = SvIV(sv);
-
-    if (DO_UTF8(lsv)) {
-        const STRLEN ulen = sv_or_pv_len_utf8(lsv, s, len);
-        if (ulen)
-            len = ulen;
-    }
-
-    if (pos < 0) {
-        pos += len;
-        if (pos < 0)
-            pos = 0;
-    }
-    else if (pos > (SSize_t)len)
-        pos = len;
-
-    found->mg_len = pos;
-    found->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
+    if(SvOK(sv))
+        sv_regex_global_pos_set(lsv, SvIV(sv));
+    else
+        sv_regex_global_pos_clear(lsv);
 
     return 0;
 }

sv.c

@@ -17783,6 +17783,71 @@ Perl_sv_regex_global_pos_get(pTHX_ SV *sv)
     return pos;
 }
 
+/*
+=for apidoc sv_regex_global_pos_set
+
+Sets the value in the regexp global match position magic, first adding it if
+necessary.  If C<pos> is given as a negative value, this will count backwards
+from the end of the string.
+
+=cut
+*/
+
+void
+Perl_sv_regex_global_pos_set(pTHX_ SV *sv, STRLEN pos)
+{
+    PERL_ARGS_ASSERT_SV_REGEX_GLOBAL_POS_SET;
+
+    MAGIC *mg = mg_find_mglob(sv);
+    if(!mg)
+        mg = sv_magicext_mglob(sv);
+
+    STRLEN len;
+    const char *pv = SvPV_const(sv, len);
+
+    /* Convert length to chars, not bytes */
+    if(DO_UTF8(sv)) {
+        const STRLEN ulen = sv_or_pv_len_utf8(sv, pv, len);
+        if(ulen)
+            len = ulen;
+    }
+
+    /* We need signed maths now */
+    SSize_t spos = pos;
+
+    /* Clip pos to length, adjust negatives to count from end */
+    if(spos < 0) {
+        spos += len;
+        if(spos < 0)
+            spos = 0;
+    }
+    else if(spos > (SSize_t)len)
+        spos = len;
+
+    /* Pos is now definitely between 0 and < length in chars */
+    mg->mg_len = spos;
+    mg->mg_flags &= ~(MGf_MINMATCH|MGf_BYTES);
+}
+
+/*
+=for apidoc sv_regex_global_pos_clear
+
+Resets the value in the regexp global match position magic, if it exists, so
+that it does not take effect.
+
+=cut
+*/
+
+void
+Perl_sv_regex_global_pos_clear(pTHX_ SV *sv)
+{
+    PERL_ARGS_ASSERT_SV_REGEX_GLOBAL_POS_CLEAR;
+
+    MAGIC *mg = mg_find_mglob(sv);
+    if(mg)
+        mg->mg_len = -1;
+}
+
 /*
  * ex: set ts=8 sts=4 sw=4 et:
  */