[perl #76814] FETCH called twice - string comparison ops

This patch changes sv_eq, sv_cmp, sv_cmp_locale and sv_collxfrm
to _flags forms, with macros under the old names for sv_eq and
sv_collxfrm, but functions for sv_cmp* since pp_sort.c needs them.

diff --git a/embed.fnc b/embed.fnc
index 619a0be..2435a51 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1162,9 +1162,12 @@ pd       |I32    |sv_clean_all
 pd     |void   |sv_clean_objs
 Apd    |void   |sv_clear       |NN SV *const sv
 Apd    |I32    |sv_cmp         |NULLOK SV *const sv1|NULLOK SV *const sv2
+Apd    |I32    |sv_cmp_flags   |NULLOK SV *const sv1|NULLOK SV *const sv2|const I32 flags
 Apd    |I32    |sv_cmp_locale  |NULLOK SV *const sv1|NULLOK SV *const sv2
+Apd    |I32    |sv_cmp_locale_flags    |NULLOK SV *const sv1|NULLOK SV *const sv2|const I32 flags
 #if defined(USE_LOCALE_COLLATE)
-Apd    |char*  |sv_collxfrm    |NN SV *const sv|NN STRLEN *const nxp
+Amd    |char*  |sv_collxfrm    |NN SV *const sv|NN STRLEN *const nxp
+Apd    |char*  |sv_collxfrm_flags      |NN SV *const sv|NN STRLEN *const nxp|I32 const flags
 #endif
 Ap     |OP*    |sv_compile_2op |NN SV *sv|NN OP **startop \
                                |NN const char *code|NN PAD **padp
@@ -1174,7 +1177,8 @@ Apd       |void   |sv_dec_nomg    |NULLOK SV *const sv
 Ap     |void   |sv_dump        |NN SV* sv
 ApdR   |bool   |sv_derived_from|NN SV* sv|NN const char *const name
 ApdR   |bool   |sv_does        |NN SV* sv|NN const char *const name
-Apd    |I32    |sv_eq          |NULLOK SV* sv1|NULLOK SV* sv2
+Amd    |I32    |sv_eq          |NULLOK SV* sv1|NULLOK SV* sv2
+Apd    |I32    |sv_eq_flags    |NULLOK SV* sv1|NULLOK SV* sv2|const I32 flags
 Apd    |void   |sv_free        |NULLOK SV *const sv
 : FIXME Used in SvREFCNT_dec() but only
 : if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN)

diff --git a/embed.h b/embed.h
index d269611..d6f0b2f 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -962,9 +962,11 @@
 #endif
 #define sv_clear               Perl_sv_clear
 #define sv_cmp                 Perl_sv_cmp
+#define sv_cmp_flags           Perl_sv_cmp_flags
 #define sv_cmp_locale          Perl_sv_cmp_locale
+#define sv_cmp_locale_flags    Perl_sv_cmp_locale_flags
 #if defined(USE_LOCALE_COLLATE)
-#define sv_collxfrm            Perl_sv_collxfrm
+#define sv_collxfrm_flags      Perl_sv_collxfrm_flags
 #endif
 #define sv_compile_2op         Perl_sv_compile_2op
 #define getcwd_sv              Perl_getcwd_sv
@@ -973,7 +975,7 @@
 #define sv_dump                        Perl_sv_dump
 #define sv_derived_from                Perl_sv_derived_from
 #define sv_does                        Perl_sv_does
-#define sv_eq                  Perl_sv_eq
+#define sv_eq_flags            Perl_sv_eq_flags
 #define sv_free                        Perl_sv_free
 #ifdef PERL_CORE
 #define sv_free_arenas         Perl_sv_free_arenas
@@ -3430,9 +3432,11 @@
 #endif
 #define sv_clear(a)            Perl_sv_clear(aTHX_ a)
 #define sv_cmp(a,b)            Perl_sv_cmp(aTHX_ a,b)
+#define sv_cmp_flags(a,b,c)    Perl_sv_cmp_flags(aTHX_ a,b,c)
 #define sv_cmp_locale(a,b)     Perl_sv_cmp_locale(aTHX_ a,b)
+#define sv_cmp_locale_flags(a,b,c)     Perl_sv_cmp_locale_flags(aTHX_ a,b,c)
 #if defined(USE_LOCALE_COLLATE)
-#define sv_collxfrm(a,b)       Perl_sv_collxfrm(aTHX_ a,b)
+#define sv_collxfrm_flags(a,b,c)       Perl_sv_collxfrm_flags(aTHX_ a,b,c)
 #endif
 #define sv_compile_2op(a,b,c,d)        Perl_sv_compile_2op(aTHX_ a,b,c,d)
 #define getcwd_sv(a)           Perl_getcwd_sv(aTHX_ a)
