diff options
63 files changed, 2414 insertions, 765 deletions
@@ -79,6 +79,266 @@ Version 5.005_58 Development release working toward 5.006 ---------------- ____________________________________________________________________________ +[ 3639] By: gsar on 1999/07/07 08:09:30 + Log: From: Brian Jepson <bjepson@home.com> + Date: Sat, 26 Jun 1999 10:47:45 -0500 (EST) + Message-ID: <Pine.LNX.4.10.9906261044180.659-100000@cx384756-a.sking1.ri.home.com> + Subject: Patch to JPL example program + Branch: perl + ! jpl/JPL_Rolo/JPL_Rolo.jpl +____________________________________________________________________________ +[ 3638] By: jhi on 1999/07/07 08:07:58 + Log: Integrate with Sarathy. + Branch: cfgperl + !> (integrate 34 files) +____________________________________________________________________________ +[ 3637] By: gsar on 1999/07/07 08:07:49 + Log: From: Stephen McCamant <smccam@uclink4.berkeley.edu> + Date: Fri, 25 Jun 1999 13:38:44 -0500 (CDT) + Message-ID: <14193.25034.113373.245377@alias-2.pr.mcs.net> + Subject: [PATCH _57, long] Eliminate CONDOPs + Branch: perl + ! bytecode.pl dump.c ext/B/B.pm ext/B/B.xs ext/B/B/Bblock.pm + ! ext/B/B/Bytecode.pm ext/B/B/C.pm ext/B/B/CC.pm + ! ext/B/B/Debug.pm ext/B/B/Xref.pm ext/B/ramblings/flip-flop + ! ext/B/typemap op.c op.h opcode.h opcode.pl perl.h + ! pod/perltoc.pod pp_ctl.c pp_hot.c +____________________________________________________________________________ +[ 3636] By: gsar on 1999/07/07 07:50:51 + Log: adapted suggested patch for IO-1.20x + From: ian@dial.pipex.com + Date: Fri, 25 Jun 1999 10:39:42 +0100 + Message-Id: <199906250939.KAA02152@homer.diplex.co.uk> + Subject: [ID 19990625.001] Minor fixes for IO::Socket.pm + Branch: perl + ! ext/IO/lib/IO/Socket.pm +____________________________________________________________________________ +[ 3635] By: gsar on 1999/07/07 07:26:05 + Log: PowerMAX hints update from Tom Horsley <Tom.Horsley@mail.ccur.com> + Branch: perl + ! hints/powerux.sh +____________________________________________________________________________ +[ 3634] By: gsar on 1999/07/07 07:20:02 + Log: From: Hugo van der Sanden <hv@crypt.compulink.co.uk> + Date: Wed, 23 Jun 1999 16:16:05 +0100 + Message-Id: <199906231516.QAA23851@crypt.compulink.co.uk> + Subject: [PATCH 5.005_57] memleak in optimizer + Branch: perl + ! embed.h embed.pl objXSUB.h op.c proto.h +____________________________________________________________________________ +[ 3633] By: gsar on 1999/07/07 07:10:52 + Log: add do-not-edit caveats for files generated by opcode.pl + (suggested by Hugo van der Sanden) + Branch: perl + ! opcode.h opcode.pl pp.sym pp_proto.h +____________________________________________________________________________ +[ 3632] By: gsar on 1999/07/07 06:41:13 + Log: better diagnostics on read operations from write-only + filehandles + Branch: perl + ! doio.c perl.c pod/perldelta.pod pod/perldiag.pod pp_hot.c + ! pp_sys.c t/pragma/warn/pp_hot t/pragma/warn/pp_sys +____________________________________________________________________________ +[ 3631] By: gsar on 1999/07/07 02:03:34 + Log: make Sys::Hostname safe against C<$SIG{CHLD}='IGNORE'> (suggested + by David Muir Sharnoff <muir@idiom.com>) + Branch: perl + ! lib/Sys/Hostname.pm +____________________________________________________________________________ +[ 3630] By: gsar on 1999/07/07 01:57:16 + Log: From: "Vishal Bhatia" <vishalb@my-deja.com> + Date: Sun, 20 Jun 1999 17:17:17 -0700 + Message-ID: <AEBDBGKPMEAJAAAA@my-deja.com> + Subject: [PATCH 5.005_57] Minor bug fix in pp_require + Branch: perl + ! ext/B/B/CC.pm +____________________________________________________________________________ +[ 3629] By: gsar on 1999/07/07 01:46:03 + Log: installperl should write normal messages to STDOUT, not STDERR + Branch: perl + ! installperl +____________________________________________________________________________ +[ 3628] By: gsar on 1999/07/07 01:41:25 + Log: BSD/OS needs -DSTRUCT_TM_HASZONE as of 4.0.1 (from mab@alink.net) + Branch: perl + ! hints/bsdos.sh +____________________________________________________________________________ +[ 3627] By: gsar on 1999/07/07 00:27:10 + Log: make diagnostic on C<my $^I> etc., more readable + Branch: perl + ! op.c +____________________________________________________________________________ +[ 3626] By: gsar on 1999/07/06 23:47:27 + Log: From: Andy Dougherty <doughera@lafayette.edu> + Date: Thu, 17 Jun 1999 12:07:11 -0400 (EDT) + Message-Id: <Pine.GSU.4.05.9906171204580.937-100000@newton.phys> + Subject: [ID 19990617.004 [PATCH 5.005_57] make distclean fixes] + Branch: perl + ! Makefile.SH utils/Makefile +____________________________________________________________________________ +[ 3625] By: jhi on 1999/07/06 21:50:46 + Log: Some new files of #3624 missing from MANIFEST. + Branch: cfgperl + ! MANIFEST +____________________________________________________________________________ +[ 3624] By: jhi on 1999/07/06 21:47:04 + Log: POSIX [[:character class:]] support for standard, locale, + and utf8. If both utf8 and locale are on, utf8 wins. + I don't fully understand why so many tables changed in + lib/unicode because of "make" -- maybe it was just overdue. + Branch: cfgperl + + lib/unicode/Is/ASCII.pl lib/unicode/Is/Cntrl.pl + + lib/unicode/Is/Graph.pl lib/unicode/Is/Punct.pl + + lib/unicode/Is/Word.pl lib/unicode/Is/XDigit.pl + ! MANIFEST Todo-5.005 embed.h embed.pl embedvar.h global.sym + ! handy.h intrpvar.h lib/unicode/Bidirectional.pl + ! lib/unicode/Block.pl lib/unicode/Category.pl + ! lib/unicode/Is/Alnum.pl lib/unicode/Is/Alpha.pl + ! lib/unicode/Is/BidiL.pl lib/unicode/Is/Digit.pl + ! lib/unicode/Is/L.pl lib/unicode/Is/Lo.pl + ! lib/unicode/Is/Lower.pl lib/unicode/Is/Print.pl + ! lib/unicode/Is/Space.pl lib/unicode/Is/Upper.pl + ! lib/unicode/Is/Z.pl lib/unicode/Is/Zs.pl lib/unicode/Name.pl + ! lib/unicode/To/Digit.pl lib/unicode/mktables.PL objXSUB.h + ! pod/perldelta.pod pod/perldiag.pod pod/perlre.pod proto.h + ! regcomp.c regcomp.h regcomp.sym regexec.c regnodes.h + ! t/op/pat.t t/op/re_tests t/op/regexp.t t/pragma/utf8.t + ! t/pragma/warn/regcomp utf8.c +____________________________________________________________________________ +[ 3623] By: gsar on 1999/07/06 20:52:48 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Wed, 16 Jun 1999 14:57:22 -0400 + Message-ID: <19990616145722.B16258@monk.mps.ohio-state.edu> + Subject: [PATCH 5.00557] Devel::Peek + Branch: perl + ! ext/Devel/Peek/Peek.pm ext/Devel/Peek/Peek.xs +____________________________________________________________________________ +[ 3622] By: gsar on 1999/07/06 20:22:59 + Log: applied patch after demunging headers with appropriate paths + From: "Vishal Bhatia" <vishalb@my-deja.com> + Date: Sat, 12 Jun 1999 08:23:59 -0700 + Message-ID: <JIHEJPFDFKIBDAAA@my-deja.com> + Subject: [Patch 5.005_57] unsigned arithmetic (Compiler) + Branch: perl + ! cc_runtime.h ext/B/B.xs ext/B/B/CC.pm ext/B/B/Stackobj.pm + ! ext/B/defsubs.h.PL lib/ExtUtils/typemap t/harness +____________________________________________________________________________ +[ 3621] By: gsar on 1999/07/06 20:10:50 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Thu, 10 Jun 1999 04:05:22 -0400 (EDT) + Message-Id: <199906100805.EAA18216@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_57] Optimize 2>&1 in commands + Branch: perl + ! doio.c +____________________________________________________________________________ +[ 3620] By: jhi on 1999/07/06 19:16:47 + Log: Mention EPOC and SOCKS. + Branch: cfgperl + ! pod/perldelta.pod +____________________________________________________________________________ +[ 3619] By: gsar on 1999/07/06 16:52:37 + Log: fix int vs STRLEN issue + Branch: perl + ! pp.c +____________________________________________________________________________ +[ 3618] By: jhi on 1999/07/06 16:52:20 + Log: There ain't Perl_atonv(). + Branch: cfgperl + ! ext/ByteLoader/bytecode.h +____________________________________________________________________________ +[ 3617] By: jhi on 1999/07/06 15:55:22 + Log: Integrate with Sarathy. + Branch: cfgperl + !> Makefile.SH +____________________________________________________________________________ +[ 3616] By: jhi on 1999/07/06 15:54:09 + Log: Tweak for #3613. + Branch: cfgperl + ! Configure config_h.SH +____________________________________________________________________________ +[ 3615] By: gsar on 1999/07/06 11:00:21 + Log: From: "Todd C. Miller" <Todd.Miller@courtesan.com> + Date: Sun, 13 Jun 1999 17:46:13 -0600 (MDT) + Message-Id: <199906132346.RAA26632@xerxes.courtesan.com> + Subject: [ID 19990613.003 linklibperl set incorrectly in Makefile.SH for OpenBSD] + Branch: perl + ! Makefile.SH +____________________________________________________________________________ +[ 3614] By: jhi on 1999/07/06 10:44:48 + Log: Integrate with Sarathy. + Branch: cfgperl + !> ext/IO/lib/IO/File.pm op.c op.h opcode.h opcode.pl perl.h pp.h + !> pp.sym pp_proto.h t/base/rs.t t/pragma/warn/op +____________________________________________________________________________ +[ 3613] By: jhi on 1999/07/06 10:43:20 + Log: From: Nathan Kurz <nate@valleytel.net> + Subject: [ID 19990612.001 compiling three deep modules within ext/] + ply-To: nate@valleytel.net + erl5-porters@perl.org + Date: Sat, 12 Jun 1999 01:26:04 -0500 + Message-Id: <199906120626.BAA04996@trinkpad.valleytel.net> + Branch: cfgperl + ! Configure config_h.SH +____________________________________________________________________________ +[ 3612] By: gsar on 1999/07/06 10:17:52 + Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Sat, 12 Jun 1999 04:49:09 -0400 (EDT) + Message-Id: <199906120849.EAA26986@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_57] Optimize away OP_SASSIGN + Branch: perl + ! op.c op.h opcode.h opcode.pl pp.h pp.sym pp_proto.h +____________________________________________________________________________ +[ 3611] By: gsar on 1999/07/06 09:51:20 + Log: From: pvhp@forte.com (Peter Prymmer) + Date: Fri, 11 Jun 99 17:07:19 PDT + Message-Id: <9906120007.AA13802@forte.com> + Subject: [PATCH _03 && _57]portability fix for IO::File and FileHandle + Branch: perl + ! ext/IO/lib/IO/File.pm +____________________________________________________________________________ +[ 3610] By: gsar on 1999/07/06 09:37:37 + Log: fix for C<$/ = 42> setting paragraph mode (applied with small + tweak) + From: "M.J.T. Guy" <mjtg@cus.cam.ac.uk> + Date: Wed, 09 Jun 1999 18:27:51 +0100 + Message-Id: <E10rm8l-00023T-00@ursa.cus.cam.ac.uk> + Subject: Re: [ID 19990608.002] Possible bug with binmode and <FH> on Perl 5.005_03 Win32 + Branch: perl + ! perl.h t/base/rs.t +____________________________________________________________________________ +[ 3609] By: jhi on 1999/07/06 09:28:48 + Log: Integrate with Sarathy. + Branch: cfgperl + !> (integrate 49 files) +____________________________________________________________________________ +[ 3608] By: gsar on 1999/07/06 09:28:21 + Log: test tweak + Branch: perl + ! t/pragma/warn/op +____________________________________________________________________________ +[ 3607] By: jhi on 1999/07/06 09:22:48 + Log: Put back the cygwin32 Configure fix of 3582 undone by 3597. + Branch: cfgperl + ! Configure config_h.SH +____________________________________________________________________________ +[ 3606] By: gsar on 1999/07/06 09:05:02 + Log: applied slightly tweaked version of suggested patch for + improved RE API + From: Ilya Zakharevich <ilya@math.ohio-state.edu> + Date: Wed, 9 Jun 1999 18:14:27 -0400 (EDT) + Message-Id: <199906092214.SAA14126@monk.mps.ohio-state.edu> + Subject: [PATCH 5.005_57] REx engine rehash + Branch: perl + ! Changes dump.c embed.h embed.pl embedvar.h ext/re/Makefile.PL + ! ext/re/re.xs global.sym objXSUB.h perl.c perl.h pp.c pp_hot.c + ! proto.h regcomp.c regcomp.h regexec.c regexp.h thrdvar.h + ! util.c +____________________________________________________________________________ +[ 3605] By: gsar on 1999/07/06 08:54:03 + Log: bug in change#3602 (cpp conditionals not allowed inside macro args) + Branch: perl + ! sv.c +____________________________________________________________________________ [ 3604] By: gsar on 1999/07/06 07:08:30 Log: From: paul.marquess@bt.com Date: Tue, 8 Jun 1999 22:37:58 +0100 @@ -40,7 +40,6 @@ README.dos Notes about dos/djgpp port README.epoc Notes about EPOC port README.hpux Notes about HP-UX port README.hurd Notes about GNU/Hurd port -README.lexwarn Notes about lexical warnings README.mint Notes about Atari MiNT port README.mpeix Notes about MPE/iX port README.os2 Notes about OS/2 port @@ -986,6 +985,7 @@ pod/perlfunc.pod Function info pod/perlguts.pod Internals info pod/perlhist.pod Perl history info pod/perlipc.pod IPC info +pod/perllexwarn.pod Lexical Warnings info pod/perllocale.pod Locale support info pod/perllol.pod How to use lists of lists pod/perlmod.pod Module mechanism info @@ -1300,11 +1300,17 @@ t/pragma/warn/2use Tests for "use warning" for warning.t t/pragma/warn/3both Tests for interaction of $^W and "use warning" t/pragma/warn/4lint Tests for -W switch t/pragma/warn/5nolint Tests for -X switch +t/pragma/warn/6default Tests default warnings +t/pragma/warn/av Tests for av.c for warning.t t/pragma/warn/doio Tests for doio.c for warning.t +t/pragma/warn/doop Tests for doop.c for warning.t t/pragma/warn/gv Tests for gv.c for warning.t +t/pragma/warn/hv Tests for hv.c for warning.t +t/pragma/warn/malloc Tests for malloc.c for warning.t t/pragma/warn/mg Tests for mg.c for warning.t t/pragma/warn/op Tests for op.c for warning.t t/pragma/warn/perl Tests for perl.c for warning.t +t/pragma/warn/perlio Tests for perlio.c for warning.t t/pragma/warn/perly Tests for perly.y for warning.t t/pragma/warn/pp Tests for pp.c for warning.t t/pragma/warn/pp_ctl Tests for pp_ctl.c for warning.t @@ -1312,11 +1318,13 @@ t/pragma/warn/pp_hot Tests for pp_hot.c for warning.t t/pragma/warn/pp_sys Tests for pp_sys.c for warning.t t/pragma/warn/regcomp Tests for regcomp.c for warning.t t/pragma/warn/regexec Tests for regexec.c for warning.t +t/pragma/warn/run Tests for run.c for warning.t t/pragma/warn/sv Tests for sv.c for warning.t t/pragma/warn/taint Tests for taint.c for warning.t t/pragma/warn/toke Tests for toke.c for warning.t t/pragma/warn/universal Tests for universal.c for warning.t t/pragma/warn/util Tests for util.c for warning.t +t/pragma/warn/utf8 Tests for utf8.c for warning.t t/pragma/warning.t See if warning controls work taint.c Tainting code thrdvar.h Per-thread variables diff --git a/README.lexwarn b/README.lexwarn deleted file mode 100644 index 27e5ec810c..0000000000 --- a/README.lexwarn +++ /dev/null @@ -1,244 +0,0 @@ -Date: 29th July 1998 - -This patch adds lexical warnings to Perl. It should apply over -5.005_50 - -NOTE: This is a prototype. Do not assume that lexical warnings will - necessarily be anything like this implementation. - -Changes -======= - - Date: 8th April 1998 - - * patch now applies cleanly over 5.004_64 - - * added the -X switch (the inverse "lint" command) - - Date: 26th Feb 1997 - - * By popular demand, the warnings bitmask can now be of arbitrary - length. The code uses an SV* to store the bitmask. - - * Rationalised the warning categories a bit. This area still needs - a lot of work. - - * Added -W switch (the "lint" command). - - * Added an experimental feature to allow warnings to be excalated - to fatal errors. - - -The "use warning" pragma -======================== - - The "use warning" pragma is intended to replace both the use of the - command line flag "-w" and its equivalent variable $^W with a pragma - that works like the existing "strict" pragma. - - This means that the scope of the pragma is limited to the enclosing - block. It also means that that a pragma setting will not leak across - files (via use/require/do). This will allow authors to define the - degree of warning checks that will be applied to their module. - - By default warnings are disabled. - - All warnings are enabled in a block by either of these: - - use warning ; - use warning 'all' ; - - Similarly all warnings are disabled in a block by either of these: - - no warning ; - no warning 'all' ; - - A hierarchy of "categories" have been defined to allow groups of - warnings to be enabled/disabled in isolation. The current - hierarchy is: - - all - +--- unsafe -------+--- taint - | | - | +--- substr - | | - | +--- signal - | | - | +--- closure - | | - | +--- untie - | - +--- io ---------+--- pipe - | | - | +--- unopened - | | - | +--- closed - | | - | +--- newline - | | - | +--- exec - | - +--- syntax ----+--- ambiguous - | | - | +--- semicolon - | | - | +--- precedence - | | - | +--- reserved - | | - | +--- octal - | | - | +--- parenthesis - | | - | +--- deprecated - | - |--- uninitialized - | - +--- void - | - +--- recursion - | - +--- redefine - | - +--- numeric - | - +--- once - | - +--- misc - - This hierarchy is very tentative. Feedback is needed. - - Just like the "strict" pragma any of these categories can be - combined - - use warning qw(void redefine) ; - no warning qw(io syntax untie) ; - -The "lint" flag, -W -=================== - -If the -W flag is used on the command line, it will enable all warnings -throughout the program regardless of whether warnings were disabled -locally using "no warning" or $^W =0. This includes any file that gets -included during compilation via use/require. - -The inverse "lint" flag, -X -=========================== -Does exactly the same as the -W flag, except it disables all warnings. - - -Backward Compatability -====================== - - How Lexical Warnings interact with -w/$^W - - 1. The -w flag just sets the global $^W variable as in 5.004 - This means that any legacy code that currently relies on - manipulating $^W to control warning behaviour will still work. - - 2. Apart from now being a boolean, the $^W variable operates in - exactly the same horrible uncontrolled global way as in 5.004, - except... - - 3. If a piece of code is under the control of a lexical warning - pragma, the $^W variable will be ignored. - - The combined effect of 2 & 3 is that it will will allow new code - which will use the lexical warning pragma to control old - $^W-type code (using a local $^W=0) if it really wants to, but - not vice-versa. - - 4. The only way to override a lexical warnings setting is with the - new -W or -X command line flags. - - -Fatal Warnings -============== - -This feature is very experimental. - -The presence of the word "FATAL" in the category list will escalate any -warnings from the category specified that are detected in the lexical -scope into fatal errors. In the code below, there are 3 places where a -deprecated warning will be detected, the middle one will produce a -fatal error. - - - use warning ; - - $a = 1 if $a EQ $b ; - - { - use warning qw(FATAL deprecated) ; - $a = 1 if $a EQ $b ; - } - - $a = 1 if $a EQ $b ; - - -TODO -==== - -test harness for -X (assuming it is a permanent fixture). -win32, os2 & vms all have warnings. These need to be included. - -Unresolved Issues -================= - - The pragma name? - A few possibilities: - warning - warnings - warn - - Hierarchy of Warnings - The current patch has a fairly arbitrary hierarchy. - Ideas for a useful hierarchy would be most welcome. - - A command line option to turn off all warnings? - -X or -q, perhaps. - - Current mandatory warnings. - May be useful to bring them under the control of this pragma. - - Severity - Do we want/need a severity classification? - pedantic - high/strict/precise - medium/default - low/common - - Versions - This is a thorhy issue. Say someone writes a script using Perl - 5.004 and places this at the top: - - use warning ; - - Time passes and 5.005 comes out. It has added a few extra warnings. - The script prints warning messages. - - A possibility is to allow the warnings that are checked to be - limited to those available in a given version of Perl. A possible - syntax could be: - - use warning 5.004 ; - - or - - use warning 5.004 qw(void uninitialized) ; - - Do we really need this amount of control? - - Documentation - There isn't any yet. - - - perl5db.pl - The debugger saves and restores $^W at runtime. I haven't checked - whether the debugger will still work with the lexical warnings - patch applied. - - diagnostics.pm - I *think* I've got diagnostics to work with the lexiacal warnings - patch, but there were design decisions made in diagnostics to work - around the limitations of $^W. Now that those limitations are gone, - the module should be revisited. @@ -25,8 +25,8 @@ Perl_av_reify(pTHX_ AV *av) if (AvREAL(av)) return; #ifdef DEBUGGING - if (SvTIED_mg((SV*)av, 'P')) - Perl_warn(aTHX_ "av_reify called on tied array"); + if (SvTIED_mg((SV*)av, 'P') && ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ WARN_DEBUGGING, "av_reify called on tied array"); #endif key = AvMAX(av) + 1; while (key > AvFILLp(av) + 1) @@ -325,8 +325,8 @@ Perl_av_clear(pTHX_ register AV *av) SV** ary; #ifdef DEBUGGING - if (SvREFCNT(av) <= 0) { - Perl_warn(aTHX_ "Attempt to clear deleted array"); + if (SvREFCNT(av) <= 0 && ckWARN_d(WARN_DEBUGGING)) { + Perl_warner(aTHX_ WARN_DEBUGGING, "Attempt to clear deleted array"); } #endif if (!av) diff --git a/djgpp/djgpp.c b/djgpp/djgpp.c index ae03f21639..5c1d3c4de4 100644 --- a/djgpp/djgpp.c +++ b/djgpp/djgpp.c @@ -119,8 +119,9 @@ pclose (FILE *pp) static int convretcode (pTHX_ int rc,char *prog,int fl) { - if (rc < 0 && PL_dowarn) - Perl_warn (aTHX_ "Can't %s \"%s\": %s",fl ? "exec" : "spawn",prog,Strerror (errno)); + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ WARN_EXEC,"Can't %s \"%s\": %s", + fl ? "exec" : "spawn",prog,Strerror (errno)); if (rc > 0) return rc <<= 8; if (rc < 0) @@ -460,8 +460,10 @@ Perl_nextargv(pTHX_ register GV *gv) fileuid = PL_statbuf.st_uid; filegid = PL_statbuf.st_gid; if (!S_ISREG(PL_filemode)) { - Perl_warn(aTHX_ "Can't do inplace edit: %s is not a regular file", - PL_oldname ); + if (ckWARN_d(WARN_INPLACE)) + Perl_warner(aTHX_ WARN_INPLACE, + "Can't do inplace edit: %s is not a regular file", + PL_oldname ); do_close(gv,FALSE); continue; } @@ -489,7 +491,9 @@ Perl_nextargv(pTHX_ register GV *gv) || (_djstat_fail_bits & _STFAIL_TRUENAME)!=0 #endif ) { - Perl_warn(aTHX_ "Can't do inplace edit: %s would not be unique", + if (ckWARN_d(WARN_INPLACE)) + Perl_warner(aTHX_ WARN_INPLACE, + "Can't do inplace edit: %s would not be unique", SvPVX(sv) ); do_close(gv,FALSE); continue; @@ -498,8 +502,10 @@ Perl_nextargv(pTHX_ register GV *gv) #ifdef HAS_RENAME #ifndef DOSISH if (PerlLIO_rename(PL_oldname,SvPVX(sv)) < 0) { - Perl_warn(aTHX_ "Can't rename %s to %s: %s, skipping file", - PL_oldname, SvPVX(sv), Strerror(errno) ); + if (ckWARN_d(WARN_INPLACE)) + Perl_warner(aTHX_ WARN_INPLACE, + "Can't rename %s to %s: %s, skipping file", + PL_oldname, SvPVX(sv), Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -512,8 +518,10 @@ Perl_nextargv(pTHX_ register GV *gv) #else (void)UNLINK(SvPVX(sv)); if (link(PL_oldname,SvPVX(sv)) < 0) { - Perl_warn(aTHX_ "Can't rename %s to %s: %s, skipping file", - PL_oldname, SvPVX(sv), Strerror(errno) ); + if (ckWARN_d(WARN_INPLACE)) + Perl_warner(aTHX_ WARN_INPLACE, + "Can't rename %s to %s: %s, skipping file", + PL_oldname, SvPVX(sv), Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -524,8 +532,10 @@ Perl_nextargv(pTHX_ register GV *gv) #if !defined(DOSISH) && !defined(AMIGAOS) # ifndef VMS /* Don't delete; use automatic file versioning */ if (UNLINK(PL_oldname) < 0) { - Perl_warn(aTHX_ "Can't remove %s: %s, skipping file", - PL_oldname, Strerror(errno) ); + if (ckWARN_d(WARN_INPLACE)) + Perl_warner(aTHX_ WARN_INPLACE, + "Can't remove %s: %s, skipping file", + PL_oldname, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -545,8 +555,9 @@ Perl_nextargv(pTHX_ register GV *gv) if (!do_open(PL_argvoutgv,SvPVX(sv),SvCUR(sv),PL_inplace!=0, O_WRONLY|O_CREAT|OPEN_EXCL,0666,Nullfp)) { #endif - Perl_warn(aTHX_ "Can't do inplace edit on %s: %s", - PL_oldname, Strerror(errno) ); + if (ckWARN_d(WARN_INPLACE)) + Perl_warner(aTHX_ WARN_INPLACE, "Can't do inplace edit on %s: %s", + PL_oldname, Strerror(errno) ); do_close(gv,FALSE); continue; } @@ -788,8 +788,8 @@ Perl_do_chop(pTHX_ register SV *astr, register SV *sv) s = send - 1; while ((*s & 0xc0) == 0x80) --s; - if (UTF8SKIP(s) != send - s) - Perl_warn(aTHX_ "Malformed UTF-8 character"); + if (UTF8SKIP(s) != send - s && ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); sv_setpvn(astr, s, send - s); *s = '\0'; SvCUR_set(sv, s - start); diff --git a/ext/B/B/Asmdata.pm b/ext/B/B/Asmdata.pm index d4128b67ea..1d0e7eddaa 100644 --- a/ext/B/B/Asmdata.pm +++ b/ext/B/B/Asmdata.pm @@ -14,7 +14,7 @@ use Exporter; @EXPORT_OK = qw(%insn_data @insn_name @optype @specialsv_name); use vars qw(%insn_data @insn_name @optype @specialsv_name); -@optype = qw(OP UNOP BINOP LOGOP CONDOP LISTOP PMOP SVOP GVOP PVOP LOOP COP); +@optype = qw(OP UNOP BINOP LOGOP LISTOP PMOP SVOP GVOP PVOP LOOP COP); @specialsv_name = qw(Nullsv &PL_sv_undef &PL_sv_yes &PL_sv_no); # XXX insn_data is initialised this way because with a large @@ -42,7 +42,7 @@ $insn_data{xrv} = [17, \&PUT_svindex, "GET_svindex"]; $insn_data{xpv} = [18, \&PUT_none, "GET_none"]; $insn_data{xiv32} = [19, \&PUT_I32, "GET_I32"]; $insn_data{xiv64} = [20, \&PUT_IV64, "GET_IV64"]; -$insn_data{xnv} = [21, \&PUT_double, "GET_double"]; +$insn_data{xnv} = [21, \&PUT_NV, "GET_NV"]; $insn_data{xlv_targoff} = [22, \&PUT_U32, "GET_U32"]; $insn_data{xlv_targlen} = [23, \&PUT_U32, "GET_U32"]; $insn_data{xlv_targ} = [24, \&PUT_svindex, "GET_svindex"]; @@ -113,33 +113,31 @@ $insn_data{op_private} = [89, \&PUT_U8, "GET_U8"]; $insn_data{op_first} = [90, \&PUT_opindex, "GET_opindex"]; $insn_data{op_last} = [91, \&PUT_opindex, "GET_opindex"]; $insn_data{op_other} = [92, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_true} = [93, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_false} = [94, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_children} = [95, \&PUT_U32, "GET_U32"]; -$insn_data{op_pmreplroot} = [96, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmreplrootgv} = [97, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_pmreplstart} = [98, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_pmnext} = [99, \&PUT_opindex, "GET_opindex"]; -$insn_data{pregcomp} = [100, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pmflags} = [101, \&PUT_U16, "GET_U16"]; -$insn_data{op_pmpermflags} = [102, \&PUT_U16, "GET_U16"]; -$insn_data{op_sv} = [103, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_gv} = [104, \&PUT_svindex, "GET_svindex"]; -$insn_data{op_pv} = [105, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{op_pv_tr} = [106, \&PUT_op_tr_array, "GET_op_tr_array"]; -$insn_data{op_redoop} = [107, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_nextop} = [108, \&PUT_opindex, "GET_opindex"]; -$insn_data{op_lastop} = [109, \&PUT_opindex, "GET_opindex"]; -$insn_data{cop_label} = [110, \&PUT_pvcontents, "GET_pvcontents"]; -$insn_data{cop_stash} = [111, \&PUT_svindex, "GET_svindex"]; -$insn_data{cop_filegv} = [112, \&PUT_svindex, "GET_svindex"]; -$insn_data{cop_seq} = [113, \&PUT_U32, "GET_U32"]; -$insn_data{cop_arybase} = [114, \&PUT_I32, "GET_I32"]; -$insn_data{cop_line} = [115, \&PUT_U16, "GET_U16"]; -$insn_data{cop_warnings} = [116, \&PUT_svindex, "GET_svindex"]; -$insn_data{main_start} = [117, \&PUT_opindex, "GET_opindex"]; -$insn_data{main_root} = [118, \&PUT_opindex, "GET_opindex"]; -$insn_data{curpad} = [119, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_children} = [93, \&PUT_U32, "GET_U32"]; +$insn_data{op_pmreplroot} = [94, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_pmreplrootgv} = [95, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_pmreplstart} = [96, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_pmnext} = [97, \&PUT_opindex, "GET_opindex"]; +$insn_data{pregcomp} = [98, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{op_pmflags} = [99, \&PUT_U16, "GET_U16"]; +$insn_data{op_pmpermflags} = [100, \&PUT_U16, "GET_U16"]; +$insn_data{op_sv} = [101, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_gv} = [102, \&PUT_svindex, "GET_svindex"]; +$insn_data{op_pv} = [103, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{op_pv_tr} = [104, \&PUT_op_tr_array, "GET_op_tr_array"]; +$insn_data{op_redoop} = [105, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_nextop} = [106, \&PUT_opindex, "GET_opindex"]; +$insn_data{op_lastop} = [107, \&PUT_opindex, "GET_opindex"]; +$insn_data{cop_label} = [108, \&PUT_pvcontents, "GET_pvcontents"]; +$insn_data{cop_stash} = [109, \&PUT_svindex, "GET_svindex"]; +$insn_data{cop_filegv} = [110, \&PUT_svindex, "GET_svindex"]; +$insn_data{cop_seq} = [111, \&PUT_U32, "GET_U32"]; +$insn_data{cop_arybase} = [112, \&PUT_I32, "GET_I32"]; +$insn_data{cop_line} = [113, \&PUT_U16, "GET_U16"]; +$insn_data{cop_warnings} = [114, \&PUT_svindex, "GET_svindex"]; +$insn_data{main_start} = [115, \&PUT_opindex, "GET_opindex"]; +$insn_data{main_root} = [116, \&PUT_opindex, "GET_opindex"]; +$insn_data{curpad} = [117, \&PUT_svindex, "GET_svindex"]; my ($insn_name, $insn_data); while (($insn_name, $insn_data) = each %insn_data) { diff --git a/ext/ByteLoader/byterun.c b/ext/ByteLoader/byterun.c index 035578f424..18fa4a150f 100644 --- a/ext/ByteLoader/byterun.c +++ b/ext/ByteLoader/byterun.c @@ -30,7 +30,6 @@ static int optype_size[] = { sizeof(UNOP), sizeof(BINOP), sizeof(LOGOP), - sizeof(CONDOP), sizeof(LISTOP), sizeof(PMOP), sizeof(SVOP), @@ -716,189 +715,175 @@ byterun(pTHXo_ struct bytestream bs) cLOGOP->op_other = arg; break; } - case INSN_OP_TRUE: /* 93 */ - { - opindex arg; - BGET_opindex(arg); - cCONDOP->op_true = arg; - break; - } - case INSN_OP_FALSE: /* 94 */ - { - opindex arg; - BGET_opindex(arg); - cCONDOP->op_false = arg; - break; - } - case INSN_OP_CHILDREN: /* 95 */ + case INSN_OP_CHILDREN: /* 93 */ { U32 arg; BGET_U32(arg); cLISTOP->op_children = arg; break; } - case INSN_OP_PMREPLROOT: /* 96 */ + case INSN_OP_PMREPLROOT: /* 94 */ { opindex arg; BGET_opindex(arg); cPMOP->op_pmreplroot = arg; break; } - case INSN_OP_PMREPLROOTGV: /* 97 */ + case INSN_OP_PMREPLROOTGV: /* 95 */ { svindex arg; BGET_svindex(arg); *(SV**)&cPMOP->op_pmreplroot = arg; break; } - case INSN_OP_PMREPLSTART: /* 98 */ + case INSN_OP_PMREPLSTART: /* 96 */ { opindex arg; BGET_opindex(arg); cPMOP->op_pmreplstart = arg; break; } - case INSN_OP_PMNEXT: /* 99 */ + case INSN_OP_PMNEXT: /* 97 */ { opindex arg; BGET_opindex(arg); *(OP**)&cPMOP->op_pmnext = arg; break; } - case INSN_PREGCOMP: /* 100 */ + case INSN_PREGCOMP: /* 98 */ { pvcontents arg; BGET_pvcontents(arg); BSET_pregcomp(PL_op, arg); break; } - case INSN_OP_PMFLAGS: /* 101 */ + case INSN_OP_PMFLAGS: /* 99 */ { U16 arg; BGET_U16(arg); cPMOP->op_pmflags = arg; break; } - case INSN_OP_PMPERMFLAGS: /* 102 */ + case INSN_OP_PMPERMFLAGS: /* 100 */ { U16 arg; BGET_U16(arg); cPMOP->op_pmpermflags = arg; break; } - case INSN_OP_SV: /* 103 */ + case INSN_OP_SV: /* 101 */ { svindex arg; BGET_svindex(arg); cSVOP->op_sv = arg; break; } - case INSN_OP_GV: /* 104 */ + case INSN_OP_GV: /* 102 */ { svindex arg; BGET_svindex(arg); *(SV**)&cGVOP->op_gv = arg; break; } - case INSN_OP_PV: /* 105 */ + case INSN_OP_PV: /* 103 */ { pvcontents arg; BGET_pvcontents(arg); cPVOP->op_pv = arg; break; } - case INSN_OP_PV_TR: /* 106 */ + case INSN_OP_PV_TR: /* 104 */ { op_tr_array arg; BGET_op_tr_array(arg); cPVOP->op_pv = arg; break; } - case INSN_OP_REDOOP: /* 107 */ + case INSN_OP_REDOOP: /* 105 */ { opindex arg; BGET_opindex(arg); cLOOP->op_redoop = arg; break; } - case INSN_OP_NEXTOP: /* 108 */ + case INSN_OP_NEXTOP: /* 106 */ { opindex arg; BGET_opindex(arg); cLOOP->op_nextop = arg; break; } - case INSN_OP_LASTOP: /* 109 */ + case INSN_OP_LASTOP: /* 107 */ { opindex arg; BGET_opindex(arg); cLOOP->op_lastop = arg; break; } - case INSN_COP_LABEL: /* 110 */ + case INSN_COP_LABEL: /* 108 */ { pvcontents arg; BGET_pvcontents(arg); cCOP->cop_label = arg; break; } - case INSN_COP_STASH: /* 111 */ + case INSN_COP_STASH: /* 109 */ { svindex arg; BGET_svindex(arg); *(SV**)&cCOP->cop_stash = arg; break; } - case INSN_COP_FILEGV: /* 112 */ + case INSN_COP_FILEGV: /* 110 */ { svindex arg; BGET_svindex(arg); *(SV**)&cCOP->cop_filegv = arg; break; } - case INSN_COP_SEQ: /* 113 */ + case INSN_COP_SEQ: /* 111 */ { U32 arg; BGET_U32(arg); cCOP->cop_seq = arg; break; } - case INSN_COP_ARYBASE: /* 114 */ + case INSN_COP_ARYBASE: /* 112 */ { I32 arg; BGET_I32(arg); cCOP->cop_arybase = arg; break; } - case INSN_COP_LINE: /* 115 */ + case INSN_COP_LINE: /* 113 */ { line_t arg; BGET_U16(arg); cCOP->cop_line = arg; break; } - case INSN_COP_WARNINGS: /* 116 */ + case INSN_COP_WARNINGS: /* 114 */ { svindex arg; BGET_svindex(arg); cCOP->cop_warnings = arg; break; } - case INSN_MAIN_START: /* 117 */ + case INSN_MAIN_START: /* 115 */ { opindex arg; BGET_opindex(arg); PL_main_start = arg; break; } - case INSN_MAIN_ROOT: /* 118 */ + case INSN_MAIN_ROOT: /* 116 */ { opindex arg; BGET_opindex(arg); PL_main_root = arg; break; } - case INSN_CURPAD: /* 119 */ + case INSN_CURPAD: /* 117 */ { svindex arg; BGET_svindex(arg); diff --git a/ext/ByteLoader/byterun.h b/ext/ByteLoader/byterun.h index 6bc03af5f1..31a9033845 100644 --- a/ext/ByteLoader/byterun.h +++ b/ext/ByteLoader/byterun.h @@ -109,34 +109,32 @@ enum { INSN_OP_FIRST, /* 90 */ INSN_OP_LAST, /* 91 */ INSN_OP_OTHER, /* 92 */ - INSN_OP_TRUE, /* 93 */ - INSN_OP_FALSE, /* 94 */ - INSN_OP_CHILDREN, /* 95 */ - INSN_OP_PMREPLROOT, /* 96 */ - INSN_OP_PMREPLROOTGV, /* 97 */ - INSN_OP_PMREPLSTART, /* 98 */ - INSN_OP_PMNEXT, /* 99 */ - INSN_PREGCOMP, /* 100 */ - INSN_OP_PMFLAGS, /* 101 */ - INSN_OP_PMPERMFLAGS, /* 102 */ - INSN_OP_SV, /* 103 */ - INSN_OP_GV, /* 104 */ - INSN_OP_PV, /* 105 */ - INSN_OP_PV_TR, /* 106 */ - INSN_OP_REDOOP, /* 107 */ - INSN_OP_NEXTOP, /* 108 */ - INSN_OP_LASTOP, /* 109 */ - INSN_COP_LABEL, /* 110 */ - INSN_COP_STASH, /* 111 */ - INSN_COP_FILEGV, /* 112 */ - INSN_COP_SEQ, /* 113 */ - INSN_COP_ARYBASE, /* 114 */ - INSN_COP_LINE, /* 115 */ - INSN_COP_WARNINGS, /* 116 */ - INSN_MAIN_START, /* 117 */ - INSN_MAIN_ROOT, /* 118 */ - INSN_CURPAD, /* 119 */ - MAX_INSN = 119 + INSN_OP_CHILDREN, /* 93 */ + INSN_OP_PMREPLROOT, /* 94 */ + INSN_OP_PMREPLROOTGV, /* 95 */ + INSN_OP_PMREPLSTART, /* 96 */ + INSN_OP_PMNEXT, /* 97 */ + INSN_PREGCOMP, /* 98 */ + INSN_OP_PMFLAGS, /* 99 */ + INSN_OP_PMPERMFLAGS, /* 100 */ + INSN_OP_SV, /* 101 */ + INSN_OP_GV, /* 102 */ + INSN_OP_PV, /* 103 */ + INSN_OP_PV_TR, /* 104 */ + INSN_OP_REDOOP, /* 105 */ + INSN_OP_NEXTOP, /* 106 */ + INSN_OP_LASTOP, /* 107 */ + INSN_COP_LABEL, /* 108 */ + INSN_COP_STASH, /* 109 */ + INSN_COP_FILEGV, /* 110 */ + INSN_COP_SEQ, /* 111 */ + INSN_COP_ARYBASE, /* 112 */ + INSN_COP_LINE, /* 113 */ + INSN_COP_WARNINGS, /* 114 */ + INSN_MAIN_START, /* 115 */ + INSN_MAIN_ROOT, /* 116 */ + INSN_CURPAD, /* 117 */ + MAX_INSN = 117 }; enum { @@ -144,14 +142,13 @@ enum { OPt_UNOP, /* 1 */ OPt_BINOP, /* 2 */ OPt_LOGOP, /* 3 */ - OPt_CONDOP, /* 4 */ - OPt_LISTOP, /* 5 */ - OPt_PMOP, /* 6 */ - OPt_SVOP, /* 7 */ - OPt_GVOP, /* 8 */ - OPt_PVOP, /* 9 */ - OPt_LOOP, /* 10 */ - OPt_COP /* 11 */ + OPt_LISTOP, /* 4 */ + OPt_PMOP, /* 5 */ + OPt_SVOP, /* 6 */ + OPt_GVOP, /* 7 */ + OPt_PVOP, /* 8 */ + OPt_LOOP, /* 9 */ + OPt_COP /* 10 */ }; EXT void byterun(pTHXo_ struct bytestream bs); @@ -609,12 +609,15 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) /* Adding a new symbol */ - if (add & GV_ADDWARN) - Perl_warn(aTHX_ "Had to create %s unexpectedly", nambeg); + if (add & GV_ADDWARN && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Had to create %s unexpectedly", nambeg); gv_init(gv, stash, name, len, add & GV_ADDMULTI); gv_init_sv(gv, sv_type); GvFLAGS(gv) |= add_gvflags; + if (isLEXWARN_on && isALPHA(name[0]) && ! ckWARN(WARN_ONCE)) + GvMULTI_on(gv) ; + /* set up magic where warranted */ switch (*name) { case 'A': @@ -946,11 +949,12 @@ Perl_gp_free(pTHX_ GV *gv) { GP* gp; CV* cv; + dTHR; if (!gv || !(gp = GvGP(gv))) return; - if (gp->gp_refcnt == 0) { - Perl_warn(aTHX_ "Attempt to free unreferenced glob pointers"); + if (gp->gp_refcnt == 0 && ckWARN_d(WARN_INTERNAL)) { + Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced glob pointers"); return; } if (gp->gp_cv) { @@ -1204,8 +1204,11 @@ Perl_unsharepvn(pTHX_ const char *str, I32 len, U32 hash) } UNLOCK_STRTAB_MUTEX; - if (!found) - Perl_warn(aTHX_ "Attempt to free non-existent shared string"); + { + dTHR; + if (!found && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free non-existent shared string"); + } } /* get a (constant) string ptr from the global string table diff --git a/jpl/JNI/JNI.xs b/jpl/JNI/JNI.xs index 678e81c66b..ee854c13b5 100644 --- a/jpl/JNI/JNI.xs +++ b/jpl/JNI/JNI.xs @@ -2886,8 +2886,8 @@ SetBooleanArrayRegion(array,start,len,buf) { if (buf_len_ < len) Perl_croak(aTHX_ "string is too short"); - else if (buf_len_ > len && PL_dowarn) - Perl_warn(aTHX_ "string is too long"); + else if (buf_len_ > len && ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "string is too long"); (*env)->SetBooleanArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -2905,8 +2905,8 @@ SetByteArrayRegion(array,start,len,buf) { if (buf_len_ < len) Perl_croak(aTHX_ "string is too short"); - else if (buf_len_ > len && PL_dowarn) - Perl_warn(aTHX_ "string is too long"); + else if (buf_len_ > len && ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "string is too long"); (*env)->SetByteArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -2924,8 +2924,8 @@ SetCharArrayRegion(array,start,len,buf) { if (buf_len_ < len) Perl_croak(aTHX_ "string is too short"); - else if (buf_len_ > len && PL_dowarn) - Perl_warn(aTHX_ "string is too long"); + else if (buf_len_ > len && ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "string is too long"); (*env)->SetCharArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -2943,8 +2943,8 @@ SetShortArrayRegion(array,start,len,buf) { if (buf_len_ < len) Perl_croak(aTHX_ "string is too short"); - else if (buf_len_ > len && PL_dowarn) - Perl_warn(aTHX_ "string is too long"); + else if (buf_len_ > len && ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "string is too long"); (*env)->SetShortArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -2962,8 +2962,8 @@ SetIntArrayRegion(array,start,len,buf) { if (buf_len_ < len) Perl_croak(aTHX_ "string is too short"); - else if (buf_len_ > len && PL_dowarn) - Perl_warn(aTHX_ "string is too long"); + else if (buf_len_ > len && ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "string is too long"); (*env)->SetIntArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -2981,8 +2981,8 @@ SetLongArrayRegion(array,start,len,buf) { if (buf_len_ < len) Perl_croak(aTHX_ "string is too short"); - else if (buf_len_ > len && PL_dowarn) - Perl_warn(aTHX_ "string is too long"); + else if (buf_len_ > len && ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "string is too long"); (*env)->SetLongArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -3000,8 +3000,8 @@ SetFloatArrayRegion(array,start,len,buf) { if (buf_len_ < len) Perl_croak(aTHX_ "string is too short"); - else if (buf_len_ > len && PL_dowarn) - Perl_warn(aTHX_ "string is too long"); + else if (buf_len_ > len && ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "string is too long"); (*env)->SetFloatArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -3019,8 +3019,8 @@ SetDoubleArrayRegion(array,start,len,buf) { if (buf_len_ < len) Perl_croak(aTHX_ "string is too short"); - else if (buf_len_ > len && PL_dowarn) - Perl_warn(aTHX_ "string is too long"); + else if (buf_len_ > len && ckWARN(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "string is too long"); (*env)->SetDoubleArrayRegion(env, array,start,len,buf); RESTOREENV; } diff --git a/lib/warning.pm b/lib/warning.pm index ac6aefafae..1df83d946f 100644 --- a/lib/warning.pm +++ b/lib/warning.pm @@ -12,31 +12,17 @@ warning - Perl pragma to control optional warnings =head1 SYNOPSIS use warning; + no warning; use warning "all"; - use warning "deprecated"; - - use warning; - no warning "unsafe"; + no warning "all"; =head1 DESCRIPTION -If no import list is supplied, all possible restrictions are assumed. -(This is the safest mode to operate in, but is sometimes too strict for -casual programming.) Currently, there are three possible things to be -strict about: - -=over 6 - -=item C<warning deprecated> - -This generates a runtime error if you use deprecated - - use warning 'deprecated'; - -=back +If no import list is supplied, all possible warnings are either enabled +or disabled. -See L<perlmod/Pragmatic Modules>. +See L<perlmod/Pragmatic Modules> and L<perllexwarn>. =cut @@ -44,71 +30,77 @@ See L<perlmod/Pragmatic Modules>. use Carp ; %Bits = ( - 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55", # [0..31] - 'ambiguous' => "\x00\x00\x00\x04\x00\x00\x00\x00", # [13] - 'closed' => "\x10\x00\x00\x00\x00\x00\x00\x00", # [2] - 'closure' => "\x00\x00\x00\x00\x00\x40\x00\x00", # [23] - 'default' => "\x01\x00\x00\x00\x00\x00\x00\x00", # [0] - 'deprecated' => "\x00\x00\x00\x10\x00\x00\x00\x00", # [14] - 'exec' => "\x40\x00\x00\x00\x00\x00\x00\x00", # [3] - 'io' => "\x54\x15\x00\x00\x00\x00\x00\x00", # [1..6] - 'misc' => "\x00\x40\x00\x00\x00\x00\x00\x00", # [7] - 'newline' => "\x00\x01\x00\x00\x00\x00\x00\x00", # [4] - 'numeric' => "\x00\x00\x01\x00\x00\x00\x00\x00", # [8] - 'octal' => "\x00\x00\x00\x40\x00\x00\x00\x00", # [15] - 'once' => "\x00\x00\x04\x00\x00\x00\x00\x00", # [9] - 'parenthesis' => "\x00\x00\x00\x00\x01\x00\x00\x00", # [16] - 'pipe' => "\x00\x04\x00\x00\x00\x00\x00\x00", # [5] - 'precedence' => "\x00\x00\x00\x00\x04\x00\x00\x00", # [17] - 'printf' => "\x00\x00\x00\x00\x10\x00\x00\x00", # [18] - 'recursion' => "\x00\x00\x10\x00\x00\x00\x00\x00", # [10] - 'redefine' => "\x00\x00\x40\x00\x00\x00\x00\x00", # [11] - 'reserved' => "\x00\x00\x00\x00\x40\x00\x00\x00", # [19] - 'semicolon' => "\x00\x00\x00\x00\x00\x01\x00\x00", # [20] - 'signal' => "\x00\x00\x00\x00\x00\x00\x01\x00", # [24] - 'substr' => "\x00\x00\x00\x00\x00\x00\x04\x00", # [25] - 'syntax' => "\x00\x00\x00\x55\x55\x01\x00\x00", # [12..20] - 'taint' => "\x00\x00\x00\x00\x00\x00\x10\x00", # [26] - 'uninitialized' => "\x00\x00\x00\x00\x00\x04\x00\x00", # [21] - 'unopened' => "\x00\x10\x00\x00\x00\x00\x00\x00", # [6] - 'unsafe' => "\x00\x00\x00\x00\x00\x50\x55\x01", # [22..28] - 'untie' => "\x00\x00\x00\x00\x00\x00\x40\x00", # [27] - 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x01", # [28] - 'void' => "\x00\x00\x00\x00\x00\x00\x00\x04", # [29] + 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..35] + 'ambiguous' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00", # [16] + 'closed' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [1] + 'closure' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [26] + 'debugging' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [12] + 'deprecated' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [17] + 'exec' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [2] + 'inplace' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [13] + 'internal' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [14] + 'io' => "\x55\x05\x00\x00\x00\x00\x00\x00\x00", # [0..5] + 'misc' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [6] + 'newline' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [3] + 'numeric' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [7] + 'octal' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [18] + 'once' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [8] + 'parenthesis' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [19] + 'pipe' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [4] + 'precedence' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [20] + 'printf' => "\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [21] + 'recursion' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00", # [9] + 'redefine' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [10] + 'reserved' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [22] + 'semicolon' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [23] + 'severe' => "\x00\x00\x40\x15\x00\x00\x00\x00\x00", # [11..14] + 'signal' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [27] + 'substr' => "\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [28] + 'syntax' => "\x00\x00\x00\x40\x55\x55\x00\x00\x00", # [15..23] + 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [29] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [24] + 'unopened' => "\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [5] + 'unsafe' => "\x00\x00\x00\x00\x00\x00\x54\x55\x00", # [25..31] + 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [30] + 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [31] + 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [32] ); %DeadBits = ( - 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..31] - 'ambiguous' => "\x00\x00\x00\x08\x00\x00\x00\x00", # [13] - 'closed' => "\x20\x00\x00\x00\x00\x00\x00\x00", # [2] - 'closure' => "\x00\x00\x00\x00\x00\x80\x00\x00", # [23] - 'default' => "\x02\x00\x00\x00\x00\x00\x00\x00", # [0] - 'deprecated' => "\x00\x00\x00\x20\x00\x00\x00\x00", # [14] - 'exec' => "\x80\x00\x00\x00\x00\x00\x00\x00", # [3] - 'io' => "\xa8\x2a\x00\x00\x00\x00\x00\x00", # [1..6] - 'misc' => "\x00\x80\x00\x00\x00\x00\x00\x00", # [7] - 'newline' => "\x00\x02\x00\x00\x00\x00\x00\x00", # [4] - 'numeric' => "\x00\x00\x02\x00\x00\x00\x00\x00", # [8] - 'octal' => "\x00\x00\x00\x80\x00\x00\x00\x00", # [15] - 'once' => "\x00\x00\x08\x00\x00\x00\x00\x00", # [9] - 'parenthesis' => "\x00\x00\x00\x00\x02\x00\x00\x00", # [16] - 'pipe' => "\x00\x08\x00\x00\x00\x00\x00\x00", # [5] - 'precedence' => "\x00\x00\x00\x00\x08\x00\x00\x00", # [17] - 'printf' => "\x00\x00\x00\x00\x20\x00\x00\x00", # [18] - 'recursion' => "\x00\x00\x20\x00\x00\x00\x00\x00", # [10] - 'redefine' => "\x00\x00\x80\x00\x00\x00\x00\x00", # [11] - 'reserved' => "\x00\x00\x00\x00\x80\x00\x00\x00", # [19] - 'semicolon' => "\x00\x00\x00\x00\x00\x02\x00\x00", # [20] - 'signal' => "\x00\x00\x00\x00\x00\x00\x02\x00", # [24] - 'substr' => "\x00\x00\x00\x00\x00\x00\x08\x00", # [25] - 'syntax' => "\x00\x00\x00\xaa\xaa\x02\x00\x00", # [12..20] - 'taint' => "\x00\x00\x00\x00\x00\x00\x20\x00", # [26] - 'uninitialized' => "\x00\x00\x00\x00\x00\x08\x00\x00", # [21] - 'unopened' => "\x00\x20\x00\x00\x00\x00\x00\x00", # [6] - 'unsafe' => "\x00\x00\x00\x00\x00\xa0\xaa\x02", # [22..28] - 'untie' => "\x00\x00\x00\x00\x00\x00\x80\x00", # [27] - 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x02", # [28] - 'void' => "\x00\x00\x00\x00\x00\x00\x00\x08", # [29] + 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..35] + 'ambiguous' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00", # [16] + 'closed' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [1] + 'closure' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [26] + 'debugging' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [12] + 'deprecated' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [17] + 'exec' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [2] + 'inplace' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [13] + 'internal' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [14] + 'io' => "\xaa\x0a\x00\x00\x00\x00\x00\x00\x00", # [0..5] + 'misc' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [6] + 'newline' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [3] + 'numeric' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [7] + 'octal' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [18] + 'once' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [8] + 'parenthesis' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [19] + 'pipe' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [4] + 'precedence' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [20] + 'printf' => "\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [21] + 'recursion' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00", # [9] + 'redefine' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [10] + 'reserved' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [22] + 'semicolon' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [23] + 'severe' => "\x00\x00\x80\x2a\x00\x00\x00\x00\x00", # [11..14] + 'signal' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [27] + 'substr' => "\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [28] + 'syntax' => "\x00\x00\x00\x80\xaa\xaa\x00\x00\x00", # [15..23] + 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [29] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [24] + 'unopened' => "\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [5] + 'unsafe' => "\x00\x00\x00\x00\x00\x00\xa8\xaa\x00", # [25..31] + 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [30] + 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [31] + 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [32] ); @@ -431,33 +431,6 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg) return 0; } -#if 0 -static char * -printW(SV *sv) -{ -#if 1 - return "" ; - -#else - int i ; - static char buffer[50] ; - char buf1[20] ; - char * p ; - - - sprintf(buffer, "Buffer %d, Length = %d - ", sv, SvCUR(sv)) ; - p = SvPVX(sv) ; - for (i = 0; i < SvCUR(sv) ; ++ i) { - sprintf (buf1, " %x [%x]", (p+i), *(p+i)) ; - strcat(buffer, buf1) ; - } - - return buffer ; - -#endif -} -#endif - int Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) { @@ -473,16 +446,17 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) sv_setsv(sv, PL_bodytarget); break; case '\002': /* ^B */ - /* printf("magic_get $^B: ") ; */ - if (PL_curcop->cop_warnings == WARN_NONE) - /* printf("WARN_NONE\n"), */ + if (PL_curcop->cop_warnings == WARN_NONE || + PL_curcop->cop_warnings == WARN_STD) + { sv_setpvn(sv, WARN_NONEstring, WARNsize) ; - else if (PL_curcop->cop_warnings == WARN_ALL) - /* printf("WARN_ALL\n"), */ + } + else if (PL_curcop->cop_warnings == WARN_ALL) { sv_setpvn(sv, WARN_ALLstring, WARNsize) ; - else - /* printf("some %s\n", printW(PL_curcop->cop_warnings)), */ + } + else { sv_setsv(sv, PL_curcop->cop_warnings); + } break; case '\003': /* ^C */ sv_setiv(sv, (IV)PL_minus_c); @@ -576,7 +550,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #endif break; case '\027': /* ^W */ - sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) == G_WARN_ON)); + sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE)); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': @@ -1234,8 +1208,8 @@ Perl_magic_setdbline(pTHX_ SV *sv, MAGIC *mg) atoi(MgPV(mg,n_a)), FALSE); if (svp && SvIOKp(*svp) && (o = (OP*)SvSTASH(*svp))) o->op_private = i; - else - Perl_warn(aTHX_ "Can't break at that line\n"); + else if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Can't break at that line\n"); return 0; } @@ -1678,16 +1652,19 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) break; case '\002': /* ^B */ if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { - if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize)) + if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize)) { PL_compiling.cop_warnings = WARN_ALL; + PL_dowarn |= G_WARN_ONCE ; + } else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize)) PL_compiling.cop_warnings = WARN_NONE; else { - if (PL_compiling.cop_warnings != WARN_NONE && - PL_compiling.cop_warnings != WARN_ALL) - sv_setsv(PL_compiling.cop_warnings, sv); - else + if (specialWARN(PL_compiling.cop_warnings)) PL_compiling.cop_warnings = newSVsv(sv) ; + else + sv_setsv(PL_compiling.cop_warnings, sv); + if (isWARN_on(PL_compiling.cop_warnings, WARN_ONCE)) + PL_dowarn |= G_WARN_ONCE ; } } break; @@ -1749,7 +1726,8 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) case '\027': /* ^W */ if ( ! (PL_dowarn & G_WARN_ALL_MASK)) { i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); - PL_dowarn = (i ? G_WARN_ON : G_WARN_OFF) ; + PL_dowarn = (PL_dowarn & ~G_WARN_ON) + | (i ? G_WARN_ON : G_WARN_OFF) ; } break; case '.': @@ -414,13 +414,14 @@ Perl_pad_findmy(pTHX_ char *name) void Perl_pad_leavemy(pTHX_ I32 fill) { + dTHR; I32 off; SV **svp = AvARRAY(PL_comppad_name); SV *sv; if (PL_min_intro_pending && fill < PL_min_intro_pending) { for (off = PL_max_intro_pending; off >= PL_min_intro_pending; off--) { - if ((sv = svp[off]) && sv != &PL_sv_undef) - Perl_warn(aTHX_ "%s never introduced", SvPVX(sv)); + if ((sv = svp[off]) && sv != &PL_sv_undef && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "%s never introduced", SvPVX(sv)); } } /* "Deintroduce" my variables that are leaving with this scope. */ @@ -731,7 +732,7 @@ S_cop_free(pTHX_ COP* cop) { Safefree(cop->cop_label); SvREFCNT_dec(cop->cop_filegv); - if (cop->cop_warnings != WARN_NONE && cop->cop_warnings != WARN_ALL) + if (! specialWARN(cop->cop_warnings)) SvREFCNT_dec(cop->cop_warnings); } @@ -1727,8 +1728,7 @@ Perl_block_start(pTHX_ int full) SAVEHINTS(); PL_hints &= ~HINT_BLOCK_SCOPE; SAVEPPTR(PL_compiling.cop_warnings); - if (PL_compiling.cop_warnings != WARN_ALL && - PL_compiling.cop_warnings != WARN_NONE) { + if (! specialWARN(PL_compiling.cop_warnings)) { PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; SAVEFREESV(PL_compiling.cop_warnings) ; } @@ -3062,8 +3062,7 @@ Perl_newSTATEOP(pTHX_ I32 flags, char *label, OP *o) } cop->cop_seq = seq; cop->cop_arybase = PL_curcop->cop_arybase; - if (PL_curcop->cop_warnings == WARN_NONE - || PL_curcop->cop_warnings == WARN_ALL) + if (specialWARN(PL_curcop->cop_warnings)) cop->cop_warnings = PL_curcop->cop_warnings ; else cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ; @@ -3839,7 +3838,10 @@ Perl_cv_clone(pTHX_ CV *proto) void Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) { - if ((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) { + dTHR; + + if (((!p != !SvPOK(cv)) || (p && strNE(p, SvPVX(cv)))) && + ckWARN_d(WARN_UNSAFE) ) { SV* msg = sv_newmortal(); SV* name = Nullsv; @@ -3855,7 +3857,7 @@ Perl_cv_ckproto(pTHX_ CV *cv, GV *gv, char *p) Perl_sv_catpvf(aTHX_ msg, "(%s)", p); else sv_catpv(msg, "none"); - Perl_warn(aTHX_ "%_", msg); + Perl_warner(aTHX_ WARN_UNSAFE, "%_", msg); } } @@ -3925,8 +3927,9 @@ Perl_newSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *block) if (SvTYPE(gv) != SVt_PVGV) { /* Prototype now, and had maximum a prototype before. */ if (SvTYPE(gv) > SVt_NULL) { - if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1)) - Perl_warn(aTHX_ "Runaway prototype"); + if (!SvPOK((SV*)gv) && !(SvIOK((SV*)gv) && SvIVX((SV*)gv) == -1) + && ckWARN_d(WARN_UNSAFE)) + Perl_warner(aTHX_ WARN_UNSAFE, "Runaway prototype"); cv_ckproto((CV*)gv, NULL, ps); } if (ps) @@ -4337,7 +4340,8 @@ Perl_oopsAV(pTHX_ OP *o) break; default: - Perl_warn(aTHX_ "oops: oopsAV"); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV"); break; } return o; @@ -4346,6 +4350,10 @@ Perl_oopsAV(pTHX_ OP *o) OP * Perl_oopsHV(pTHX_ OP *o) { + dTHR; + + dTHR; + switch (o->op_type) { case OP_PADSV: case OP_PADAV: @@ -4361,7 +4369,8 @@ Perl_oopsHV(pTHX_ OP *o) break; default: - Perl_warn(aTHX_ "oops: oopsHV"); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV"); break; } return o; @@ -795,8 +795,8 @@ U32 addflag; goto retry; } } - if (rc < 0 && PL_dowarn) - warn("Can't %s \"%s\": %s\n", + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s\n", ((execf != EXECF_EXEC && execf != EXECF_TRUEEXEC) ? "spawn" : "exec"), PL_Argv[0], Strerror(errno)); @@ -903,8 +903,8 @@ do_spawn3(char *cmd, int execf, int flag) /* In the ak code internal P_NOWAIT is P_WAIT ??? */ rc = result(P_WAIT, spawnl(P_NOWAIT,shell,shell,copt,cmd,(char*)0)); - if (rc < 0 && PL_dowarn) - warn("Can't %s \"%s\": %s", + if (rc < 0 && ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", (execf == EXECF_SPAWN ? "spawn" : "exec"), shell, Strerror(errno)); if (rc < 0) rc = 255 << 8; /* Emulate the fork(). */ @@ -448,18 +448,20 @@ perl_destruct(pTHXx) SvREFCNT_dec(hv); FREETMPS; - if (destruct_level >= 2) { + if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) { if (PL_scopestack_ix != 0) - Perl_warn(aTHX_ "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", + Perl_warner(aTHX_ WARN_INTERNAL, + "Unbalanced scopes: %ld more ENTERs than LEAVEs\n", (long)PL_scopestack_ix); if (PL_savestack_ix != 0) - Perl_warn(aTHX_ "Unbalanced saves: %ld more saves than restores\n", + Perl_warner(aTHX_ WARN_INTERNAL, + "Unbalanced saves: %ld more saves than restores\n", (long)PL_savestack_ix); if (PL_tmps_floor != -1) - Perl_warn(aTHX_ "Unbalanced tmps: %ld more allocs than frees\n", + Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced tmps: %ld more allocs than frees\n", (long)PL_tmps_floor + 1); if (cxstack_ix != -1) - Perl_warn(aTHX_ "Unbalanced context: %ld more PUSHes than POPs\n", + Perl_warner(aTHX_ WARN_INTERNAL,"Unbalanced context: %ld more PUSHes than POPs\n", (long)cxstack_ix + 1); } @@ -488,8 +490,9 @@ perl_destruct(pTHXx) array = HvARRAY(PL_strtab); hent = array[0]; for (;;) { - if (hent) { - Perl_warn(aTHX_ "Unbalanced string table refcount: (%d) for \"%s\"", + if (hent && ckWARN_d(WARN_INTERNAL)) { + Perl_warner(aTHX_ WARN_INTERNAL, + "Unbalanced string table refcount: (%d) for \"%s\"", HeVAL(hent) - Nullsv, HeKEY(hent)); HeVAL(hent) = Nullsv; hent = HeNEXT(hent); @@ -503,8 +506,8 @@ perl_destruct(pTHXx) } SvREFCNT_dec(PL_strtab); - if (PL_sv_count != 0) - Perl_warn(aTHX_ "Scalars leaked: %ld\n", (long)PL_sv_count); + if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count); sv_free_arenas(); @@ -988,7 +991,7 @@ print \" \\@INC:\\n @INC\\n\";"); if (PL_do_undump) my_unexec(); - if (ckWARN(WARN_ONCE)) + if (isWARN_ONCE) gv_check(PL_defstash); LEAVE; @@ -1582,6 +1585,7 @@ Perl_moreswitches(pTHX_ char *s) } return s; case 'D': + { #ifdef DEBUGGING forbid_setid("-D"); if (isALPHA(s[1])) { @@ -1597,11 +1601,15 @@ Perl_moreswitches(pTHX_ char *s) } PL_debug |= 0x80000000; #else - Perl_warn(aTHX_ "Recompile perl with -DDEBUGGING to use -D switch\n"); + dTHR; + if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ WARN_DEBUGGING, + "Recompile perl with -DDEBUGGING to use -D switch\n"); for (s++; isALNUM(*s); s++) ; #endif /*SUPPRESS 530*/ return s; + } case 'h': usage(PL_origargv[0]); PerlProc_exit(0); @@ -141,8 +141,8 @@ PerlIO_canset_cnt(PerlIO *f) void PerlIO_set_cnt(PerlIO *f, int cnt) { - if (cnt < -1) - Perl_warn(aTHX_ "Setting cnt to %d\n",cnt); + if (cnt < -1 && ckWARN_s(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d\n",cnt); #if defined(USE_STDIO_PTR) && defined(STDIO_CNT_LVALUE) FILE_cnt(f) = cnt; #else @@ -157,10 +157,10 @@ PerlIO_set_ptrcnt(PerlIO *f, STDCHAR *ptr, int cnt) #ifdef FILE_bufsiz STDCHAR *e = FILE_base(f) + FILE_bufsiz(f); int ec = e - ptr; - if (ptr > e + 1) - Perl_warn(aTHX_ "Setting ptr %p > end+1 %p\n", ptr, e + 1); - if (cnt != ec) - Perl_warn(aTHX_ "Setting cnt to %d, ptr implies %d\n",cnt,ec); + if (ptr > e + 1 && ckWARN_s(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Setting ptr %p > end+1 %p\n", ptr, e + 1); + if (cnt != ec && ckWARN_s(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Setting cnt to %d, ptr implies %d\n",cnt,ec); #endif #if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) FILE_ptr(f) = ptr; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index be5366d116..f64bea66fb 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -95,7 +95,8 @@ scope. See L<utf8> for more information. =head2 Lexically scoped warning categories You can now control the granularity of warnings emitted by perl at a finer -level using the C<use warning> pragma. See L<warning> for details. +level using the C<use warning> pragma. See L<warning> and L<perllexwarn> +for details. =head2 Binary numbers supported diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 45c7be1905..0484882c91 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -1300,7 +1300,7 @@ the name. (W) You redefined a format. To suppress this warning, say { - local $^W = 0; + no warning; eval "format NAME =..."; } @@ -2552,7 +2552,7 @@ may break this. (W) You redefined a subroutine. To suppress this warning, say { - local $^W = 0; + no warning; eval "sub name { ... }"; } diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index 6b0fd9d323..ddf64d07bb 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -4760,6 +4760,7 @@ are also implemented this way. Currently implemented pragmas are: use sigtrap qw(SEGV BUS); use strict qw(subs vars refs); use subs qw(afunc blurfl); + use warning qw(all); Some of these pseudo-modules import semantics into the current block scope (like C<strict> or C<integer>, unlike ordinary modules, @@ -4771,6 +4772,7 @@ by C<use>, i.e., it calls C<unimport Module LIST> instead of C<import>. no integer; no strict 'refs'; + no warning; If no C<unimport> method can be found the call fails with a fatal error. diff --git a/pod/perllexwarn.pod b/pod/perllexwarn.pod new file mode 100644 index 0000000000..11947550c5 --- /dev/null +++ b/pod/perllexwarn.pod @@ -0,0 +1,322 @@ +=head1 NAME + +perllexwarn - Perl Lexical Warnings + +=head1 DESCRIPTION + +The C<use warning> pragma is a replacement for both the command line +flag B<-w> and the equivalent Perl variable, C<$^W>. + +The pragma works just like the existing "strict" pragma. +This means that the scope of the warning pragma is limited to the +enclosing block. It also means that that the pragma setting will not +leak across files (via C<use>, C<require> or C<do>). This allows +authors to independently define the degree of warning checks that will +be applied to their module. + +By default, optional warnings are disabled, so any legacy code that +doesn't attempt to control the warnings will work unchanged. + +All warnings are enabled in a block by either of these: + + use warning ; + use warning 'all' ; + +Similarly all warnings are disabled in a block by either of these: + + no warning ; + no warning 'all' ; + +For example, consider the code below: + + use warning ; + my $a ; + my $b ; + { + no warning ; + $b = 2 if $a EQ 3 ; + } + $b = 1 if $a NE 3 ; + +The code in the enclosing block has warnings enabled, but the inner +block has them disabled. In this case that means that the use of the C<EQ> +operator won't trip a C<"Use of EQ is deprecated"> warning, but the use of +C<NE> will produce a C<"Use of NE is deprecated"> warning. + +=head2 Default Warnings and Optional Warnings + +Before the introduction of lexical warnings, Perl had two classes of +warnings: mandatory and optional. + +As its name suggests, if your code tripped a mandatory warning, you +would get a warning whether you wanted it or not. +For example, the code below would always produce an C<"integer overflow"> +warning. + + my $a = oct "777777777777777777777777777777777777" ; + + +With the introduction of lexical warnings, mandatory warnings now become +I<default> warnings. The difference is that although the previously +mandatory warnings are still enabled by default, they can then be +subsequently enabled or disabled with the lexical warning pragma. For +example, in the code below, an C<"integer overflow"> warning will only +be reported for the C<$a> variable. + + my $a = oct "777777777777777777777777777777777777" ; + no warning ; + my $b = oct "777777777777777777777777777777777777" ; + +Note that neither the B<-w> flag or the C<$^W> can be used to +disable/enable default warnings. They are still mandatory in this case. + +=head2 What's wrong with B<-w> and C<$^W> + +Although very useful, the big problem with using B<-w> on the command +line to enable warnings is that it is all or nothing. Take the typical +scenario when you are writing a Perl program. Parts of the code you +will write yourself, but it's very likely that you will make use of +pre-written Perl modules. If you use the B<-w> flag in this case, you +end up enabling warnings in pieces of code that you haven't written. + +Similarly, using C<$^W> to either disable or enable blocks of code is +fundamentally flawed. For a start, say you want to disable warnings in +a block of code. You might expect this to be enough to do the trick: + + { + local ($^W) = 0 ; + my $a =+ 2 ; + my $b ; chop $b ; + } + +When this code is run with the B<-w> flag, a warning will be produced +for the C<$a> line -- C<"Reversed += operator">. + +The problem is that Perl has both compile-time and run-time warnings. To +disable compile-time warnings you need to rewrite the code like this: + + { + BEGIN { $^W = 0 } + my $a =+ 2 ; + my $b ; chop $b ; + } + +The other big problem with C<$^W> is that way you can inadvertently +change the warning setting in unexpected places in your code. For example, +when the code below is run (without the B<-w> flag), the second call +to C<doit> will trip a C<"Use of uninitialized value"> warning, whereas +the first will not. + + sub doit + { + my $b ; chop $b ; + } + + doit() ; + + { + local ($^W) = 1 ; + doit() + } + +This is a side-effect of C<$^W> being dynamically scoped. + +Lexical warnings get around these limitations by allowing finer control +over where warnings can or can't be tripped. + +=head2 Controlling Warnings from the Command Line + +There are three Command Line flags that can be used to control when +warnings are (or aren't) produced: + +=over 5 + +=item B<-w> + +This is the existing flag. If the lexical warnings pragma is B<not> +used in any of you code, or any of the modules that you use, this flag +will enable warnings everywhere. See L<Backward Compatibility> for +details of how this flag interacts with lexical warnings. + +=item B<-W> + +If the B<-W> flag is used on the command line, it will enable all warnings +throughout the program regardless of whether warnings were disabled +locally using C<no warning> or C<$^W =0>. This includes all files that get +included via C<use>, C<require> or C<do>. +Think of it as the Perl equivalent of the "lint" command. + +=item B<-X> + +Does the exact opposite to the B<-W> flag, i.e. it disables all warnings. + +=back + +=head2 Backward Compatibility + +If you are used with working with a version of Perl prior to the +introduction of lexically scoped warnings, or have code that uses both +lexical warnings and C<$^W>, this section will describe how they interact. + +How Lexical Warnings interact with B<-w>/C<$^W>: + +=over 5 + +=item 1. + +If none of the three command line flags (B<-w>, B<-W> or B<-X>) that +control warnings is used and neither C<$^W> or lexical warnings are used, +then default warnings will be enabled and optional warnings disabled. +This means that legacy code that doesn't attempt to control the warnings +will work unchanged. + +=item 2. + +The B<-w> flag just sets the global C<$^W> variable as in 5.005 -- this +means that any legacy code that currently relies on manipulating C<$^W> +to control warning behavior will still work as is. + +=item 3. + +Apart from now being a boolean, the C<$^W> variable operates in exactly +the same horrible uncontrolled global way, except that it cannot +disable/enable default warnings. + +=item 4. + +If a piece of code is under the control of the lexical warning pragma, +both the C<$^W> variable and the B<-w> flag will be ignored for the +scope of the lexical warning. + +=item 5. + +The only way to override a lexical warnings setting is with the B<-W> +or B<-X> command line flags. + +=back + +The combined effect of 3 & 4 is that it will will allow code which uses +the lexical warning pragma to control the warning behavior of $^W-type +code (using a C<local $^W=0>) if it really wants to, but not vice-versa. + +=head1 EXPERIMENTAL FEATURES + +The features described in this section are experimental, and so subject +to change. + +=head2 Category Hierarchy + +A tentative hierarchy of "categories" have been defined to allow groups +of warnings to be enabled/disabled in isolation. The current +hierarchy is: + + all - +--- unsafe -------+--- taint + | | + | +--- substr + | | + | +--- signal + | | + | +--- closure + | | + | +--- untie + | | + | +--- utf8 + | + +--- io ---------+--- pipe + | | + | +--- unopened + | | + | +--- closed + | | + | +--- newline + | | + | +--- exec + | + +--- syntax ----+--- ambiguous + | | + | +--- semicolon + | | + | +--- precedence + | | + | +--- reserved + | | + | +--- octal + | | + | +--- parenthesis + | | + | +--- deprecated + | | + | +--- printf + | + +--- severe ----+--- inplace + | | + | +--- internal + | | + | +--- debugging + | + |--- uninitialized + | + +--- void + | + +--- recursion + | + +--- redefine + | + +--- numeric + | + +--- once + | + +--- misc + + +Just like the "strict" pragma any of these categories can be +combined + + use warning qw(void redefine) ; + no warning qw(io syntax untie) ; + +=head2 Fatal Warnings + +This feature is B<very> experimental. + +The presence of the word "FATAL" in the category list will escalate any +warnings from the category specified that are detected in the lexical +scope into fatal errors. In the code below, there are 3 places where +a deprecated warning will be detected, the middle one will produce a +fatal error. + + + use warning ; + + $a = 1 if $a EQ $b ; + + { + use warning qw(FATAL deprecated) ; + $a = 1 if $a EQ $b ; + } + + $a = 1 if $a EQ $b ; + +=head1 TODO + +The experimental features need bottomed out. + + perl5db.pl + The debugger saves and restores C<$^W> at runtime. I haven't checked + whether the debugger will still work with the lexical warnings + patch applied. + + diagnostics.pm + I *think* I've got diagnostics to work with the lexical warnings + patch, but there were design decisions made in diagnostics to work + around the limitations of C<$^W>. Now that those limitations are gone, + the module should be revisited. + + +=head1 SEE ALSO + +L<warning>. + +=head1 AUTHOR + +Paul Marquess diff --git a/pod/perlmodlib.pod b/pod/perlmodlib.pod index 4cee4556b6..79892344df 100644 --- a/pod/perlmodlib.pod +++ b/pod/perlmodlib.pod @@ -30,6 +30,7 @@ by saying: no integer; no strict 'refs'; + no warning; which lasts until the end of that BLOCK. @@ -125,6 +126,10 @@ turn on UTF-8 and Unicode support predeclare global variable names +=item warning + +control optional warnings + =item vmsish control VMS-specific language features diff --git a/pod/perlrun.pod b/pod/perlrun.pod index c71b9f3ca4..8a511ae930 100644 --- a/pod/perlrun.pod +++ b/pod/perlrun.pod @@ -4,7 +4,7 @@ perlrun - how to execute the Perl interpreter =head1 SYNOPSIS -B<perl> S<[ B<-sTuU> ]> +B<perl> S<[ B<-sTuUWX> ]> S<[ B<-hv> ] [ B<-V>[:I<configvar>] ]> S<[ B<-cw> ] [ B<-d>[:I<debugger>] ] [ B<-D>[I<number/list>] ]> S<[ B<-pna> ] [ B<-F>I<pattern> ] [ B<-l>[I<octal>] ] [ B<-0>[I<octal>] ]> @@ -695,6 +695,16 @@ facility is also available if you want to manipulate entire classes of warnings; see L<warning> (or better yet, its source code) about that. +=item B<-W> + +Enables all warnings regardless of +See L<perllexwarn>. + +=item B<-X> + +Disables all warnings regardless of +See L<perllexwarn>. + =item B<-x> I<directory> tells Perl that the program is embedded in a larger chunk of unrelated diff --git a/pod/perlvar.pod b/pod/perlvar.pod index 9402608daf..c13c41742b 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -688,6 +688,13 @@ of perl in the right bracket?) Example: See also the documentation of C<use VERSION> and C<require VERSION> for a convenient way to fail if the running Perl interpreter is too old. +=item $^B + +The current set of warning checks enabled by C<use warning>. +See the documentation of C<warning> for more details. + +Used by lexical warnings to store the + =item $COMPILING =item $^C @@ -3198,8 +3198,9 @@ PP(pp_reverse) up = (char*)s; s += UTF8SKIP(s); down = (char*)(s - 1); - if (s > send || !((*down & 0xc0) == 0x80)) { - Perl_warn(aTHX_ "Malformed UTF-8 character"); + if ((s > send || !((*down & 0xc0) == 0x80)) && + ckWARN_d(WARN_UTF8)) { + Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); break; } while (down > up) { @@ -2984,9 +2984,13 @@ PP(pp_require) SAVEHINTS(); PL_hints = 0; SAVEPPTR(PL_compiling.cop_warnings); - PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL - : WARN_NONE); - + if (PL_dowarn & G_WARN_ALL_ON) + PL_compiling.cop_warnings = WARN_ALL ; + else if (PL_dowarn & G_WARN_ALL_OFF) + PL_compiling.cop_warnings = WARN_NONE ; + else + PL_compiling.cop_warnings = WARN_STD ; + /* switch to eval mode */ push_return(PL_op->op_next); @@ -3048,8 +3052,7 @@ PP(pp_entereval) SAVEHINTS(); PL_hints = PL_op->op_targ; SAVEPPTR(PL_compiling.cop_warnings); - if (PL_compiling.cop_warnings != WARN_ALL - && PL_compiling.cop_warnings != WARN_NONE){ + if (!specialWARN(PL_compiling.cop_warnings)) { PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ; SAVEFREESV(PL_compiling.cop_warnings) ; } @@ -39,8 +39,8 @@ Perl_runops_debug(pTHX) { #ifdef DEBUGGING dTHR; - if (!PL_op) { - Perl_warn(aTHX_ "NULL OP IN RUN"); + if (!PL_op && ckWARN_d(WARN_DEBUGGING)) { + Perl_warner(aTHX_ WARN_DEBUGGING, "NULL OP IN RUN"); return 0; } @@ -205,7 +205,9 @@ S_del_sv(pTHX_ SV *p) ok = 1; } if (!ok) { - Perl_warn(aTHX_ "Attempt to free non-arena SV: 0x%lx", (unsigned long)p); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, + "Attempt to free non-arena SV: 0x%lx", (unsigned long)p); return; } } @@ -2966,10 +2968,11 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN void Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) { + dTHR; U32 refcnt = SvREFCNT(sv); SV_CHECK_THINKFIRST(sv); - if (SvREFCNT(nsv) != 1) - Perl_warn(aTHX_ "Reference miscount in sv_replace()"); + if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()"); if (SvMAGICAL(sv)) { if (SvMAGICAL(nsv)) mg_free(nsv); @@ -3186,6 +3189,7 @@ Perl_sv_newref(pTHX_ SV *sv) void Perl_sv_free(pTHX_ SV *sv) { + dTHR; int refcount_is_zero; if (!sv) @@ -3200,7 +3204,8 @@ Perl_sv_free(pTHX_ SV *sv) SvREFCNT(sv) = (~(U32)0)/2; return; } - Perl_warn(aTHX_ "Attempt to free unreferenced scalar"); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar"); return; } ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv)); @@ -3208,7 +3213,9 @@ Perl_sv_free(pTHX_ SV *sv) return; #ifdef DEBUGGING if (SvTEMP(sv)) { - Perl_warn(aTHX_ "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv); + if (ckWARN_d(WARN_DEBUGGING)) + Perl_warner(aTHX_ WARN_DEBUGGING, + "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv); return; } #endif @@ -3314,7 +3321,9 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) ++len; } if (s != send) { - Perl_warn(aTHX_ "Malformed UTF-8 character"); + dTHR; + if (ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); --len; } *offsetp = len; @@ -4051,12 +4060,14 @@ Perl_newRV(pTHX_ SV *tmpRef) SV * Perl_newSVsv(pTHX_ register SV *old) { + dTHR; register SV *sv; if (!old) return Nullsv; if (SvTYPE(old) == SVTYPEMASK) { - Perl_warn(aTHX_ "semi-panic: attempt to dup freed string"); + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string"); return Nullsv; } new_SV(sv); diff --git a/t/pragma/warn/3both b/t/pragma/warn/3both index 7c3260126b..1d7deb8636 100644 --- a/t/pragma/warn/3both +++ b/t/pragma/warn/3both @@ -18,6 +18,20 @@ Use of uninitialized value at - line 6. # Check interaction of $^W and use warning sub fred { + use warning ; + my $b ; + chop $b ; +} +{ $^W = 0 ; + fred() ; +} + +EXPECT +Use of uninitialized value at - line 6. +######## + +# Check interaction of $^W and use warning +sub fred { no warning ; my $b ; chop $b ; @@ -27,7 +41,21 @@ sub fred { } EXPECT -Use of uninitialized value at - line 6. + +######## + +# Check interaction of $^W and use warning +sub fred { + no warning ; + my $b ; + chop $b ; +} +{ $^W = 1 ; + fred() ; +} + +EXPECT + ######## # Check interaction of $^W and use warning @@ -54,7 +82,7 @@ no warning ; my $b ; chop $b ; EXPECT -Use of uninitialized value at - line 6. + ######## # Check interaction of $^W and use warning @@ -63,4 +91,107 @@ $^W = 1 ; my $b ; chop $b ; EXPECT + +######## +-w +# Check interaction of $^W and use warning +no warning ; +my $b ; +chop $b ; +EXPECT + +######## +-w +# Check interaction of $^W and use warning +use warning ; +my $b ; +chop $b ; +EXPECT +Use of uninitialized value at - line 5. +######## + +# Check interaction of $^W and use warning +sub fred { + use warning ; + my $b ; + chop $b ; +} +BEGIN { $^W = 0 } +fred() ; +EXPECT +Use of uninitialized value at - line 6. +######## + +# Check interaction of $^W and use warning +sub fred { + no warning ; + my $b ; + chop $b ; +} +BEGIN { $^W = 1 } +fred() ; + +EXPECT + +######## + +# Check interaction of $^W and use warning +use warning ; +BEGIN { $^W = 1 } +my $b ; +chop $b ; +EXPECT Use of uninitialized value at - line 6. +######## + +# Check interaction of $^W and use warning +BEGIN { $^W = 1 } +use warning ; +my $b ; +chop $b ; +EXPECT +Use of uninitialized value at - line 6. +######## + +# Check interaction of $^W and use warning +BEGIN { $^W = 1 } +no warning ; +my $b ; +chop $b ; +EXPECT + +######## + +# Check interaction of $^W and use warning +no warning ; +BEGIN { $^W = 1 } +my $b ; +chop $b ; +EXPECT + +######## + +# Check interaction of $^W and use warning +BEGIN { $^W = 1 } +{ + no warning ; + my $b ; + chop $b ; +} +my $b ; +chop $b ; +EXPECT +Use of uninitialized value at - line 10. +######## + +# Check interaction of $^W and use warning +BEGIN { $^W = 0 } +{ + use warning ; + my $b ; + chop $b ; +} +my $b ; +chop $b ; +EXPECT +Use of uninitialized value at - line 7. diff --git a/t/pragma/warn/6default b/t/pragma/warn/6default new file mode 100644 index 0000000000..c095b20827 --- /dev/null +++ b/t/pragma/warn/6default @@ -0,0 +1,34 @@ +Check default warnings + +__END__ +# default warning should be displayed if you don't add anything +# optional shouldn't +my $a = oct "7777777777777777777777777777777777779" ; +EXPECT +Integer overflow in octal number at - line 3. +######## +# no warning should be displayed +no warning ; +my $a = oct "7777777777777777777777777777777777779" ; +EXPECT +######## +# all warning should be displayed +use warning ; +my $a = oct "7777777777777777777777777777777777779" ; +EXPECT +Integer overflow in octal number at - line 3. +Illegal octal digit '9' ignored at - line 3. +######## +# check scope +use warning ; +my $a = oct "7777777777777777777777777777777777779" ; +{ + no warning ; + my $a = oct "7777777777777777777777777777777777779" ; +} +my $c = oct "7777777777777777777777777777777777779" ; +EXPECT +Integer overflow in octal number at - line 3. +Illegal octal digit '9' ignored at - line 3. +Integer overflow in octal number at - line 8. +Illegal octal digit '9' ignored at - line 8. diff --git a/t/pragma/warn/av b/t/pragma/warn/av new file mode 100644 index 0000000000..79bd3b7600 --- /dev/null +++ b/t/pragma/warn/av @@ -0,0 +1,9 @@ + av.c + + Mandatory Warnings ALL TODO + ------------------ + av_reify called on tied array [av_reify] + + Attempt to clear deleted array [av_clear] + +__END__ diff --git a/t/pragma/warn/doio b/t/pragma/warn/doio index 97f0804bfa..5bcca8d78c 100644 --- a/t/pragma/warn/doio +++ b/t/pragma/warn/doio @@ -41,29 +41,50 @@ Can't exec \"%s\": %s + Mandatory Warnings ALL TODO + ------------------ + Can't do inplace edit: %s is not a regular file + edit a directory + + Can't do inplace edit: %s would not be unique + Can't rename %s to %s: %s, skipping file + Can't rename %s to %s: %s, skipping file + Can't remove %s: %s, skipping file + Can't do inplace edit on %s: %s + + __END__ # doio.c use warning 'io' ; open(F, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); close(F); +no warning 'io' ; +open(G, '|'.($^O eq 'VMS' ? 'mcr ':'')."$^X -e 1|"); +close(G); EXPECT Can't do bidirectional pipe at - line 3. ######## # doio.c use warning 'io' ; -open(F, "| ") +open(F, "| "); +no warning 'io' ; +open(G, "| "); EXPECT Missing command in piped open at - line 3. ######## # doio.c use warning 'io' ; -open(F, " |") +open(F, " |"); +no warning 'io' ; +open(G, " |"); EXPECT Missing command in piped open at - line 3. ######## # doio.c use warning 'io' ; -open(F, "<true\ncd") +open(F, "<true\ncd"); +no warning 'io' ; +open(G, "<true\ncd"); EXPECT Unsuccessful open on filename containing newline at - line 3. ######## @@ -74,6 +95,12 @@ tell(STDIN); $a = seek(STDIN,1,1); $a = sysseek(STDIN,1,1); -x STDIN ; +no warning 'io' ; +close STDIN ; +tell(STDIN); +$a = seek(STDIN,1,1); +$a = sysseek(STDIN,1,1); +-x STDIN ; EXPECT tell() on unopened file at - line 4. seek() on unopened file at - line 5. @@ -83,6 +110,8 @@ Stat on unopened file <STDIN> at - line 7. # doio.c use warning 'uninitialized' ; print $a ; +no warning 'uninitialized' ; +print $b ; EXPECT Use of uninitialized value at - line 3. ######## @@ -96,6 +125,9 @@ EXPECT use warning 'io' ; stat "ab\ncd"; lstat "ab\ncd"; +no warning 'io' ; +stat "ab\ncd"; +lstat "ab\ncd"; EXPECT Unsuccessful stat on filename containing newline at - line 3. Unsuccessful stat on filename containing newline at - line 4. @@ -103,6 +135,8 @@ Unsuccessful stat on filename containing newline at - line 4. # doio.c use warning 'io' ; exec "lskdjfalksdjfdjfkls","" ; +no warning 'io' ; +exec "lskdjfalksdjfdjfkls","" ; EXPECT OPTION regex Can't exec "lskdjfalksdjfdjfkls": .+ @@ -110,6 +144,36 @@ Can't exec "lskdjfalksdjfdjfkls": .+ # doio.c use warning 'io' ; exec "lskdjfalksdjfdjfkls", "abc" ; +no warning 'io' ; +exec "lskdjfalksdjfdjfkls", "abc" ; EXPECT OPTION regex Can't exec "lskdjfalksdjfdjfkls(:? abc)?": .+ +######## +# doio.c +$^W = 0 ; +my $filename = "./temp" ; +mkdir $filename, 0777 + or die "Cannot create directory $filename: $!\n" ; +{ + local (@ARGV) = ($filename) ; + local ($^I) = "" ; + my $x = <> ; +} +{ + no warning 'inplace' ; + local (@ARGV) = ($filename) ; + local ($^I) = "" ; + my $x = <> ; +} +{ + use warning 'inplace' ; + local (@ARGV) = ($filename) ; + local ($^I) = "" ; + my $x = <> ; +} +rmdir $filename ; +EXPECT +Can't do inplace edit: ./temp is not a regular file at - line 9. +Can't do inplace edit: ./temp is not a regular file at - line 21. + diff --git a/t/pragma/warn/doop b/t/pragma/warn/doop new file mode 100644 index 0000000000..458a3b2803 --- /dev/null +++ b/t/pragma/warn/doop @@ -0,0 +1,25 @@ + doop.c AOK + + Malformed UTF-8 character + + +__END__ +# doop.c +use utf8 ; +$_ = "\x80 \xff" ; +chop ; +EXPECT +Malformed UTF-8 character at - line 4. +######## +# doop.c +use warning 'utf8' ; +use utf8 ; +$_ = "\x80 \xff" ; +chop ; +no warning 'utf8' ; +$_ = "\x80 \xff" ; +chop ; +EXPECT +\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 4. +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 4. +Malformed UTF-8 character at - line 5. diff --git a/t/pragma/warn/gv b/t/pragma/warn/gv index bd442b97d6..e33f8ca04f 100644 --- a/t/pragma/warn/gv +++ b/t/pragma/warn/gv @@ -14,7 +14,12 @@ $a = ${"#"} ; $a = ${"*"} ; + Mandatory Warnings ALL TODO + ------------------ + Had to create %s unexpectedly [gv_fetchpv] + Attempt to free unreferenced glob pointers [gp_free] + __END__ # gv.c use warning 'misc' ; @@ -24,6 +29,12 @@ Can't locate package Fred for @main::ISA at - line 3. Undefined subroutine &main::joe called at - line 3. ######## # gv.c +no warning 'misc' ; +@ISA = qw(Fred); joe() +EXPECT +Undefined subroutine &main::joe called at - line 3. +######## +# gv.c sub Other::AUTOLOAD { 1 } sub Other::fred {} @ISA = qw(Other) ; use warning 'deprecated' ; @@ -35,6 +46,9 @@ Use of inherited AUTOLOAD for non-method main::fred() is deprecated at - line 5. use warning 'deprecated' ; $a = ${"#"}; $a = ${"*"}; +no warning 'deprecated' ; +$a = ${"#"}; +$a = ${"*"}; EXPECT Use of $# is deprecated at - line 3. Use of $* is deprecated at - line 4. diff --git a/t/pragma/warn/hv b/t/pragma/warn/hv new file mode 100644 index 0000000000..c9eec028f1 --- /dev/null +++ b/t/pragma/warn/hv @@ -0,0 +1,8 @@ + hv.c + + + Mandatory Warnings ALL TODO + ------------------ + Attempt to free non-existent shared string [unsharepvn] + +__END__ diff --git a/t/pragma/warn/malloc b/t/pragma/warn/malloc new file mode 100644 index 0000000000..2f8b096a51 --- /dev/null +++ b/t/pragma/warn/malloc @@ -0,0 +1,9 @@ + malloc.c + + + Mandatory Warnings ALL TODO + ------------------ + %s free() ignored [Perl_mfree] + %s", "Bad free() ignored [Perl_mfree] + +__END__ diff --git a/t/pragma/warn/mg b/t/pragma/warn/mg index 14307e0de0..7f40ded7f8 100644 --- a/t/pragma/warn/mg +++ b/t/pragma/warn/mg @@ -6,6 +6,9 @@ SIG%s handler \"%s\" not defined. $SIG{"INT"} = "ok3"; kill "INT",$$; + Mandatory Warnings TODO + ------------------ + Can't break at that line [magic_setdbline] __END__ # mg.c @@ -15,6 +18,12 @@ EXPECT No such signal: SIGFRED at - line 3. ######## # mg.c +no warning 'signal' ; +$SIG{FRED} = sub {}; +EXPECT + +######## +# mg.c use warning 'signal' ; if ($^O eq 'MSWin32' || $^O eq 'VMS') { print "SKIPPED\n# $^O, can't kill() to raise()\n"; exit; @@ -23,3 +32,13 @@ $|=1; $SIG{"INT"} = "fred"; kill "INT",$$; EXPECT SIGINT handler "fred" not defined. +######## +# mg.c +no warning 'signal' ; +if ($^O eq 'MSWin32' || $^O eq 'VMS') { + print "SKIPPED\n# win32, can't kill() to raise()\n"; exit; +} +$|=1; +$SIG{"INT"} = "fred"; kill "INT",$$; +EXPECT + diff --git a/t/pragma/warn/op b/t/pragma/warn/op index 7c2b6b8050..dce52d8c93 100644 --- a/t/pragma/warn/op +++ b/t/pragma/warn/op @@ -98,11 +98,27 @@ defined %h ; my %h ; defined %h ; + Mandatory Warnings + ------------------ + Prototype mismatch: [cv_ckproto] + sub fred() ; + sub fred($) {} + + %s never introduced [pad_leavemy] TODO + Runaway prototype [newSUB] TODO + oops: oopsAV [oopsAV] TODO + oops: oopsHV [oopsHV] TODO + + + + __END__ # op.c use warning 'unsafe' ; my $x ; my $x ; +no warning 'unsafe' ; +my $x ; EXPECT "my" variable $x masks earlier declaration in same scope at - line 4. ######## @@ -118,6 +134,17 @@ EXPECT Variable "$x" will not stay shared at - line 7. ######## # op.c +no warning 'unsafe' ; +sub x { + my $x; + sub y { + $x + } + } +EXPECT + +######## +# op.c use warning 'unsafe' ; sub x { my $x; @@ -129,20 +156,37 @@ EXPECT Variable "$x" may be unavailable at - line 6. ######## # op.c +no warning 'unsafe' ; +sub x { + my $x; + sub y { + sub { $x } + } + } +EXPECT + +######## +# op.c use warning 'syntax' ; 1 if $a = 1 ; +no warning 'syntax' ; +1 if $a = 1 ; EXPECT Found = in conditional, should be == at - line 3. ######## # op.c use warning 'deprecated' ; split ; +no warning 'deprecated' ; +split ; EXPECT Use of implicit split to @_ is deprecated at - line 3. ######## # op.c use warning 'deprecated' ; $a = split ; +no warning 'deprecated' ; +$a = split ; EXPECT Use of implicit split to @_ is deprecated at - line 3. ######## @@ -239,8 +283,65 @@ Useless use of getpwnam in void context at - line 52. Useless use of getpwuid in void context at - line 53. ######## # op.c +no warning 'void' ; close STDIN ; +1 x 3 ; # OP_REPEAT + # OP_GVSV +wantarray ; # OP_WANTARRAY + # OP_GV + # OP_PADSV + # OP_PADAV + # OP_PADHV + # OP_PADANY + # OP_AV2ARYLEN +ref ; # OP_REF +\@a ; # OP_REFGEN +\$a ; # OP_SREFGEN +defined $a ; # OP_DEFINED +hex $a ; # OP_HEX +oct $a ; # OP_OCT +length $a ; # OP_LENGTH +substr $a,1 ; # OP_SUBSTR +vec $a,1,2 ; # OP_VEC +index $a,1,2 ; # OP_INDEX +rindex $a,1,2 ; # OP_RINDEX +sprintf $a ; # OP_SPRINTF +$a[0] ; # OP_AELEM + # OP_AELEMFAST +@a[0] ; # OP_ASLICE +#values %a ; # OP_VALUES +#keys %a ; # OP_KEYS +$a{0} ; # OP_HELEM +@a{0} ; # OP_HSLICE +unpack "a", "a" ; # OP_UNPACK +pack $a,"" ; # OP_PACK +join "" ; # OP_JOIN +(@a)[0,1] ; # OP_LSLICE + # OP_ANONLIST + # OP_ANONHASH +sort(1,2) ; # OP_SORT +reverse(1,2) ; # OP_REVERSE + # OP_RANGE + # OP_FLIP +(1 ..2) ; # OP_FLOP +caller ; # OP_CALLER +fileno STDIN ; # OP_FILENO +eof STDIN ; # OP_EOF +tell STDIN ; # OP_TELL +readlink 1; # OP_READLINK +time ; # OP_TIME +localtime ; # OP_LOCALTIME +gmtime ; # OP_GMTIME +eval { getgrnam 1 }; # OP_GGRNAM +eval { getgrgid 1 }; # OP_GGRGID +eval { getpwnam 1 }; # OP_GPWNAM +eval { getpwuid 1 }; # OP_GPWUID +EXPECT +######## +# op.c use warning 'void' ; for (@{[0]}) { "$_" } # check warning isn't duplicated +no warning 'void' ; +for (@{[0]}) { "$_" } # check warning isn't duplicated EXPECT Useless use of string in void context at - line 3. ######## @@ -257,6 +358,8 @@ EOM } } telldir 1 ; # OP_TELLDIR +no warning 'void' ; +telldir 1 ; # OP_TELLDIR EXPECT Useless use of telldir in void context at - line 13. ######## @@ -273,6 +376,8 @@ EOM } } getppid ; # OP_GETPPID +no warning 'void' ; +getppid ; # OP_GETPPID EXPECT Useless use of getppid in void context at - line 13. ######## @@ -289,6 +394,8 @@ EOM } } getpgrp ; # OP_GETPGRP +no warning 'void' ; +getpgrp ; # OP_GETPGRP EXPECT Useless use of getpgrp in void context at - line 13. ######## @@ -305,6 +412,8 @@ EOM } } times ; # OP_TMS +no warning 'void' ; +times ; # OP_TMS EXPECT Useless use of times in void context at - line 13. ######## @@ -321,6 +430,8 @@ EOM } } getpriority 1,2; # OP_GETPRIORITY +no warning 'void' ; +getpriority 1,2; # OP_GETPRIORITY EXPECT Useless use of getpriority in void context at - line 13. ######## @@ -337,6 +448,8 @@ EOM } } getlogin ; # OP_GETLOGIN +no warning 'void' ; +getlogin ; # OP_GETLOGIN EXPECT Useless use of getlogin in void context at - line 13. ######## @@ -377,6 +490,22 @@ getprotoent ; # OP_GPROTOENT getservbyname 1,2; # OP_GSBYNAME getservbyport 1,2; # OP_GSBYPORT getservent ; # OP_GSERVENT + +no warning 'void' ; +getsockname STDIN ; # OP_GETSOCKNAME +getpeername STDIN ; # OP_GETPEERNAME +gethostbyname 1 ; # OP_GHBYNAME +gethostbyaddr 1,2; # OP_GHBYADDR +gethostent ; # OP_GHOSTENT +getnetbyname 1 ; # OP_GNBYNAME +getnetbyaddr 1,2 ; # OP_GNBYADDR +getnetent ; # OP_GNETENT +getprotobyname 1; # OP_GPBYNAME +getprotobynumber 1; # OP_GPBYNUMBER +getprotoent ; # OP_GPROTOENT +getservbyname 1,2; # OP_GSBYNAME +getservbyport 1,2; # OP_GSBYPORT +getservent ; # OP_GSERVENT INIT { # some functions may not be there, so we exit without running exit; @@ -403,6 +532,11 @@ use warning 'void' ; $a ; # OP_RV2SV @a ; # OP_RV2AV %a ; # OP_RV2HV +no warning 'void' ; +*a ; # OP_RV2GV +$a ; # OP_RV2SV +@a ; # OP_RV2AV +%a ; # OP_RV2HV EXPECT Useless use of a variable in void context at - line 3. Useless use of a variable in void context at - line 4. @@ -413,6 +547,9 @@ Useless use of a variable in void context at - line 6. use warning 'void' ; "abc"; # OP_CONST 7 ; # OP_CONST +no warning 'void' ; +"abc"; # OP_CONST +7 ; # OP_CONST EXPECT Useless use of a constant in void context at - line 3. Useless use of a constant in void context at - line 4. @@ -432,6 +569,22 @@ my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; %$c =~ /abc/ ; %$c =~ s/a/b/ ; %$c =~ tr/a/b/ ; +{ +no warning 'unsafe' ; +my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; +@a =~ /abc/ ; +@a =~ s/a/b/ ; +@a =~ tr/a/b/ ; +@$b =~ /abc/ ; +@$b =~ s/a/b/ ; +@$b =~ tr/a/b/ ; +%a =~ /abc/ ; +%a =~ s/a/b/ ; +%a =~ tr/a/b/ ; +%$c =~ /abc/ ; +%$c =~ s/a/b/ ; +%$c =~ tr/a/b/ ; +} EXPECT Applying pattern match to @array will act on scalar(@array) at - line 4. Applying substitution to @array will act on scalar(@array) at - line 5. @@ -446,23 +599,29 @@ Applying character translation to %hash will act on scalar(%hash) at - line 12. Applying pattern match to %hash will act on scalar(%hash) at - line 13. Applying substitution to %hash will act on scalar(%hash) at - line 14. Applying character translation to %hash will act on scalar(%hash) at - line 15. -Execution of - aborted due to compilation errors. +BEGIN not safe after errors--compilation aborted at - line 17. ######## # op.c use warning 'syntax' ; my $a, $b = (1,2); +no warning 'syntax' ; +my $c, $d = (1,2); EXPECT Parentheses missing around "my" list at - line 3. ######## # op.c use warning 'syntax' ; local $a, $b = (1,2); +no warning 'syntax' ; +local $c, $d = (1,2); EXPECT Parentheses missing around "local" list at - line 3. ######## # op.c use warning 'syntax' ; print (ABC || 1) ; +no warning 'syntax' ; +print (ABC || 1) ; EXPECT Probable precedence problem on logical or at - line 3. ######## @@ -473,6 +632,8 @@ Probable precedence problem on logical or at - line 3. use warning 'unsafe' ; open FH, "<abc" ; $x = 1 if $x = <FH> ; +no warning 'unsafe' ; +$x = 1 if $x = <FH> ; EXPECT Value of <HANDLE> construct can be "0"; test with defined() at - line 4. ######## @@ -480,6 +641,8 @@ Value of <HANDLE> construct can be "0"; test with defined() at - line 4. use warning 'unsafe' ; opendir FH, "." ; $x = 1 if $x = readdir FH ; +no warning 'unsafe' ; +$x = 1 if $x = readdir FH ; closedir FH ; EXPECT Value of readdir() operator can be "0"; test with defined() at - line 4. @@ -487,6 +650,8 @@ Value of readdir() operator can be "0"; test with defined() at - line 4. # op.c use warning 'unsafe' ; $x = 1 if $x = <*> ; +no warning 'unsafe' ; +$x = 1 if $x = <*> ; EXPECT Value of glob construct can be "0"; test with defined() at - line 3. ######## @@ -494,12 +659,16 @@ Value of glob construct can be "0"; test with defined() at - line 3. use warning 'unsafe' ; %a = (1,2,3,4) ; $x = 1 if $x = each %a ; +no warning 'unsafe' ; +$x = 1 if $x = each %a ; EXPECT Value of each() operator can be "0"; test with defined() at - line 4. ######## # op.c use warning 'unsafe' ; $x = 1 while $x = <*> and 0 ; +no warning 'unsafe' ; +$x = 1 while $x = <*> and 0 ; EXPECT Value of glob construct can be "0"; test with defined() at - line 3. ######## @@ -507,6 +676,8 @@ Value of glob construct can be "0"; test with defined() at - line 3. use warning 'unsafe' ; opendir FH, "." ; $x = 1 while $x = readdir FH and 0 ; +no warning 'unsafe' ; +$x = 1 while $x = readdir FH and 0 ; closedir FH ; EXPECT Value of readdir() operator can be "0"; test with defined() at - line 4. @@ -515,6 +686,8 @@ Value of readdir() operator can be "0"; test with defined() at - line 4. use warning 'redefine' ; sub fred {} sub fred {} +no warning 'redefine' ; +sub fred {} EXPECT Subroutine fred redefined at - line 4. ######## @@ -522,6 +695,8 @@ Subroutine fred redefined at - line 4. use warning 'redefine' ; sub fred () { 1 } sub fred () { 1 } +no warning 'redefine' ; +sub fred () { 1 } EXPECT Constant subroutine fred redefined at - line 4. ######## @@ -531,18 +706,25 @@ format FRED = . format FRED = . +no warning 'redefine' ; +format FRED = +. EXPECT Format FRED redefined at - line 5. ######## # op.c use warning 'syntax' ; push FRED; +no warning 'syntax' ; +push FRED; EXPECT Array @FRED missing the @ in argument 1 of push() at - line 3. ######## # op.c use warning 'syntax' ; @a = keys FRED ; +no warning 'syntax' ; +@a = keys FRED ; EXPECT Hash %FRED missing the % in argument 1 of keys() at - line 3. ######## @@ -588,3 +770,35 @@ my %h; defined(%h); EXPECT defined(%hash) is deprecated at - line 3. (Maybe you should just omit the defined()?) +######## +# op.c +no warning 'syntax' ; +exec "$^X -e 1" ; +my $a +EXPECT + +######## +# op.c +sub fred(); +sub fred($) {} +EXPECT +Prototype mismatch: sub main::fred () vs ($) at - line 3. +######## +# op.c +$^W = 0 ; +sub fred() ; +sub fred($) {} +{ + no warning 'unsafe' ; + sub Fred() ; + sub Fred($) {} + use warning 'unsafe' ; + sub freD() ; + sub freD($) {} +} +sub FRED() ; +sub FRED($) {} +EXPECT +Prototype mismatch: sub main::fred () vs ($) at - line 4. +Prototype mismatch: sub main::freD () vs ($) at - line 11. +Prototype mismatch: sub main::FRED () vs ($) at - line 14. diff --git a/t/pragma/warn/perl b/t/pragma/warn/perl index 5211990902..25f125e03d 100644 --- a/t/pragma/warn/perl +++ b/t/pragma/warn/perl @@ -3,10 +3,55 @@ gv_check(defstash) Name \"%s::%s\" used only once: possible typo + Mandatory Warnings All TODO + ------------------ + Recompile perl with -DDEBUGGING to use -D switch [moreswitches] + Unbalanced scopes: %ld more ENTERs than LEAVEs [perl_destruct] + Unbalanced saves: %ld more saves than restores [perl_destruct] + Unbalanced tmps: %ld more allocs than frees [perl_destruct] + Unbalanced context: %ld more PUSHes than POPs [perl_destruct] + Unbalanced string table refcount: (%d) for \"%s\" [perl_destruct] + Scalars leaked: %ld [perl_destruct] + __END__ # perl.c +no warning 'once' ; +$x = 3 ; use warning 'once' ; +$z = 3 ; +EXPECT +Name "main::z" used only once: possible typo at - line 5. +######## +-w +# perl.c $x = 3 ; +no warning 'once' ; +$z = 3 EXPECT Name "main::x" used only once: possible typo at - line 3. +######## +# perl.c +BEGIN { $^W =1 ; } +$x = 3 ; +no warning 'once' ; +$z = 3 +EXPECT +Name "main::x" used only once: possible typo at - line 3. +######## +-W +# perl.c +no warning 'once' ; +$x = 3 ; +use warning 'once' ; +$z = 3 ; +EXPECT +Name "main::x" used only once: possible typo at - line 4. +Name "main::z" used only once: possible typo at - line 6. +######## +-X +# perl.c +use warning 'once' ; +$x = 3 ; +EXPECT + diff --git a/t/pragma/warn/perlio b/t/pragma/warn/perlio new file mode 100644 index 0000000000..18c0dfa89f --- /dev/null +++ b/t/pragma/warn/perlio @@ -0,0 +1,10 @@ + perlio.c + + + Mandatory Warnings ALL TODO + ------------------ + Setting cnt to %d + Setting ptr %p > end+1 %p + Setting cnt to %d, ptr implies %d + +__END__ diff --git a/t/pragma/warn/perly b/t/pragma/warn/perly index fd420d3b22..bddc39c716 100644 --- a/t/pragma/warn/perly +++ b/t/pragma/warn/perly @@ -18,6 +18,12 @@ do fred(1) ; $a = "fred" ; do $a() ; do $a(1) ; +no warning 'deprecated' ; +do fred() ; +do fred(1) ; +$a = "fred" ; +do $a() ; +do $a(1) ; EXPECT Use of "do" to call subroutines is deprecated at - line 4. Use of "do" to call subroutines is deprecated at - line 5. diff --git a/t/pragma/warn/pp b/t/pragma/warn/pp index 7a3b28991c..9baf9c14b0 100644 --- a/t/pragma/warn/pp +++ b/t/pragma/warn/pp @@ -25,14 +25,21 @@ Explicit blessing to '' (assuming package main) bless \[], ""; - Constant subroutine %s undefined <<< - Constant subroutine (anonymous) undefined <<< + Constant subroutine %s undefined <<<TODO + Constant subroutine (anonymous) undefined <<<TODO + + Mandatory Warnings + ------------------ + Malformed UTF-8 character __END__ # pp.c use warning 'substr' ; $a = "ab" ; -$a = substr($a, 4,5) +$a = substr($a, 4,5); +no warning 'substr' ; +$a = "ab" ; +$a = substr($a, 4,5); EXPECT substr outside of string at - line 4. ######## @@ -41,6 +48,8 @@ use warning 'substr' ; $a = "ab" ; $b = \$a ; substr($b, 1,1) = "ab" ; +no warning 'substr' ; +substr($b, 1,1) = "ab" ; EXPECT Attempt to use reference as lvalue in substr at - line 5. ######## @@ -53,6 +62,8 @@ EXPECT # pp.c use warning 'unsafe' ; my $a = { 1,2,3}; +no warning 'unsafe' ; +my $b = { 1,2,3}; EXPECT Odd number of elements in hash assignment at - line 3. ######## @@ -60,6 +71,9 @@ Odd number of elements in hash assignment at - line 3. use warning 'unsafe' ; my @a = unpack ("A,A", "22") ; my $a = pack ("A,A", 1,2) ; +no warning 'unsafe' ; +my @b = unpack ("A,A", "22") ; +my $b = pack ("A,A", 1,2) ; EXPECT Invalid type in unpack: ',' at - line 3. Invalid type in pack: ',' at - line 4. @@ -67,7 +81,9 @@ Invalid type in pack: ',' at - line 4. # pp.c use warning 'uninitialized' ; my $a = undef ; -my $b = $$a +my $b = $$a; +no warning 'uninitialized' ; +my $c = $$a; EXPECT Use of uninitialized value at - line 4. ######## @@ -75,11 +91,35 @@ Use of uninitialized value at - line 4. use warning 'unsafe' ; sub foo { my $a = "a"; return $a . $a++ . $a++ } my $a = pack("p", &foo) ; +no warning 'unsafe' ; +my $b = pack("p", &foo) ; EXPECT Attempt to pack pointer to temporary value at - line 4. ######## # pp.c use warning 'unsafe' ; bless \[], "" ; +no warning 'unsafe' ; +bless \[], "" ; EXPECT Explicit blessing to '' (assuming package main) at - line 3. +######## +# pp.c +use utf8 ; +$_ = "\x80 \xff" ; +reverse ; +EXPECT +Malformed UTF-8 character at - line 4. +######## +# pp.c +use warning 'utf8' ; +use utf8 ; +$_ = "\x80 \xff" ; +reverse ; +no warning 'utf8' ; +$_ = "\x80 \xff" ; +reverse ; +EXPECT +\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 4. +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 4. +Malformed UTF-8 character at - line 5. diff --git a/t/pragma/warn/pp_ctl b/t/pragma/warn/pp_ctl index 5a1c2338ed..4d6d8ca2af 100644 --- a/t/pragma/warn/pp_ctl +++ b/t/pragma/warn/pp_ctl @@ -71,6 +71,16 @@ Not enough format arguments at - line 5. 1 ######## # pp_ctl.c +no warning 'syntax' ; +format = +@<<< @<<< +1 +. +write ; +EXPECT +1 +######## +# pp_ctl.c use warning 'unsafe' ; $_ = "abc" ; @@ -78,6 +88,11 @@ while ($i ++ == 0) { s/ab/last/e ; } +no warning 'unsafe' ; +while ($i ++ == 0) +{ + s/ab/last/e ; +} EXPECT Exiting substitution via last at - line 7. ######## @@ -85,12 +100,20 @@ Exiting substitution via last at - line 7. use warning 'unsafe' ; sub fred { last } { fred() } +no warning 'unsafe' ; +sub joe { last } +{ joe() } EXPECT Exiting subroutine via last at - line 3. ######## # pp_ctl.c -use warning 'unsafe' ; -{ eval "last;" } +{ + eval "use warning 'unsafe' ; last;" +} +print STDERR $@ ; +{ + eval "no warning 'unsafe' ;last;" +} print STDERR $@ ; EXPECT Exiting eval via last at (eval 1) line 1. @@ -99,6 +122,8 @@ Exiting eval via last at (eval 1) line 1. use warning 'unsafe' ; @a = (1,2) ; @b = sort { last } @a ; +no warning 'unsafe' ; +@b = sort { last } @a ; EXPECT Exiting pseudo-block via last at - line 4. Can't "last" outside a block at - line 4. @@ -111,6 +136,11 @@ while ($i ++ == 0) { s/ab/last fred/e ; } +no warning 'unsafe' ; +while ($i ++ == 0) +{ + s/ab/last fred/e ; +} EXPECT Exiting substitution via last at - line 7. ######## @@ -118,12 +148,18 @@ Exiting substitution via last at - line 7. use warning 'unsafe' ; sub fred { last joe } joe: { fred() } +no warning 'unsafe' ; +sub Fred { last Joe } +Joe: { Fred() } EXPECT Exiting subroutine via last at - line 3. ######## # pp_ctl.c -use warning 'unsafe' ; -joe: { eval "last joe;" } +joe: +{ eval "use warning 'unsafe' ; last joe;" } +print STDERR $@ ; +Joe: +{ eval "no warning 'unsafe' ; last Joe;" } print STDERR $@ ; EXPECT Exiting eval via last at (eval 1) line 1. @@ -132,6 +168,8 @@ Exiting eval via last at (eval 1) line 1. use warning 'unsafe' ; @a = (1,2) ; fred: @b = sort { last fred } @a ; +no warning 'unsafe' ; +Fred: @b = sort { last Fred } @a ; EXPECT Exiting pseudo-block via last at - line 4. Label not found for "last fred" at - line 4. @@ -149,6 +187,18 @@ EXPECT Deep recursion on subroutine "main::fred" at - line 6. ######## # pp_ctl.c +no warning 'recursion' ; +BEGIN { warn "PREFIX\n" ;} +sub fred +{ + goto &fred() if $a++ < 200 +} + +goto &fred() +EXPECT +Can't find label +######## +# pp_ctl.c use warning 'unsafe' ; package Foo; DESTROY { die "@{$_[0]} foo bar" } @@ -157,3 +207,12 @@ DESTROY { die "@{$_[0]} foo bar" } EXPECT (in cleanup) A foo bar at - line 4. (in cleanup) B foo bar at - line 4. +######## +# pp_ctl.c +no warning 'unsafe' ; +package Foo; +DESTROY { die "@{$_[0]} foo bar" } +{ bless ['A'], 'Foo' for 1..10 } +{ bless ['B'], 'Foo' for 1..10 } +EXPECT + diff --git a/t/pragma/warn/pp_hot b/t/pragma/warn/pp_hot index 817c0c89d6..60490bcd6a 100644 --- a/t/pragma/warn/pp_hot +++ b/t/pragma/warn/pp_hot @@ -37,7 +37,9 @@ __END__ # pp_hot.c use warning 'unopened' ; $f = $a = "abc" ; -print $f $a +print $f $a; +no warning 'unopened' ; +print $f $a; EXPECT Filehandle main::abc never opened at - line 4. ######## @@ -50,6 +52,8 @@ open(FOO, ">&STDOUT") and print <FOO>; print getc(STDERR); print getc(FOO); read(FOO,$_,1); +no warning 'io' ; +print STDIN "anc"; EXPECT Filehandle main::STDIN opened only for input at - line 3. Filehandle main::STDOUT opened only for output at - line 4. @@ -63,38 +67,50 @@ Filehandle main::FOO opened only for output at - line 9. use warning 'closed' ; close STDIN ; print STDIN "anc"; +no warning 'closed' ; +print STDIN "anc"; EXPECT print on closed filehandle main::STDIN at - line 4. ######## # pp_hot.c use warning 'uninitialized' ; my $a = undef ; -my @b = @$a +my @b = @$a; +no warning 'uninitialized' ; +my @c = @$a; EXPECT Use of uninitialized value at - line 4. ######## # pp_hot.c use warning 'uninitialized' ; my $a = undef ; -my %b = %$a +my %b = %$a; +no warning 'uninitialized' ; +my %c = %$a; EXPECT Use of uninitialized value at - line 4. ######## # pp_hot.c use warning 'unsafe' ; my %X ; %X = (1,2,3) ; +no warning 'unsafe' ; +my %Y ; %Y = (1,2,3) ; EXPECT Odd number of elements in hash assignment at - line 3. ######## # pp_hot.c use warning 'unsafe' ; my %X ; %X = [1 .. 3] ; +no warning 'unsafe' ; +my %Y ; %Y = [1 .. 3] ; EXPECT Reference found where even-sized list expected at - line 3. ######## # pp_hot.c use warning 'closed' ; close STDIN ; $a = <STDIN> ; +no warning 'closed' ; +$a = <STDIN> ; EXPECT Read on closed filehandle main::STDIN at - line 3. ######## @@ -114,6 +130,21 @@ EXPECT ok ######## # pp_hot.c +no warning 'recursion' ; +sub fred +{ + fred() if $a++ < 200 +} +{ + local $SIG{__WARN__} = sub { + die "ok\n" if $_[0] =~ /^Deep recursion on subroutine "main::fred"/ + }; + fred(); +} +EXPECT + +######## +# pp_hot.c use warning 'recursion' ; $b = sub { @@ -123,3 +154,14 @@ $b = sub &$b ; EXPECT Deep recursion on anonymous subroutine at - line 5. +######## +# pp_hot.c +no warning 'recursion' ; +$b = sub +{ + &$b if $a++ < 200 +} ; + +&$b ; +EXPECT + diff --git a/t/pragma/warn/pp_sys b/t/pragma/warn/pp_sys index 82d1501147..bf64a940e1 100644 --- a/t/pragma/warn/pp_sys +++ b/t/pragma/warn/pp_sys @@ -82,6 +82,9 @@ use warning 'untie' ; sub TIESCALAR { bless [] } ; $b = tie $a, 'main'; untie $a ; +no warning 'untie' ; +$c = tie $d, 'main'; +untie $d ; EXPECT untie attempted while 1 inner references still exist at - line 5. ######## @@ -90,6 +93,8 @@ use warning 'io' ; format STDIN = . write STDIN; +no warning 'io' ; +write STDIN; EXPECT Filehandle main::STDIN opened only for input at - line 5. ######## @@ -99,6 +104,8 @@ format STDIN = . close STDIN; write STDIN; +no warning 'closed' ; +write STDIN; EXPECT Write on closed filehandle main::STDIN at - line 6. ######## @@ -115,26 +122,34 @@ $= = 1 ; $- =1 ; open STDOUT, ">".($^O eq 'VMS'? 'NL:' : '/dev/null') ; write ; +no warning 'io' ; +write ; EXPECT page overflow at - line 13. ######## # pp_sys.c use warning 'unopened' ; $a = "abc"; -printf $a "fred" +printf $a "fred"; +no warning 'unopened' ; +printf $a "fred"; EXPECT Filehandle main::abc never opened at - line 4. ######## # pp_sys.c use warning 'closed' ; close STDIN ; -printf STDIN "fred" +printf STDIN "fred"; +no warning 'closed' ; +printf STDIN "fred"; EXPECT printf on closed filehandle main::STDIN at - line 4. ######## # pp_sys.c use warning 'io' ; -printf STDIN "fred" +printf STDIN "fred"; +no warning 'io' ; +printf STDIN "fred"; EXPECT Filehandle main::STDIN opened only for input at - line 3. ######## @@ -142,6 +157,8 @@ Filehandle main::STDIN opened only for input at - line 3. use warning 'closed' ; close STDIN; syswrite STDIN, "fred", 1; +no warning 'closed' ; +syswrite STDIN, "fred", 1; EXPECT Syswrite on closed filehandle at - line 4. ######## @@ -176,6 +193,17 @@ setsockopt STDIN, 1,2,3; getsockopt STDIN, 1,2; getsockname STDIN; getpeername STDIN; +no warning 'io' ; +send STDIN, "fred", 1; +bind STDIN, "fred" ; +connect STDIN, "fred" ; +listen STDIN, 2; +accept STDIN, "fred" ; +shutdown STDIN, 0; +setsockopt STDIN, 1,2,3; +getsockopt STDIN, 1,2; +getsockname STDIN; +getpeername STDIN; EXPECT Send on closed socket at - line 22. bind() on closed fd at - line 23. @@ -191,6 +219,8 @@ get{sock, peer}name() on closed fd at - line 31. # pp_sys.c use warning 'newline' ; stat "abc\ndef"; +no warning 'newline' ; +stat "abc\ndef"; EXPECT Unsuccessful stat on filename containing newline at - line 3. ######## @@ -198,11 +228,15 @@ Unsuccessful stat on filename containing newline at - line 3. use warning 'unopened' ; close STDIN ; -T STDIN ; +no warning 'unopened' ; +-T STDIN ; EXPECT Test on unopened file <STDIN> at - line 4. ######## # pp_sys.c use warning 'newline' ; -T "abc\ndef" ; +no warning 'newline' ; +-T "abc\ndef" ; EXPECT Unsuccessful open on filename containing newline at - line 3. diff --git a/t/pragma/warn/regcomp b/t/pragma/warn/regcomp index 52a163a2f5..4b2f7ff2ba 100644 --- a/t/pragma/warn/regcomp +++ b/t/pragma/warn/regcomp @@ -19,6 +19,8 @@ __END__ use warning 'unsafe' ; my $a = "ABC123" ; $a =~ /(?=a)*/ ; +no warning 'unsafe' ; +$a =~ /(?=a)*/ ; EXPECT (?=a)* matches null string many times at - line 4. ######## @@ -26,6 +28,8 @@ EXPECT use warning 'unsafe' ; $_ = "" ; /(?=a)?/; +no warning 'unsafe' ; +/(?=a)?/; EXPECT Strange *+?{} on zero-length expression at - line 4. ######## @@ -35,6 +39,10 @@ $_ = "" ; /[a[:xyz:]b]/; /[a[.xyz.]b]/; /[a[=xyz=]b]/; +no warning 'unsafe' ; +/[a[:xyz:]b]/; +/[a[.xyz.]b]/; +/[a[=xyz=]b]/; EXPECT Character class syntax [: :] is reserved for future extensions at - line 4. Character class syntax [. .] is reserved for future extensions at - line 5. @@ -47,6 +55,10 @@ $_ = "" ; /[a[:xyz:]b]/; /[a[.xyz.]b]/; /[a[=xyz=]b]/; +no warning 'unsafe' ; +/[a[:xyz:]b]/; +/[a[.xyz.]b]/; +/[a[=xyz=]b]/; EXPECT Character class syntax [: :] is reserved for future extensions at - line 5. Character class syntax [. .] is reserved for future extensions at - line 6. diff --git a/t/pragma/warn/regexec b/t/pragma/warn/regexec index 6d4ec320e7..ce4eac7083 100644 --- a/t/pragma/warn/regexec +++ b/t/pragma/warn/regexec @@ -42,6 +42,32 @@ Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9. ######## # regexec.c print("SKIPPED\n# most systems run into stacksize limits\n"),exit; +no warning 'unsafe' ; +$SIG{__WARN__} = sub{local ($m) = shift; + $m =~ s/\(\d+\)/(*MASKED*)/; + print STDERR $m}; +$_ = 'a' x (2**15+1); +/^()(a\1)*$/ ; +# +# If this test fails with a segmentation violation or similar, +# you may have to increase the default stacksize limit in your +# shell. You may need superuser privileges. +# +# Under the sh, ksh, zsh: +# $ ulimit -s +# 8192 +# $ ulimit -s 16000 +# +# Under the csh: +# % limit stacksize +# stacksize 8192 kbytes +# % limit stacksize 16000 +# +EXPECT + +######## +# regexec.c +print("SKIPPED\n# most systems run into stacksize limits\n"),exit; use warning 'unsafe' ; $SIG{__WARN__} = sub{local ($m) = shift; $m =~ s/\(\d+\)/(*MASKED*)/; @@ -65,3 +91,29 @@ $_ = 'a' x (2**15+1); # EXPECT Complex regular subexpression recursion limit (*MASKED*) exceeded at - line 9. +######## +# regexec.c +print("SKIPPED\n# most systems run into stacksize limits\n"),exit; +no warning 'unsafe' ; +$SIG{__WARN__} = sub{local ($m) = shift; + $m =~ s/\(\d+\)/(*MASKED*)/; + print STDERR $m}; +$_ = 'a' x (2**15+1); +/^()(a\1)*?$/ ; +# +# If this test fails with a segmentation violation or similar, +# you may have to increase the default stacksize limit in your +# shell. You may need superuser privileges. +# +# Under the sh, ksh, zsh: +# $ ulimit -s +# 8192 +# $ ulimit -s 16000 +# +# Under the csh: +# % limit stacksize +# stacksize 8192 kbytes +# % limit stacksize 16000 +# +EXPECT + diff --git a/t/pragma/warn/run b/t/pragma/warn/run new file mode 100644 index 0000000000..7a4be20e70 --- /dev/null +++ b/t/pragma/warn/run @@ -0,0 +1,8 @@ + run.c + + + Mandatory Warnings ALL TODO + ------------------ + NULL OP IN RUN + +__END__ diff --git a/t/pragma/warn/sv b/t/pragma/warn/sv index f3c530f884..0421192104 100644 --- a/t/pragma/warn/sv +++ b/t/pragma/warn/sv @@ -1,4 +1,4 @@ - sv.c AOK + sv.c warn(warn_uninit); @@ -32,12 +32,27 @@ Undefined value assigned to typeglob + Mandatory Warnings + ------------------ + Malformed UTF-8 character [sv_pos_b2u] + my $a = rindex "a\xff bc ", "bc" ; + + Mandatory Warnings TODO + ------------------ + Attempt to free non-arena SV: 0x%lx [del_sv] + Reference miscount in sv_replace() [sv_replace] + Attempt to free unreferenced scalar [sv_free] + Attempt to free temp prematurely: SV 0x%lx [sv_free] + semi-panic: attempt to dup freed string [newSVsv] + __END__ # sv.c use integer ; use warning 'uninitialized' ; $x = 1 + $a[0] ; # a +no warning 'uninitialized' ; +$x = 1 + $b[0] ; # a EXPECT Use of uninitialized value at - line 4. ######## @@ -51,6 +66,8 @@ tie $A, 'fred' ; use integer ; use warning 'uninitialized' ; $A *= 2 ; +no warning 'uninitialized' ; +$A *= 2 ; EXPECT Use of uninitialized value at - line 10. ######## @@ -58,6 +75,8 @@ Use of uninitialized value at - line 10. use integer ; use warning 'uninitialized' ; my $x *= 2 ; #b +no warning 'uninitialized' ; +my $y *= 2 ; #b EXPECT Use of uninitialized value at - line 4. ######## @@ -71,25 +90,35 @@ tie $A, 'fred' ; use warning 'uninitialized' ; $B = 0 ; $B |= $A ; +no warning 'uninitialized' ; +$B = 0 ; +$B |= $A ; EXPECT Use of uninitialized value at - line 10. ######## # sv.c use warning 'uninitialized' ; my $Y = 1 ; -my $x = 1 | $a[$Y] +my $x = 1 | $a[$Y] ; +no warning 'uninitialized' ; +my $Y = 1 ; +$x = 1 | $b[$Y] ; EXPECT Use of uninitialized value at - line 4. ######## # sv.c use warning 'uninitialized' ; my $x *= 1 ; # d +no warning 'uninitialized' ; +my $y *= 1 ; # d EXPECT Use of uninitialized value at - line 3. ######## # sv.c use warning 'uninitialized' ; $x = 1 + $a[0] ; # e +no warning 'uninitialized' ; +$x = 1 + $b[0] ; # e EXPECT Use of uninitialized value at - line 3. ######## @@ -102,24 +131,32 @@ package main ; tie $A, 'fred' ; use warning 'uninitialized' ; $A *= 2 ; +no warning 'uninitialized' ; +$A *= 2 ; EXPECT Use of uninitialized value at - line 9. ######## # sv.c use warning 'uninitialized' ; $x = $y + 1 ; # f +no warning 'uninitialized' ; +$x = $z + 1 ; # f EXPECT Use of uninitialized value at - line 3. ######## # sv.c use warning 'uninitialized' ; $x = chop undef ; # g +no warning 'uninitialized' ; +$x = chop undef ; # g EXPECT Modification of a read-only value attempted at - line 3. ######## # sv.c use warning 'uninitialized' ; $x = chop $y ; # h +no warning 'uninitialized' ; +$x = chop $z ; # h EXPECT Use of uninitialized value at - line 3. ######## @@ -133,6 +170,9 @@ tie $A, 'fred' ; use warning 'uninitialized' ; $B = "" ; $B .= $A ; +no warning 'uninitialized' ; +$C = "" ; +$C .= $A ; EXPECT Use of uninitialized value at - line 10. ######## @@ -141,13 +181,17 @@ use warning 'numeric' ; sub TIESCALAR{bless[]} ; sub FETCH {"def"} ; tie $a,"main" ; -my $b = 1 + $a +my $b = 1 + $a; +no warning 'numeric' ; +my $c = 1 + $a; EXPECT Argument "def" isn't numeric in add at - line 6. ######## # sv.c use warning 'numeric' ; my $x = 1 + "def" ; +no warning 'numeric' ; +my $z = 1 + "def" ; EXPECT Argument "def" isn't numeric in add at - line 3. ######## @@ -155,6 +199,8 @@ Argument "def" isn't numeric in add at - line 3. use warning 'numeric' ; my $a = "def" ; my $x = 1 + $a ; +no warning 'numeric' ; +my $y = 1 + $a ; EXPECT Argument "def" isn't numeric in add at - line 4. ######## @@ -162,12 +208,16 @@ Argument "def" isn't numeric in add at - line 4. use warning 'numeric' ; use integer ; my $a = "def" ; my $x = 1 + $a ; +no warning 'numeric' ; +my $z = 1 + $a ; EXPECT Argument "def" isn't numeric in i_add at - line 4. ######## # sv.c use warning 'numeric' ; my $x = 1 & "def" ; +no warning 'numeric' ; +my $z = 1 & "def" ; EXPECT Argument "def" isn't numeric in bit_and at - line 3. ######## @@ -176,6 +226,9 @@ use warning 'redefine' ; sub fred {} sub joe {} *fred = \&joe ; +no warning 'redefine' ; +sub jim {} +*jim = \&joe ; EXPECT Subroutine fred redefined at - line 5. ######## @@ -188,6 +241,13 @@ printf F "%" ; $a = sprintf "%" ; printf F "%\x02" ; $a = sprintf "%\x02" ; +no warning 'printf' ; +printf F "%q\n" ; +$a = sprintf "%q" ; +printf F "%" ; +$a = sprintf "%" ; +printf F "%\x02" ; +$a = sprintf "%\x02" ; EXPECT Invalid conversion in sprintf: "%q" at - line 5. Invalid conversion in sprintf: end of string at - line 7. @@ -199,5 +259,22 @@ Invalid conversion in printf: "%\002" at - line 8. # sv.c use warning 'unsafe' ; *a = undef ; +no warning 'unsafe' ; +*b = undef ; EXPECT Undefined value assigned to typeglob at - line 3. +######## +# sv.c +use utf8 ; +$^W =0 ; +{ + use warning 'utf8' ; + my $a = rindex "a\xff bc ", "bc" ; + no warning 'utf8' ; + $a = rindex "a\xff bc ", "bc" ; +} +my $a = rindex "a\xff bc ", "bc" ; +EXPECT +\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 6. +Malformed UTF-8 character at - line 6. +Malformed UTF-8 character at - line 10. diff --git a/t/pragma/warn/taint b/t/pragma/warn/taint index 40fadd0913..17ab0423c6 100644 --- a/t/pragma/warn/taint +++ b/t/pragma/warn/taint @@ -1,25 +1,49 @@ - taint.c TODO + taint.c AOK - Insecure %s%s while running setuid - Insecure %s%s while running setgid Insecure %s%s while running with -T switch - - Insecure directory in %s%s while running setuid - Insecure directory in %s%s while running setgid - Insecure directory in %s%s while running with -T switch - - - __END__ +-T +--FILE-- abc +def +--FILE-- # taint.c -use warning 'misc' ; - +open(FH, "<abc") ; +$a = <FH> ; +close FH ; +chdir $a ; +print "xxx\n" ; EXPECT - +Insecure dependency in chdir while running with -T switch at - line 5. ######## +-TU +--FILE-- abc +def +--FILE-- # taint.c -use warning 'misc' ; - +open(FH, "<abc") ; +$a = <FH> ; +close FH ; +chdir $a ; +print "xxx\n" ; EXPECT - +xxx +######## +-TU +--FILE-- abc +def +--FILE-- +# taint.c +open(FH, "<abc") ; +$a = <FH> ; +close FH ; +use warning 'taint' ; +chdir $a ; +print "xxx\n" ; +no warning 'taint' ; +chdir $a ; +print "yyy\n" ; +EXPECT +Insecure dependency in chdir while running with -T switch at - line 6. +xxx +yyy diff --git a/t/pragma/warn/toke b/t/pragma/warn/toke index da6c0dc9ae..72c1e2fddc 100644 --- a/t/pragma/warn/toke +++ b/t/pragma/warn/toke @@ -97,6 +97,21 @@ toke.c AOK use utf8 ; $_ = "\xffe" + Mandatory Warnings + ------------------ + Use of "%s" without parentheses is ambiguous [check_uni] + rand + 4 + + Ambiguous use of -%s resolved as -&%s() [yylex] + sub fred {} ; - fred ; + + Precedence problem: open %.*s should be open(%.*s) [yylex] + open FOO || die; + + Operator or semicolon missing before %c%s [yylex] + Ambiguous use of %c resolved as operator %c + *foo *foo + __END__ # toke.c use warning 'deprecated' ; @@ -106,6 +121,13 @@ use warning 'deprecated' ; 1 if $a LT $b ; 1 if $a GE $b ; 1 if $a LE $b ; +no warning 'deprecated' ; +1 if $a EQ $b ; +1 if $a NE $b ; +1 if $a GT $b ; +1 if $a LT $b ; +1 if $a GE $b ; +1 if $a LE $b ; EXPECT Use of EQ is deprecated at - line 3. Use of NE is deprecated at - line 4. @@ -120,24 +142,31 @@ format STDOUT = @<<< @||| @>>> @>>> $a $b "abc" 'def' . -($a, $b) = (1,2,3); -write; +no warning 'deprecated' ; +format STDOUT = +@<<< @||| @>>> @>>> +$a $b "abc" 'def' +. EXPECT Use of comma-less variable list is deprecated at - line 5. Use of comma-less variable list is deprecated at - line 5. Use of comma-less variable list is deprecated at - line 5. -1 2 abc def ######## # toke.c use warning 'deprecated' ; $a = <<; +no warning 'deprecated' ; +$a = <<; + EXPECT Use of bare << to mean <<"" is deprecated at - line 3. ######## # toke.c use warning 'syntax' ; s/(abc)/\1/; +no warning 'syntax' ; +s/(abc)/\1/; EXPECT \1 better written as $1 at - line 3. ######## @@ -145,6 +174,9 @@ EXPECT use warning 'semicolon' ; $a = 1 &time ; +no warning 'semicolon' ; +$a = 1 +&time ; EXPECT Semicolon seems to be missing at - line 3. ######## @@ -180,14 +212,40 @@ Reversed <= operator at - line 15. Unterminated <> operator at - line 15. ######## # toke.c +BEGIN { + # Scalars leaked: due to syntax errors + $ENV{PERL_DESTRUCT_LEVEL} = 0 unless $ENV{PERL_DESTRUCT_LEVEL} > 3; +} +no warning 'syntax' ; +my $a =+ 2 ; +$a =- 2 ; +$a =* 2 ; +$a =% 2 ; +$a =& 2 ; +$a =. 2 ; +$a =^ 2 ; +$a =| 2 ; +$a =< 2 ; +$a =/ 2 ; +EXPECT +syntax error at - line 12, near "=." +syntax error at - line 13, near "=^" +syntax error at - line 14, near "=|" +Unterminated <> operator at - line 15. +######## +# toke.c use warning 'syntax' ; my $a = $a[1,2] ; +no warning 'syntax' ; +my $a = $a[1,2] ; EXPECT Multidimensional syntax $a[1,2] not supported at - line 3. ######## # toke.c use warning 'syntax' ; sub fred {} ; $SIG{TERM} = fred; +no warning 'syntax' ; +$SIG{TERM} = fred; EXPECT You need to quote "fred" at - line 3. ######## @@ -195,6 +253,9 @@ You need to quote "fred" at - line 3. use warning 'syntax' ; @a[3] = 2; @a{3} = 2; +no warning 'syntax' ; +@a[3] = 2; +@a{3} = 2; EXPECT Scalar value @a[3] better written as $a[3] at - line 3. Scalar value @a{3} better written as $a{3} at - line 4. @@ -203,36 +264,49 @@ Scalar value @a{3} better written as $a{3} at - line 4. use warning 'syntax' ; $_ = "ab" ; s/(ab)/\1/e; +no warning 'syntax' ; +$_ = "ab" ; +s/(ab)/\1/e; EXPECT Can't use \1 to mean $1 in expression at - line 4. ######## # toke.c use warning 'reserved' ; $a = abc; +no warning 'reserved' ; +$a = abc; EXPECT Unquoted string "abc" may clash with future reserved word at - line 3. ######## # toke.c use warning 'octal' ; chmod 3; +no warning 'octal' ; +chmod 3; EXPECT chmod: mode argument is missing initial 0 at - line 3, at end of line ######## # toke.c use warning 'syntax' ; @a = qw(a, b, c) ; +no warning 'syntax' ; +@a = qw(a, b, c) ; EXPECT Possible attempt to separate words with commas at - line 3. ######## # toke.c use warning 'syntax' ; @a = qw(a b #) ; +no warning 'syntax' ; +@a = qw(a b #) ; EXPECT Possible attempt to put comments in qw() list at - line 3. ######## # toke.c use warning 'octal' ; umask 3; +no warning 'octal' ; +umask 3; EXPECT umask: argument is missing initial 0 at - line 3, at end of line ######## @@ -243,20 +317,40 @@ EXPECT print (...) interpreted as function at - line 3. ######## # toke.c +no warning 'syntax' ; +print ("") +EXPECT + +######## +# toke.c use warning 'syntax' ; printf ("") EXPECT printf (...) interpreted as function at - line 3. ######## # toke.c +no warning 'syntax' ; +printf ("") +EXPECT + +######## +# toke.c use warning 'syntax' ; sort ("") EXPECT sort (...) interpreted as function at - line 3. ######## # toke.c +no warning 'syntax' ; +sort ("") +EXPECT + +######## +# toke.c use warning 'ambiguous' ; $a = ${time[2]}; +no warning 'ambiguous' ; +$a = ${time[2]}; EXPECT Ambiguous use of ${time[...]} resolved to $time[...] at - line 3. ######## @@ -267,8 +361,16 @@ EXPECT Ambiguous use of ${time{...}} resolved to $time{...} at - line 3. ######## # toke.c +no warning 'ambiguous' ; +$a = ${time{2}}; +EXPECT + +######## +# toke.c use warning 'ambiguous' ; $a = ${time} ; +no warning 'ambiguous' ; +$a = ${time} ; EXPECT Ambiguous use of ${time} resolved to $time at - line 3. ######## @@ -276,6 +378,8 @@ Ambiguous use of ${time} resolved to $time at - line 3. use warning 'ambiguous' ; sub fred {} $a = ${fred} ; +no warning 'ambiguous' ; +$a = ${fred} ; EXPECT Ambiguous use of ${fred} resolved to $fred at - line 4. ######## @@ -283,6 +387,9 @@ Ambiguous use of ${fred} resolved to $fred at - line 4. use warning 'syntax' ; $a = 1_2; $a = 1_2345_6; +no warning 'syntax' ; +$a = 1_2; +$a = 1_2345_6; EXPECT Misplaced _ in number at - line 3. Misplaced _ in number at - line 4. @@ -292,13 +399,18 @@ Misplaced _ in number at - line 4. use warning 'unsafe' ; #line 25 "bar" $a = FRED:: ; +no warning 'unsafe' ; +#line 25 "bar" +$a = FRED:: ; EXPECT Bareword "FRED::" refers to nonexistent package at bar line 25. ######## # toke.c use warning 'ambiguous' ; sub time {} -my $a = time() +my $a = time() ; +no warning 'ambiguous' ; +my $b = time() ; EXPECT Ambiguous call resolved as CORE::time(), qualify as such or use & at - line 4. ######## @@ -314,8 +426,101 @@ EXPECT Use of \x{} without utf8 declaration at foo line 30. ######## # toke.c +no warning 'utf8' ; +eval <<'EOE'; +{ +#line 30 "foo" + $_ = " \x{123} " ; +} +EOE +EXPECT + +######## +# toke.c use warning 'utf8' ; use utf8 ; $_ = " \xffe " ; +no warning 'utf8' ; +$_ = " \xffe " ; EXPECT \xff will produce malformed UTF-8 character; use \x{ff} for that at - line 4. +######## +# toke.c +my $a = rand + 4 ; +EXPECT +Warning: Use of "rand" without parens is ambiguous at - line 2. +######## +# toke.c +$^W = 0 ; +my $a = rand + 4 ; +{ + no warning 'ambiguous' ; + $a = rand + 4 ; + use warning 'ambiguous' ; + $a = rand + 4 ; +} +$a = rand + 4 ; +EXPECT +Warning: Use of "rand" without parens is ambiguous at - line 3. +Warning: Use of "rand" without parens is ambiguous at - line 8. +Warning: Use of "rand" without parens is ambiguous at - line 10. +######## +# toke.c +sub fred {}; +-fred ; +EXPECT +Ambiguous use of -fred resolved as -&fred() at - line 3. +######## +# toke.c +$^W = 0 ; +sub fred {} ; +-fred ; +{ + no warning 'ambiguous' ; + -fred ; + use warning 'ambiguous' ; + -fred ; +} +-fred ; +EXPECT +Ambiguous use of -fred resolved as -&fred() at - line 4. +Ambiguous use of -fred resolved as -&fred() at - line 9. +Ambiguous use of -fred resolved as -&fred() at - line 11. +######## +# toke.c +open FOO || time; +EXPECT +Precedence problem: open FOO should be open(FOO) at - line 2. +######## +# toke.c +$^W = 0 ; +open FOO || time; +{ + no warning 'ambiguous' ; + open FOO || time; + use warning 'ambiguous' ; + open FOO || time; +} +open FOO || time; +EXPECT +Precedence problem: open FOO should be open(FOO) at - line 3. +Precedence problem: open FOO should be open(FOO) at - line 8. +Precedence problem: open FOO should be open(FOO) at - line 10. +######## +# toke.c +$^W = 0 ; +*foo *foo ; +{ + no warning 'ambiguous' ; + *foo *foo ; + use warning 'ambiguous' ; + *foo *foo ; +} +*foo *foo ; +EXPECT +Operator or semicolon missing before *foo at - line 3. +Ambiguous use of * resolved as operator * at - line 3. +Operator or semicolon missing before *foo at - line 8. +Ambiguous use of * resolved as operator * at - line 8. +Operator or semicolon missing before *foo at - line 10. +Ambiguous use of * resolved as operator * at - line 10. diff --git a/t/pragma/warn/universal b/t/pragma/warn/universal index e2814e11c4..37e77195ca 100644 --- a/t/pragma/warn/universal +++ b/t/pragma/warn/universal @@ -1,4 +1,4 @@ - universal.c + universal.c TODO Can't locate package %s for @%s::ISA diff --git a/t/pragma/warn/utf8 b/t/pragma/warn/utf8 new file mode 100644 index 0000000000..380d53bbcc --- /dev/null +++ b/t/pragma/warn/utf8 @@ -0,0 +1,56 @@ + + utf8.c AOK + + All Mandatory warnings + + [utf8_to_uv] + Malformed UTF-8 character + my $a = ord "\x80" ; + + Malformed UTF-8 character + my $a = ord "\xf080" ; + + [utf16_to_utf8] + Malformed UTF-16 surrogate + <<<<<< Add a test when somethig actually calls utf16_to_utf8 + +__END__ +# utf8.c +use utf8 ; +my $a = ord "\x80" ; +EXPECT +Malformed UTF-8 character at - line 3. +######## +# utf8.c +use utf8 ; +my $a = ord "\x80" ; +{ + use warning 'utf8' ; + my $a = ord "\x80" ; + no warning 'utf8' ; + my $a = ord "\x80" ; +} +EXPECT +Malformed UTF-8 character at - line 3. +\x80 will produce malformed UTF-8 character; use \x{80} for that at - line 6. +Malformed UTF-8 character at - line 6. +######## +# utf8.c +use utf8 ; +my $a = ord "\xf080" ; +EXPECT +Malformed UTF-8 character at - line 3. +######## +# utf8.c +use utf8 ; +my $a = ord "\xf080" ; +{ + use warning 'utf8' ; + my $a = ord "\xf080" ; + no warning 'utf8' ; + my $a = ord "\xf080" ; +} +EXPECT +Malformed UTF-8 character at - line 3. +\xf0 will produce malformed UTF-8 character; use \x{f0} for that at - line 6. +Malformed UTF-8 character at - line 6. diff --git a/t/pragma/warn/util b/t/pragma/warn/util index d58f4b70fa..bd29f7b254 100644 --- a/t/pragma/warn/util +++ b/t/pragma/warn/util @@ -9,21 +9,74 @@ Illegal binary digit ignored my $a = oct "0b9" ; + + Mandatory Warnings + ------------------ + Integer overflow in binary number + Integer overflow in octal number + Integer overflow in hex number + __END__ # util.c use warning 'octal' ; my $a = oct "029" ; +no warning 'octal' ; +my $a = oct "029" ; EXPECT Illegal octal digit '9' ignored at - line 3. ######## # util.c use warning 'unsafe' ; *a = hex "0xv9" ; +no warning 'unsafe' ; +*a = hex "0xv9" ; EXPECT Illegal hex digit 'v' ignored at - line 3. ######## # util.c use warning 'unsafe' ; *a = oct "0b9" ; +no warning 'unsafe' ; +*a = oct "0b9" ; EXPECT Illegal binary digit '9' ignored at - line 3. +######## +# util.c +$^W =1 ; +{ + use warning 'unsafe' ; + my $a = oct "0b111111111111111111111111111111111" ; + no warning 'unsafe' ; + $a = oct "0b111111111111111111111111111111111" ; +} +my $a = oct "0b111111111111111111111111111111111" ; +EXPECT +Integer overflow in binary number at - line 5. +Integer overflow in binary number at - line 9. +######## +# util.c +$^W =1 ; +{ + use warning 'unsafe' ; + my $a = oct "777777777777777777777777777777777777" ; + no warning 'unsafe' ; + $a = oct "777777777777777777777777777777777777" ; +} +my $a = oct "777777777777777777777777777777777777" ; +EXPECT +Integer overflow in octal number at - line 5. +Integer overflow in octal number at - line 9. +######## +# util.c +$^W =1 ; +{ + use warning 'unsafe' ; + my $a = hex "ffffffffffffffffffffffffffffffff" ; + no warning 'unsafe' ; + $a = hex "ffffffffffffffffffffffffffffffff" ; +} +my $a = hex "ffffffffffffffffffffffffffffffff" ; +EXPECT +Integer overflow in hex number at - line 5. +Integer overflow in hex number at - line 9. + diff --git a/t/pragma/warning.t b/t/pragma/warning.t index 7914121ae8..73e4c8d1a8 100755 --- a/t/pragma/warning.t +++ b/t/pragma/warning.t @@ -79,7 +79,7 @@ for (@prgs){ `MCR $^X $switch $tmpfile` : $Is_MSWin32 ? `.\\perl -I../lib $switch $tmpfile 2>&1` : - `./perl $switch $tmpfile 2>&1`; + `./perl -I../lib $switch $tmpfile 2>&1`; my $status = $?; $results =~ s/\n+$//; # allow expected output to be written as if $prog is on STDIN @@ -465,6 +465,7 @@ S_check_uni(pTHX) char *s; char ch; char *t; + dTHR; if (PL_oldoldbufptr != PL_last_uni) return; @@ -473,10 +474,14 @@ S_check_uni(pTHX) for (s = PL_last_uni; isALNUM_lazy(s) || *s == '-'; s++) ; if ((t = strchr(s, '(')) && t < PL_bufptr) return; - ch = *s; - *s = '\0'; - Perl_warn(aTHX_ "Warning: Use of \"%s\" without parens is ambiguous", PL_last_uni); - *s = ch; + if (ckWARN_d(WARN_AMBIGUOUS)){ + ch = *s; + *s = '\0'; + Perl_warner(aTHX_ WARN_AMBIGUOUS, + "Warning: Use of \"%s\" without parens is ambiguous", + PL_last_uni); + *s = ch; + } } #ifdef CRIPPLED_CC @@ -1433,10 +1438,12 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) if (!SvUPGRADE(datasv, SVt_PVIO)) Perl_die(aTHX_ "Can't upgrade filter_add data to SVt_PVIO"); IoDIRP(datasv) = (DIR*)funcp; /* stash funcp into spare field */ +#ifdef DEBUGGING if (PL_filter_debug) { STRLEN n_a; Perl_warn(aTHX_ "filter_add func %p (%s)", funcp, SvPV(datasv, n_a)); } +#endif /* DEBUGGING */ av_unshift(PL_rsfp_filters, 1); av_store(PL_rsfp_filters, 0, datasv) ; return(datasv); @@ -1447,8 +1454,10 @@ Perl_filter_add(pTHX_ filter_t funcp, SV *datasv) void Perl_filter_del(pTHX_ filter_t funcp) { +#ifdef DEBUGGING if (PL_filter_debug) Perl_warn(aTHX_ "filter_del func %p", funcp); +#endif /* DEBUGGING */ if (!PL_rsfp_filters || AvFILLp(PL_rsfp_filters)<0) return; /* if filter is on top of stack (usual case) just pop it off */ @@ -1478,8 +1487,10 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) if (idx > AvFILLp(PL_rsfp_filters)){ /* Any more filters? */ /* Provide a default input filter to make life easy. */ /* Note that we append to the line. This is handy. */ +#ifdef DEBUGGING if (PL_filter_debug) Perl_warn(aTHX_ "filter_read %d: from rsfp\n", idx); +#endif /* DEBUGGING */ if (maxlen) { /* Want a block */ int len ; @@ -1507,17 +1518,21 @@ Perl_filter_read(pTHX_ int idx, SV *buf_sv, int maxlen) } /* Skip this filter slot if filter has been deleted */ if ( (datasv = FILTER_DATA(idx)) == &PL_sv_undef){ +#ifdef DEBUGGING if (PL_filter_debug) Perl_warn(aTHX_ "filter_read %d: skipped (filter deleted)\n", idx); +#endif /* DEBUGGING */ return FILTER_READ(idx+1, buf_sv, maxlen); /* recurse */ } /* Get function pointer hidden within datasv */ funcp = (filter_t)IoDIRP(datasv); +#ifdef DEBUGGING if (PL_filter_debug) { STRLEN n_a; Perl_warn(aTHX_ "filter_read %d: via function %p (%s)\n", idx, funcp, SvPV(datasv,n_a)); } +#endif /* DEBUGGING */ /* Call function. The function is expected to */ /* call "FILTER_READ(idx+1, buf_sv)" first. */ /* Return: <0:error, =0:eof, >0:not eof */ @@ -3188,8 +3203,9 @@ Perl_yylex(pTHX) if (gv && GvCVu(gv)) { CV* cv; - if (lastchar == '-') - Perl_warn(aTHX_ "Ambiguous use of -%s resolved as -&%s()", + if (lastchar == '-' && ckWARN_d(WARN_AMBIGUOUS)) + Perl_warner(aTHX_ WARN_AMBIGUOUS, + "Ambiguous use of -%s resolved as -&%s()", PL_tokenbuf, PL_tokenbuf); /* Check for a constant sub */ cv = GvCV(gv); @@ -3243,10 +3259,13 @@ Perl_yylex(pTHX) } safe_bareword: - if (lastchar && strchr("*%&", lastchar)) { - Perl_warn(aTHX_ "Operator or semicolon missing before %c%s", + if (lastchar && strchr("*%&", lastchar) && + ckWARN_d(WARN_AMBIGUOUS)) { + Perl_warner(aTHX_ WARN_AMBIGUOUS, + "Operator or semicolon missing before %c%s", lastchar, PL_tokenbuf); - Perl_warn(aTHX_ "Ambiguous use of %c resolved as operator %c", + Perl_warner(aTHX_ WARN_AMBIGUOUS, + "Ambiguous use of %c resolved as operator %c", lastchar, lastchar); } TOKEN(WORD); @@ -3736,9 +3755,10 @@ Perl_yylex(pTHX) char *t; for (d = s; isALNUM_lazy(d); d++) ; t = skipspace(d); - if (strchr("|&*+-=!?:.", *t)) - Perl_warn(aTHX_ "Precedence problem: open %.*s should be open(%.*s)", - d-s,s, d-s,s); + if (strchr("|&*+-=!?:.", *t) && ckWARN_d(WARN_AMBIGUOUS)) + Perl_warner(aTHX_ WARN_AMBIGUOUS, + "Precedence problem: open %.*s should be open(%.*s)", + d-s,s, d-s,s); } LOP(OP_OPEN,XTERM); @@ -5983,6 +6003,7 @@ Perl_scan_num(pTHX_ char *start) UV u; I32 shift; bool overflowed = FALSE; + dTHR; /* check for hex */ if (s[1] == 'x') { @@ -6050,8 +6071,8 @@ Perl_scan_num(pTHX_ char *start) digit: n = u << shift; /* make room for the digit */ if (!overflowed && (n >> shift) != u - && !(PL_hints & HINT_NEW_BINARY)) { - Perl_warn(aTHX_ "Integer overflow in %s number", + && !(PL_hints & HINT_NEW_BINARY) && ckWARN_d(WARN_UNSAFE)) { + Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in %s number", (shift == 4) ? "hex" : ((shift == 3) ? "octal" : "binary")); overflowed = TRUE; @@ -107,7 +107,9 @@ Perl_utf8_to_uv(pTHX_ U8* s, I32* retlen) return *s; } if (!(uv & 0x40)) { - Perl_warn(aTHX_ "Malformed UTF-8 character"); + dTHR; + if (ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); if (retlen) *retlen = 1; return *s; @@ -127,7 +129,9 @@ Perl_utf8_to_uv(pTHX_ U8* s, I32* retlen) s++; while (len--) { if ((*s & 0xc0) != 0x80) { - Perl_warn(aTHX_ "Malformed UTF-8 character"); + dTHR; + if (ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character"); if (retlen) *retlen -= len + 1; return 0xfffd; @@ -203,9 +207,11 @@ Perl_utf16_to_utf8(pTHX_ U16* p, U8* d, I32 bytelen) continue; } if (uv >= 0xd800 && uv < 0xdbff) { /* surrogates */ + dTHR; int low = *p++; if (low < 0xdc00 || low >= 0xdfff) { - Perl_warn(aTHX_ "Malformed UTF-16 surrogate"); + if (ckWARN_d(WARN_UTF8)) + Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-16 surrogate"); p--; uv = 0xfffd; } @@ -2752,9 +2752,10 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) register UV retval = 0; bool overflowed = FALSE; while (len && *s >= '0' && *s <= '1') { + dTHR; register UV n = retval << 1; - if (!overflowed && (n >> 1) != retval) { - Perl_warn(aTHX_ "Integer overflow in binary number"); + if (!overflowed && (n >> 1) != retval && ckWARN_d(WARN_UNSAFE)) { + Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in binary number"); overflowed = TRUE; } retval = n | (*s++ - '0'); @@ -2776,9 +2777,10 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) bool overflowed = FALSE; while (len && *s >= '0' && *s <= '7') { + dTHR; register UV n = retval << 3; - if (!overflowed && (n >> 3) != retval) { - Perl_warn(aTHX_ "Integer overflow in octal number"); + if (!overflowed && (n >> 3) != retval && ckWARN_d(WARN_UNSAFE)) { + Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in octal number"); overflowed = TRUE; } retval = n | (*s++ - '0'); @@ -2816,9 +2818,12 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) } } n = retval << 4; - if (!overflowed && (n >> 4) != retval) { - Perl_warn(aTHX_ "Integer overflow in hex number"); - overflowed = TRUE; + { + dTHR; + if (!overflowed && (n >> 4) != retval && ckWARN_d(WARN_UNSAFE)) { + Perl_warner(aTHX_ WARN_UNSAFE, "Integer overflow in hex number"); + overflowed = TRUE; + } } retval = n | ((tmp - PL_hexdigit) & 15); } @@ -4,97 +4,100 @@ */ -#define Off(x) ((x) / 8) -#define Bit(x) (1 << ((x) % 8)) +#define Off(x) ((x) / 8) +#define Bit(x) (1 << ((x) % 8)) #define IsSet(a, x) ((a)[Off(x)] & Bit(x)) + #define G_WARN_OFF 0 /* $^W == 0 */ -#define G_WARN_ON 1 /* $^W != 0 */ +#define G_WARN_ON 1 /* -w flag and $^W != 0 */ #define G_WARN_ALL_ON 2 /* -W flag */ #define G_WARN_ALL_OFF 4 /* -X flag */ +#define G_WARN_ONCE 8 /* set if 'once' ever enabled */ #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF) -#if 1 +#define WARN_STD Nullsv +#define WARN_ALL (&PL_sv_yes) /* use warning 'all' */ +#define WARN_NONE (&PL_sv_no) /* no warning 'all' */ -/* Part of the logic below assumes that WARN_NONE is NULL */ +#define specialWARN(x) ((x) == WARN_STD || (x) == WARN_ALL || \ + (x) == WARN_NONE) #define ckDEAD(x) \ - (PL_curcop->cop_warnings != WARN_ALL && \ - PL_curcop->cop_warnings != WARN_NONE && \ + ( ! specialWARN(PL_curcop->cop_warnings) && \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1)) #define ckWARN(x) \ - ( (PL_curcop->cop_warnings && \ + ( (PL_curcop->cop_warnings != WARN_STD && \ + PL_curcop->cop_warnings != WARN_NONE && \ (PL_curcop->cop_warnings == WARN_ALL || \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \ - || (PL_dowarn & G_WARN_ON) ) + || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) ) #define ckWARN2(x,y) \ - ( (PL_curcop->cop_warnings && \ + ( (PL_curcop->cop_warnings != WARN_STD && \ + PL_curcop->cop_warnings != WARN_NONE && \ (PL_curcop->cop_warnings == WARN_ALL || \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \ - || (PL_dowarn & G_WARN_ON) ) - -#else - -#define ckDEAD(x) \ - (PL_curcop->cop_warnings != WARN_ALL && \ - PL_curcop->cop_warnings != WARN_NONE && \ - SvPVX(PL_curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) ) - -#define ckWARN(x) \ - ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \ - PL_curcop->cop_warnings && \ - ( PL_curcop->cop_warnings == WARN_ALL || \ - SvPVX(PL_curcop->cop_warnings)[Off(2*x)] & Bit(2*x) ) ) ) - -#define ckWARN2(x,y) \ - ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \ - PL_curcop->cop_warnings && \ - ( PL_curcop->cop_warnings == WARN_ALL || \ - SvPVX(PL_curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || \ - SvPVX(PL_curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) ) - -#endif - -#define WARN_NONE NULL -#define WARN_ALL (&PL_sv_yes) - -#define WARN_DEFAULT 0 -#define WARN_IO 1 -#define WARN_CLOSED 2 -#define WARN_EXEC 3 -#define WARN_NEWLINE 4 -#define WARN_PIPE 5 -#define WARN_UNOPENED 6 -#define WARN_MISC 7 -#define WARN_NUMERIC 8 -#define WARN_ONCE 9 -#define WARN_RECURSION 10 -#define WARN_REDEFINE 11 -#define WARN_SYNTAX 12 -#define WARN_AMBIGUOUS 13 -#define WARN_DEPRECATED 14 -#define WARN_OCTAL 15 -#define WARN_PARENTHESIS 16 -#define WARN_PRECEDENCE 17 -#define WARN_PRINTF 18 -#define WARN_RESERVED 19 -#define WARN_SEMICOLON 20 -#define WARN_UNINITIALIZED 21 -#define WARN_UNSAFE 22 -#define WARN_CLOSURE 23 -#define WARN_SIGNAL 24 -#define WARN_SUBSTR 25 -#define WARN_TAINT 26 -#define WARN_UNTIE 27 -#define WARN_UTF8 28 -#define WARN_VOID 29 - -#define WARNsize 8 -#define WARN_ALLstring "\125\125\125\125\125\125\125\125" -#define WARN_NONEstring "\0\0\0\0\0\0\0\0" + || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) ) + +#define ckWARN_d(x) \ + (PL_curcop->cop_warnings == WARN_STD || \ + PL_curcop->cop_warnings == WARN_ALL || \ + (PL_curcop->cop_warnings != WARN_NONE && \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) + +#define ckWARN2_d(x,y) \ + (PL_curcop->cop_warnings == WARN_STD || \ + PL_curcop->cop_warnings == WARN_ALL || \ + (PL_curcop->cop_warnings != WARN_NONE && \ + (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) ) + + +#define isLEXWARN_on (PL_curcop->cop_warnings != WARN_STD) +#define isLEXWARN_off (PL_curcop->cop_warnings == WARN_STD) +#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) +#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x))) + +#define WARN_IO 0 +#define WARN_CLOSED 1 +#define WARN_EXEC 2 +#define WARN_NEWLINE 3 +#define WARN_PIPE 4 +#define WARN_UNOPENED 5 +#define WARN_MISC 6 +#define WARN_NUMERIC 7 +#define WARN_ONCE 8 +#define WARN_RECURSION 9 +#define WARN_REDEFINE 10 +#define WARN_SEVERE 11 +#define WARN_DEBUGGING 12 +#define WARN_INPLACE 13 +#define WARN_INTERNAL 14 +#define WARN_SYNTAX 15 +#define WARN_AMBIGUOUS 16 +#define WARN_DEPRECATED 17 +#define WARN_OCTAL 18 +#define WARN_PARENTHESIS 19 +#define WARN_PRECEDENCE 20 +#define WARN_PRINTF 21 +#define WARN_RESERVED 22 +#define WARN_SEMICOLON 23 +#define WARN_UNINITIALIZED 24 +#define WARN_UNSAFE 25 +#define WARN_CLOSURE 26 +#define WARN_SIGNAL 27 +#define WARN_SUBSTR 28 +#define WARN_TAINT 29 +#define WARN_UNTIE 30 +#define WARN_UTF8 31 +#define WARN_VOID 32 + +#define WARNsize 9 +#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125" +#define WARN_NONEstring "\0\0\0\0\0\0\0\0\0" /* end of file warning.h */ diff --git a/warning.pl b/warning.pl index e6b435f92d..400fc7e569 100644 --- a/warning.pl +++ b/warning.pl @@ -32,6 +32,10 @@ my $tree = { 'deprecated' => DEFAULT_OFF, 'printf' => DEFAULT_OFF, }, + 'severe' => { 'inplace' => DEFAULT_ON, + 'internal' => DEFAULT_ON, + 'debugging' => DEFAULT_ON, + }, 'void' => DEFAULT_OFF, 'recursion' => DEFAULT_OFF, 'redefine' => DEFAULT_OFF, @@ -39,7 +43,7 @@ my $tree = { 'uninitialized'=> DEFAULT_OFF, 'once' => DEFAULT_OFF, 'misc' => DEFAULT_OFF, - 'default' => DEFAULT_ON, + #'default' => DEFAULT_ON, } ; @@ -130,62 +134,62 @@ print WARN <<'EOM' ; */ -#define Off(x) ((x) / 8) -#define Bit(x) (1 << ((x) % 8)) +#define Off(x) ((x) / 8) +#define Bit(x) (1 << ((x) % 8)) #define IsSet(a, x) ((a)[Off(x)] & Bit(x)) + #define G_WARN_OFF 0 /* $^W == 0 */ -#define G_WARN_ON 1 /* $^W != 0 */ +#define G_WARN_ON 1 /* -w flag and $^W != 0 */ #define G_WARN_ALL_ON 2 /* -W flag */ #define G_WARN_ALL_OFF 4 /* -X flag */ +#define G_WARN_ONCE 8 /* set if 'once' ever enabled */ #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF) -#if 1 +#define WARN_STD Nullsv +#define WARN_ALL (&PL_sv_yes) /* use warning 'all' */ +#define WARN_NONE (&PL_sv_no) /* no warning 'all' */ -/* Part of the logic below assumes that WARN_NONE is NULL */ +#define specialWARN(x) ((x) == WARN_STD || (x) == WARN_ALL || \ + (x) == WARN_NONE) #define ckDEAD(x) \ - (PL_curcop->cop_warnings != WARN_ALL && \ - PL_curcop->cop_warnings != WARN_NONE && \ + ( ! specialWARN(PL_curcop->cop_warnings) && \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*x+1)) #define ckWARN(x) \ - ( (PL_curcop->cop_warnings && \ + ( (PL_curcop->cop_warnings != WARN_STD && \ + PL_curcop->cop_warnings != WARN_NONE && \ (PL_curcop->cop_warnings == WARN_ALL || \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) \ - || (PL_dowarn & G_WARN_ON) ) + || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) ) #define ckWARN2(x,y) \ - ( (PL_curcop->cop_warnings && \ + ( (PL_curcop->cop_warnings != WARN_STD && \ + PL_curcop->cop_warnings != WARN_NONE && \ (PL_curcop->cop_warnings == WARN_ALL || \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) \ - || (PL_dowarn & G_WARN_ON) ) + || (PL_curcop->cop_warnings == WARN_STD && PL_dowarn & G_WARN_ON) ) -#else +#define ckWARN_d(x) \ + (PL_curcop->cop_warnings == WARN_STD || \ + PL_curcop->cop_warnings == WARN_ALL || \ + (PL_curcop->cop_warnings != WARN_NONE && \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) ) ) -#define ckDEAD(x) \ - (PL_curcop->cop_warnings != WARN_ALL && \ - PL_curcop->cop_warnings != WARN_NONE && \ - SvPVX(PL_curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) ) +#define ckWARN2_d(x,y) \ + (PL_curcop->cop_warnings == WARN_STD || \ + PL_curcop->cop_warnings == WARN_ALL || \ + (PL_curcop->cop_warnings != WARN_NONE && \ + (IsSet(SvPVX(PL_curcop->cop_warnings), 2*x) || \ + IsSet(SvPVX(PL_curcop->cop_warnings), 2*y) ) ) ) -#define ckWARN(x) \ - ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \ - PL_curcop->cop_warnings && \ - ( PL_curcop->cop_warnings == WARN_ALL || \ - SvPVX(PL_curcop->cop_warnings)[Off(2*x)] & Bit(2*x) ) ) ) -#define ckWARN2(x,y) \ - ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \ - PL_curcop->cop_warnings && \ - ( PL_curcop->cop_warnings == WARN_ALL || \ - SvPVX(PL_curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || \ - SvPVX(PL_curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) ) - -#endif - -#define WARN_NONE NULL -#define WARN_ALL (&PL_sv_yes) +#define isLEXWARN_on (PL_curcop->cop_warnings != WARN_STD) +#define isLEXWARN_off (PL_curcop->cop_warnings == WARN_STD) +#define isWARN_ONCE (PL_dowarn & (G_WARN_ON|G_WARN_ONCE)) +#define isWARN_on(c,x) (IsSet(SvPVX(c), 2*(x))) EOM @@ -269,31 +273,17 @@ warning - Perl pragma to control optional warnings =head1 SYNOPSIS use warning; + no warning; use warning "all"; - use warning "deprecated"; - - use warning; - no warning "unsafe"; + no warning "all"; =head1 DESCRIPTION -If no import list is supplied, all possible restrictions are assumed. -(This is the safest mode to operate in, but is sometimes too strict for -casual programming.) Currently, there are three possible things to be -strict about: - -=over 6 - -=item C<warning deprecated> - -This generates a runtime error if you use deprecated - - use warning 'deprecated'; - -=back +If no import list is supplied, all possible warnings are either enabled +or disabled. -See L<perlmod/Pragmatic Modules>. +See L<perlmod/Pragmatic Modules> and L<perllexwarn>. =cut diff --git a/win32/win32.c b/win32/win32.c index a8ba54d1c0..1fffbaf66f 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -546,8 +546,9 @@ do_aspawn(pTHX_ void *vreally, void **vmark, void **vsp) if (flag != P_NOWAIT) { if (status < 0) { - if (PL_dowarn) - Perl_warn(aTHX_ "Can't spawn \"%s\": %s", argv[0], strerror(errno)); + dTHR; + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ WARN_EXEC, "Can't spawn \"%s\": %s", argv[0], strerror(errno)); status = 255 * 256; } else @@ -634,8 +635,9 @@ do_spawn2(pTHX_ char *cmd, int exectype) } if (exectype != EXECF_SPAWN_NOWAIT) { if (status < 0) { - if (PL_dowarn) - Perl_warn(aTHX_ "Can't %s \"%s\": %s", + dTHR; + if (ckWARN(WARN_EXEC)) + Perl_warner(aTHX_ WARN_EXEC, "Can't %s \"%s\": %s", (exectype == EXECF_EXEC ? "exec" : "spawn"), cmd, strerror(errno)); status = 255 * 256; |