Added sv_regex_global_pos_get(), _set() and _clear()

leonerd · leonerd · commit a2ecfe19ca6c · 2025-02-26T23:45:37.000Z
These new API functions allow XS modules to interact with the stored
`pos()` position without actually depending on the current magic-based
implementation. This allows the internal mechanism to be altered in a
future version without breaking such modules that use the abstraction
API.
diff --git a/MANIFEST b/MANIFEST
@@ -5169,6 +5169,7 @@ ext/XS-APItest/t/printf.t			XS::APItest extension
 ext/XS-APItest/t/ptr_table.t			Test ptr_table_* APIs
 ext/XS-APItest/t/push.t				XS::APItest extension
 ext/XS-APItest/t/refs.t				Test typemap ref handling
+ext/XS-APItest/t/regex_global_pos.t		Test regex_global_pos functions
 ext/XS-APItest/t/rmagical.t			XS::APItest extension
 ext/XS-APItest/t/rpp_invoke_xs.t		XS::APItest: test rpp_invoke_xs()
 ext/XS-APItest/t/rv2cv_op_cv.t			test rv2cv_op_cv() API
diff --git a/embed.fnc b/embed.fnc
@@ -3388,6 +3388,17 @@ AMTdip	|void	|SvREFCNT_inc_void					\
 				|NULLOK SV *sv
 ARdp	|const char *|sv_reftype|NN const SV * const sv 		\
 				|const int ob
+
+Adp	|void	|sv_regex_global_pos_clear				\
+				|NN SV *sv
+ARdp	|bool	|sv_regex_global_pos_get				\
+				|NN SV *sv				\
+				|NN STRLEN *posp			\
+				|U32 flags
+Adp	|void	|sv_regex_global_pos_set				\
+				|NN SV *sv				\
+				|STRLEN pos				\
+				|U32 flags
 Adp	|void	|sv_replace	|NN SV * const sv			\
 				|NN SV * const nsv
 Adp	|void	|sv_report_used
diff --git a/embed.h b/embed.h
@@ -780,6 +780,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,b,c)         Perl_sv_regex_global_pos_get(aTHX_ a,b,c)
+# define sv_regex_global_pos_set(a,b,c)         Perl_sv_regex_global_pos_set(aTHX_ a,b,c)
 # 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)
diff --git a/ext/XS-APItest/APItest.pm b/ext/XS-APItest/APItest.pm
@@ -4,7 +4,7 @@ use strict;
 use warnings;
 use Carp;
 
-our $VERSION = '1.40';
+our $VERSION = '1.41';
 
 require XSLoader;
 
diff --git a/ext/XS-APItest/APItest.xs b/ext/XS-APItest/APItest.xs
@@ -4959,6 +4959,20 @@ modify_pv(IV pi, IV sz)
         /* used by op/pack.t when testing pack "p" */
         memset(INT2PTR(char *, pi), 'y', sz);
 
+STRLEN
+sv_regex_global_pos_get(SV *sv, U32 flags = 0)
+    CODE:
+        if(!sv_regex_global_pos_get(sv, &RETVAL, flags))
+            XSRETURN_UNDEF;
+    OUTPUT:
+        RETVAL
+
+void
+sv_regex_global_pos_set(SV *sv, STRLEN pos, U32 flags = 0)
+
+void
+sv_regex_global_pos_clear(SV *sv)
+
 MODULE = XS::APItest PACKAGE = XS::APItest::AUTOLOADtest
 
 int