@@ -3441,7 +3445,7 @@
 #define sv_dump(a)             Perl_sv_dump(aTHX_ a)
 #define sv_derived_from(a,b)   Perl_sv_derived_from(aTHX_ a,b)
 #define sv_does(a,b)           Perl_sv_does(aTHX_ a,b)
-#define sv_eq(a,b)             Perl_sv_eq(aTHX_ a,b)
+#define sv_eq_flags(a,b,c)     Perl_sv_eq_flags(aTHX_ a,b,c)
 #define sv_free(a)             Perl_sv_free(aTHX_ a)
 #ifdef PERL_CORE
 #define sv_free_arenas()       Perl_sv_free_arenas(aTHX)

diff --git a/global.sym b/global.sym
index db75a27..22b358d 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -559,8 +559,10 @@ Perl_sv_catsv
 Perl_sv_chop
 Perl_sv_clear
 Perl_sv_cmp
+Perl_sv_cmp_flags
 Perl_sv_cmp_locale
-Perl_sv_collxfrm
+Perl_sv_cmp_locale_flags
+Perl_sv_collxfrm_flags
 Perl_sv_compile_2op
 Perl_getcwd_sv
 Perl_sv_dec
@@ -568,7 +570,7 @@ Perl_sv_dec_nomg
 Perl_sv_dump
 Perl_sv_derived_from
 Perl_sv_does
-Perl_sv_eq
+Perl_sv_eq_flags
 Perl_sv_free
 Perl_sv_free2
 Perl_sv_gets

diff --git a/mathoms.c b/mathoms.c
index 1bb33d3..44d8e8f 100644 (file)
--- a/mathoms.c
+++ b/mathoms.c
@@ -80,6 +80,8 @@ PERL_CALLCONV HV * Perl_newHV(pTHX);
 PERL_CALLCONV IO * Perl_newIO(pTHX);
 PERL_CALLCONV I32 Perl_my_stat(pTHX);
 PERL_CALLCONV I32 Perl_my_lstat(pTHX);
+PERL_CALLCONV I32 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2);
+PERL_CALLCONV char * Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp);
 
 /* ref() is now a macro using Perl_doref;
  * this version provided for binary compatibility only.
@@ -1533,6 +1535,18 @@ Perl_my_lstat(pTHX)
     return my_lstat_flags(SV_GMAGIC);
 }
 
+I32
+Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
+{
+    return sv_eq_flags(sv1, sv2, SV_GMAGIC);
+}
+
+char *
+Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
+{
+    return sv_collxfrm_flags(sv, nxp, SV_GMAGIC);
+}
+
 #endif /* NO_MATHOMS */
 
 /*

diff --git a/pp.c b/pp.c
index 2ee6049..c3191b8 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -2336,8 +2336,8 @@ PP(pp_sle)
     {
       dPOPTOPssrl;
       const int cmp = (IN_LOCALE_RUNTIME
-                ? sv_cmp_locale(left, right)
-                : sv_cmp(left, right));
+                ? sv_cmp_locale_flags(left, right, 0)
+                : sv_cmp_flags(left, right, 0));
       SETs(boolSV(cmp * multiplier < rhs));
       RETURN;
     }
@@ -2349,7 +2349,7 @@ PP(pp_seq)
     tryAMAGICbin_MG(seq_amg, AMGf_set);
     {
       dPOPTOPssrl;
-      SETs(boolSV(sv_eq(left, right)));
+      SETs(boolSV(sv_eq_flags(left, right, 0)));
       RETURN;
     }
 }
@@ -2360,7 +2360,7 @@ PP(pp_sne)
     tryAMAGICbin_MG(sne_amg, AMGf_set);
     {
       dPOPTOPssrl;
-      SETs(boolSV(!sv_eq(left, right)));
+      SETs(boolSV(!sv_eq_flags(left, right, 0)));
       RETURN;
     }
 }
@@ -2372,8 +2372,8 @@ PP(pp_scmp)
     {
       dPOPTOPssrl;
       const int cmp = (IN_LOCALE_RUNTIME
-                ? sv_cmp_locale(left, right)
-                : sv_cmp(left, right));
+                ? sv_cmp_locale_flags(left, right, 0)
+                : sv_cmp_flags(left, right, 0));
       SETi( cmp );
       RETURN;
     }

diff --git a/proto.h b/proto.h
index 91dae7c..688cf12 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3359,12 +3359,18 @@ PERL_CALLCONV void      Perl_sv_clear(pTHX_ SV *const sv)
        assert(sv)
 
 PERL_CALLCONV I32      Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2);
+PERL_CALLCONV I32      Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, const I32 flags);
 PERL_CALLCONV I32      Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2);
+PERL_CALLCONV I32      Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, const I32 flags);
 #if defined(USE_LOCALE_COLLATE)
-PERL_CALLCONV char*    Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
+/* PERL_CALLCONV char* sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2); */
+
+PERL_CALLCONV char*    Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, I32 const flags)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
-#define PERL_ARGS_ASSERT_SV_COLLXFRM   \
+#define PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS     \
        assert(sv); assert(nxp)
 
 #endif
