In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/f2ab0494188e59db7cc6ec444d773e86d96b2ad3?hp=e654efc25137667e687e787a95f6c53aa0ed69e1>
- Log ----------------------------------------------------------------- commit f2ab0494188e59db7cc6ec444d773e86d96b2ad3 Merge: e654efc b1d0a83 Author: Father Chrysostomos <[email protected]> Date: Thu Jun 7 08:19:32 2012 -0700 [Merge] SvPOK bug hunt Spurred on by a comment in ticket #109542, I went looking for misuse of SvPOK, where SvPOKp should be used instead (since variables with get-magic donât have SvPOK set). I discovered a few bugs like that, plus many more bugs that were sim- ilar, but not quite the same. commit b1d0a83378b21d719f9e1fd57b852ca875a7c228 Author: Father Chrysostomos <[email protected]> Date: Wed Jun 6 23:19:47 2012 -0700 Make warn treat $@=3 and $@="3" the same If we get this: $ ./perl -Ilib -e '$@ = "3"; warn' 3 ...caught at -e line 1. then we shouldnât get this: $ ./perl -Ilib -e '$@ = 3; warn' Warning: something's wrong at -e line 1. as the two scalars hold the same value. M pp_sys.c M t/op/warn.t commit 288163b0396d677d915ce0beb12619dc26646926 Author: Father Chrysostomos <[email protected]> Date: Wed Jun 6 23:07:18 2012 -0700 pp.c:pp_negate: Move looks_like_number where it matters Since we already have a check further down to see whether a string begins with an identifier or sign, and since looks_like_number was added for strings representing negative numbers, move the looks_like_number down to where we already know the string begins with '-'. This is a micro-optimisation, but it also makes the code more straightforward (to me at least). This happens to let magical integers-as-strings fall down to code that they used not to reach, so that has to change to account. M pp.c commit 7dbe31506f4be3f410f64640daa16b8ad483d61f Author: Father Chrysostomos <[email protected]> Date: Wed Jun 6 23:05:24 2012 -0700 pp_negate: Support magic big ints as strings -$1 was treating $1 as a float even if the string consisted of an integer, due to incorrect flag checks. It was doing the same things with tied variables returning str+int dualvars. Simply checking whether the privates flags consist solely of SVp_IOK (which works for tie variables returning pure integers--so I wasnât entirely wrong in adding that logic a few commits ago), isnât suffi- cient. For gmagical variables that have already had get-magic called on them, the private flags are equivalent to public flags for other variables. M pp.c M t/op/negate.t commit d5aa71b8d668347b748a6c784882e3ca8c85e3c6 Author: Father Chrysostomos <[email protected]> Date: Wed Jun 6 15:54:08 2012 -0700 pp_negate and the Unicode Bug $ ./perl -Ilib -Mutf8 -CO -le 'print -"3 apples"' -3 $ ./perl -Ilib -Mutf8 -CO -le 'print -"3 μá¿Î»Î±"' -3 μá¿Î»Î± This has been this way since 5.10.1. In 5.10.0, it was consistent: $ perl5.10.0 -Mutf8 -CO -le 'print -"3 apples"' -3 $ perl5.10.0 -Mutf8 -CO -le 'print -"3 μá¿Î»Î±"' -3 But the worst part is that we get a non-numeric warning now for a string operation: $ perl5.10.1 -Mutf8 -CO -lwe 'print -"3 μá¿Î»Î±"' Argument "\x{33}\x{20}..." isn't numeric in negation (-) at -e line 1. -3 μá¿Î»Î± This goes back to commit a43d94f2c089, which by itself looks perfectly correct (I wonât quote the diff here, as it is long; but it doesnât touch pp_negate): commit a43d94f2c089c6f14197795daeebb7835550a747 Author: Nicholas Clark <[email protected]> Date: Mon Jan 7 18:24:39 2008 +0000 Don't set the public IV or NV flags if the string converted from has trailing garbage. This behaviour is consistent with not setting the public IV or NV flags if the value is out of range for the type. p4raw-id: //depot/perl@32894 It seems that pp_negate was already buggy before that (or âvalidlyâ assumed that numeric coercion would set public flags). And it looks as though commit 8eb28a70b2e is at fault here. It changed this: $ perl5.6.2 -Mutf8 -lwe 'print -"ð"' -ð to this: $ perl5.8.1 -Mutf8 -lwe 'print -"ð"' Argument "\x{f0}" isn't numeric in negation (-) at -e line 1. 0 to comply with what happens when the UTF8 flag is not set. But it was relying on bugs in sv_2iv, etc. So, from 5.8.0 to 5.10.0 inclusive, unary negation prepends "-" if the string begins with [A-Za-z], but from 5.10.1 onwards it behaves diffe- rently depending on the internal UTF8 flag (even prepending "-" to ASCII-only strings like "%apples" if the UTF8 flag is on). This commit restores the 5.8.0-5.10.0 behaviour, which was at least self-consistent. M pp.c M t/op/negate.t commit e38171cf57fef8a0f4063d9e539998f145135ade Author: Father Chrysostomos <[email protected]> Date: Wed Jun 6 12:49:05 2012 -0700 Fix perl #57706 for magical vars: -"-10" Commit a5b92898 caused -"-10" to return 10, not "+10". But it wasnât working for magical variables. SvIV_please_nomg was fixed recently for magical variables, but not SvIV_please, so change pp_negate to use that. (Ironically, SvIV_please has never called magic, so the SvIV_please_nomg variant never needed to exist. So the two could be merged.) M pp.c M t/op/negate.t commit 8a5decd86e575fa785c97ea9b6642e4e87294101 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 01f91bf275559c4ad5a42efe7848a0db00ceb317 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 ef5fe392ebd662891a80860e9ba74cc961823c81 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 6954f42f948dcf1dba2014aa06dd5c33b7561992 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 A t/echo3001 A t/utf67682.pl commit bf3d870f8b8accd379ab520c1ff1daa10317d27d Author: Father Chrysostomos <[email protected]> Date: Fri May 25 22:44:39 2012 -0700 Make strict refs report $1 the same way as "$1" A magical variable is never SvPOK, but only SvPOKp. The code that determined whether to put an ellipsis mark after a truncated symbol name was only checking SvPOK, resulting in this discrepancy: $ perl5.15.9 -e 'use strict; *{"a"x40}' Can't use string ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"...) as a symbol ref while "strict refs" in use at -e line 1. $ perl5.15.9 -e 'use strict; ("a"x40)=~/(.*)/; *{$1}' Can't use string ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa") as a symbol ref while "strict refs" in use at -e line 1. $ perl5.15.9 -e 'use strict; ${"a"x40}' Can't use string ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"...) as a SCALAR ref while "strict refs" in use at -e line 1. $ perl5.15.9 -e 'use strict; ("a"x40)=~/(.*)/; ${$1}' Can't use string ("aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa") as a SCALAR ref while "strict refs" in use at -e line 1. SvPOK variables are also SvPOKp, so checking just the latter suffices. M pp.c M t/lib/strict/refs commit f90b723246c15bceccd726b73c412184c27eca7d Author: Father Chrysostomos <[email protected]> Date: Thu May 24 23:13:37 2012 -0700 Make open(... "<&", $fileno) respect magic A magical variable is never SvPOK, but only SvPOKp. The code for checking whether a duplicatee is a numeric file descriptor was only checking SvPOK. So a regular variable containing a fileno-as-a-string would work, such as the $a below, as would a stringified magical vari- able ("$1"), but not $1 itself. $ echo foo | perl -le '$a = "0"; open a, "<&", $a; warn <a>' foo $ echo foo | perl -le '"0" =~ /(.)/; open a, "<&", $1; warn <a>' Can't use an undefined value as filehandle reference at -e line 1. $ echo foo | perl -le '"0" =~ /(.)/; open a, "<&", "$1"; warn <a>' foo SvPOK variables are also SvPOKp, so checking only the latter suffices. M doio.c M t/io/open.t commit 1e00d6e92a9b49086ba010b4c50b9362ce8f2caa Author: Father Chrysostomos <[email protected]> Date: Thu May 24 22:46:56 2012 -0700 util.c:report_evil_fh: Report name w/initial null In the error message, we shouldnât omit a handle whose name begins with "\0", but, rather, a handle whose name has no length to it. M t/lib/warnings/pp_hot M util.c commit 877e92d0ed656f4550e604d6c599c78ec1eb6765 Author: Father Chrysostomos <[email protected]> Date: Thu May 24 22:46:16 2012 -0700 util.c:report_evil_fh: Rmv redundant SvPOK newSVhek (used to create this SV) always returns an SvPOK scalar. M util.c commit b3c8159837b8c43db90210ef63a293dceebf2f32 Author: Father Chrysostomos <[email protected]> Date: Thu May 24 22:41:53 2012 -0700 util.c:report_wrongway_fh: Report name w/initial null In the error message, we shouldnât omit a handle whose name begins with "\0", but, rather, a handle whose name has no length to it. M t/lib/warnings/pp_hot M util.c commit 5c5c5f453ae0dda3c851bdfad81fe7b65fe7fbc7 Author: Father Chrysostomos <[email protected]> Date: Thu May 24 22:19:29 2012 -0700 util.c:report_evil_fh: Rmv redundant isGV check Checking isGV_with_GP makes the isGV check redundant. The only case in which isGV could be true when isGV_with_GP is false could be a GV playing PVBM, but those donât exist any more. When they did exist, this check was probably wrong (and crashable). M util.c commit 0223a80133899e1c84be7768d5224ee894e33c6f Author: Father Chrysostomos <[email protected]> Date: Thu May 24 22:16:52 2012 -0700 util.c:report_wrongway_fh: Donât create an SV Now that sv_vcatpvfn supports HEKs directly, we donât need to create a temporary SV out of one. M util.c commit c6e4ff343b63c6923b5be105aa9e384e8176673a Author: Father Chrysostomos <[email protected]> Date: Thu May 24 22:10:32 2012 -0700 util.c:report_wrongway_fh: Rmv redundant isGV check Checking isGV_with_GP makes the isGV check redundant. The only case in which isGV could be true when isGV_with_GP is false could be a GV playing PVBM, but those donât exist any more. When they did exist, this check was probably wrong (and crashable). M util.c commit cee59a6aac1243619d4052d0291981c8f2a9966d Author: Father Chrysostomos <[email protected]> Date: Thu May 24 20:37:01 2012 -0700 Make UNIVERSAL::can treats str and num the same way M t/op/universal.t M universal.c commit 44b7e78a9416df5de92da12988790f8e11c1b6f4 Author: Father Chrysostomos <[email protected]> Date: Thu May 24 12:45:58 2012 -0700 Use the same top format error for "" See also the previous commit. 2dd78f96 added the âUndefined top format calledâ message for those cases where a GV doesnât have a name. That was a bug that used to happen with *{$io}, which canât happen any more. The code that 2dd78f96 added ended up changing a zero-length name to be treated the same way as no name. It also checked the length by cheating and checking the first character instead. Now that we have support for embedded nulls, that logic ends up wrong for names like "\0foo". And there is no need to treat "" differently from "foo" anyway. So this patch restores things the way they were before 2dd78f96. It also improves the tests for âUndefined formatâ. Writing tests for âUndefined top formatâ was quite painful, as that error seems to leave the internal state out of synch. I suspect PL_formtarget needs to be localised, or the error just needs to come earlier in pp_leavewrite. But Iâll save that for later, or for Dave Mitchell. :-) M pp_sys.c M t/op/write.t M t/porting/diag.t commit 2d1ebc9b3f82056c2c09ae5e780fff582bd5d5dc Author: Father Chrysostomos <[email protected]> Date: Thu May 24 12:17:02 2012 -0700 Get rid of âNot a format referenceâ This commit: commit 2dd78f96d61cc6382dc72214930c993567209597 Author: Jarkko Hietaniemi <[email protected]> Date: Sun Aug 6 01:33:55 2000 +0000 Continue fixing the io warnings. This also sort of fixes bug ID 20000802.003: the core dump is no more. Whether the current behaviour is correct (giving a warning: "Not a format reference"), is another matter. p4raw-id: //depot/perl@6531 added a check to see whether the format GVâs name is null, and, if so, it dies with âNot a format referenceâ. Before that, that message occurred only for lack of a GV. The bug mentioned is now #3617, involving write(*STDOUT{IO}). write puts an implicit *{} around its argument. *{$io} has historically been very buggy in its stringification, so this patch seems to have been working around that bugginess, by fall- ing back to the âNot a format referenceâ error if the name couldnât be determined for âUndefined format "foo" calledâ. *{$io} was fixed once and for all in 5.16. It now stringifies as *foopackage::__ANONIO__. I donât think producing a completetly different error based on the name of the GV (whether itâs "foo" or "") is correct at all. And the patch that made it happen was just a fix for a crash that canât hap- pen any more. So the only case that should produce âNot a format referenceâ is that in which there is no format GV (fgv). I can prove that fgv is always set (see below), and has been at least since 5.000, so that âNot a format referenceâ actually could never occur before 2dd78f96d61c. (Actually, XS code could set PL_defoutgv to null until the previous commit, but everything would start crashing as a result, so it has never been done in practice.) gv_efullname4 always returns a name, so checking SvPOK(tmpsv) is redundant; checking whether the string buffer begins with a non-null char is not even correct, as "\0foo" fails that test. Proof that fgv is always set: The current (prior to this commit) code in pp_enterwrite is like this: if (MAXARG == 0) { gv = PL_defoutgv; EXTEND(SP, 1); } else { gv = MUTABLE_GV(POPs); if (!gv) gv = PL_defoutgv; } If the stack value is null (which actually canât happen), PL_defoutgv is used. PL_defoutgv canât be null. At this point, gv is set to something non-null. io = GvIO(gv); if (!io) { RETPUSHNO; } Here we only set fgv to IoFMT_GV(io) if it is non-null. Otherwise we use gv, which we know is non-null. if (IoFMT_GV(io)) fgv = IoFMT_GV(io); else fgv = gv; M pod/perldiag.pod M pp_sys.c M t/op/write.t commit 9a9bb270a1f2bcd7b19692797bdfbb5ea12ec08c Author: Father Chrysostomos <[email protected]> Date: Thu May 24 12:07:37 2012 -0700 Make setdefout accept only NN Just search through the source for GvIOp(PL_defoutgv) and you will see that perl assumes that PL_defoutgv is never null. I tried setting it to null from XS and got crashes, unsurprisingly. The only CPAN user of PL_defoutgv sets it to STDOUT. M embed.fnc M pp_sys.c M proto.h commit 2748e6020278d4118252bc18ecc0db56ef04a973 Author: Father Chrysostomos <[email protected]> Date: Wed May 23 23:24:35 2012 -0700 Assertion failure with $/=*foo; warn; $ ./perl -Ilib -e '$/=*foo; <>; warn' <./perl Assertion failed: (!isGV_with_GP(_svcur)), function Perl_mess_sv, file util.c, line 1467. Abort trap The assertion happens when â<...> line 42â is being appended to the message. The line of code in question is this: const bool line_mode = (RsSIMPLE(PL_rs) && SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n'); It uses this macro in perl.h: #define RsSIMPLE(sv) (SvOK(sv) && (! SvPOK(sv) || SvCUR(sv))) which was last modified by commit af7d13df559: -#define RsSIMPLE(sv) (SvOK(sv) && SvCUR(sv)) -#define RsPARA(sv) (SvOK(sv) && ! SvCUR(sv)) +#define RsSIMPLE(sv) (SvOK(sv) && (! SvPOK(sv) || SvCUR(sv))) +#define RsPARA(sv) (SvPOK(sv) && ! SvCUR(sv)) So it looks as though it has always called SvCUR on something that is not necessarily a PV. As of commit af7d13df559, it has also called SvPVX on a potential non-PV. Fixing this simply involves using SvPV instead of SvPVX. I donât know that t/io/open.t is the best place for the test, but all the other â<...> line 42â tests are there. M t/io/open.t M util.c ----------------------------------------------------------------------- Summary of changes: doio.c | 5 ++- embed.fnc | 3 +- embed.h | 1 + pod/perldiag.pod | 5 --- pp.c | 78 ++++++++++++----------------------------------- pp_hot.c | 7 +--- pp_sys.c | 40 +++++++++++++----------- proto.h | 11 ++++++- sv.c | 22 +++++++++++++ sv.h | 10 +++++- t/comp/proto.t | 10 +++++- t/echo3001 | 1 + t/io/open.t | 11 ++++++- t/lib/strict/refs | 23 ++++++++++++++ t/lib/warnings/pp_hot | 27 ++++++++++++++++ t/op/arith.t | 53 ++++++++++++++++++++++++++++++++- t/op/negate.t | 32 ++++++++++++++++++- t/op/tie_fetch_count.t | 14 ++++++++- t/op/universal.t | 5 ++- t/op/warn.t | 46 +++++++++++++++++++++++++++- t/op/write.t | 43 ++++++++++++++++++++++++-- t/porting/diag.t | 1 - t/utf67682.pl | Bin 0 -> 50 bytes universal.c | 4 +- util.c | 17 +++++----- 25 files changed, 354 insertions(+), 115 deletions(-) create mode 100644 t/echo3001 create mode 100644 t/utf67682.pl diff --git a/doio.c b/doio.c index 69d091c..fed1a49 100644 --- a/doio.c +++ b/doio.c @@ -320,7 +320,10 @@ Perl_do_openn(pTHX_ GV *gv, register const char *oname, I32 len, int as_raw, } while (isSPACE(*type)) type++; - if (num_svs && (SvIOK(*svp) || (SvPOK(*svp) && looks_like_number(*svp)))) { + if (num_svs && ( + SvIOK(*svp) + || (SvPOKp(*svp) && looks_like_number(*svp)) + )) { fd = SvUV(*svp); num_svs = 0; } diff --git a/embed.fnc b/embed.fnc index 455a8c3..5bfa543 100644 --- a/embed.fnc +++ b/embed.fnc @@ -1194,7 +1194,7 @@ Apd |NV |scan_oct |NN const char* start|STRLEN len|NN STRLEN* retlen AMpd |OP* |op_scope |NULLOK OP* o Ap |char* |screaminstr |NN SV *bigstr|NN SV *littlestr|I32 start_shift \ |I32 end_shift|NN I32 *old_posp|I32 last -Apd |void |setdefout |NULLOK GV* gv +Apd |void |setdefout |NN GV* gv Ap |HEK* |share_hek |NN const char* str|I32 len|U32 hash #if defined(HAS_SIGACTION) && defined(SA_SIGINFO) : Used in perl.c @@ -1311,6 +1311,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 1815481..781366b 100644 --- a/embed.h +++ b/embed.h @@ -1197,6 +1197,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/pod/perldiag.pod b/pod/perldiag.pod index 01b9202..2a486bb 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -3186,11 +3186,6 @@ subroutine), but found a reference to something else instead. You can use the ref() function to find out what kind of ref it really was. See also L<perlref>. -=item Not a format reference - -(F) I'm not sure how you managed to generate a reference to an anonymous -format, but this indicates you did, and that it didn't exist. - =item Not a GLOB reference (F) Perl was trying to evaluate a reference to a "typeglob" (that is, a diff --git a/pp.c b/pp.c index 6e7544a..0066513 100644 --- a/pp.c +++ b/pp.c @@ -218,7 +218,7 @@ S_rv2gv(pTHX_ SV *sv, const bool vivify_sv, const bool strict, (SV *)Perl_die(aTHX_ S_no_symref_sv, sv, - (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), + (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), "a symbol" ); if ((PL_op->op_private & (OPpLVAL_INTRO|OPpDONT_INIT_GV)) @@ -271,7 +271,8 @@ Perl_softref2xv(pTHX_ SV *const sv, const char *const what, if (PL_op->op_private & HINT_STRICT_REFS) { if (SvOK(sv)) - Perl_die(aTHX_ S_no_symref_sv, sv, (SvPOK(sv) && SvCUR(sv)>32 ? "..." : ""), what); + Perl_die(aTHX_ S_no_symref_sv, sv, + (SvPOKp(sv) && SvCUR(sv)>32 ? "..." : ""), what); else Perl_die(aTHX_ PL_no_usym, what); } @@ -431,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)) { @@ -1022,11 +1024,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; @@ -1124,8 +1122,6 @@ PP(pp_pow) RETURN; } } - } - } } float_it: #endif @@ -1189,14 +1185,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)); @@ -1334,10 +1328,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; @@ -1412,8 +1403,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); @@ -1445,8 +1435,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); @@ -1476,9 +1465,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); @@ -1491,7 +1478,6 @@ PP(pp_modulo) left = -aiv; } } - } } else { dleft = SvNV_nomg(svl); @@ -1706,8 +1692,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. */ @@ -1721,8 +1706,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 { @@ -1950,11 +1934,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)) { @@ -1990,7 +1971,6 @@ Perl_do_ncmp(pTHX_ SV* const left, SV * const right) } } /* NOTREACHED */ - } } #endif { @@ -2176,14 +2156,9 @@ 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) || (SvGMAGICAL(sv) && SvIOKp(sv))) { + /* It's publicly an integer */ oops_its_an_int: if (SvIsUV(sv)) { if (SvIVX(sv) == IV_MIN) { @@ -2207,7 +2182,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; @@ -2216,27 +2191,14 @@ PP(pp_negate) sv_setpvs(TARG, "-"); sv_catsv(TARG, sv); } - else if (*s == '+' || *s == '-') { + else if (*s == '+' || (*s == '-' && !looks_like_number(sv))) { sv_setsv_nomg(TARG, sv); *SvPV_force_nomg(TARG, len) = *s == '-' ? '+' : '-'; } - else if (DO_UTF8(sv)) { - SvIV_please_nomg(sv); - if (SvIOK(sv)) - goto oops_its_an_int; - if (SvNOK(sv)) - sv_setnv(TARG, -SvNV_nomg(sv)); - else { - sv_setpvs(TARG, "-"); - sv_catsv(TARG, sv); - } - } - else { - SvIV_please_nomg(sv); - if (SvIOK(sv)) + else if (SvIV_please_nomg(sv)) goto oops_its_an_int; + else sv_setnv(TARG, -SvNV_nomg(sv)); - } SETTARG; } else diff --git a/pp_hot.c b/pp_hot.c index 59ff881..5338fd7 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 5a87da5..79ef266 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) : SvNIOKp(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)); @@ -1227,7 +1236,8 @@ void Perl_setdefout(pTHX_ GV *gv) { dVAR; - SvREFCNT_inc_simple_void(gv); + PERL_ARGS_ASSERT_SETDEFOUT; + SvREFCNT_inc_simple_void_NN(gv); SvREFCNT_dec(PL_defoutgv); PL_defoutgv = gv; } @@ -1360,18 +1370,13 @@ PP(pp_enterwrite) else fgv = gv; - if (!fgv) - goto not_a_format_reference; + assert(fgv); cv = GvFORM(fgv); if (!cv) { tmpsv = sv_newmortal(); gv_efullname4(tmpsv, fgv, NULL, FALSE); - if (SvPOK(tmpsv) && *SvPV_nolen_const(tmpsv)) - DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv)); - - not_a_format_reference: - DIE(aTHX_ "Not a format reference"); + DIE(aTHX_ "Undefined format \"%"SVf"\" called", SVfARG(tmpsv)); } IoFLAGS(io) &= ~IOf_DIDTOP; return doform(cv,gv,PL_op->op_next); @@ -1456,10 +1461,7 @@ PP(pp_leavewrite) if (!cv) { SV * const sv = sv_newmortal(); gv_efullname4(sv, fgv, NULL, FALSE); - if (SvPOK(sv) && *SvPV_nolen_const(sv)) - DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv)); - else - DIE(aTHX_ "Undefined top format called"); + DIE(aTHX_ "Undefined top format \"%"SVf"\" called", SVfARG(sv)); } return doform(cv, gv, PL_op); } diff --git a/proto.h b/proto.h index 539d06d..02bc3cc 100644 --- a/proto.h +++ b/proto.h @@ -3638,7 +3638,11 @@ PERL_CALLCONV void Perl_set_context(void *t) PERL_CALLCONV void Perl_set_numeric_local(pTHX); PERL_CALLCONV void Perl_set_numeric_radix(pTHX); PERL_CALLCONV void Perl_set_numeric_standard(pTHX); -PERL_CALLCONV void Perl_setdefout(pTHX_ GV* gv); +PERL_CALLCONV void Perl_setdefout(pTHX_ GV* gv) + __attribute__nonnull__(pTHX_1); +#define PERL_ARGS_ASSERT_SETDEFOUT \ + assert(gv) + PERL_CALLCONV HEK* Perl_share_hek(pTHX_ const char* str, I32 len, U32 hash) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_SHARE_HEK \ @@ -3955,6 +3959,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 b4716db..2034c00 100644 --- a/sv.c +++ b/sv.c @@ -2332,6 +2332,28 @@ 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; + PERL_ARGS_ASSERT_SV_GMAGICAL_2IV_PLEASE; + assert(SvGMAGICAL(sv) && !SvIOKp(sv) && (SvNOKp(sv) || SvPOKp(sv))); + if (S_sv_2iuv_common(aTHX_ sv)) { SvNIOK_off(sv); return 0; } + has_int = !!SvIOK(sv); + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); + 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 9078517..6d26f85 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 8e9821f..d5e4d5b 100644 --- a/t/comp/proto.t +++ b/t/comp/proto.t @@ -18,7 +18,7 @@ BEGIN { # strict use strict; -print "1..179\n"; +print "1..180\n"; my $i = 1; @@ -409,7 +409,7 @@ 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"; @@ -423,6 +423,12 @@ print "# CORE::\\x{100}: => ($p), \$@ => '$@'\nnot " if $@ !~ /^Can't find an opnumber for "\x{100}"/; 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++, " - \$1 containing CORE::Foo\n"; + # correctly note too-short parameter lists that don't end with '$', # a possible regression. diff --git a/t/echo3001 b/t/echo3001 new file mode 100644 index 0000000..841ea7f --- /dev/null +++ b/t/echo3001 @@ -0,0 +1 @@ +print "@ARGV\n" diff --git a/t/io/open.t b/t/io/open.t index 6b1f1d7..e06fc8e 100644 --- a/t/io/open.t +++ b/t/io/open.t @@ -10,7 +10,7 @@ $| = 1; use warnings; use Config; -plan tests => 119; +plan tests => 121; my $Perl = which_perl(); @@ -233,6 +233,10 @@ like( $@, qr/Bad filehandle:\s+$afile/, ' right error' ); # used to try to open a file [perl #17830] ok( open(my $stdin, "<&", fileno STDIN), 'dup fileno(STDIN) into lexical fh') or _diag $!; + + fileno(STDIN) =~ /(.)/; + ok open($stdin, "<&", $1), 'open ... "<&", $magical_fileno', + || _diag $!; } SKIP: { @@ -278,6 +282,11 @@ SKIP: { open($fh3{k}, "TEST"); gimme($fh3{k}); like($@, qr/<\$fh3\{...}> line 1\./, "autoviv fh lexical helem"); + + local $/ = *F; # used to cause an assertion failure + gimme($fh3{k}); + like($@, qr/<\$fh3\{...}> chunk 2\./, + '<...> line 1 when $/ is set to a glob'); } SKIP: { diff --git a/t/lib/strict/refs b/t/lib/strict/refs index d9bff7c..21dbfcf 100644 --- a/t/lib/strict/refs +++ b/t/lib/strict/refs @@ -27,6 +27,29 @@ Can't use string ("A::Really::Big::Package::Name::T"...) as a HASH ref while "st # strict refs - error use strict ; +"A::Really::Big::Package::Name::To::Use" =~ /(.*)/; +${$1}; +EXPECT +Can't use string ("A::Really::Big::Package::Name::T"...) as a SCALAR ref while "strict refs" in use at - line 5. +######## + +# strict refs - error +use strict ; +*{"A::Really::Big::Package::Name::To::Use"; } +EXPECT +Can't use string ("A::Really::Big::Package::Name::T"...) as a symbol ref while "strict refs" in use at - line 4. +######## + +# strict refs - error +use strict ; +"A::Really::Big::Package::Name::To::Use" =~ /(.*)/; +*{$1} +EXPECT +Can't use string ("A::Really::Big::Package::Name::T"...) as a symbol ref while "strict refs" in use at - line 5. +######## + +# strict refs - error +use strict ; my $fred ; my $a = ${"fred"} ; EXPECT diff --git a/t/lib/warnings/pp_hot b/t/lib/warnings/pp_hot index 9ef68e0..ad63d2a 100644 --- a/t/lib/warnings/pp_hot +++ b/t/lib/warnings/pp_hot @@ -61,6 +61,15 @@ EXPECT print() on unopened filehandle abc at - line 4. ######## # pp_hot.c [pp_print] +use warnings 'unopened' ; +$SIG{__WARN__} = sub { warn $_[0] =~ s/\0/\\0/rug; }; +print {"a\0b"} "anc"; +print {"\0b"} "anc"; +EXPECT +print() on unopened filehandle a\0b at - line 4. +print() on unopened filehandle \0b at - line 5. +######## +# pp_hot.c [pp_print] use warnings 'io' ; # There is no guarantee that STDOUT is output only, or STDIN input only. # Certainly on some BSDs (at least FreeBSD, Darwin, BSDi) file descriptors @@ -90,6 +99,24 @@ Filehandle FH opened only for input at - line 19. Filehandle FOO opened only for input at - line 20. ######## # pp_hot.c [pp_print] +$SIG{__WARN__} = sub { warn $_[0] =~ s/\0/\\0/rug; }; +use warnings 'io' ; +my $file = "./xcv" ; unlink $file ; +open (FH, ">$file") or die $! ; +close FH or die $! ; +die "There is no file $file" unless -f $file ; +open ("a\0b", "<$file") or die $! ; +print {"a\0b"} "anc" ; +open ("\0b", "<$file") or die $! ; +print {"\0b"} "anc" ; +close "a\0b" or die $! ; +close "\0b" or die $! ; +unlink $file ; +EXPECT +Filehandle a\0b opened only for input at - line 9. +Filehandle \0b opened only for input at - line 11. +######## +# pp_hot.c [pp_print] use warnings 'closed' ; close STDIN ; print STDIN "anc"; 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..6c355c7 100644 --- a/t/op/negate.t +++ b/t/op/negate.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -plan tests => 16; +plan tests => 24; # Some of these will cause warnings if left on. Here we're checking the # functionality, not the warnings. @@ -19,7 +19,11 @@ is(-"10", -10, "Negation of a positive string to negative"); is(-"10.0", -10, "Negation of a positive decimal sting to negative"); is(-"10foo", -10, "Negation of a numeric-lead string returns negation of numeric"); is(-"-10", 10, 'Negation of string starting with "-" returns a positive number - integer'); +"-10" =~ /(.*)/; +is(-$1, 10, 'Negation of magical string starting with "-" - integer'); is(-"-10.0", 10.0, 'Negation of string starting with "-" returns a positive number - decimal'); +"-10.0" =~ /(.*)/; +is(-$1, 10.0, 'Negation of magical string starting with "-" - decimal'); is(-"-10foo", "+10foo", 'Negation of string starting with "-" returns a string starting with "+" - non-numeric'); is(-"xyz", "-xyz", 'Negation of a negative string adds "-" to the front'); is(-"-xyz", "+xyz", "Negation of a negative string to positive"); @@ -28,4 +32,28 @@ 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"'); +"9765625000000000" =~ /(\d+)/; +is -$1, -"$1", '-$1 vs -"$1" with big int'; + +$a = "%apples"; +chop($au = "%apples\x{100}"); +is(-$au, -$a, 'utf8 flag makes no difference for string negation'); +is -"\x{100}", 0, '-(non-ASCII) is equivalent to -(punct)'; + +sub TIESCALAR { bless[] } +sub STORE { $_[0][0] = $_[1] } +sub FETCH { $_[0][0] } + +tie $t, ""; +$a = "97656250000000000"; +() = 0+$a; +$t = $a; +is -$t, -97656250000000000, 'magic str+int dualvar'; 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/universal.t b/t/op/universal.t index 991a6f3..40f14ce 100644 --- a/t/op/universal.t +++ b/t/op/universal.t @@ -10,7 +10,7 @@ BEGIN { require "./test.pl"; } -plan tests => 133; +plan tests => 135; $a = {}; bless $a, "Bob"; @@ -108,6 +108,9 @@ for ($p=0; $p < @refs; $p++) { }; ok ! UNIVERSAL::can(23, "can"); +++${"23::foo"}; +ok UNIVERSAL::can("23", "can"), '"23" can can when the pack exists'; +ok UNIVERSAL::can(23, "can"), '23 can can when the pack exists'; ok $a->can("VERSION"); diff --git a/t/op/warn.t b/t/op/warn.t index 4a927e2..71de5e2 100644 --- a/t/op/warn.t +++ b/t/op/warn.t @@ -7,7 +7,7 @@ BEGIN { require './test.pl'; } -plan 22; +plan 30; my @warnings; my $wa = []; my $ea = []; @@ -148,4 +148,48 @@ 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'; + +@warnings = (); +eval "#line 42 Cholmondeley\n \$\@ = '3'; warn"; +eval "#line 42 Cholmondeley\n \$\@ = 3; warn"; +is @warnings, 2; +is $warnings[1], $warnings[0], 'warn treats $@=3 and $@="3" the same way'; + 1; diff --git a/t/op/write.t b/t/op/write.t index 8be0b41..64831ea 100644 --- a/t/op/write.t +++ b/t/op/write.t @@ -61,7 +61,7 @@ for my $tref ( @NumTests ){ my $bas_tests = 20; # number of tests in section 3 -my $bug_tests = 4 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3; +my $bug_tests = 8 + 3 * 3 * 5 * 2 * 3 + 2 + 66 + 4 + 2 + 3; # number of tests in section 4 my $hmb_tests = 35; @@ -504,13 +504,50 @@ for my $tref ( @NumTests ){ { local $~ = ''; eval { write }; - like $@, qr/Not a format reference/, 'format reference'; + like $@, qr/Undefined format ""/, 'format with 0-length name'; + + $~ = "\0foo"; + eval { write }; + like $@, qr/Undefined format "\0foo"/, + 'no such format beginning with null'; $~ = "NOSUCHFORMAT"; eval { write }; - like $@, qr/Undefined format/, 'no such format'; + like $@, qr/Undefined format "NOSUCHFORMAT"/, 'no such format'; } +select +(select(OUT21), do { + open(OUT21, '>Op_write.tmp') || die "Can't create Op_write.tmp"; + + format OUT21 = +@<< +$_ +. + + local $^ = ''; + local $= = 1; + $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; + like $@, qr/Undefined top format ""/, 'top format with 0-length name'; + + $^ = "\0foo"; + # For some reason, we have to do this twice to get the error again. + $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; + $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; + like $@, qr/Undefined top format "\0foo"/, + 'no such top format beginning with null'; + + $^ = "NOSUCHFORMAT"; + $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; + $_ = "aataaaaaaaaaaaaaa"; eval { write(OUT21) }; + like $@, qr/Undefined top format "NOSUCHFORMAT"/, 'no such top format'; + + # reset things; + eval { write(OUT21) }; + undef $^A; + + close OUT21 or die "Could not close: $!"; +})[0]; + { package Count; diff --git a/t/porting/diag.t b/t/porting/diag.t index c075626..d86282a 100644 --- a/t/porting/diag.t +++ b/t/porting/diag.t @@ -453,7 +453,6 @@ The telldir() function is not implemented on NetWare Too deeply nested ()-groups in %s Too many args on %s line of "%s" U0 mode on a byte string -Undefined top format called Unstable directory path, current directory changed unexpectedly Unterminated compressed integer in unpack Usage: CODE(0x%x)(%s) diff --git a/t/utf67682.pl b/t/utf67682.pl new file mode 100644 index 0000000..66777ee Binary files /dev/null and b/t/utf67682.pl differ diff --git a/universal.c b/universal.c index af3207f..384d307 100644 --- a/universal.c +++ b/universal.c @@ -356,8 +356,8 @@ XS(XS_UNIVERSAL_can) SvGETMAGIC(sv); - if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) - || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) + if (!SvOK(sv) || !(SvROK(sv) || SvNIOK(sv) || (SvPOK(sv) && SvCUR(sv)) + || (SvGMAGICAL(sv) && (SvNIOKp(sv) || (SvPOKp(sv) && SvCUR(sv)))))) XSRETURN_UNDEF; rv = &PL_sv_undef; diff --git a/util.c b/util.c index d0fea67..e1dc7d6 100644 --- a/util.c +++ b/util.c @@ -1306,8 +1306,9 @@ Perl_mess_sv(pTHX_ SV *basemsg, bool consume) if (GvIO(PL_last_in_gv) && (SvTYPE(GvIOp(PL_last_in_gv)) == SVt_PVIO) && IoLINES(GvIOp(PL_last_in_gv))) { + STRLEN l; const bool line_mode = (RsSIMPLE(PL_rs) && - SvCUR(PL_rs) == 1 && *SvPVX_const(PL_rs) == '\n'); + *SvPV_const(PL_rs,l) == '\n' && l == 1); Perl_sv_catpvf(aTHX_ sv, ", <%"SVf"> %s %"IVdf, SVfARG(PL_last_in_gv == PL_argvgv ? &PL_sv_no @@ -3715,15 +3716,15 @@ void Perl_report_wrongway_fh(pTHX_ const GV *gv, const char have) { if (ckWARN(WARN_IO)) { - SV * const name - = gv && (isGV(gv) || isGV_with_GP(gv)) - ? sv_2mortal(newSVhek(GvENAME_HEK((gv)))) + HEK * const name + = gv && (isGV_with_GP(gv)) + ? GvENAME_HEK((gv)) : NULL; const char * const direction = have == '>' ? "out" : "in"; - if (name && SvPOK(name) && *SvPV_nolen(name)) + if (name && HEK_LEN(name)) Perl_warner(aTHX_ packWARN(WARN_IO), - "Filehandle %"SVf" opened only for %sput", + "Filehandle %"HEKf" opened only for %sput", name, direction); else Perl_warner(aTHX_ packWARN(WARN_IO), @@ -3750,7 +3751,7 @@ Perl_report_evil_fh(pTHX_ const GV *gv) if (ckWARN(warn_type)) { SV * const name - = gv && (isGV(gv) || isGV_with_GP(gv)) && GvENAMELEN(gv) ? + = gv && isGV_with_GP(gv) && GvENAMELEN(gv) ? sv_2mortal(newSVhek(GvENAME_HEK(gv))) : NULL; const char * const pars = (const char *)(OP_IS_FILETEST(op) ? "" : "()"); @@ -3763,7 +3764,7 @@ Perl_report_evil_fh(pTHX_ const GV *gv) (const char *) (OP_IS_SOCKET(op) || (io && IoTYPE(io) == IoTYPE_SOCKET) ? "socket" : "filehandle"); - const bool have_name = name && SvPOK(name) && *SvPV_nolen(name); + const bool have_name = name && SvCUR(name); Perl_warner(aTHX_ packWARN(warn_type), "%s%s on %s %s%s%"SVf, func, pars, vile, type, have_name ? " " : "", -- Perl5 Master Repository
