This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
lexical warnings update (warning.t fails one test
authorPaul Marquess <paul.marquess@btinternet.com>
Sat, 26 Jun 1999 23:19:52 +0000 (00:19 +0100)
committerGurusamy Sarathy <gsar@cpan.org>
Wed, 7 Jul 1999 09:45:43 +0000 (09:45 +0000)
due to leaked scalar, investigation pending)
Message-ID: <5104D4DBC598D211B5FE0000F8FE7EB29C6C8E@mbtlipnt02.btlabs.bt.co.uk>
Subject: [PATCH 5.005_57] Lexical Warnings - mandatory warning are now default warnings

p4raw-id: //depot/perl@3640

63 files changed:
Changes
MANIFEST
README.lexwarn [deleted file]
av.c
djgpp/djgpp.c
doio.c
doop.c
ext/B/B/Asmdata.pm
ext/ByteLoader/byterun.c
ext/ByteLoader/byterun.h
gv.c
hv.c
jpl/JNI/JNI.xs
lib/warning.pm
mg.c
op.c
os2/os2.c
perl.c
perlio.c
pod/perldelta.pod
pod/perldiag.pod
pod/perlfunc.pod
pod/perllexwarn.pod [new file with mode: 0644]
pod/perlmodlib.pod
pod/perlrun.pod
pod/perlvar.pod
pp.c
pp_ctl.c
run.c
sv.c
t/pragma/warn/3both
t/pragma/warn/6default [new file with mode: 0644]
t/pragma/warn/av [new file with mode: 0644]
t/pragma/warn/doio
t/pragma/warn/doop [new file with mode: 0644]
t/pragma/warn/gv
t/pragma/warn/hv [new file with mode: 0644]
t/pragma/warn/malloc [new file with mode: 0644]
t/pragma/warn/mg
t/pragma/warn/op
t/pragma/warn/perl
t/pragma/warn/perlio [new file with mode: 0644]
t/pragma/warn/perly
t/pragma/warn/pp
t/pragma/warn/pp_ctl
t/pragma/warn/pp_hot
t/pragma/warn/pp_sys
t/pragma/warn/regcomp
t/pragma/warn/regexec
t/pragma/warn/run [new file with mode: 0644]
t/pragma/warn/sv
t/pragma/warn/taint
t/pragma/warn/toke
t/pragma/warn/universal
t/pragma/warn/utf8 [new file with mode: 0644]
t/pragma/warn/util
t/pragma/warning.t
toke.c
utf8.c
util.c
warning.h
warning.pl
win32/win32.c

diff --git a/Changes b/Changes
index 87d97f4..1c38a7f 100644 (file)
--- a/Changes
+++ b/Changes
@@ -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 
index 11543e1..86eaebc 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -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 (file)
index 27e5ec8..0000000
+++ /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.
diff --git a/av.c b/av.c
index 3b0913a..8dabb7b 100644 (file)
--- a/av.c
+++ b/av.c
@@ -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)
index ae03f21..5c1d3c4 100644 (file)
@@ -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)
diff --git a/doio.c b/doio.c
index f6eb798..1533bc5 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -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;
                }
diff --git a/doop.c b/doop.c
index 2857792..e31af50 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -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);
index d4128b6..1d0e7ed 100644 (file)
@@ -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) {
index 035578f..18fa4a1 100644 (file)
@@ -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);
index 6bc03af..31a9033 100644 (file)
@@ -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);
diff --git a/gv.c b/gv.c
index e531204..d1cf7ae 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -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) {
diff --git a/hv.c b/hv.c
index 8656fa0..857bd70 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -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
index 678e81c..ee854c1 100644 (file)
@@ -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;
        }
index ac6aefa..1df83d9 100644 (file)
@@ -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]
   );
 
 
diff --git a/mg.c b/mg.c
index 0e9ca19..cc40a29 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -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 '.':
diff --git a/op.c b/op.c
index 81df30e..f4dc624 100644 (file)
--- a/op.c
+++ b/op.c
@@ -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;
index 09135a6..7c23200 100644 (file)
--- a/os2/os2.c
+++ b/os2/os2.c
@@ -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(). */
diff --git a/perl.c b/perl.c
index 1bd2346..ee6d20b 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -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);
index 3094ea7..505548a 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -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;
index be5366d..f64bea6 100644 (file)
@@ -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
 