@@ -3402,7 +3408,8 @@ PERL_CALLCONV bool        Perl_sv_does(pTHX_ SV* sv, const char *const name)
 #define PERL_ARGS_ASSERT_SV_DOES       \
        assert(sv); assert(name)
 
-PERL_CALLCONV I32      Perl_sv_eq(pTHX_ SV* sv1, SV* sv2);
+/* PERL_CALLCONV I32   sv_eq(pTHX_ SV* sv1, SV* sv2); */
+PERL_CALLCONV I32      Perl_sv_eq_flags(pTHX_ SV* sv1, SV* sv2, const I32 flags);
 PERL_CALLCONV void     Perl_sv_free(pTHX_ SV *const sv);
 PERL_CALLCONV void     Perl_sv_free2(pTHX_ SV *const sv)
                        __attribute__nonnull__(pTHX_1);

diff --git a/sv.c b/sv.c
index 0c78725..79472a4 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -6773,11 +6773,17 @@ Returns a boolean indicating whether the strings in the two SVs are
 identical. Is UTF-8 and 'use bytes' aware, handles get magic, and will
 coerce its args to strings if necessary.
 
+=for apidoc sv_eq_flags
+
+Returns a boolean indicating whether the strings in the two SVs are
+identical. Is UTF-8 and 'use bytes' aware and coerces its args to strings
+if necessary. If the flags include SV_GMAGIC, it handles get-magic, too.
+
 =cut
 */
 
 I32
-Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
+Perl_sv_eq_flags(pTHX_ register SV *sv1, register SV *sv2, const I32 flags)
 {
     dVAR;
     const char *pv1;
@@ -6794,12 +6800,14 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
     }
     else {
        /* if pv1 and pv2 are the same, second SvPV_const call may
-        * invalidate pv1, so we may need to make a copy */
-       if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
+        * invalidate pv1 (if we are handling magic), so we may need to
+        * make a copy */
+       if (sv1 == sv2 && flags & SV_GMAGIC
+        && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) {
            pv1 = SvPV_const(sv1, cur1);
            sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2));
        }
-       pv1 = SvPV_const(sv1, cur1);
+       pv1 = SvPV_flags_const(sv1, cur1, flags);
     }
 
     if (!sv2){
@@ -6807,7 +6815,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
        cur2 = 0;
     }
     else
-       pv2 = SvPV_const(sv2, cur2);
+       pv2 = SvPV_flags_const(sv2, cur2, flags);
 
     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
         /* Differing utf8ness.
@@ -6874,12 +6882,26 @@ string in C<sv1> is less than, equal to, or greater than the string in
 C<sv2>. Is UTF-8 and 'use bytes' aware, handles get magic, and will
 coerce its args to strings if necessary.  See also C<sv_cmp_locale>.
 
+=for apidoc sv_cmp_flags
+
+Compares the strings in two SVs.  Returns -1, 0, or 1 indicating whether the
+string in C<sv1> is less than, equal to, or greater than the string in
+C<sv2>. Is UTF-8 and 'use bytes' aware and will coerce its args to strings
+if necessary. If the flags include SV_GMAGIC, it handles get magic. See
+also C<sv_cmp_locale_flags>.
+
 =cut
 */
 
 I32
 Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
 {
+    return sv_cmp_flags(sv1, sv2, SV_GMAGIC);
+}
+
+I32
+Perl_sv_cmp_flags(pTHX_ register SV *const sv1, register SV *const sv2, const I32 flags)
+{
     dVAR;
     STRLEN cur1, cur2;
     const char *pv1, *pv2;
@@ -6892,14 +6914,14 @@ Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2)
        cur1 = 0;
     }
     else
-       pv1 = SvPV_const(sv1, cur1);
+       pv1 = SvPV_flags_const(sv1, cur1, flags);
 
     if (!sv2) {
        pv2 = "";
        cur2 = 0;
     }
     else
