[perl #76814] FETCH called twice - !

This fixes ! by changing sv_2bool to sv_2bool_flags (with a macro
wrapper) and adding SvTRUE_nomg. It also corrects the docs that state
incorrectly that SvTRUE does not handle magic.

diff --git a/embed.fnc b/embed.fnc
index 2435a51..9ba33d1 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1116,7 +1116,8 @@ Ap        |SV**   |stack_grow     |NN SV** sp|NN SV** p|int n
 Ap     |I32    |start_subparse |I32 is_format|U32 flags
 : Used in pp_ctl.c
 p      |void   |sub_crush_depth|NN CV* cv
-Apd    |bool   |sv_2bool       |NN SV *const sv
+Amd    |bool   |sv_2bool       |NN SV *const sv
+Apd    |bool   |sv_2bool_flags |NN SV *const sv|const I32 flags
 Apd    |CV*    |sv_2cv         |NULLOK SV* sv|NN HV **const st|NN GV **const gvp \
                                |const I32 lref
 Apd    |IO*    |sv_2io         |NN SV *const sv

diff --git a/embed.h b/embed.h
index d6f0b2f..0330641 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -919,7 +919,7 @@
 #ifdef PERL_CORE
 #define sub_crush_depth                Perl_sub_crush_depth
 #endif
-#define sv_2bool               Perl_sv_2bool
+#define sv_2bool_flags         Perl_sv_2bool_flags
 #define sv_2cv                 Perl_sv_2cv
 #define sv_2io                 Perl_sv_2io
 #if defined(PERL_IN_SV_C)
@@ -3390,7 +3390,7 @@
 #ifdef PERL_CORE
 #define sub_crush_depth(a)     Perl_sub_crush_depth(aTHX_ a)
 #endif
-#define sv_2bool(a)            Perl_sv_2bool(aTHX_ a)
+#define sv_2bool_flags(a,b)    Perl_sv_2bool_flags(aTHX_ a,b)
 #define sv_2cv(a,b,c,d)                Perl_sv_2cv(aTHX_ a,b,c,d)
 #define sv_2io(a)              Perl_sv_2io(aTHX_ a)
 #if defined(PERL_IN_SV_C)

diff --git a/global.sym b/global.sym
index 22b358d..6c4c570 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -528,7 +528,7 @@ Perl_share_hek
 Perl_csighandler
 Perl_stack_grow
 Perl_start_subparse
-Perl_sv_2bool
+Perl_sv_2bool_flags
 Perl_sv_2cv
 Perl_sv_2io
 Perl_sv_2iv

diff --git a/mathoms.c b/mathoms.c
index 44d8e8f..78516b3 100644 (file)
--- a/mathoms.c
+++ b/mathoms.c
@@ -82,6 +82,7 @@ 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);
+PERL_CALLCONV bool Perl_sv_2bool(pTHX_ register SV *const sv);
 
 /* ref() is now a macro using Perl_doref;
  * this version provided for binary compatibility only.
@@ -1547,6 +1548,12 @@ Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp)
     return sv_collxfrm_flags(sv, nxp, SV_GMAGIC);
 }
 
+bool
+Perl_sv_2bool(pTHX_ register SV *const sv)
+{
+    return sv_2bool_flags(sv, SV_GMAGIC);
+}
+
 #endif /* NO_MATHOMS */
 
 /*

diff --git a/pp.c b/pp.c
index c3191b8..476212e 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -2507,7 +2507,7 @@ PP(pp_not)
 {
     dVAR; dSP;
     tryAMAGICun_MG(not_amg, AMGf_set);
-    *PL_stack_sp = boolSV(!SvTRUE(*PL_stack_sp));
+    *PL_stack_sp = boolSV(!SvTRUE_nomg(*PL_stack_sp));
     return NORMAL;
 }
 

diff --git a/proto.h b/proto.h
index 688cf12..a2fd1f7 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -3214,9 +3214,12 @@ PERL_CALLCONV void       Perl_sub_crush_depth(pTHX_ CV* cv)
 #define PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH       \
        assert(cv)
 
-PERL_CALLCONV bool     Perl_sv_2bool(pTHX_ SV *const sv)
+/* PERL_CALLCONV bool  sv_2bool(pTHX_ SV *const sv)
+                       __attribute__nonnull__(pTHX_1); */
+
+PERL_CALLCONV bool     Perl_sv_2bool_flags(pTHX_ SV *const sv, const I32 flags)
                        __attribute__nonnull__(pTHX_1);
