diff options
| -rw-r--r-- | embed.fnc | 3 | ||||
| -rw-r--r-- | embed.h | 4 | ||||
| -rw-r--r-- | global.sym | 2 | ||||
| -rw-r--r-- | mathoms.c | 7 | ||||
| -rw-r--r-- | pp.c | 2 | ||||
| -rw-r--r-- | proto.h | 7 | ||||
| -rw-r--r-- | sv.c | 18 | ||||
| -rw-r--r-- | sv.h | 23 | ||||
| -rw-r--r-- | t/op/tie_fetch_count.t | 2 |
9 files changed, 55 insertions, 13 deletions
@@ -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 @@ -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 22b358ddca..6c4c57028b 100644 --- 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 @@ -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 */ /* @@ -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; } @@ -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) @@ -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; @@ -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 9a767f1761..10c12b8042 100644 --- 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'; } |