Evaluate arg once in all forms of SvTRUE

5.32 did this for one form; now all do.

diff --git a/embed.fnc b/embed.fnc
index ff98258..1371a34 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2727,6 +2727,10 @@ AiMdp    |void   |SvREFCNT_dec   |NULLOK SV *sv
 AiMdp  |void   |SvREFCNT_dec_NN|NN SV *sv
 AiTp   |void   |SvAMAGIC_on    |NN SV *sv
 AiTp   |void   |SvAMAGIC_off   |NN SV *sv
+Aipd   |bool   |SvTRUE         |NULLOK SV *sv
+Aipd   |bool   |SvTRUE_nomg    |NULLOK SV *sv
+Aipd   |bool   |SvTRUE_NN      |NN SV *sv
+Cip    |bool   |SvTRUE_common  |NN SV *sv|const bool sv_2bool_is_fallback
 : This is indirectly referenced by globals.c. This is somewhat annoying.
 p      |int    |magic_killbackrefs|NN SV *sv|NN MAGIC *mg
 Ap     |OP*    |newANONATTRSUB |I32 floor|NULLOK OP *proto|NULLOK OP *attrs|NULLOK OP *block

diff --git a/embed.h b/embed.h
index 8d27796..fd5f3b4 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -31,6 +31,10 @@
 #define Gv_AMupdate(a,b)       Perl_Gv_AMupdate(aTHX_ a,b)
 #define SvAMAGIC_off           Perl_SvAMAGIC_off
 #define SvAMAGIC_on            Perl_SvAMAGIC_on
+#define SvTRUE(a)              Perl_SvTRUE(aTHX_ a)
+#define SvTRUE_NN(a)           Perl_SvTRUE_NN(aTHX_ a)
+#define SvTRUE_common(a,b)     Perl_SvTRUE_common(aTHX_ a,b)
+#define SvTRUE_nomg(a)         Perl_SvTRUE_nomg(aTHX_ a)
 #define _force_out_malformed_utf8_message(a,b,c,d)     Perl__force_out_malformed_utf8_message(aTHX_ a,b,c,d)
 #define _is_uni_FOO(a,b)       Perl__is_uni_FOO(aTHX_ a,b)
 #define _is_uni_perl_idcont(a) Perl__is_uni_perl_idcont(aTHX_ a)

diff --git a/inline.h b/inline.h
index 3b34ad4..c186372 100644 (file)
--- a/inline.h
+++ b/inline.h
@@ -212,13 +212,62 @@ Perl_ReANY(const REGEXP * const re)
 /* ------------------------------- sv.h ------------------------------- */
 
 PERL_STATIC_INLINE bool