index 45c7be1..0484882 100644 (file)
@@ -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 { ... }";
     }
 
index 6b0fd9d..ddf64d0 100644 (file)
@@ -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 (file)
index 0000000..1194755
--- /dev/null
@@ -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
index 4cee455..7989234 100644 (file)
@@ -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
index c71b9f3..8a511ae 100644 (file)
@@ -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
index 9402608..c13c417 100644 (file)
@@ -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
diff --git a/pp.c b/pp.c
index 2f51f87..3f21cf2 100644 (file)
--- a/pp.c
+++ b/pp.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) {
index 1a15a01..af6394d 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -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) ;
     }
diff --git a/run.c b/run.c
index 0d9f7cf..e218144 100644 (file)
--- a/run.c
+++ b/run.c
@@ -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;
     }
 
diff --git a/sv.c b/sv.c
index a61d2ea..97044c9 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -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);
index 7c32601..1d7deb8 100644 (file)
@@ -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 (file)
index 0000000..c095b20
--- /dev/null
@@ -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 (file)
index 0000000..79bd3b7
--- /dev/null
@@ -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__
index 97f0804..5bcca8d 100644 (file)
   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 (file)
index 0000000..458a3b2
--- /dev/null
@@ -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.
index bd442b9..e33f8ca 100644 (file)
        $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 (file)
index 0000000..c9eec02
--- /dev/null
@@ -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 (file)
index 0000000..2f8b096
--- /dev/null
@@ -0,0 +1,9 @@
+  malloc.c 
+
+
+  Mandatory Warnings ALL TODO
+  ------------------
+    %s free() ignored          [Perl_mfree]
+    %s", "Bad free() ignored   [Perl_mfree]
+
+__END__
index 14307e0..7f40ded 100644 (file)
@@ -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
+
index 7c2b6b8..dce52d8 100644 (file)
        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.
index 5211990..25f125e 100644 (file)
@@ -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 (file)
index 0000000..18c0dfa
--- /dev/null
@@ -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__
index fd420d3..bddc39c 100644 (file)
@@ -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.
index 7a3b289..9baf9c1 100644 (file)
   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.
index 5a1c233..4d6d8ca 100644 (file)
@@ -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
+
index 817c0c8..60490bc 100644 (file)
@@ -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
+
index 82d1501..bf64a94 100644 (file)
@@ -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.
index 52a163a..4b2f7ff 100644 (file)
@@ -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.
index 6d4ec32..ce4eac7 100644 (file)
@@ -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 (file)
index 0000000..7a4be20
--- /dev/null
@@ -0,0 +1,8 @@
+  run.c 
+
+
+  Mandatory Warnings ALL TODO
+  ------------------
+        NULL OP IN RUN
+
+__END__
index f3c530f..0421192 100644 (file)
@@ -1,4 +1,4 @@
-  sv.c AOK
+  sv.c 
 
   warn(warn_uninit);
 
 
   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.
index 40fadd0..17ab042 100644 (file)
@@ -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
index da6c0dc..72c1e2f 100644 (file)
@@ -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.
index e2814e1..37e7719 100644 (file)
@@ -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 (file)
index 0000000..380d53b
--- /dev/null
@@ -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.
index d58f4b7..bd29f7b 100644 (file)
@@ -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.
+
index 7914121..73e4c8d 100755 (executable)
@@ -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
diff --git a/toke.c b/toke.c
index 7849152..d9f54f7 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -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;
diff --git a/utf8.c b/utf8.c
index 8c7aee2..4bb2e9b 100644 (file)
--- a/utf8.c
+++ b/utf8.c
@@ -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;
            }
diff --git a/util.c b/util.c
index 242a308..5f867ae 100644 (file)
--- a/util.c
+++ b/util.c
@@ -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);
     }
index dde254d..8b0cace 100644 (file)
--- a/warning.h
+++ b/warning.h
 */
 
 
-#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 */
 
index e6b435f..400fc7e 100644 (file)
@@ -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
index a8ba54d..1fffbaf 100644 (file)
@@ -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;