In perl.git, the branch sprout/pok-bug-hunt has been updated <http://perl5.git.perl.org/perl.git/commitdiff/a28d44b0929a7b81ad67e33ae6f9e42ea3b89dc4?hp=51dc64dea5efd5df1c6b5cbd2c5899115f12addc>
- Log ----------------------------------------------------------------- commit a28d44b0929a7b81ad67e33ae6f9e42ea3b89dc4 Author: Father Chrysostomos <[email protected]> Date: Tue Jun 5 22:38:12 2012 -0700 pp_negate: Donât treat nummified str as num I think itâs a bug that this prints 0: $ ./perl -lIlib -MDevel::Peek -e '$x = "dogs"; 0+$x; Dump $x; print -$x' SV = PVNV(0x802340) at 0x821b90 REFCNT = 1 FLAGS = (POK,pIOK,pNOK,pPOK) IV = 0 NV = 0 PV = 0x301620 "dogs"\0 CUR = 4 LEN = 16 0 This variable is a string, not a number. The number 0 is just a cached value. It lacks the IOK flag precisely because the IV is not representative of the actual value of the scalar. This logic here is a little bit odd: if( !SvNIOK( sv ) && looks_like_number( sv ) ){ SvIV_please( sv ); } if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { SvIV_please sets the flags on sv but then they are ignored when check- ing for integrality. To fix the bug mentioned above, I had to change this logic to use sv directly, rather than the saved flags. That meant that this bug was also fixed at the same time, since the integer code is no longer bypassed when it is SvIV_please that sets the integer flags: $ ./perl -Ilib -le 'print -97656250000000000' -97656250000000000 $ ./perl -Ilib -le 'print -"97656250000000000"' -9.765625e+16 M pp.c M t/op/negate.t commit 10735ab13707ef6d3d2a55540c4950133e9e7d09 Author: Father Chrysostomos <[email protected]> Date: Tue Jun 5 20:09:32 2012 -0700 [perl #109542] Make num ops treat $1 as "$1" Numeric ops were not taking magical variables into account. So $1 (a magical variable) would be treated differently from "$1" (a non-magi- cal variable0. In determining whether to use an integer operation, they would call SvIV_please_nomg, and then check whether the sv was SvIOK as a result. SvIV_please_nomg would call SvIV_nomg if the sv were SvPOK or SvNOK. The problem here is that gmagical variables are never SvIOK, but only SvIOKp. In fact, the private flags are used differently for gmagical and non- magical variables. For non-gmagical variables, the private flag indi- cates that there is a cached value. If the public flag is not set, then the cached value is imprecise. For gmagical variables, imprecise values are never cached; only the private flags are used, and they are equivalent to the public flags on non-gmagical variables. This commit changes SvIV_please_nomg to take gmagical variables into account, using the newly-added sv_gmagical_2iv_please (see the docs for it in the diff). SvIV_please_nomg now returns true or false, not void, since a subsequent SvIOK is not reliable. So âSvIV_please_nomg(sv); if(SvIOK)â becomes âif(SvIV_please_nomg(sv))â. M embed.fnc M embed.h M pp.c M pp_hot.c M proto.h M sv.c M sv.h M t/op/arith.t commit 9dd13ad477d39d8791eedccef6e3514b66aaf773 Author: Father Chrysostomos <[email protected]> Date: Sun May 27 00:11:31 2012 -0700 Make warn handle magic vars (fixes [perl #97480]) pp_warn was checking flags before calling get-magic, resulting in sev- eral bugs that I fixed all at once:: ⢠warn now calls get-magic exactly once on its argument, when there is just one argument (it always worked correctly for multiple) [perl #97480]. ⢠warn calls get-magic exactly once on $@ when falling back to it, instead of zero times. ⢠A tied variable returning an object that stringifies as an empty string is no longer ignored if the tied variable was not ROK before FETCH. ⢠A tied $@ containing a string, or $@ aliased to $1, is no longer ignored. â¢Â A tied $@ that last returned a reference but will return a string on the next FETCH now gets "\t...caught" appended. M pp_sys.c M t/op/tie_fetch_count.t M t/op/warn.t commit f4abf6be8e4f092e8daed74a231ca8e5c901817e Author: Father Chrysostomos <[email protected]> Date: Sat May 26 06:00:01 2012 -0700 Make prototype call FETCH before checking CORE:: prefix $ perl5.16.0 -e '"CORE::length" =~ /(.*)/; warn prototype $1;' Warning: something's wrong at -e line 1. $ perl5.16.0 -e 'warn prototype "CORE::length"' _ at -e line 1. Since sv_2cv calls get-magic, the easiest solution is to copy the argument if it is magical. M pp.c M t/comp/proto.t ----------------------------------------------------------------------- Summary of changes: embed.fnc | 1 + embed.h | 1 + pp.c | 50 ++++++++++++-------------------------------- pp_hot.c | 7 +---- pp_sys.c | 23 ++++++++++++++------ proto.h | 5 ++++ sv.c | 24 +++++++++++++++++++++ sv.h | 10 +++++++- t/comp/proto.t | 10 +++++++- t/op/arith.t | 53 +++++++++++++++++++++++++++++++++++++++++++++++- t/op/negate.t | 11 ++++++++- t/op/tie_fetch_count.t | 14 +++++++++++- t/op/warn.t | 40 +++++++++++++++++++++++++++++++++++- 13 files changed, 192 insertions(+), 57 deletions(-) diff --git a/embed.fnc b/embed.fnc index 694238d..a94176f 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1308,6 +1308,7 @@ Apd |STRLEN |sv_len |NULLOK SV *const sv Apd |STRLEN |sv_len_utf8 |NULLOK SV *const sv Apd |void |sv_magic |NN SV *const sv|NULLOK SV *const obj|const int how \ |NULLOK const char *const name|const I32 namlen +pd |bool |sv_gmagical_2iv_please|NN SV *sv Apd |MAGIC *|sv_magicext |NN SV *const sv|NULLOK SV *const obj|const int how \ |NULLOK const MGVTBL *const vtbl|NULLOK const char *const name \ |const I32 namlen diff --git a/embed.h b/embed.h index f5d5e5d..fc8a3e0 100644 --- a/embed.h +++ b/embed.h @@ -1201,6 +1201,7 @@ #define sv_clean_objs() Perl_sv_clean_objs(aTHX) #define sv_del_backref(a,b) Perl_sv_del_backref(aTHX_ a,b) #define sv_free_arenas() Perl_sv_free_arenas(aTHX) +#define sv_gmagical_2iv_please(a) Perl_sv_gmagical_2iv_please(aTHX_ a) #define sv_ref(a,b,c) Perl_sv_ref(aTHX_ a,b,c) #define sv_sethek(a,b) Perl_sv_sethek(aTHX_ a,b) #ifndef PERL_IMPLICIT_CONTEXT diff --git a/pp.c b/pp.c index 7e37e9d..7c890b3 100644 --- a/pp.c +++ b/pp.c @@ -432,6 +432,7 @@ PP(pp_prototype) GV *gv; SV *ret = &PL_sv_undef; + if (SvGMAGICAL(TOPs)) SETs(sv_mortalcopy(TOPs)); if (SvPOK(TOPs) && SvCUR(TOPs) >= 7) { const char * s = SvPVX_const(TOPs); if (strnEQ(s, "CORE::", 6)) { @@ -1093,11 +1094,7 @@ PP(pp_pow) /* For integer to integer power, we do the calculation by hand wherever we're sure it is safe; otherwise we call pow() and try to convert to integer afterwards. */ - { - SvIV_please_nomg(svr); - if (SvIOK(svr)) { - SvIV_please_nomg(svl); - if (SvIOK(svl)) { + if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) { UV power; bool baseuok; UV baseuv; @@ -1195,8 +1192,6 @@ PP(pp_pow) RETURN; } } - } - } } float_it: #endif @@ -1260,14 +1255,12 @@ PP(pp_multiply) svr = TOPs; svl = TOPm1s; #ifdef PERL_PRESERVE_IVUV - SvIV_please_nomg(svr); - if (SvIOK(svr)) { + if (SvIV_please_nomg(svr)) { /* Unless the left argument is integer in range we are going to have to use NV maths. Hence only attempt to coerce the right argument if we know the left is integer. */ /* Left operand is defined, so is it IV? */ - SvIV_please_nomg(svl); - if (SvIOK(svl)) { + if (SvIV_please_nomg(svl)) { bool auvok = SvUOK(svl); bool buvok = SvUOK(svr); const UV topmask = (~ (UV)0) << (4 * sizeof (UV)); @@ -1405,10 +1398,7 @@ PP(pp_divide) #endif #ifdef PERL_TRY_UV_DIVIDE - SvIV_please_nomg(svr); - if (SvIOK(svr)) { - SvIV_please_nomg(svl); - if (SvIOK(svl)) { + if (SvIV_please_nomg(svr) && SvIV_please_nomg(svl)) { bool left_non_neg = SvUOK(svl); bool right_non_neg = SvUOK(svr); UV left; @@ -1483,8 +1473,7 @@ PP(pp_divide) RETURN; } /* tried integer divide but it was not an integer result */ } /* else (PERL_ABS(result) < 1.0) or (both UVs in range for NV) */ - } /* left wasn't SvIOK */ - } /* right wasn't SvIOK */ + } /* one operand wasn't SvIOK */ #endif /* PERL_TRY_UV_DIVIDE */ { NV right = SvNV_nomg(svr); @@ -1516,8 +1505,7 @@ PP(pp_modulo) NV dleft = 0.0; SV * const svr = TOPs; SV * const svl = TOPm1s; - SvIV_please_nomg(svr); - if (SvIOK(svr)) { + if (SvIV_please_nomg(svr)) { right_neg = !SvUOK(svr); if (!right_neg) { right = SvUVX(svr); @@ -1547,9 +1535,7 @@ PP(pp_modulo) /* At this point use_double is only true if right is out of range for a UV. In range NV has been rounded down to nearest UV and use_double false. */ - SvIV_please_nomg(svl); - if (!use_double && SvIOK(svl)) { - if (SvIOK(svl)) { + if (!use_double && SvIV_please_nomg(svl)) { left_neg = !SvUOK(svl); if (!left_neg) { left = SvUVX(svl); @@ -1562,7 +1548,6 @@ PP(pp_modulo) left = -aiv; } } - } } else { dleft = SvNV_nomg(svl); @@ -1777,8 +1762,7 @@ PP(pp_subtract) #ifdef PERL_PRESERVE_IVUV /* See comments in pp_add (in pp_hot.c) about Overflow, and how "bad things" happen if you rely on signed integers wrapping. */ - SvIV_please_nomg(svr); - if (SvIOK(svr)) { + if (SvIV_please_nomg(svr)) { /* Unless the left argument is integer in range we are going to have to use NV maths. Hence only attempt to coerce the right argument if we know the left is integer. */ @@ -1792,8 +1776,7 @@ PP(pp_subtract) /* left operand is undef, treat as zero. */ } else { /* Left operand is defined, so is it IV? */ - SvIV_please_nomg(svl); - if (SvIOK(svl)) { + if (SvIV_please_nomg(svl)) { if ((auvok = SvUOK(svl))) auv = SvUVX(svl); else { @@ -2021,11 +2004,8 @@ Perl_do_ncmp(pTHX_ SV* const left, SV * const right) PERL_ARGS_ASSERT_DO_NCMP; #ifdef PERL_PRESERVE_IVUV - SvIV_please_nomg(right); /* Fortunately it seems NaN isn't IOK */ - if (SvIOK(right)) { - SvIV_please_nomg(left); - if (SvIOK(left)) { + if (SvIV_please_nomg(right) && SvIV_please_nomg(left)) { if (!SvUOK(left)) { const IV leftiv = SvIVX(left); if (!SvUOK(right)) { @@ -2061,7 +2041,6 @@ Perl_do_ncmp(pTHX_ SV* const left, SV * const right) } } /* NOTREACHED */ - } } #endif { @@ -2247,14 +2226,13 @@ PP(pp_negate) tryAMAGICun_MG(neg_amg, AMGf_numeric); { SV * const sv = TOPs; - const int flags = SvFLAGS(sv); if( !SvNIOK( sv ) && looks_like_number( sv ) ){ SvIV_please( sv ); } - if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { - /* It's publicly an integer, or privately an integer-not-float */ + if (SvIOK(sv) || (SvOKp(sv) == SVp_IOK)) { + /* It's publicly an integer, or privately just an integer */ oops_its_an_int: if (SvIsUV(sv)) { if (SvIVX(sv) == IV_MIN) { @@ -2278,7 +2256,7 @@ PP(pp_negate) } #endif } - if (SvNIOKp(sv)) + if (SvNIOKp(sv) && (SvNIOK(sv) || !SvPOK(sv))) SETn(-SvNV_nomg(sv)); else if (SvPOKp(sv)) { STRLEN len; diff --git a/pp_hot.c b/pp_hot.c index 1a5b76c..878aafb 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -505,9 +505,7 @@ PP(pp_add) unsigned code below is actually shorter than the old code. :-) */ - SvIV_please_nomg(svr); - - if (SvIOK(svr)) { + if (SvIV_please_nomg(svr)) { /* Unless the left argument is integer in range we are going to have to use NV maths. Hence only attempt to coerce the right argument if we know the left is integer. */ @@ -523,8 +521,7 @@ PP(pp_add) lots of code to speed up what is probably a rarish case. */ } else { /* Left operand is defined, so is it IV? */ - SvIV_please_nomg(svl); - if (SvIOK(svl)) { + if (SvIV_please_nomg(svl)) { if ((auvok = SvUOK(svl))) auv = SvUVX(svl); else { diff --git a/pp_sys.c b/pp_sys.c index 6f59757..472d65e 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -438,20 +438,29 @@ PP(pp_warn) } else { exsv = TOPs; + if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv); } if (SvROK(exsv) || (SvPV_const(exsv, len), len)) { /* well-formed exception supplied */ } - else if (SvROK(ERRSV)) { - exsv = ERRSV; - } - else if (SvPOK(ERRSV) && SvCUR(ERRSV)) { - exsv = sv_mortalcopy(ERRSV); - sv_catpvs(exsv, "\t...caught"); - } else { + SvGETMAGIC(ERRSV); + if (SvROK(ERRSV)) { + if (SvGMAGICAL(ERRSV)) { + exsv = sv_newmortal(); + sv_setsv_nomg(exsv, ERRSV); + } + else exsv = ERRSV; + } + else if (SvPOKp(ERRSV) && SvCUR(ERRSV)) { + exsv = sv_newmortal(); + sv_setsv_nomg(exsv, ERRSV); + sv_catpvs(exsv, "\t...caught"); + } + else { exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP); + } } if (SvROK(exsv) && !PL_warnhook) Perl_warn(aTHX_ "%"SVf, SVfARG(exsv)); diff --git a/proto.h b/proto.h index b8ffa3c..e802bd3 100644 --- a/proto.h +++ b/proto.h @@ -3963,6 +3963,11 @@ PERL_CALLCONV char* Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 appen #define PERL_ARGS_ASSERT_SV_GETS \ assert(sv); assert(fp) +PERL_CALLCONV bool Perl_sv_gmagical_2iv_please(pTHX_ SV *sv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_SV_GMAGICAL_2IV_PLEASE \ + assert(sv) + PERL_CALLCONV char* Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SV_GROW \ diff --git a/sv.c b/sv.c index c96a81d..921297b 100644 --- a/sv.c +++ b/sv.c @@ -2332,6 +2332,30 @@ Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags) } /* +=for apidoc sv_gmagical_2iv_please + +Used internally by C<SvIV_please_nomg>, this function sets the C<SvIVX> +slot if C<sv_2iv> would have made the scalar C<SvIOK> had it not been +magical. In that case it returns true. + +=cut +*/ + +bool +Perl_sv_gmagical_2iv_please(pTHX_ register SV *sv) +{ + bool has_int; + bool was_nokp = !!SvNOKp(sv); + PERL_ARGS_ASSERT_SV_GMAGICAL_2IV_PLEASE; + assert(SvGMAGICAL(sv) && !SvIOKp(sv) && (SvNOKp(sv) || SvPOKp(sv))); + if (S_sv_2iuv_common(aTHX_ sv)) return 0; + has_int = !!SvIOK(sv); + SvNIOK_off(sv); + if (was_nokp) SvNOKp_on(sv); + return has_int; +} + +/* =for apidoc sv_2uv_flags Return the unsigned integer value of an SV, doing any necessary string diff --git a/sv.h b/sv.h index 97ce119..39d9882 100644 --- a/sv.h +++ b/sv.h @@ -1208,8 +1208,14 @@ the scalar's value cannot change unless written to. STMT_START {if (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv))) \ (void) SvIV(sv); } STMT_END #define SvIV_please_nomg(sv) \ - STMT_START {if (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv))) \ - (void) SvIV_nomg(sv); } STMT_END + (!SvIOKp(sv) && (SvNOK(sv) || SvPOK(sv)) \ + ? (SvIV_nomg(sv), SvIOK(sv)) \ + : SvGMAGICAL(sv) \ + ? SvIOKp(sv) || ( \ + (SvNOKp(sv) || SvPOKp(sv)) \ + && sv_gmagical_2iv_please(sv) \ + ) \ + : SvIOK(sv)) #define SvIV_set(sv, val) \ STMT_START { \ assert(PL_valid_types_IV_set[SvTYPE(sv) & SVt_MASK]); \ diff --git a/t/comp/proto.t b/t/comp/proto.t index 04fea69..3d5e075 100644 --- a/t/comp/proto.t +++ b/t/comp/proto.t @@ -18,7 +18,7 @@ BEGIN { # strict use strict; -print "1..177\n"; +print "1..178\n"; my $i = 1; @@ -409,10 +409,16 @@ print "ok ", $i++, "\n"; print "# CORE::open => ($p)\nnot " if ($p = prototype('CORE::open')) ne '*;$@'; print "ok ", $i++, "\n"; -print "# CORE:Foo => ($p), \$@ => '$@'\nnot " +print "# CORE::Foo => ($p), \$@ => '$@'\nnot " if defined ($p = eval { prototype('CORE::Foo') or 1 }) or $@ !~ /^Can't find an opnumber/; print "ok ", $i++, "\n"; +"CORE::Foo" =~ /(.*)/; +print "# \$1 containing CORE::Foo => ($p), \$@ => '$@'\nnot " + if defined ($p = eval { prototype($1) or 1 }) + or $@ !~ /^Can't find an opnumber/; +print "ok ", $i++, "\n"; + # correctly note too-short parameter lists that don't end with '$', # a possible regression. diff --git a/t/op/arith.t b/t/op/arith.t index 58c1f75..2906402 100644 --- a/t/op/arith.t +++ b/t/op/arith.t @@ -5,7 +5,7 @@ BEGIN { @INC = '../lib'; } -print "1..145\n"; +print "1..159\n"; sub try ($$) { print +($_[1] ? "ok" : "not ok"), " $_[0]\n"; @@ -324,3 +324,54 @@ else { } print "ok ", $T++, "\n"; } + +# [perl #109542] $1 and "$1" should be treated the same way +"976562500000000" =~ /(\d+)/; +$a = ($1 * 1024); +$b = ("$1" * 1024); +print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" * something\n'; +$a = (1024 * $1); +$b = (1024 * "$1"); +print "not "x($a ne $b), "ok ", $T++, qq ' - something * \$1 vs "\$1"\n'; +$a = ($1 + 102400000000000); +$b = ("$1" + 102400000000000); +print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" + something\n'; +$a = (102400000000000 + $1); +$b = (102400000000000 + "$1"); +print "not "x($a ne $b), "ok ", $T++, qq ' - something + \$1 vs "\$1"\n'; +$a = ($1 - 10240000000000000); +$b = ("$1" - 10240000000000000); +print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" - something\n'; +$a = (10240000000000000 - $1); +$b = (10240000000000000 - "$1"); +print "not "x($a ne $b), "ok ", $T++, qq ' - something - \$1 vs "\$1"\n'; +"976562500" =~ /(\d+)/; +$a = ($1 ** 2); +$b = ("$1" ** 2); +print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" ** something\n'; +"32" =~ /(\d+)/; +$a = (3 ** $1); +$b = (3 ** "$1"); +print "not "x($a ne $b), "ok ", $T++, qq ' - something ** \$1 vs "\$1"\n'; +"97656250000000000" =~ /(\d+)/; +$a = ($1 / 10); +$b = ("$1" / 10); +print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" / something\n'; +"10" =~ /(\d+)/; +$a = (97656250000000000 / $1); +$b = (97656250000000000 / "$1"); +print "not "x($a ne $b), "ok ", $T++, qq ' - something / \$1 vs "\$1"\n'; +"97656250000000000" =~ /(\d+)/; +$a = ($1 <=> 97656250000000001); +$b = ("$1" <=> 97656250000000001); +print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" <=> something\n'; +$a = (97656250000000001 <=> $1); +$b = (97656250000000001 <=> "$1"); +print "not "x($a ne $b), "ok ", $T++, qq ' - something <=> \$1 vs "\$1"\n'; +"97656250000000001" =~ /(\d+)/; +$a = ($1 % 97656250000000002); +$b = ("$1" % 97656250000000002); +print "not "x($a ne $b), "ok ", $T++, qq ' - \$1 vs "\$1" % something\n'; +$a = (97656250000000000 % $1); +$b = (97656250000000000 % "$1"); +print "not "x($a ne $b), "ok ", $T++, qq ' - something % \$1 vs "\$1"\n'; diff --git a/t/op/negate.t b/t/op/negate.t index 8a0ef2b..62dc418 100644 --- a/t/op/negate.t +++ b/t/op/negate.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 16; +plan tests => 18; # Some of these will cause warnings if left on. Here we're checking the # functionality, not the warnings. @@ -28,4 +28,11 @@ is(-bareword, "-bareword", "Negation of bareword treated like a string"); is(- -bareword, "+bareword", "Negation of -bareword returns string +bareword"); is(-" -10", 10, "Negation of a whitespace-lead numeric string"); is(-" -10.0", 10, "Negation of a whitespace-lead decimal string"); -is(-" -10foo", 10, "Negation of a whitespace-lead sting starting with a numeric") +is(-" -10foo", 10, + "Negation of a whitespace-lead sting starting with a numeric"); + +$x = "dogs"; +()=0+$x; +is -$x, '-dogs', 'cached numeric value does not sabotage string negation'; + +is(-"97656250000000000", -97656250000000000, '-bigint vs -"bigint"'); diff --git a/t/op/tie_fetch_count.t b/t/op/tie_fetch_count.t index 8eae578..26666f2 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 => 299); + plan (tests => 303); } use strict; @@ -248,6 +248,18 @@ for ([chdir=>''],[chmod=>'0,'],[chown=>'0,0,'],[utime=>'0,0,'], ; check_count 'select $tied_undef, ...'; } +{ + local $SIG{__WARN__} = sub {}; + $dummy = warn $var ; check_count 'warn $tied'; + tie $@, => 'main', 1; + $dummy = warn ; check_count 'warn() with $@ tied (num)'; + tie $@, => 'main', \1; + $dummy = warn ; check_count 'warn() with $@ tied (ref)'; + tie $@, => 'main', "foo\n"; + $dummy = warn ; check_count 'warn() with $@ tied (str)'; + untie $@; +} + ############################################### # Tests for $foo binop $foo # ############################################### diff --git a/t/op/warn.t b/t/op/warn.t index 4a927e2..a0a072e 100644 --- a/t/op/warn.t +++ b/t/op/warn.t @@ -7,7 +7,7 @@ BEGIN { require './test.pl'; } -plan 22; +plan 28; my @warnings; my $wa = []; my $ea = []; @@ -148,4 +148,42 @@ fresh_perl_like( 'warn stringifies in the absence of $SIG{__WARN__}' ); +use Tie::Scalar; +tie $@, "Tie::StdScalar"; + +$@ = "foo\n"; +@warnings = (); +warn; +is @warnings, 1; +like $warnings[0], qr/^foo\n\t\.\.\.caught at warn\.t /, + '...caught is appended to tied $@'; + +$@ = \$_; +@warnings = (); +{ + local *{ref(tied $@) . "::STORE"} = sub {}; + undef $@; +} +warn; +is @warnings, 1; +is $warnings[0], \$_, '!SvOK tied $@ that returns ref is used'; + +untie $@; + +@warnings = (); +{ + package o; + use overload '""' => sub { "" }; +} +tie $t, Tie::StdScalar; +$t = bless [], o; +{ + local *{ref(tied $t) . "::STORE"} = sub {}; + undef $t; +} +warn $t; +is @warnings, 1; +object_ok $warnings[0], 'o', + 'warn $tie_returning_object_that_stringifes_emptily'; + 1; -- Perl5 Master Repository