-       pv2 = SvPV_const(sv2, cur2);
+       pv2 = SvPV_flags_const(sv2, cur2, flags);
 
     if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
         /* Differing utf8ness.
@@ -6956,12 +6978,24 @@ Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
 'use bytes' aware, handles get magic, and will coerce its args to strings
 if necessary.  See also C<sv_cmp>.
 
+=for apidoc sv_cmp_locale_flags
+
+Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and
+'use bytes' aware and will coerce its args to strings if necessary. If the
+flags contain SV_GMAGIC, it handles get magic. See also C<sv_cmp_flags>.
+
 =cut
 */
 
 I32
 Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
 {
+    return sv_cmp_locale_flags(sv1, sv2, SV_GMAGIC);
+}
+
+I32
+Perl_sv_cmp_locale_flags(pTHX_ register SV *const sv1, register SV *const sv2, const I32 flags)
+{
     dVAR;
 #ifdef USE_LOCALE_COLLATE
 
@@ -6973,9 +7007,9 @@ Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
        goto raw_compare;
 
     len1 = 0;
-    pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
+    pv1 = sv1 ? sv_collxfrm_flags(sv1, &len1, flags) : (char *) NULL;
     len2 = 0;
-    pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
+    pv2 = sv2 ? sv_collxfrm_flags(sv2, &len2, flags) : (char *) NULL;
 
     if (!pv1 || !len1) {
        if (pv2 && len2)
@@ -7014,7 +7048,13 @@ Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2)
 /*
 =for apidoc sv_collxfrm
 
-Add Collate Transform magic to an SV if it doesn't already have it.
+This calls C<sv_collxfrm_flags> with the SV_GMAGIC flag. See
+C<sv_collxfrm_flags>.
+
+=for apidoc sv_collxfrm_flags
+
+Add Collate Transform magic to an SV if it doesn't already have it. If the
+flags contain SV_GMAGIC, it handles get-magic.
 
 Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
 scalar data of the variable, but transformed to such a format that a normal
@@ -7025,12 +7065,12 @@ settings.
 */
 
 char *
-Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
+Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags)
 {
     dVAR;
     MAGIC *mg;
 
-    PERL_ARGS_ASSERT_SV_COLLXFRM;
+    PERL_ARGS_ASSERT_SV_COLLXFRM_FLAGS;
 
     mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
     if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
@@ -7040,7 +7080,7 @@ Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
 
        if (mg)
            Safefree(mg->mg_ptr);
-       s = SvPV_const(sv, len);
+       s = SvPV_flags_const(sv, len, flags);
        if ((xf = mem_collxfrm(s, len, &xlen))) {
            if (! mg) {
 #ifdef PERL_OLD_COPY_ON_WRITE

diff --git a/sv.h b/sv.h
index a96c6f5..07966b2 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -1799,6 +1799,8 @@ mg.c:1024: warning: left-hand operand of comma expression has no effect
 #define sv_2iv(sv) sv_2iv_flags(sv, SV_GMAGIC)
 #define sv_2uv(sv) sv_2uv_flags(sv, SV_GMAGIC)
 #define sv_2nv(sv) sv_2nv_flags(sv, SV_GMAGIC)
+#define sv_eq(sv1, sv2) sv_eq_flags(sv1, sv2, SV_GMAGIC)
+#define sv_collxfrm(sv, nxp) sv_cmp_flags(sv, nxp, SV_GMAGIC)
 #define sv_insert(bigstr, offset, len, little, littlelen)              \
        Perl_sv_insert_flags(aTHX_ (bigstr),(offset), (len), (little),  \
                             (littlelen), SV_GMAGIC)

diff --git a/t/op/tie_fetch_count.t b/t/op/tie_fetch_count.t
index 42f8474..9a767f1 100644 (file)
--- a/t/op/tie_fetch_count.t
+++ b/t/op/tie_fetch_count.t
@@ -68,16 +68,13 @@ $dummy  =  $var  !=   1 ; check_count '!=';
 $dummy  =  $var <=>   1 ; check_count '<=>';
 
 # String comparison
-TODO: {
-    local $::TODO = $TODO;
-    $dummy  =  $var  lt   1 ; check_count 'lt';
-    $dummy  =  $var  le   1 ; check_count 'le';
-    $dummy  =  $var  eq   1 ; check_count 'eq';
-    $dummy  =  $var  ge   1 ; check_count 'ge';
-    $dummy  =  $var  gt   1 ; check_count 'gt';
-    $dummy  =  $var  ne   1 ; check_count 'ne';
-    $dummy  =  $var cmp   1 ; check_count 'cmp';
-}
+$dummy  =  $var  lt   1 ; check_count 'lt';
+$dummy  =  $var  le   1 ; check_count 'le';
+$dummy  =  $var  eq   1 ; check_count 'eq';
+$dummy  =  $var  ge   1 ; check_count 'ge';
+$dummy  =  $var  gt   1 ; check_count 'gt';
+$dummy  =  $var  ne   1 ; check_count 'ne';
+$dummy  =  $var cmp   1 ; check_count 'cmp';
 
 # Bitwise operators
 $dummy  =  $var   &   1 ; check_count '&';