----------------
____________________________________________________________________________
+[ 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
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
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
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
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
+++ /dev/null
-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.
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)
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)
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)
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;
}
|| (_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;
#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;
}
#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;
}
#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;
}
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;
}
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);
@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
$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"];
$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) {
sizeof(UNOP),
sizeof(BINOP),
sizeof(LOGOP),
- sizeof(CONDOP),
sizeof(LISTOP),
sizeof(PMOP),
sizeof(SVOP),
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);
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 {
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);
/* 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':
{
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) {
}
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
{
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;
}
{
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;
}
{
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;
}
{
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;
}
{
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;
}
{
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;
}
{
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;
}
{
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;
}
=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
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]
);
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)
{
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);
#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 '&':
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;
}
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;
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 '.':
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. */
{
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);
}
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) ;
}
}
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) ;
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;
Perl_sv_catpvf(aTHX_ msg, "(%s)", p);
else
sv_catpv(msg, "none");
- Perl_warn(aTHX_ "%_", msg);
+ Perl_warner(aTHX_ WARN_UNSAFE, "%_", msg);
}
}
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)
break;
default:
- Perl_warn(aTHX_ "oops: oopsAV");
+ if (ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsAV");
break;
}
return o;
OP *
Perl_oopsHV(pTHX_ OP *o)
{
+ dTHR;
+
+ dTHR;
+
switch (o->op_type) {
case OP_PADSV:
case OP_PADAV:
break;
default:
- Perl_warn(aTHX_ "oops: oopsHV");
+ if (ckWARN_d(WARN_INTERNAL))
+ Perl_warner(aTHX_ WARN_INTERNAL, "oops: oopsHV");
break;
}
return o;
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));
/* 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(). */
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);
}
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);
}
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();
if (PL_do_undump)
my_unexec();
- if (ckWARN(WARN_ONCE))
+ if (isWARN_ONCE)
gv_check(PL_defstash);
LEAVE;
}
return s;
case 'D':
+ {
#ifdef DEBUGGING
forbid_setid("-D");
if (isALPHA(s[1])) {
}
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);
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
#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;
=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
(W) You redefined a format. To suppress this warning, say
{
- local $^W = 0;
+ no warning;
eval "format NAME =...";
}
(W) You redefined a subroutine. To suppress this warning, say
{
- local $^W = 0;
+ no warning;
eval "sub name { ... }";
}
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,
no integer;
no strict 'refs';
+ no warning;
If no C<unimport> method can be found the call fails with a fatal error.
--- /dev/null
+=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
no integer;
no strict 'refs';
+ no warning;
which lasts until the end of that BLOCK.
predeclare global variable names
+=item warning
+
+control optional warnings
+
=item vmsish
control VMS-specific language features
=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>] ]>
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
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
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) {
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);
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) ;
}
{
#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;
}
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;
}
}
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);
void
Perl_sv_free(pTHX_ SV *sv)
{
+ dTHR;
int refcount_is_zero;
if (!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));
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
++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;
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);
# 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 ;
}
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
my $b ;
chop $b ;
EXPECT
-Use of uninitialized value at - line 6.
+
########
# Check interaction of $^W and use warning
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.
--- /dev/null
+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.
--- /dev/null
+ av.c
+
+ Mandatory Warnings ALL TODO
+ ------------------
+ av_reify called on tied array [av_reify]
+
+ Attempt to clear deleted array [av_clear]
+
+__END__
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.
########
$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.
# doio.c
use warning 'uninitialized' ;
print $a ;
+no warning 'uninitialized' ;
+print $b ;
EXPECT
Use of uninitialized value at - line 3.
########
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.
# doio.c
use warning 'io' ;
exec "lskdjfalksdjfdjfkls","" ;
+no warning 'io' ;
+exec "lskdjfalksdjfdjfkls","" ;
EXPECT
OPTION regex
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.
+
--- /dev/null
+ 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.
$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' ;
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' ;
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.
--- /dev/null
+ hv.c
+
+
+ Mandatory Warnings ALL TODO
+ ------------------
+ Attempt to free non-existent shared string [unsharepvn]
+
+__END__
--- /dev/null
+ malloc.c
+
+
+ Mandatory Warnings ALL TODO
+ ------------------
+ %s free() ignored [Perl_mfree]
+ %s", "Bad free() ignored [Perl_mfree]
+
+__END__
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
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;
$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
+
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.
########
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;
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.
########
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.
########
}
}
telldir 1 ; # OP_TELLDIR
+no warning 'void' ;
+telldir 1 ; # OP_TELLDIR
EXPECT
Useless use of telldir in void context at - line 13.
########
}
}
getppid ; # OP_GETPPID
+no warning 'void' ;
+getppid ; # OP_GETPPID
EXPECT
Useless use of getppid in void context at - line 13.
########
}
}
getpgrp ; # OP_GETPGRP
+no warning 'void' ;
+getpgrp ; # OP_GETPGRP
EXPECT
Useless use of getpgrp in void context at - line 13.
########
}
}
times ; # OP_TMS
+no warning 'void' ;
+times ; # OP_TMS
EXPECT
Useless use of times in void context at - line 13.
########
}
}
getpriority 1,2; # OP_GETPRIORITY
+no warning 'void' ;
+getpriority 1,2; # OP_GETPRIORITY
EXPECT
Useless use of getpriority in void context at - line 13.
########
}
}
getlogin ; # OP_GETLOGIN
+no warning 'void' ;
+getlogin ; # OP_GETLOGIN
EXPECT
Useless use of getlogin in void context at - line 13.
########
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;
$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.
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.
%$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.
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.
########
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.
########
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.
# 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.
########
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.
########
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.
use warning 'redefine' ;
sub fred {}
sub fred {}
+no warning 'redefine' ;
+sub fred {}
EXPECT
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.
########
.
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.
########
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.
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
+
--- /dev/null
+ perlio.c
+
+
+ Mandatory Warnings ALL TODO
+ ------------------
+ Setting cnt to %d
+ Setting ptr %p > end+1 %p
+ Setting cnt to %d, ptr implies %d
+
+__END__
$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.
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.
########
$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.
########
# 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.
########
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.
# 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.
########
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.
1
########
# pp_ctl.c
+no warning 'syntax' ;
+format =
+@<<< @<<<
+1
+.
+write ;
+EXPECT
+1
+########
+# pp_ctl.c
use warning 'unsafe' ;
$_ = "abc" ;
{
s/ab/last/e ;
}
+no warning 'unsafe' ;
+while ($i ++ == 0)
+{
+ s/ab/last/e ;
+}
EXPECT
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.
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.
{
s/ab/last fred/e ;
}
+no warning 'unsafe' ;
+while ($i ++ == 0)
+{
+ s/ab/last fred/e ;
+}
EXPECT
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.
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.
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" }
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
+
# 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.
########
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.
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.
########
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
{
&$b ;
EXPECT
Deep recursion on anonymous subroutine at - line 5.
+########
+# pp_hot.c
+no warning 'recursion' ;
+$b = sub
+{
+ &$b if $a++ < 200
+} ;
+
+&$b ;
+EXPECT
+
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.
########
format STDIN =
.
write STDIN;
+no warning 'io' ;
+write STDIN;
EXPECT
Filehandle main::STDIN opened only for input at - line 5.
########
.
close STDIN;
write STDIN;
+no warning 'closed' ;
+write STDIN;
EXPECT
Write on closed filehandle main::STDIN at - line 6.
########
$- =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.
########
use warning 'closed' ;
close STDIN;
syswrite STDIN, "fred", 1;
+no warning 'closed' ;
+syswrite STDIN, "fred", 1;
EXPECT
Syswrite on closed filehandle at - line 4.
########
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.
# 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.
########
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.
use warning 'unsafe' ;
my $a = "ABC123" ;
$a =~ /(?=a)*/ ;
+no warning 'unsafe' ;
+$a =~ /(?=a)*/ ;
EXPECT
(?=a)* matches null string many times at - line 4.
########
use warning 'unsafe' ;
$_ = "" ;
/(?=a)?/;
+no warning 'unsafe' ;
+/(?=a)?/;
EXPECT
Strange *+?{} on zero-length expression at - line 4.
########
/[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.
/[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.
########
# 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*)/;
#
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
+
--- /dev/null
+ run.c
+
+
+ Mandatory Warnings ALL TODO
+ ------------------
+ NULL OP IN RUN
+
+__END__
- 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.
########
use integer ;
use warning 'uninitialized' ;
$A *= 2 ;
+no warning 'uninitialized' ;
+$A *= 2 ;
EXPECT
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.
########
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.
########
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.
########
use warning 'uninitialized' ;
$B = "" ;
$B .= $A ;
+no warning 'uninitialized' ;
+$C = "" ;
+$C .= $A ;
EXPECT
Use of uninitialized value at - line 10.
########
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.
########
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.
########
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.
########
sub fred {}
sub joe {}
*fred = \&joe ;
+no warning 'redefine' ;
+sub jim {}
+*jim = \&joe ;
EXPECT
Subroutine fred redefined at - line 5.
########
$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.
# 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.
- 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
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' ;
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.
@<<< @||| @>>> @>>>
$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.
########
use warning 'semicolon' ;
$a = 1
&time ;
+no warning 'semicolon' ;
+$a = 1
+&time ;
EXPECT
Semicolon seems to be missing at - line 3.
########
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.
########
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.
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
########
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.
########
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.
########
use warning 'ambiguous' ;
sub fred {}
$a = ${fred} ;
+no warning 'ambiguous' ;
+$a = ${fred} ;
EXPECT
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.
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.
########
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.
- universal.c
+ universal.c TODO
Can't locate package %s for @%s::ISA
--- /dev/null
+
+ 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.
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.
+
`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
char *s;
char ch;
char *t;
+ dTHR;
if (PL_oldoldbufptr != PL_last_uni)
return;
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
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);
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 */
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 ;
}
/* 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 */
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);
}
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);
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);
UV u;
I32 shift;
bool overflowed = FALSE;
+ dTHR;
/* check for hex */
if (s[1] == 'x') {
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;
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;
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;
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;
}
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');
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');
}
}
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);
}
*/
-#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 */
'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,
'uninitialized'=> DEFAULT_OFF,
'once' => DEFAULT_OFF,
'misc' => DEFAULT_OFF,
- 'default' => DEFAULT_ON,
+ #'default' => DEFAULT_ON,
} ;
*/
-#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
=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
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
}
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;
projects / p5sagit/p5-mst-13.2.git / commitdiff