diff --git a/ext/XS-APItest/Makefile.PL b/ext/XS-APItest/Makefile.PL
@@ -25,7 +25,7 @@ my @names = (qw(HV_DELETE HV_DISABLE_UVAR_XKEY HV_FETCH_ISSTORE
 		G_SCALAR G_LIST G_VOID G_DISCARD G_EVAL G_NOARGS
 		G_KEEPERR G_NODEBUG G_METHOD G_FAKINGEVAL G_RETHROW
 		GV_NOADD_NOINIT G_USEHINTS
-		SV_GMAGIC SV_SKIP_OVERLOAD
+		SV_GMAGIC SV_SKIP_OVERLOAD SV_POSBYTES
 		IS_NUMBER_IN_UV IS_NUMBER_GREATER_THAN_UV_MAX
 		IS_NUMBER_NOT_INT IS_NUMBER_NEG IS_NUMBER_INFINITY
 		IS_NUMBER_NAN IS_NUMBER_TRAILING PERL_SCAN_TRAILING
diff --git a/ext/XS-APItest/t/regex_global_pos.t b/ext/XS-APItest/t/regex_global_pos.t
@@ -0,0 +1,60 @@
+#!perl
+
+use v5.40;
+
+use Test::More;
+
+use XS::APItest;
+
+# get
+{
+    my $sv = "hello";
+    is(sv_regex_global_pos_get($sv), undef, 'pos_get before setting');
+
+    $sv =~ m/.../gc;
+    is(sv_regex_global_pos_get($sv), 3, 'pos_get after successful match');
+}
+
+# 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');
+}
+
+# characters vs bytes
+{
+    use utf8;
+    my $sv = "café here";
+
+    # pos should be 5 characters even though it is 6 bytes
+    $sv =~ m/ /gc;
+    is(sv_regex_global_pos_get($sv), 5, 'pos_get returns count in chars');
+    # can query position in bytes directly
+    is(sv_regex_global_pos_get($sv, SV_POSBYTES), 6, 'pos_get with SV_POSBYTES returns count in bytes');
+
+    pos($sv) = 0;
+    sv_regex_global_pos_set($sv, 4);
+    $sv =~ m/(.)/gc;
+    is($1, " ", 'regexp match after pos_set in chars');
+
+    pos($sv) = 0;
+    sv_regex_global_pos_set($sv, 5, SV_POSBYTES);
+    $sv =~ m/(.)/gc;
+    is($1, " ", 'regexp match after pos_set in bytes');
+}
+
+done_testing;
diff --git a/mg.c b/mg.c
@@ -2439,17 +2439,14 @@ int
 Perl_magic_getpos(pTHX_ SV *sv, MAGIC *mg)
 {
     SV* const lsv = LvTARG(sv);
-    MAGIC * const found = mg_find_mglob(lsv);
 
     PERL_ARGS_ASSERT_MAGIC_GETPOS;
     PERL_UNUSED_ARG(mg);
 
-    if (found && found->mg_len != -1) {
-            STRLEN i = found->mg_len;
-            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;
+    STRLEN pos;
+    if (sv_regex_global_pos_get(lsv, &pos, 0)) {
+        sv_setuv(sv, pos);
+        return 0;
     }
     sv_set_undef(sv);
     return 0;
@@ -2459,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), 0);
+    else
+        sv_regex_global_pos_clear(lsv);
 
     return 0;
 }
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
@@ -348,7 +348,12 @@ well.
 
 =item *
 
-XXX
+Three new API functions have been added to interact with the regexp global
+match position stored in an SV.  These are C<sv_regex_global_pos_get()>,
+C<sv_regex_global_pos_set()> and C<sv_regex_global_pos_clear()>.  Using these
+API functions avoids XS modules needing to know about or interact directly
+with the way this position is currently stored, which involves the
+C<PERL_MAGIC_regex_global> magic type.
 
 =back
 
diff --git a/proto.h b/proto.h
diff --git a/sv.c b/sv.c
@@ -17778,6 +17778,112 @@ void S_croak_sv_setsv_flags(pTHX_ SV * const dsv, SV * const ssv)
 
 }
 
+/*
+=for apidoc sv_regex_global_pos_get
+
+If the given SV has regexp global match position magic, sets the STRLEN
+pointed to by C<posp> to the current value of the position and returns true.
+If not, returns false.
+
+If flags is zero, the return value will count in units of characters.  If
+the C<SV_POSBYTES> flag is present, this will count instead in units of bytes,
+which may be different if the SV has the C<SvUTF8> flag set.
+
+=cut
+*/
+
+bool
+Perl_sv_regex_global_pos_get(pTHX_ SV *sv, STRLEN *posp, U32 flags)
+{
+    PERL_ARGS_ASSERT_SV_REGEX_GLOBAL_POS_GET;
+
+    MAGIC *mg = mg_find_mglob(sv);
+    if(!mg || mg->mg_len == -1)
+        return false;
+
+    STRLEN pos = mg->mg_len;
+    if(!(flags & SV_POSBYTES) && (mg->mg_flags & MGf_BYTES) && DO_UTF8(sv))
+        pos = sv_pos_b2u_flags(sv, pos, SV_GMAGIC|SV_CONST_RETURN);
+
+    *posp = pos;
+    return true;
+}
+
+/*
+=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.
+
+If flags is zero, C<pos> will count in units of characters.  If the
+C<SV_POSBYTES> flag is present, this will count instead in units of bytes,
+which may be different if the SV has the C<SvUTF8> flag set.  In that case, it
+will be the caller's responsibility to ensure that C<pos> only lands on the
+boundary between characters, and not in the middle of a multi-byte character.
+
+=cut
+*/
+
+void
+Perl_sv_regex_global_pos_set(pTHX_ SV *sv, STRLEN pos, U32 flags)
+{
+    PERL_ARGS_ASSERT_SV_REGEX_GLOBAL_POS_SET;
+    bool countbytes = (flags & SV_POSBYTES);
+
+    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(!countbytes && 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 */
+    mg->mg_len = spos;
+    if(countbytes)
+        mg->mg_flags &= ~MGf_MINMATCH, mg->mg_flags |= MGf_BYTES;
+    else
+        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:
  */
diff --git a/sv.h b/sv.h
@@ -2155,6 +2155,9 @@ Returns the hash for C<sv> created by C<L</newSVpvn_share>>.
 #define SV_CATBYTES             (1 << 14) /* 0x4000 - 16384 */
 #define SV_CATUTF8              (1 << 15) /* 0x8000 - 32768 */
 
+/* sv_regex_global_pos_*() should count in bytes, not chars */
+#define SV_POSBYTES             SV_CATBYTES
+
 /* The core is safe for this COW optimisation. XS code on CPAN may not be.
    So only default to doing the COW setup if we're in the core.
  */
