In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/a7e935015aa7c242f0e4ad14366401108880ed0b?hp=582ac935ddba404ce00c7eda1a75e8a2c0412eee>
- Log -----------------------------------------------------------------
commit a7e935015aa7c242f0e4ad14366401108880ed0b
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Sep 24 20:42:54 2010 -0700
perldelta entries for the double-magic fixes [perl #76814]
M pod/perldelta.pod
commit 9138d6cae0eac4fc349c2e253e64077481cf6a49
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Sep 24 20:33:47 2010 -0700
[perl #76814] FETCH called twice - y
This patch stops y from calling get-magic twice. (This has caused
double magick since as far back as 5.6.2.)
M doop.c
M t/op/tie_fetch_count.t
commit a9984b10c8213b2dc4345882bd808798485d584c
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Sep 24 20:33:42 2010 -0700
[perl #76814] FETCH called twice - m and s
This fixes m and s. It modifies pp_regcomp to avoid extra magic. It
also corrects a bug in sv_catsv_flags, which would still call
mg_get(ssv) even without the SV_GMAGIC flag set.
M pp_ctl.c
M sv.c
M t/op/tie_fetch_count.t
commit 06c841cf64c10f912e4cb0d12dbfc0add671bb81
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Sep 24 20:33:03 2010 -0700
[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.
M embed.fnc
M embed.h
M global.sym
M mathoms.c
M pp.c
M proto.h
M sv.c
M sv.h
M t/op/tie_fetch_count.t
commit 078504b2d0c069e5cefbe4670341aa18838d452d
Author: Father Chrysostomos <spr...@cpan.org>
Date: Fri Sep 24 20:31:28 2010 -0700
[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.
M embed.fnc
M embed.h
M global.sym
M mathoms.c
M pp.c
M proto.h
M sv.c
M sv.h
M t/op/tie_fetch_count.t
-----------------------------------------------------------------------
Summary of changes:
doop.c | 12 +++---
embed.fnc | 11 ++++--
embed.h | 16 +++++---
global.sym | 8 +++--
mathoms.c | 21 ++++++++++++
pod/perldelta.pod | 59 ++++++++++++++++++++++++++++++++-
pp.c | 14 ++++----
pp_ctl.c | 10 +++++-
proto.h | 20 ++++++++---
sv.c | 86 +++++++++++++++++++++++++++++++++++++----------
sv.h | 25 ++++++++++++++
t/op/tie_fetch_count.t | 32 ++++++++----------
12 files changed, 245 insertions(+), 69 deletions(-)
diff --git a/doop.c b/doop.c
index 903144c..35efba6 100644
--- a/doop.c
+++ b/doop.c
@@ -33,7 +33,7 @@ S_do_trans_simple(pTHX_ SV * const sv)
dVAR;
I32 matches = 0;
STRLEN len;
- U8 *s = (U8*)SvPV(sv,len);
+ U8 *s = (U8*)SvPV_nomg(sv,len);
U8 * const send = s+len;
const short * const tbl = (short*)cPVOP->op_pv;
@@ -101,7 +101,7 @@ S_do_trans_count(pTHX_ SV * const sv)
{
dVAR;
STRLEN len;
- const U8 *s = (const U8*)SvPV_const(sv, len);
+ const U8 *s = (const U8*)SvPV_nomg_const(sv, len);
const U8 * const send = s + len;
I32 matches = 0;
const short * const tbl = (short*)cPVOP->op_pv;
@@ -139,7 +139,7 @@ S_do_trans_complex(pTHX_ SV * const sv)
{
dVAR;
STRLEN len;
- U8 *s = (U8*)SvPV(sv, len);
+ U8 *s = (U8*)SvPV_nomg(sv, len);
U8 * const send = s+len;
I32 matches = 0;
const short * const tbl = (short*)cPVOP->op_pv;
@@ -325,7 +325,7 @@ S_do_trans_simple_utf8(pTHX_ SV * const sv)
PERL_ARGS_ASSERT_DO_TRANS_SIMPLE_UTF8;
- s = (U8*)SvPV(sv, len);
+ s = (U8*)SvPV_nomg(sv, len);
if (!SvUTF8(sv)) {
const U8 *t = s;
const U8 * const e = s + len;
@@ -426,7 +426,7 @@ S_do_trans_count_utf8(pTHX_ SV * const sv)
PERL_ARGS_ASSERT_DO_TRANS_COUNT_UTF8;
- s = (const U8*)SvPV_const(sv, len);
+ s = (const U8*)SvPV_nomg_const(sv, len);
if (!SvUTF8(sv)) {
const U8 *t = s;
const U8 * const e = s + len;
@@ -478,7 +478,7 @@ S_do_trans_complex_utf8(pTHX_ SV * const sv)
STRLEN len;
U8 *dstart, *dend;
U8 hibit = 0;
- U8 *s = (U8*)SvPV(sv, len);
+ U8 *s = (U8*)SvPV_nomg(sv, len);
PERL_ARGS_ASSERT_DO_TRANS_COMPLEX_UTF8;
diff --git a/embed.fnc b/embed.fnc
index 619a0be..9ba33d1 100644
--- 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
@@ -1162,9 +1163,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 +1178,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..0330641 100644
--- 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)
@@ -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
@@ -3388,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)
@@ -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..6c4c570 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
@@ -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..78516b3 100644
--- a/mathoms.c
+++ b/mathoms.c
@@ -80,6 +80,9 @@ 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);
+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.
@@ -1533,6 +1536,24 @@ 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);
+}
+
+bool
+Perl_sv_2bool(pTHX_ register SV *const sv)
+{
+ return sv_2bool_flags(sv, SV_GMAGIC);
+}
+
#endif /* NO_MATHOMS */
/*
diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index a3c89ce..abbca52 100644
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -231,7 +231,8 @@ section.
=item *
-XXX Description of the change here
+The documentation for the C<SvTRUE> macro was simply wrong in stating that
+get-magic is not processed. It has been corrected.
=back
@@ -388,6 +389,37 @@ be noted as well.
See L</Regular expressions retain their localeness when interpolated>,
above.
+=item *
+
+The C<sv_cmp_flags>, C<sv_cmp_locale_flags>, C<sv_eq_flags> and
+C<sv_collxfrm_flags> functions have been added. These are like their
+non-_flags counterparts, but allow one to specify whether get-magic is
+processed.
+
+The C<sv_cmp>, C<sv_cmp_locale>, C<sv_eq> and C<sv_collxfrm> functions have
+been replaced with wrappers around the new functions.
+
+=item *
+
+A new C<sv_2bool_flags> function has been added.
+
+This is like C<sv_2bool>, but it lets the calling code decide whether
+get-magic is handled. C<sv_2bool> is now a macro that calls the new
+function.
+
+=item *
+
+A new macro, C<SvTRUE_nomg>, has been added.
+
+This is like C<SvTRUE>, except that it does not process magic. It uses the
+new C<sv_2bool_flags> function.
+
+=item *
+
+C<sv_catsv_flags> no longer calls C<mg_get> on its second argument (the
+source string) if the flags passed to it do not include SV_GMAGIC. So it
+now matches what the documentation says it does.
+
=back
=head1 Selected Bug Fixes
@@ -436,6 +468,31 @@ sometimes did not, depending on what order things happened
to be arranged
in memory
L<[perl #71806]|http://rt.perl.org/rt3//Public/Bug/Display.html?id=71806>.
+=item *
+
+The C<y///> or C<tr///> operator now calls get-magic (e.g., the C<FETCH>
+method of a tie) on its left-hand side just once, not twice
+L<[perl #76814]|http://rt.perl.org/rt3//Public/Bug/Display.html?id=76814>.
+
+=item *
+
+String comparison (C<eq>, C<ne>, C<lt>, C<gt>, C<le>, C<ge> and
+C<cmp>) and logical not (C<not> and C<!>) operators no longer call magic
+(e.g., tie methods) twice on their operands
+L<[perl #76814]|http://rt.perl.org/rt3//Public/Bug/Display.html?id=76814>.
+
+This bug was introduced in an earlier 5.13 release, and does not affect
+perl 5.12.
+
+=item *
+
+When a tied (or other magic) variable is used as, or in, a regular
+expression, it no longer has its C<FETCH> method called twice
+L<[perl #76814]|http://rt.perl.org/rt3//Public/Bug/Display.html?id=76814>.
+
+This bug was introduced in an earlier 5.13 release, and does not affect
+perl 5.12.
+
=back
=head1 Known Problems
diff --git a/pp.c b/pp.c
index 2ee6049..476212e 100644
--- 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;
}
@@ -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/pp_ctl.c b/pp_ctl.c
index 601a25c..2444452 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -127,7 +127,7 @@ PP(pp_regcomp)
sv_setsv(tmpstr, sv);
continue;
}
- sv_catsv(tmpstr, msv);
+ sv_catsv_nomg(tmpstr, msv);
}
SvSETMAGIC(tmpstr);
SP = ORIGMARK;
@@ -219,6 +219,14 @@ PP(pp_regcomp)
tmpstr = newSVpvn_flags(t, len, SVs_TEMP | SvUTF8(tmpstr));
}
+ /* If it is gmagical, create a mortal copy, but without calling
+ get-magic, as we have already done that. */
+ if(SvGMAGICAL(tmpstr)) {
+ SV *mortalcopy = sv_newmortal();
+ sv_setsv_flags(mortalcopy, tmpstr, 0);
+ tmpstr = mortalcopy;
+ }
+
if (eng)
PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
else
diff --git a/proto.h b/proto.h
index 91dae7c..a2fd1f7 100644
--- 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)
@@ -3359,12 +3362,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 +3411,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..ad292d1 100644
--- 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;
@@ -4781,7 +4789,7 @@ Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV
*const ssv, const I32 flags
if (ssv) {
STRLEN slen;
- const char *spv = SvPV_const(ssv, slen);
+ const char *spv = SvPV_flags_const(ssv, slen, flags);
if (spv) {
/* sutf8 and dutf8 were type bool, but under USE_ITHREADS,
gcc version 2.95.2 20000220 (Debian GNU/Linux) for
@@ -6773,11 +6781,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 +6808,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 +6823,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 +6890,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 +6922,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 +6986,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 +7015,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 +7056,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 +7073,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 +7088,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..c081d6a 100644
--- 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__ */
@@ -1799,6 +1821,9 @@ 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_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 42f8474..a5e652e 100644
--- a/t/op/tie_fetch_count.t
+++ b/t/op/tie_fetch_count.t
@@ -7,7 +7,7 @@ BEGIN {
chdir 't' if -d 't';
@INC = '../lib';
require './test.pl';
- plan (tests => 92);
+ plan (tests => 94);
}
use strict;
@@ -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 '&';
@@ -86,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';
}
@@ -146,12 +143,11 @@ $_ = "foo";
$dummy = $var =~ m/ / ; check_count 'm//';
$dummy = $var =~ s/ //; check_count 's///';
$dummy = $var ~~ 1 ; check_count '~~';
-TODO: {
- local $::TODO = $TODO;
- $dummy = $var =~ y/ //; check_count 'y///';
- /$var/ ; check_count 'm/pattern/';
- s/$var// ; check_count 's/pattern//';
-}
+$dummy = $var =~ y/ //; check_count 'y///';
+ /$var/ ; check_count 'm/pattern/';
+ /$var foo/ ; check_count 'm/$tied foo/';
+ s/$var// ; check_count 's/pattern//';
+ s/$var foo// ; check_count 's/$tied foo//';
s/./$var/ ; check_count 's//replacement/';
# Dereferencing
--
Perl5 Master Repository
