In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/cbacc9aa064469dbad90cdce51a3e7abbdf202be?hp=fe5e93dee32154bdde539f1862a8382cd476ac66>
- Log ----------------------------------------------------------------- commit cbacc9aa064469dbad90cdce51a3e7abbdf202be Author: Father Chrysostomos <[email protected]> Date: Fri Sep 14 22:08:19 2012 -0700 [perl #114888] Localise PL_comppad_name in cv_clone In 9ef8d56 I made closures share their pad name lists, and not just the names themselves, for speed (no need to SvREFCNT_inc each name and copy the list). To make that work, I had to set PL_comppad_name in cv_clone, before the pad_new call. But I failed to move the PL_comppad_name localisa- tion from pad_new to cv_clone. So cv_clone would merrily clobber the previous value of PL_comppad_name *before* localising it. This only manifested itself in source filters. Most of the time, pp_anoncode is called at run time when either no code is being com- piled (PL_comppad_name is only used at compile time) or inside a BEGIN block which itself localises PL_comppad_name. But inside a Filter::Util::Call source filter there was no buffer like that to protect it. This meant that pad name creation (my $x) would create the name in the PL_comppad_name belonging to the last-cloned sub. A subsequent name lookup ($x) would look in the correct place, as it uses the moral equivalent of PadlistNAMES(CvPADLIST(PL_compcv)), not PL_comppad_name. So it would not find it, resulting in a global variable or a stricture violation. M pad.c M t/op/closure.t commit 37b0b3b2e3fecf62fbb5a9c784ad24707e8d3581 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 14 14:20:07 2012 -0700 Make SUPER::method respect method changes in moved pkg ->SUPER::method calls inside the Foo package cache the method for reuse inside the stash Foo::SUPER. Before the call, @Foo::SUPER::ISA is set to "Foo", so that those caches will be invalidated properly. (@ISA has the magic to make that work.) The actual value in @Foo::SUPER::ISA unused. Now we have two types of package names. If you alias the Foo package and then clobber the original entry: *Bar:: = *Foo::; undef *Foo::; __PACKAGE__ and HvNAME will return Foo still, but HvENAME (the effec- tive name) will return Bar, because that is where the package is to be found. As of the previous commit, the package used for ISA is based on the effective name, Bar::SUPER in this case. But @Bar::SUPER::ISA is still set to Foo. So even if we make changes to methods inherited by what is now the Bar package, a previous method cached in *Bar::SUPER::method will be reused. BEGIN { *Bar:: = *Foo::; undef *Foo::; } package Bar; @ISA = 'Baz'; *Baz::m = sub { "method 1" }; anthying->SUPER::m; undef *Baz::m; *Baz::m = sub { "method 2" }; warn anything->SUPER::m; __END__ method 1 at - line 11. M gv.c M t/op/method.t commit 0308a534a635b8c34297657046d32a3f05818821 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 14 13:35:53 2012 -0700 Make SUPER::method calls work in moved stashes BEGIN { *foo:: = *bar::; *bar:: = *baz; } package foo; @ISA = 'door'; sub door::dohtem { 'dohtem' } warn bar->SUPER::dohtem; __END__ Can't locate object method "dohtem" via package "bar::SUPER" at - line 8. When gv_fetchmethod_pvn_flags looks up a package it changes SUPER to __PACKAGE__ . "::SUPER" first. Then gv_fetchmeth_pvn uses HvNAME on the package and strips off the ::SUPER suffix if any, before doing isa lookup. The problem with using __PACKAGE__ (actually HvNAME) is that it might not be possible to find the current stash under that name. HvENAME should be used instead. The above example happens to work if @ISA is changed to âour @ISAâ, but that is because of an @ISA bug. M gv.c M t/op/method.t commit 3c104e59d83f6195ebcc80776f15604d74d666b2 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 14 13:13:30 2012 -0700 Make SUPER:: in main less sensitive $ perl -e '$main::SUPER::; sub bar::bar{} @ISA = bar; main->SUPER::bar' $ perl -e '$SUPER::; sub bar::bar{} @ISA = bar; main->SUPER::bar' Can't locate object method "bar" via package "main" at -e line 1. (Thatâs 5.10.1. More recent perls say package "SUPER".) The only differnce that $SUPER:: variable makes is the name of the SUPER:: package. It ends up being called SUPER instead of main::SUPER. This causes problems because gv_fetchmeth_pvn, seeing a package end- ing in ::SUPER, strips off the ::SUPER before doing isa lookup. But SUPER does not end in ::SUPER, so this commit adjusts gv_fetchmeth_pvn to account. M gv.c M t/op/method.t commit 697efb9be70535836d8ebd1327ecb1c72666000e Author: Father Chrysostomos <[email protected]> Date: Fri Sep 14 12:32:28 2012 -0700 method.t: Add basic tests for SUPER M t/op/method.t commit bfde49d45e9457b1d8a9e18b55d5b0c7615ddcd6 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 14 10:19:58 2012 -0700 method.t: Test more method-BLOCK edge cases M t/op/method.t commit bb5a0ddc2479daec4187d55d77d2e37d4aad78bb Author: Father Chrysostomos <[email protected]> Date: Fri Sep 14 10:12:33 2012 -0700 cop.h: Remove obsolete comment 623e6609 (2 Apr 2006) added this to cop.h: +/* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h) */ +#define CopHINTS_get(c) ((c)->op_private + 0) +#define CopHINTS_set(c, h) STMT_START { \ + (c)->op_private \ + = (U8)((h) & HINT_PRIVATE_MASK); \ + } STMT_END + d5ec2987 (20 May 2006) made this change, ignoring the FIXME: /* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h) */ -#define CopHINTS_get(c) ((c)->op_private + 0) +#define CopHINTS_get(c) ((c)->cop_hints + 0) #define CopHINTS_set(c, h) STMT_START { \ - (c)->op_private \ - = (U8)((h) & HINT_PRIVATE_MASK); \ + (c)->cop_hints = (h); \ } STMT_END There is nothing to be fixed here, as vmsish.h uses ->op_private directly, instead of using the CopHINTS macros. Even having caller return cop_hints instead of op_private doesnât hurt, as newly-created cops copy the vms hints from PL_hints to op_private. So assigning (caller $n)[8] to $^H will still work. M cop.h commit 2f8e87a8913461b1a55ef9ecbf91d7846701cf35 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 14 06:28:21 2012 -0700 pp_ctl.c:caller: Remove obsolete comment This was added in f3aa04c29a, but stopped being relevant in d5ec2987912. M pp_ctl.c commit d2691ae2082d66317df547754a5f551ba3ef3bf0 Author: Father Chrysostomos <[email protected]> Date: Fri Sep 14 06:20:34 2012 -0700 Prevent assertion failure with âno a a 3â This particular syntax error, whittled down from âno if $] >= 5.17.4 warnings => "deprecated"â (which contains a type), causes the parser to try to free an op from the new sub (for the BEGIN block) after freeing the new sub. This happens on line 526 of perly.c. It should not be necessary for the parser to free the op at this point, since after an error any ops owned by incomplete subsâ slabs will be freed. Iâm leaving the other three instances of op_free in perly.c in place, at least for now, since there are cases where the forced token stack prevents ops from being freed when their subs are. M perly.c M t/comp/parser.t commit 40490cca4e530eb6432933baf72ce12db36a4b6c Author: Father Chrysostomos <[email protected]> Date: Fri Sep 14 00:16:35 2012 -0700 Increase $warnings::VERSION to 1.14 M lib/warnings.pm M regen/warnings.pl commit 7fc874e826a059bd024f1cbd568e1021c5731f35 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 13 23:46:46 2012 -0700 Stop lexical warnings from turning off deprecations Some warnings, such as deprecation warnings, are on by default: $ perl5.16.0 -e '$*' $* is no longer supported at -e line 1. But turning *on* other warnings will turn them off: $ perl5.16.0 -e 'use warnings "void"; $*' Useless use of a variable in void context at -e line 1. Either all warnings in any given scope are controlled by lexical hints, or none of them are. When a single warnings category is turned on or off, if the warn- ings were controlled by $^W, then all warnings are first turned on lexically if $^W is 1 and all warnings are turned off lexically if $^W is 0. That has the unfortunate affect of turning off warnings when it was only requested that warnings be turned on. These categories contain default warnings: ambiguous debugging deprecated inplace internal io malloc utf8 redefine syntax glob inplace overflow precedence prototype threads misc Most also contain regular warnings, but these contain *only* default warnings: debugging deprecated glob inplace malloc So we can treat $^W==0 as equivalent to qw(debugging deprecated glob inplace malloc) when enabling lexical warnings. While this means that some default warnings will still be turned off by âuse warnings "void"â, it wonât be as many as before. So at least this is a step in the right direction. (The real solution, of course, is to allow each warning to be turned off or on on its own.) M dist/IO/t/IO.t M lib/warnings.pm M regen/warnings.pl M t/lib/warnings/2use M t/lib/warnings/regcomp M t/lib/warnings/toke M t/op/universal.t M t/uni/universal.t commit f07626add3eda6dfda7c5f6fe05cbe1c9293ccd2 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 13 23:33:03 2012 -0700 Make (caller $n)[9] respect std warnings In commit 7e4f04509c6 I forgot about caller. This commit makes the value returned by (caller $n)[9] assignable to ${^WARNING_BITS} to produce exactly the same warnings settings, including warnings con- trolled by $^W. M pp_ctl.c M t/op/caller.t commit 38248b9d23f2dd91529d8b3c32ad8f5f3ec93950 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 13 21:23:34 2012 -0700 perldiag: 13 years for reserved word deprec. is enough Use of âourâ (which was not a keyword yet) was deprecated in 1997 in commit 85b81015bd, so that it could be used as a keyword later. âourâ variables were introduced in 1999 in commit 77ca0c92d2c, remov- ing the deprecation warning. The notice in perldiag survived, ...till now. M pod/perldiag.pod commit 8f7e4d2c6f691c4079497afafd8e98a4610ced06 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 13 18:01:44 2012 -0700 perldiag: âAttempt to free unreffed scalarâ is S M pod/perldiag.pod commit db79017c68626c46695db05da56108f703166992 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 13 17:50:15 2012 -0700 perlhacktips.pod: readonly ops update (again) M pod/perlhacktips.pod commit 9ac6f7d9006999423110b8393f43cfbe04af6607 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 13 14:08:46 2012 -0700 sv.c: %vd printf format microöptimisation The %vd printf format does not need to make two copies of a version objectâs stringification or stringify the object twice. M sv.c commit 8b6051f1221d6cda04269ae9d98a69b379a35ba9 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 13 13:00:12 2012 -0700 Fix %vd with alpha version There are five problems with it: First, this warning is not suppressible, even with -X: $ perl -Xe' sprintf "[%vd]\n", new version v1.1_1' vector argument not supported with alpha versions at -e line 1. To keep the behaviour as close as possible to what it was already without the incorrect behaviour, I have made it a default warning. Secondly, putting it in the internal category does not make sense. internal is a subset of severe, and contains warnings that indicate internal inconsistencies, like âScalars leakedâ and âUnbalanced string table refcountâ. It should be in the printf warnings category. Thirdly, if we turn warnings on explicitly, we see this: $ perl -we '() = sprintf "[%vd]\n", new version v1.1_1' vector argument not supported with alpha versions at -e line 1. Invalid conversion in printf: "%v" at -e line 1. %vd is not invalid. That warning is bogus. Fourthly, %vd itself gets output when fed an alpha version: $ perl -Xe 'printf "[%vd]\n", new version v1.1_1' vector argument not supported with alpha versions at -e line 1. [%vd] If an argument is missing or invalid or what have you, the %-format itself should not be output. An empty string makes the most sense. Fifthly, it leaks memory. Run this and watch memory usage go up: $ perl -e ' warn $$; $SIG{__WARN__} = sub {}; $v = new version v1.1_1; sprintf "%vd", $v while 1 ' It does savesvpv before shortcircuiting for alphas. But the corres- ponding Safefree comes after the shortcircuiting, which skips it. M pod/perldiag.pod M sv.c M t/lib/warnings/sv M t/op/sprintf.t commit 31ff3bd29b12e1b9b727dcadfb890c6de37a3191 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 13 08:35:39 2012 -0700 perldiag: âUnbalanced string tableâ is a default warning M pod/perldiag.pod commit 7bd1381d1eadc68b8162724881e34b5652c2d1e6 Author: Father Chrysostomos <[email protected]> Date: Thu Sep 13 08:33:41 2012 -0700 perldiag: âScalars leakedâ is a default warning M pod/perldiag.pod ----------------------------------------------------------------------- Summary of changes: cop.h | 1 - dist/IO/t/IO.t | 1 + gv.c | 14 ++++++----- lib/warnings.pm | 14 +++++++---- pad.c | 3 +- perly.c | 2 - pod/perldiag.pod | 17 +++---------- pod/perlhacktips.pod | 31 +++---------------------- pp_ctl.c | 8 ++---- regen/warnings.pl | 24 +++++++++++++------ sv.c | 9 +++---- t/comp/parser.t | 6 ++++- t/lib/warnings/2use | 19 +++++++++++++++ t/lib/warnings/regcomp | 2 +- t/lib/warnings/sv | 12 +++++++++ t/lib/warnings/toke | 2 +- t/op/caller.t | 19 ++++++++++++++- t/op/closure.t | 26 +++++++++++++++++++++ t/op/method.t | 59 ++++++++++++++++++++++++++++++++++++++++++++++- t/op/sprintf.t | 3 ++ t/op/universal.t | 1 + t/uni/universal.t | 1 + 22 files changed, 195 insertions(+), 79 deletions(-) diff --git a/cop.h b/cop.h index e05c89e..4c7b710 100644 --- a/cop.h +++ b/cop.h @@ -544,7 +544,6 @@ be zero. /* OutCopFILE() is CopFILE for output (caller, die, warn, etc.) */ #define OutCopFILE(c) CopFILE(c) -/* FIXME NATIVE_HINTS if this is changed from op_private (see perl.h) */ #define CopHINTS_get(c) ((c)->cop_hints + 0) #define CopHINTS_set(c, h) STMT_START { \ (c)->cop_hints = (h); \ diff --git a/dist/IO/t/IO.t b/dist/IO/t/IO.t index 382e282..2551b24 100644 --- a/dist/IO/t/IO.t +++ b/dist/IO/t/IO.t @@ -49,6 +49,7 @@ local $SIG{__WARN__} = sub { $warn = "@_" } ; { local $^W = 0; + no if $^V >= 5.17.4, warnings => "deprecated"; IO->import(); is( $warn, '', "... import default, should not warn"); $warn = '' ; diff --git a/gv.c b/gv.c index e29f2fd..e64c8f2 100644 --- a/gv.c +++ b/gv.c @@ -692,10 +692,12 @@ Perl_gv_fetchmeth_pvn(pTHX_ HV *stash, const char *name, STRLEN len, I32 level, } packlen = HvNAMELEN_get(stash); - if (packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) { + if ((packlen >= 7 && strEQ(hvname + packlen - 7, "::SUPER")) + || (packlen == 5 && strEQ(hvname, "SUPER"))) { HV* basestash; - packlen -= 7; - basestash = gv_stashpvn(hvname, packlen, + basestash = packlen == 5 + ? PL_defstash + : gv_stashpvn(hvname, packlen - 7, GV_ADD | (HvNAMEUTF8(stash) ? SVf_UTF8 : 0)); linear_av = mro_get_linear_isa(basestash); } @@ -919,7 +921,7 @@ S_gv_get_super_pkg(pTHX_ const char* name, I32 namelen, U32 flags) GvMULTI_on(gv); sv_magic(MUTABLE_SV(superisa), MUTABLE_SV(gv), PERL_MAGIC_isa, NULL, 0); av_push(superisa, newSVhek(CopSTASH(PL_curcop) - ? HvNAME_HEK(CopSTASH(PL_curcop)) : NULL)); + ? HvENAME_HEK(CopSTASH(PL_curcop)) : NULL)); return stash; } @@ -992,12 +994,12 @@ Perl_gv_fetchmethod_pvn_flags(pTHX_ HV *stash, const char *name, const STRLEN le /* ->SUPER::method should really be looked up in original stash */ SV * const tmpstr = sv_2mortal(Perl_newSVpvf(aTHX_ "%"HEKf"::SUPER", - HEKfARG(HvNAME_HEK((HV*)CopSTASH(PL_curcop))) + HEKfARG(HvENAME_HEK((HV*)CopSTASH(PL_curcop))) )); /* __PACKAGE__::SUPER stash should be autovivified */ stash = gv_get_super_pkg(SvPVX_const(tmpstr), SvCUR(tmpstr), SvUTF8(tmpstr)); DEBUG_o( Perl_deb(aTHX_ "Treating %s as %s::%s\n", - origname, HvNAME_get(stash), name) ); + origname, HvENAME_get(stash), name) ); } else { /* don't autovifify if ->NoSuchStash::method */ diff --git a/lib/warnings.pm b/lib/warnings.pm index 3b2d87d..0577ad3 100644 --- a/lib/warnings.pm +++ b/lib/warnings.pm @@ -5,7 +5,7 @@ package warnings; -our $VERSION = '1.13'; +our $VERSION = '1.14'; # Verify that we're called correctly so that warnings will work. # see also strict.pm. @@ -336,6 +336,7 @@ our %DeadBits = ( ); $NONE = "\0\0\0\0\0\0\0\0\0\0\0\0\0"; +$DEFAULT = "\x10\x01\x00\x00\x00\x50\x04\x00\x00\x00\x00\x00\x00", # [2,4,22,23,25] $LAST_BIT = 102 ; $BYTES = 13 ; @@ -387,7 +388,7 @@ sub import { shift; - my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ; + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; if (vec($mask, $Offsets{'all'}, 1)) { $mask |= $Bits{'all'} ; @@ -403,7 +404,7 @@ sub unimport shift; my $catmask ; - my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ; + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; if (vec($mask, $Offsets{'all'}, 1)) { $mask |= $Bits{'all'} ; @@ -482,8 +483,11 @@ sub __chk $i = _error_loc(); # see where Carp will allocate the error } - # Defaulting this to 0 reduces complexity in code paths below. - my $callers_bitmask = (caller($i))[9] || 0 ; + # Default to 0 if caller returns nothing. Default to $DEFAULT if it + # explicitly returns undef. + my(@callers_bitmask) = (caller($i))[9] ; + my $callers_bitmask = + @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ; my @results; foreach my $type (FATAL, NORMAL) { diff --git a/pad.c b/pad.c index fd75d42..711fd21 100644 --- a/pad.c +++ b/pad.c @@ -247,8 +247,8 @@ Perl_pad_new(pTHX_ int flags) if (flags & padnew_SAVE) { SAVECOMPPAD(); - SAVESPTR(PL_comppad_name); if (! (flags & padnew_CLONE)) { + SAVESPTR(PL_comppad_name); SAVEI32(PL_padix); SAVEI32(PL_comppad_name_fill); SAVEI32(PL_min_intro_pending); @@ -2004,6 +2004,7 @@ Perl_cv_clone(pTHX_ CV *proto) if (SvMAGIC(proto)) mg_copy((SV *)proto, (SV *)cv, 0, 0); + SAVESPTR(PL_comppad_name); PL_comppad_name = protopad_name; CvPADLIST(cv) = pad_new(padnew_CLONE|padnew_SAVE); CvPADLIST(cv)->xpadl_id = protopadlist->xpadl_id; diff --git a/perly.c b/perly.c index 5fb2d72..c83a932 100644 --- a/perly.c +++ b/perly.c @@ -522,8 +522,6 @@ Perl_yyparse (pTHX_ int gramtype) } YYDSYMPRINTF ("Error: discarding", yytoken, &parser->yylval); - if (yy_type_tab[yytoken] == toketype_opval) - op_free(parser->yylval.opval); parser->yychar = YYEMPTY; } diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 847afb2..0de3c1a 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -313,7 +313,7 @@ try to free it. =item Attempt to free unreferenced scalar: SV 0x%x -(W internal) Perl went to decrement the reference count of a scalar to +(S internal) Perl went to decrement the reference count of a scalar to see if it would go to 0, and discovered that it had already gone to 0 earlier, and should have been freed, and in fact, probably was freed. This could indicate that SvREFCNT_dec() was called too many times, or @@ -4259,7 +4259,7 @@ really a dirhandle. Check your control flow. =item Scalars leaked: %d -(W internal) Something went wrong in Perl's internal bookkeeping +(S internal) Something went wrong in Perl's internal bookkeeping of scalars: not all scalar variables were deallocated by the time Perl exited. What this usually indicates is a memory leak, which is of course bad, especially if the Perl program is intended to be @@ -4903,7 +4903,7 @@ many blocks were entered and left. =item Unbalanced string table refcount: (%d) for "%s" -(W internal) On exit, Perl found some strings remaining in the shared +(S internal) On exit, Perl found some strings remaining in the shared string table used for copy on write and for hash keys. The entries should have been freed, so this indicates a bug somewhere. @@ -5533,15 +5533,6 @@ C<$array[0+$ref]>. This warning is not given for overloaded objects, however, because you can overload the numification and stringification operators and then you presumably know what you are doing. -=item Use of reserved word "%s" is deprecated - -(D deprecated) The indicated bareword is a reserved word. Future -versions of perl may use it as a keyword, so you're better off either -explicitly quoting the word in a manner appropriate for its context of -use, or using a different name altogether. The warning can be -suppressed for subroutine names by either adding a C<&> prefix, or using -a package qualifier, e.g. C<&our()>, or C<Foo::our()>. - =item Use of tainted arguments in %s is deprecated (W taint, deprecated) You have supplied C<system()> or C<exec()> with multiple @@ -5695,7 +5686,7 @@ are automatically rebound to the current values of such variables. =item vector argument not supported with alpha versions -(W internal) The %vd (s)printf format does not support version objects +(S printf) The %vd (s)printf format does not support version objects with alpha parts. =item Verb pattern '%s' has a mandatory argument in regex; marked by <-- HERE in m/%s/ diff --git a/pod/perlhacktips.pod b/pod/perlhacktips.pod index 3032bb2..3880e17 100644 --- a/pod/perlhacktips.pod +++ b/pod/perlhacktips.pod @@ -1466,34 +1466,11 @@ write access to an op results in a C<SIGBUS> and abort. This code is intended for development only, and may not be portable even to all Unix variants. Also, it is an 80% solution, in that it -isn't able to make all ops read only. Specifically it +isn't able to make all ops read only. Specifically it does not apply to op +slabs belonging to C<BEGIN> blocks. -=over - -=item * 1 - -Does not apply to op slabs belonging to C<BEGIN> blocks. - -=item * 2 - -Turns an entire slab of ops read-write if the refcount of any op in the -slab needs to be increased or decreased. This means that anonymous -closures will never have read-only ops, and thread creation will make all -existing ops read-write. - -=item * 3 - -Turns an entire slab of ops read-write if any op from the slab is -freed. - -=back - -It's not possible to turn the slabs to read-only after an action -requiring read-write access, as either can happen during op tree -building time, so there may still be legitimate write access. - -However, as an 80% solution it is still effective, as currently it catches -the setting of breakpoints in the debugger and some XSUB definitions. +However, as an 80% solution it is still effective, as it has caught bugs in +the past. =head2 The .i Targets diff --git a/pp_ctl.c b/pp_ctl.c index ec03976..ce88220 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1896,17 +1896,15 @@ PP(pp_caller) Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*); AvFILLp(PL_dbargs) = AvFILLp(ary) + off; } - /* XXX only hints propagated via op_private are currently - * visible (others are not easily accessible, since they - * use the global PL_hints) */ mPUSHi(CopHINTS_get(cx->blk_oldcop)); { SV * mask ; STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ; - if (old_warnings == pWARN_NONE || - (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0)) + if (old_warnings == pWARN_NONE) mask = newSVpvn(WARN_NONEstring, WARNsize) ; + else if (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0) + mask = &PL_sv_undef ; else if (old_warnings == pWARN_ALL || (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) { /* Get the bit mask for $warnings::Bits{all}, because diff --git a/regen/warnings.pl b/regen/warnings.pl index d990a6c..5ed8b12 100644 --- a/regen/warnings.pl +++ b/regen/warnings.pl @@ -53,11 +53,11 @@ my $tree = { }], 'severe' => [ 5.008, { 'inplace' => [ 5.008, DEFAULT_ON], - 'internal' => [ 5.008, DEFAULT_ON], + 'internal' => [ 5.008, DEFAULT_OFF], 'debugging' => [ 5.008, DEFAULT_ON], 'malloc' => [ 5.008, DEFAULT_ON], }], - 'deprecated' => [ 5.008, DEFAULT_OFF], + 'deprecated' => [ 5.008, DEFAULT_ON], 'void' => [ 5.008, DEFAULT_OFF], 'recursion' => [ 5.008, DEFAULT_OFF], 'redefine' => [ 5.008, DEFAULT_OFF], @@ -66,7 +66,7 @@ my $tree = { 'once' => [ 5.008, DEFAULT_OFF], 'misc' => [ 5.008, DEFAULT_OFF], 'regexp' => [ 5.008, DEFAULT_OFF], - 'glob' => [ 5.008, DEFAULT_OFF], + 'glob' => [ 5.008, DEFAULT_ON], 'untie' => [ 5.008, DEFAULT_OFF], 'substr' => [ 5.008, DEFAULT_OFF], 'taint' => [ 5.008, DEFAULT_OFF], @@ -89,6 +89,7 @@ my $tree = { }], } ; +my @def ; my %list ; my %Value ; my %ValueToName ; @@ -151,6 +152,8 @@ sub walk my ($ver, $rest) = @{ $v } ; if (ref $rest) { push (@{ $list{$k} }, walk ($rest)) } + elsif ($rest == DEFAULT_ON) + { push @def, $NameToValue{uc $k} } push @list, @{ $list{$k} } ; } @@ -416,6 +419,8 @@ foreach $k (sort keys %list) { print $pm " );\n\n" ; print $pm '$NONE = "', ('\0' x $warn_size) , "\";\n" ; +print $pm '$DEFAULT = "', mkHex($warn_size, map $_ * 2, @def), + '", # [', mkRange(@def), "]\n" ; print $pm '$LAST_BIT = ' . "$index ;\n" ; print $pm '$BYTES = ' . "$warn_size ;\n" ; while (<DATA>) { @@ -427,7 +432,7 @@ read_only_bottom_close_and_rename($pm); __END__ package warnings; -our $VERSION = '1.13'; +our $VERSION = '1.14'; # Verify that we're called correctly so that warnings will work. # see also strict.pm. @@ -636,7 +641,7 @@ sub import { shift; - my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ; + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; if (vec($mask, $Offsets{'all'}, 1)) { $mask |= $Bits{'all'} ; @@ -652,7 +657,7 @@ sub unimport shift; my $catmask ; - my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $NONE) ; + my $mask = ${^WARNING_BITS} // ($^W ? $Bits{all} : $DEFAULT) ; if (vec($mask, $Offsets{'all'}, 1)) { $mask |= $Bits{'all'} ; @@ -731,8 +736,11 @@ sub __chk $i = _error_loc(); # see where Carp will allocate the error } - # Defaulting this to 0 reduces complexity in code paths below. - my $callers_bitmask = (caller($i))[9] || 0 ; + # Default to 0 if caller returns nothing. Default to $DEFAULT if it + # explicitly returns undef. + my(@callers_bitmask) = (caller($i))[9] ; + my $callers_bitmask = + @callers_bitmask ? $callers_bitmask[0] // $DEFAULT : 0 ; my @results; foreach my $type (FATAL, NORMAL) { diff --git a/sv.c b/sv.c index b47dc75..5996ec1 100644 --- a/sv.c +++ b/sv.c @@ -10375,20 +10375,19 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * vectorize happen normally */ if (sv_isobject(vecsv) && sv_derived_from(vecsv, "version")) { - char *version = savesvpv(vecsv); if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) { - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), + Perl_ck_warner_d(aTHX_ packWARN(WARN_PRINTF), "vector argument not supported with alpha versions"); - goto unknown; + goto vdblank; } vecsv = sv_newmortal(); - scan_vstring(version, version + veclen, vecsv); + scan_vstring(vecstr, vecstr + veclen, vecsv); vecstr = (U8*)SvPV_const(vecsv, veclen); vec_utf8 = DO_UTF8(vecsv); - Safefree(version); } } else { + vdblank: vecstr = (U8*)""; veclen = 0; } diff --git a/t/comp/parser.t b/t/comp/parser.t index 27f81dc..a5ba93c 100644 --- a/t/comp/parser.t +++ b/t/comp/parser.t @@ -3,7 +3,7 @@ # Checks if the parser behaves correctly in edge cases # (including weird syntax errors) -print "1..152\n"; +print "1..153\n"; sub failed { my ($got, $expected, $name) = @_; @@ -443,6 +443,10 @@ is prototype "Hello::_he_said", '_', 'initial tick in sub declaration'; 'literal -> [0] after an array subscript within ""'); } +eval 'no if $] >= 5.17.4 warnings => "deprecated"'; +is 1,1, ' no crash for "no ... syntax error"'; + + # Add new tests HERE (above this line) # bug #74022: Loop on characters in \p{OtherIDContinue} diff --git a/t/lib/warnings/2use b/t/lib/warnings/2use index e5a8103..c0d203a 100644 --- a/t/lib/warnings/2use +++ b/t/lib/warnings/2use @@ -358,3 +358,22 @@ $a =+ 1 ; EXPECT Reversed += operator at - line 6. Use of uninitialized value $c in scalar chop at - line 9. +######## + +# Check that deprecation warnings are not implicitly disabled by use +$*; +use warnings "void"; +$#; +EXPECT +$* is no longer supported at - line 3. +$# is no longer supported at - line 5. +Useless use of a variable in void context at - line 5. +######## + +# Check that deprecation warnings are not implicitly disabled by no +$*; +no warnings "void"; +$#; +EXPECT +$* is no longer supported at - line 3. +$# is no longer supported at - line 5. diff --git a/t/lib/warnings/regcomp b/t/lib/warnings/regcomp index a329639..15a658f 100644 --- a/t/lib/warnings/regcomp +++ b/t/lib/warnings/regcomp @@ -54,7 +54,7 @@ Unrecognized escape \m passed through in regex; marked by <-- HERE in m/a\m <-- ######## # regcomp.c [S_regatom] # The \q should warn, the \_ should NOT warn. -use warnings 'regexp'; +use warnings 'regexp'; no warnings "deprecated"; "foo" =~ /\q/; "foo" =~ /\q{/; "foo" =~ /\w{/; diff --git a/t/lib/warnings/sv b/t/lib/warnings/sv index d6cacd8..41a4fab 100644 --- a/t/lib/warnings/sv +++ b/t/lib/warnings/sv @@ -34,6 +34,8 @@ Reference is already weak [Perl_sv_rvweaken] <<TODO + vector argument not supported with alpha versions + Mandatory Warnings ------------------ Malformed UTF-8 character [sv_pos_b2u] (not tested: difficult to produce @@ -385,3 +387,13 @@ sub ì§ {} *ì§ = \&조Ȩ ; EXPECT Subroutine main::ï½ë redefined at - line 7. +######## +# sv.c +sprintf "%vd", new version v1.1_0; +use warnings 'printf' ; +sprintf "%vd", new version v1.1_0; +no warnings 'printf' ; +sprintf "%vd", new version v1.1_0; +EXPECT +vector argument not supported with alpha versions at - line 2. +vector argument not supported with alpha versions at - line 4. diff --git a/t/lib/warnings/toke b/t/lib/warnings/toke index e436cec..8a8fb05 100644 --- a/t/lib/warnings/toke +++ b/t/lib/warnings/toke @@ -1085,7 +1085,7 @@ Number found where operator expected at (eval 1) line 1, near "5 6" (Missing operator before 6?) ######## # toke.c -use warnings "syntax"; +use warnings "syntax"; no warnings "deprecated"; $_ = $a = 1; $a !=~ /1/; $a !=~ m#1#; diff --git a/t/op/caller.t b/t/op/caller.t index b7c5f9b..0735eaa 100644 --- a/t/op/caller.t +++ b/t/op/caller.t @@ -5,7 +5,7 @@ BEGIN { chdir 't' if -d 't'; @INC = '../lib'; require './test.pl'; - plan( tests => 90 ); + plan( tests => 91 ); } my @c; @@ -280,6 +280,23 @@ is eval "s//<<END/e;\nfoo\nEND\n(caller 0)[6]", "s//<<END/e;\nfoo\nEND\n(caller 0)[6]", 'here-docs in quote-like ops do not gut eval text'; +# The bitmask should be assignable to ${^WARNING_BITS} without resulting in +# different warnings settings. +{ + my $ bits = sub { (caller 0)[9] }->(); + my $w; + local $SIG{__WARN__} = sub { $w++ }; + eval ' + use warnings; + BEGIN { ${^WARNING_BITS} = $bits } + local $^W = 1; + () = 1 + undef; + $^W = 0; + () = 1 + undef; + '; + is $w, 1, 'value from (caller 0)[9] (bitmask) works in ${^WARNING_BITS}'; +} + $::testing_caller = 1; do './op/caller.pl' or die $@; diff --git a/t/op/closure.t b/t/op/closure.t index 756ad04..089ceb5 100644 --- a/t/op/closure.t +++ b/t/op/closure.t @@ -789,4 +789,30 @@ sub staleval { staleval 1; staleval; +# [perl #114888] +# Test that closure creation localises PL_comppad_name properly. Usually +# at compile time a BEGIN block will localise PL_comppad_name for use, so +# pp_anoncode can mess with it without any visible effects. +# But inside a source filter, it affects the directly enclosing compila- +# tion scope. +SKIP: { + skip_if_miniperl("no XS on miniperl (for source filters)"); + fresh_perl_is <<' [perl #114888]', "ok\n", {stderr=>1}, + use strict; + BEGIN { + package Foo; + use Filter::Util::Call; + sub import { filter_add( sub { + my $status = filter_read(); + sub { $status }; + $status; + })} + Foo->import + } + my $x = "ok\n"; # stores $x in the wrong padnamelist + print $x; # cannot find it - strict violation + [perl #114888] + 'closures in source filters do not interfere with pad names'; +} + done_testing(); diff --git a/t/op/method.t b/t/op/method.t index 09f6ee3..584ffd9 100644 --- a/t/op/method.t +++ b/t/op/method.t @@ -13,7 +13,7 @@ BEGIN { use strict; no warnings 'once'; -plan(tests => 98); +plan(tests => 110); @A::ISA = 'B'; @B::ISA = 'C'; @@ -223,7 +223,50 @@ like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/); eval '$e = bless {}, "UNIVERSAL"; $e->E::F::foo()'; like ($@, qr/^\QCan't locate object method "foo" via package "E::F" at/); -# TODO: we need some tests for the SUPER:: pseudoclass +# SUPER:: pseudoclass +@Saab::ISA = "Souper"; +sub Souper::method { @_ } +@OtherSaab::ISA = "OtherSouper"; +sub OtherSouper::method { "Isidore Ropen, Draft Manager" } +{ + my $o = bless [], "Saab"; + package Saab; + my @ret = $o->SUPER::method('whatever'); + ::is $ret[0], $o, 'object passed to SUPER::method'; + ::is $ret[1], 'whatever', 'argument passed to SUPER::method'; + @ret = $o->SUPER'method('whatever'); + ::is $ret[0], $o, "object passed to SUPER'method"; + ::is $ret[1], 'whatever', "argument passed to SUPER'method"; + @ret = Saab->SUPER::method; + ::is $ret[0], 'Saab', "package name passed to SUPER::method"; + @ret = OtherSaab->SUPER::method; + ::is $ret[0], 'OtherSaab', + "->SUPER::method uses current package, not invocant"; +} +() = *SUPER::; +{ + local our @ISA = "Souper"; + is eval { (main->SUPER::method)[0] }, 'main', + 'Mentioning *SUPER:: does not stop ->SUPER from working in main'; +} +{ + BEGIN { + *Mover:: = *Mover2::; + *Mover2:: = *foo; + } + package Mover; + no strict; + # Not our(@ISA), because the bug we are testing for interacts with an + # our() bug that cancels this bug out. + @ISA = 'door'; + sub door::dohtem { 'dohtem' } + ::is eval { Mover->SUPER::dohtem; }, 'dohtem', + 'SUPER inside moved package'; + undef *door::dohtem; + *door::dohtem = sub { 'method' }; + ::is eval { Mover->SUPER::dohtem; }, 'method', + 'SUPER inside moved package respects method changes'; +} # failed method call or UNIVERSAL::can() should not autovivify packages is( $::{"Foo::"} || "none", "none"); # sanity check 1 @@ -417,3 +460,15 @@ eval { () = undef; new {} }; like $@, qr/^Can't call method "new" without a package or object reference/, 'Err msg from new{} when stack contains undef'; + +package egakacp { + our @ISA = 'ASI'; + sub ASI::m { shift; "@_" }; + my @a = (bless([]), 'arg'); + my $r = SUPER::m{@a}; + ::is $r, 'arg', 'method{@array}'; + $r = SUPER::m{}@a; + ::is $r, 'arg', 'method{}@array'; + $r = SUPER::m{@a}"b"; + ::is $r, 'arg b', 'method{@array}$more_args'; +} diff --git a/t/op/sprintf.t b/t/op/sprintf.t index 34086c8..a04abf5 100644 --- a/t/op/sprintf.t +++ b/t/op/sprintf.t @@ -62,6 +62,8 @@ $SIG{__WARN__} = sub { $w .= ' UNINIT'; } elsif ($_[0] =~ /^Missing argument/) { $w .= ' MISSING'; + } elsif ($_[0]=~/^vector argument not supported with alpha versions/) { + $w .= ' ALPHA'; } else { warn @_; } @@ -317,6 +319,7 @@ __END__ >%vd< >[version->new("1.002")]< >1.2< >%vd< >[version->new("1048576.5")]< >1048576.5< >%vd< >[version->new("50")]< >50< +>[%vd]< >[version->new(v1.1_1)]< >[] ALPHA< >%v.3d< >"\01\02\03"< >001.002.003< >%0v3d< >"\01\02\03"< >001.002.003< >%v.3d< >[version::qv("1.2.3")]< >001.002.003< diff --git a/t/op/universal.t b/t/op/universal.t index bbee79e..9db10c8 100644 --- a/t/op/universal.t +++ b/t/op/universal.t @@ -175,6 +175,7 @@ ok ! UNIVERSAL::isa("\xff\xff\xff\0", 'HASH'); { package Pickup; + no warnings "deprecated"; use UNIVERSAL qw( isa can VERSION ); ::ok isa "Pickup", UNIVERSAL; diff --git a/t/uni/universal.t b/t/uni/universal.t index 8f158e9..626c30f 100644 --- a/t/uni/universal.t +++ b/t/uni/universal.t @@ -119,6 +119,7 @@ ok $a->can("slèèp"); { package Pìckùp; + no warnings "deprecated"; use UNIVERSAL qw( isa can VERSION ); ::ok isa "Pìckùp", UNIVERSAL; -- Perl5 Master Repository
