In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/77b030b5bd8a1500c27a6b5c5d30903c83a4c704?hp=afdb3b14b41a9073ddecc2080ea6b46a16f31fc3>
- Log ----------------------------------------------------------------- commit 77b030b5bd8a1500c27a6b5c5d30903c83a4c704 Author: Father Chrysostomos <[email protected]> Date: Sat Sep 27 16:36:52 2014 -0700 Fix FETCH count for sprintf "...", $tied Commit 540a63d62 was the first culprit. 354b74ae6f made things worse. M sv.c M t/op/tie_fetch_count.t commit 1e9a122e7153b27147b741ef2c47f91e5c01e33f Author: Father Chrysostomos <[email protected]> Date: Sat Sep 27 14:36:45 2014 -0700 Fix double FETCH with pack "w" M pp_pack.c M t/op/tie_fetch_count.t ----------------------------------------------------------------------- Summary of changes: pp_pack.c | 4 ++-- sv.c | 13 ++++++++----- t/op/tie_fetch_count.t | 19 ++++++++++++++++++- 3 files changed, 28 insertions(+), 8 deletions(-) diff --git a/pp_pack.c b/pp_pack.c index 97ddb27..40db6ef 100644 --- a/pp_pack.c +++ b/pp_pack.c @@ -2874,7 +2874,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) if (SvIOK(fromstr) || anv < UV_MAX_P1) { char buf[(sizeof(UV)*CHAR_BIT)/7+1]; char *in = buf + sizeof(buf); - UV auv = SvUV(fromstr); + UV auv = SvUV_nomg(fromstr); do { *--in = (char)((auv & 0x7f) | 0x80); @@ -2925,7 +2925,7 @@ S_pack_rec(pTHX_ SV *cat, tempsym_t* symptr, SV **beglist, SV **endlist ) w_string: /* Copy string and check for compliance */ - from = SvPV_const(fromstr, len); + from = SvPV_nomg_const(fromstr, len); if ((norm = is_an_int(from, len)) == NULL) Perl_croak(aTHX_ "Can only compress unsigned integers in pack"); diff --git a/sv.c b/sv.c index ccdf270..67a2b6f 100644 --- a/sv.c +++ b/sv.c @@ -11534,8 +11534,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (infnan) Perl_croak(aTHX_ "Cannot printf %"NVgf" with '%c'", /* no va_arg() case */ - SvNV(argsv), (int)c); - uv = (args) ? va_arg(*args, int) : SvIV(argsv); + SvNV_nomg(argsv), (int)c); + uv = (args) ? va_arg(*args, int) : SvIV_nomg(argsv); if ((uv > 255 || (!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv))) && !IN_BYTES) { @@ -11653,7 +11653,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } else { - IV tiv = SvIV(argsv); /* work around GCC bug #13488 */ + IV tiv = SvIV_nomg(argsv); /* work around GCC bug #13488 */ switch (intsize) { case 'c': iv = (char)tiv; break; case 'h': iv = (short)tiv; break; @@ -11757,7 +11757,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } else { - UV tuv = SvUV(argsv); /* work around GCC bug #13488 */ + UV tuv = SvUV_nomg(argsv); /* work around GCC bug #13488 */ switch (intsize) { case 'c': uv = (unsigned char)tuv; break; case 'h': uv = (unsigned short)tuv; break; @@ -11905,7 +11905,10 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p #endif } else - NV_TO_FV(SvNV(argsv), fv); + { + if (!infnan) SvGETMAGIC(argsv); + NV_TO_FV(SvNV_nomg(argsv), fv); + } need = 0; /* frexp() (or frexpl) has some unspecified behaviour for diff --git a/t/op/tie_fetch_count.t b/t/op/tie_fetch_count.t index c97b9b4..6955d19 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'; require './test.pl'; set_up_inc('../lib'); - plan (tests => 312); + plan (tests => 340); } use strict; @@ -260,11 +260,28 @@ for ([chdir=>''],[chmod=>'0,'],[chown=>'0,0,'],[utime=>'0,0,'], chop(my $u = "\xff\x{100}"); tie $var, "main", $u; $dummy = pack "u", $var; check_count 'pack "u", $utf8'; +$var = 0; +$dummy = pack "w", $var; check_count 'pack "w", $tied_int'; +$var = "111111111111111111111111111111111111111111111111111111111111111"; +$dummy = eval { pack "w", $var }; + check_count 'pack "w", $tied_huge_int_as_str'; tie $var, "main", "\x{100}"; pos$var = 0 ; check_count 'lvalue pos $utf8'; $dummy=sprintf"%1s",$var; check_count 'sprintf "%1s", $utf8'; $dummy=sprintf"%.1s",$var; check_count 'sprintf "%.1s", $utf8'; + +tie $var, "main", 23; +for (qw(B b c D d i O o p u U X x)) { + $dummy=sprintf"%$_",$var; check_count "sprintf '%$_'" +} +tie $var, "main", "Inf"; +for (qw(B b c D d i O o p u U X x)) { + $dummy = eval { sprintf "%$_", $var }; + check_count "sprintf '%$_', \$tied_inf" +} + +tie $var, "main", "\x{100}"; $dummy = substr$var,0,1; check_count 'substr $utf8'; my $l =\substr$var,0,1; $dummy = $$l ; check_count 'reading lvalue substr($utf8)'; -- Perl5 Master Repository