-#define PERL_ARGS_ASSERT_SV_2BOOL      \
+#define PERL_ARGS_ASSERT_SV_2BOOL_FLAGS        \
        assert(sv)
 
 PERL_CALLCONV CV*      Perl_sv_2cv(pTHX_ SV* sv, HV **const st, GV **const gvp, const I32 lref)

diff --git a/sv.c b/sv.c
index 79472a4..309ee6d 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3072,20 +3072,28 @@ Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp)
 /*
 =for apidoc sv_2bool
 
-This function is only called on magical items, and is only used by
-sv_true() or its macro equivalent.
+This macro is only used by sv_true() or its macro equivalent, and only if
+the latter's argument is neither SvPOK, SvIOK nor SvNOK.
+It calls sv_2bool_flags with the SV_GMAGIC flag.
+
+=for apidoc sv_2bool_flags
+
+This function is only used by sv_true() and friends,  and only if
+the latter's argument is neither SvPOK, SvIOK nor SvNOK. If the flags
+contain SV_GMAGIC, then it does an mg_get() first.
+
 
 =cut
 */
 
 bool
-Perl_sv_2bool(pTHX_ register SV *const sv)
+Perl_sv_2bool_flags(pTHX_ register SV *const sv, const I32 flags)
 {
     dVAR;
 
-    PERL_ARGS_ASSERT_SV_2BOOL;
+    PERL_ARGS_ASSERT_SV_2BOOL_FLAGS;
 
-    SvGETMAGIC(sv);
+    if(flags & SV_GMAGIC) SvGETMAGIC(sv);
 
     if (!SvOK(sv))
        return 0;

diff --git a/sv.h b/sv.h
index 07966b2..c081d6a 100644 (file)
--- a/sv.h
+++ b/sv.h
@@ -1459,6 +1459,12 @@ otherwise use the more efficient C<SvUV>.
 
 =for apidoc Am|bool|SvTRUE|SV* sv
 Returns a boolean indicating whether Perl would evaluate the SV as true or
+false.  See SvOK() for a defined/undefined test.  Handles 'get' magic
+unless the scalar is already SvPOK, SvIOK or SvNOK (the public, not the
+private flags).
+
+=for apidoc Am|bool|SvTRUE_nomg|SV* sv
+Returns a boolean indicating whether Perl would evaluate the SV as true or
 false.  See SvOK() for a defined/undefined test.  Does not handle 'get' magic.
 
 =for apidoc Am|char*|SvPVutf8_force|SV* sv|STRLEN len
@@ -1653,6 +1659,22 @@ Like sv_utf8_upgrade, but doesn't do magic on C<sv>
            :   SvNOK(sv)                                       \
                ? SvNVX(sv) != 0.0                              \
                : sv_2bool(sv) )
+#  define SvTRUE_nomg(sv) (                                    \
+    !sv                                                                \
+    ? 0                                                                \
+    :    SvPOK(sv)                                             \
+       ?   (({XPV *nxpv = (XPV*)SvANY(sv);                     \
+            nxpv &&                                            \
+            (nxpv->xpv_cur > 1 ||                              \
+             (nxpv->xpv_cur && *(sv)->sv_u.svu_pv != '0')); }) \
+            ? 1                                                \
+            : 0)                                               \
+       :                                                       \
+           SvIOK(sv)                                           \
+           ? SvIVX(sv) != 0                                    \
+           :   SvNOK(sv)                                       \
+               ? SvNVX(sv) != 0.0                              \
+               : sv_2bool_flags(sv,0) )
 #  define SvTRUEx(sv) ({SV *_sv = (sv); SvTRUE(_sv); })
 
 #else /* __GNUC__ */
@@ -1801,6 +1823,7 @@ mg.c:1024: warning: left-hand operand of comma expression has no effect
 #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_2bool(sv) sv_2bool_flags(sv, 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 9a767f1..10c12b8 100644 (file)
--- a/t/op/tie_fetch_count.t
+++ b/t/op/tie_fetch_count.t
@@ -83,9 +83,9 @@ $dummy  =  $var   |   1 ; check_count '|';
 $dummy  = ~$var         ; check_count '~';
 
 # Logical operators
+$dummy  = !$var         ; check_count '!';
 TODO: {
     local $::TODO = $TODO;
-    $dummy  = !$var         ; check_count '!';
     $dummy  =  $var  ||   1 ; check_count '||';
     $dummy  = ($var  or   1); check_count 'or';
 }