-Perl_SvTRUE(pTHX_ SV *sv) {
+Perl_SvTRUE(pTHX_ SV *sv)
+{
+    PERL_ARGS_ASSERT_SVTRUE;
+
     if (UNLIKELY(sv == NULL))
         return FALSE;
     SvGETMAGIC(sv);
     return SvTRUE_nomg_NN(sv);
 }
 
+PERL_STATIC_INLINE bool
+Perl_SvTRUE_nomg(pTHX_ SV *sv)
+{
+    PERL_ARGS_ASSERT_SVTRUE_NOMG;
+
+    if (UNLIKELY(sv == NULL))
+        return FALSE;
+    return SvTRUE_nomg_NN(sv);
+}
+
+PERL_STATIC_INLINE bool
+Perl_SvTRUE_NN(pTHX_ SV *sv)
+{
+    PERL_ARGS_ASSERT_SVTRUE_NN;
+
+    SvGETMAGIC(sv);
+    return SvTRUE_nomg_NN(sv);
+}
+
+PERL_STATIC_INLINE bool
+Perl_SvTRUE_common(pTHX_ SV * sv, const bool sv_2bool_is_fallback)
+{
+    PERL_ARGS_ASSERT_SVTRUE_COMMON;
+
+    if (UNLIKELY(SvIMMORTAL_INTERP(sv)))
+        return SvIMMORTAL_TRUE(sv);
+
+    if (! SvOK(sv))
+        return FALSE;
+
+    if (SvPOK(sv))
+        return SvPVXtrue(sv);
+
+    if (SvIOK(sv))
+        return SvIVX(sv) != 0; /* casts to bool */
+
+    if (SvROK(sv) && !(SvOBJECT(SvRV(sv)) && HvAMAGIC(SvSTASH(SvRV(sv)))))
+        return TRUE;
+
+    if (sv_2bool_is_fallback)
+        return sv_2bool_nomg(sv);
+
+    return isGV_with_GP(sv);
+}
+
+
 PERL_STATIC_INLINE SV *
 Perl_SvREFCNT_inc(SV *sv)
 {

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 8c06208..d0c4daa 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -389,7 +389,9 @@ well.
 
 =item *
 
-XXX
+All C<SvTRUE>-ish functions now evaluate their arguments exactly once.
+In 5.32, plain L<perlapi/C<SvTRUE>> was changed to do that; now the rest
+do as well.
 
 =back
 

diff --git a/proto.h b/proto.h
index 46ce076..5015f24 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -117,6 +117,24 @@ PERL_STATIC_INLINE void    Perl_SvREFCNT_inc_void(SV *sv);
 #define PERL_ARGS_ASSERT_SVREFCNT_INC_VOID
 #endif
 #ifndef PERL_NO_INLINE_FUNCTIONS
+PERL_STATIC_INLINE bool        Perl_SvTRUE(pTHX_ SV *sv);
+#define PERL_ARGS_ASSERT_SVTRUE
+#endif
+#ifndef PERL_NO_INLINE_FUNCTIONS
+PERL_STATIC_INLINE bool        Perl_SvTRUE_NN(pTHX_ SV *sv);
+#define PERL_ARGS_ASSERT_SVTRUE_NN     \
+       assert(sv)
+#endif
+#ifndef PERL_NO_INLINE_FUNCTIONS
+PERL_STATIC_INLINE bool        Perl_SvTRUE_common(pTHX_ SV *sv, const bool sv_2bool_is_fallback);
+#define PERL_ARGS_ASSERT_SVTRUE_COMMON \
+       assert(sv)
+#endif
+#ifndef PERL_NO_INLINE_FUNCTIONS
+PERL_STATIC_INLINE bool        Perl_SvTRUE_nomg(pTHX_ SV *sv);
+#define PERL_ARGS_ASSERT_SVTRUE_NOMG
+#endif
+#ifndef PERL_NO_INLINE_FUNCTIONS
 PERL_STATIC_INLINE I32 Perl_TOPMARK(pTHX);
 #define PERL_ARGS_ASSERT_TOPMARK
 #endif

diff --git a/sv.c b/sv.c
index 5c4c355..486f07d 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3424,7 +3424,7 @@ Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags)
     if (SvNOK(sv) && !SvPOK(sv))
         return SvNVX(sv) != 0.0;
 
-    return SvTRUE_common(sv, isGV_with_GP(sv) ? 1 : 0);
+    return SvTRUE_common(sv, 0);
 }
 
 /*

diff --git a/sv.h b/sv.h
index f753a94..02f1a4b 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -1631,24 +1631,33 @@ efficient C<SvUV>.
 
 C<SvUV_nomg> is the same as C<SvUV>, but does not perform 'get' magic.
 
-=for apidoc Am|bool|SvTRUE|SV* sv
-Returns a boolean indicating whether Perl would evaluate the SV as true or
-false.  See C<L</SvOK>> for a defined/undefined test.  Handles 'get' magic
-unless the scalar is already C<SvPOK>, C<SvIOK> or C<SvNOK> (the public, not the
-private flags).
+=for apidoc SvTRUE
+=for apidoc_item SvTRUEx
+=for apidoc_item SvTRUE_nomg
+=for apidoc_item SvTRUE_NN
+=for apidoc_item SvTRUE_nomg_NN
 
-As of Perl 5.32, this is guaranteed to evaluate C<sv> only once.  Prior to that
-release, use C<L</SvTRUEx>> for single evaluation.
+These return a boolean indicating whether Perl would evaluate the SV as true or
+false.  See C<L</SvOK>> for a defined/undefined test.
 
-=for apidoc Am|bool|SvTRUE_nomg|SV* sv
-Returns a boolean indicating whether Perl would evaluate the SV as true or
-false.  See C<L</SvOK>> for a defined/undefined test.  Does not handle 'get' magic.
+As of Perl 5.32, all are guaranteed to evaluate C<sv> only once.  Prior to that
+release, only C<SvTRUEx> guaranteed single evaluation; now C<SvTRUEx> is
+identical to C<SvTRUE>.
 
-=for apidoc Am|bool|SvTRUEx|SV* sv
-Identical to C<L</SvTRUE>>.  Prior to 5.32, they differed in that only this one
-was guaranteed to evaluate C<sv> only once; in 5.32 they both evaluated it
-once, but C<SvTRUEx> was slightly slower on some platforms; now they are
-identical.
+C<SvTRUE_nomg> and C<TRUE_nomg_NN> do not perform 'get' magic; the others do
+unless the scalar is already C<SvPOK>, C<SvIOK>, or C<SvNOK> (the public, not
+the private flags).
+
+C<SvTRUE_NN> is like C<L</SvTRUE>>, but C<sv> is assumed to be
+non-null (NN).  If there is a possibility that it is NULL, use plain
+C<SvTRUE>.
+
+C<SvTRUE_nomg_NN> is like C<L</SvTRUE_nomg>>, but C<sv> is assumed to be
+non-null (NN).  If there is a possibility that it is NULL, use plain
+C<SvTRUE_nomg>.
+
+C<SvTRUE_NN> is like C<SvTRUE>, but C<sv> is assumed to be non-null (NN).  If
+there is a possibility that it is NULL, use plain C<SvTRUE>.
 
 =for apidoc Am|char*|SvPVutf8_force|SV* sv|STRLEN len
 Like C<SvPV_force>, but converts C<sv> to UTF-8 first if necessary.
@@ -1855,25 +1864,9 @@ scalar.
 #define SvPVutf8x_force(sv, len) sv_pvutf8n_force(sv, &len)
 #define SvPVbytex_force(sv, len) sv_pvbyten_force(sv, &len)
 
-#define SvTRUE(sv)         Perl_SvTRUE(aTHX_ sv)
 #define SvTRUEx(sv)        SvTRUE(sv)
-#define SvTRUE_nomg(sv)    (LIKELY(sv) && SvTRUE_nomg_NN(sv))
-#define SvTRUE_NN(sv)      (SvGETMAGIC(sv), SvTRUE_nomg_NN(sv))
-#define SvTRUE_nomg_NN(sv) (SvTRUE_common(sv, sv_2bool_nomg(sv)))
-
-#define SvTRUE_common(sv,fallback) (                   \
-      SvIMMORTAL_INTERP(sv)                             \
-        ? SvIMMORTAL_TRUE(sv)                           \
-    : !SvOK(sv)                                                \
-       ? 0                                             \
-    : SvPOK(sv)                                                \
-       ? SvPVXtrue(sv)                                 \
-    : SvIOK(sv)                                                \
-        ? (SvIVX(sv) != 0 /* cast to bool */)           \
-    : (SvROK(sv) && !(   SvOBJECT(SvRV(sv))             \
-                      && HvAMAGIC(SvSTASH(SvRV(sv)))))  \
-        ? TRUE                                          \
-    : (fallback))
+#define SvTRUEx_nomg(sv)   SvTRUE_nomg(sv)
+#define SvTRUE_nomg_NN(sv) SvTRUE_common(sv, TRUE)
 
 #if defined(PERL_USE_GCC_BRACE_GROUPS)
 
@@ -1887,7 +1880,6 @@ scalar.
 #  define SvPVutf8x(sv, len) ({SV *_sv = (sv); SvPVutf8(_sv, len); })
 #  define SvPVbytex(sv, len) ({SV *_sv = (sv); SvPVbyte(_sv, len); })
 #  define SvPVbytex_nolen(sv) ({SV *_sv = (sv); SvPVbyte_nolen(_sv); })
-#  define SvTRUEx_nomg(sv) ({SV *_sv = (sv); SvTRUE_nomg(_sv); })
 
 #else /* __GNUC__ */
 
@@ -1904,7 +1896,6 @@ scalar.
 #  define SvPVutf8x(sv, len) ((PL_Sv = (sv)), SvPVutf8(PL_Sv, len))
 #  define SvPVbytex(sv, len) ((PL_Sv = (sv)), SvPVbyte(PL_Sv, len))
 #  define SvPVbytex_nolen(sv) ((PL_Sv = (sv)), SvPVbyte_nolen(PL_Sv))
-#  define SvTRUEx_nomg(sv) ((PL_Sv = (sv)), SvTRUE_nomg(PL_Sv))
 #endif /* __GNU__ */
 
 #define SvPVXtrue(sv)  (                                       \