----------------
-Version 5.005_50 Development release working toward 5.006
+Version 5.005_51 Development release working toward 5.006
+----------------
+
+____________________________________________________________________________
+[ 1772] By: gsar on 1998/08/08 23:06:00
+ Log: bump patchlevel to 5.005_51
+ Branch: perl
+ ! patchlevel.h win32/Makefile win32/config_H.bc
+ ! win32/config_H.gc win32/config_H.vc win32/makefile.mk
+____________________________________________________________________________
+[ 1771] By: gsar on 1998/08/08 23:01:57
+ Log: fix bogus warning on "\x{123}"
+ From: pmarquess@claudius.bfsec.bt.co.uk (Paul Marquess)
+ Date: Mon, 27 Jul 1998 06:16:15 +0100 (BST)
+ Message-Id: <9807270534.AA11102@claudius.bfsec.bt.co.uk>
+ Subject: [5.005_50 PATCH] Some unicode problems
+ Branch: perl
+ ! regcomp.c toke.c
+____________________________________________________________________________
+[ 1770] By: gsar on 1998/08/08 22:56:55
+ Log: hide dup symbol for static build of ext/re
+ From: Dominic Dunlop <domo@ppp72.vo.lu>
+ Date: Wed, 29 Jul 1998 11:09:56 +0100 (WET DST)
+ Message-Id: <199807291009.LAA08935@ppp72.vo.lu>
+ Subject: Not OK: perl 5.00550 on powerpc-machten 4.1 [BOGUS PATCH]
+ Branch: perl
+ ! regcomp.c
+____________________________________________________________________________
+[ 1769] By: gsar on 1998/08/08 22:45:06
+ Log: fix double free on -Mutf8 -e '$b=uc("")'
+ From: larry@wall.org (Larry Wall)
+ Date: Fri, 7 Aug 1998 14:42:43 -0700
+ Message-Id: <199808072142.OAA14920@wall.org>
+ Subject: [PATCH 5.005_50]: uc("") and lc("") under utf8 fails
+ Branch: perl
+ ! pp.c
+____________________________________________________________________________
+[ 1768] By: gsar on 1998/08/08 22:42:29
+ Log: substr() assumes utf8 without say-so
+ From: larry@wall.org (Larry Wall)
+ Date: Fri, 7 Aug 1998 12:25:12 -0700
+ Message-Id: <199808071925.MAA13436@wall.org>
+ Subject: [PATCH 5.005_50] substr bug?
+ Branch: perl
+ ! pp.c
+____________________________________________________________________________
+[ 1767] By: gsar on 1998/08/08 22:38:25
+ Log: fix intolerance of SWASHes for blank lines
+ From: Gisle Aas <aas@sn.no>
+ Date: 06 Aug 1998 23:28:57 +0200
+ Message-ID: <m3emutkdeu.fsf@furu.g.aas.no>
+ Subject: Re: Re[2]: another joyride begins
+ Branch: perl
+ ! lib/utf8_heavy.pl
+____________________________________________________________________________
+[ 1766] By: gsar on 1998/08/08 22:33:10
+ Log: utf8 doc tweak
+ From: Gisle Aas <aas@sn.no>
+ Date: 05 Aug 1998 00:41:04 +0200
+ Message-ID: <m3yat4wetb.fsf@furu.g.aas.no>
+ Subject: Matching clumps
+ Branch: perl
+ ! lib/utf8.pm
+____________________________________________________________________________
+[ 1765] By: gsar on 1998/08/08 22:31:37
+ Log: kill bogus warning from -we 'use utf8; $_="\x{FF}"'
+ From: Gisle Aas <aas@sn.no>
+ Date: 04 Aug 1998 22:56:11 +0200
+ Message-ID: <m3yat4sbys.fsf@furu.g.aas.no>
+ Subject: Re: another joyride begins
+ Branch: perl
+ ! lib/utf8_heavy.pl
+____________________________________________________________________________
+[ 1764] By: gsar on 1998/08/08 22:28:43
+ Log: From: larry@wall.org (Larry Wall)
+ Date: Tue, 4 Aug 1998 17:04:51 -0700
+ Message-Id: <199808050004.RAA22592@wall.org>
+ Subject: [PATCH 5.005_50] \pX not implemented!
+ Branch: perl
+ ! regcomp.c
+____________________________________________________________________________
+[ 1763] By: gsar on 1998/08/08 22:27:15
+ Log: From: Stephen McCamant <alias@mcs.com>
+ Date: Sun, 2 Aug 1998 16:33:18 -0500 (CDT)
+ Message-ID: <13764.55116.921952.837027@alias-2.pr.mcs.net>
+ Subject: [PATCH] Eliminate superfluous RV2p[AH]Vs in oops[AH]V()
+ Branch: perl
+ ! op.c
+____________________________________________________________________________
+[ 1762] By: gsar on 1998/08/08 22:26:09
+ Log: From: Jarkko Hietaniemi <jhi@iki.fi>
+ Date: Sun, 2 Aug 1998 22:05:28 +0300 (EET DST)
+ Message-Id: <199808021905.WAA10592@alpha.hut.fi>
+ Subject: [PATCH] 5.005_02-TRIAL1 or 5.004_05-MAINT_TRIAL_5: t/op/{pw,gr}ent.t
+ Branch: perl
+ + t/op/grent.t t/op/pwent.t
+ ! MANIFEST
+____________________________________________________________________________
+[ 1761] By: gsar on 1998/08/08 22:21:52
+ Log: From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Date: Thu, 30 Jul 1998 19:23:56 -0400 (EDT)
+ Message-Id: <199807302323.TAA21175@monk.mps.ohio-state.edu>
+ Subject: [5.005_50 PATCH] misprint in RE engine
+ Branch: perl
+ ! regexec.c t/op/re_tests
+____________________________________________________________________________
+[ 1760] By: gsar on 1998/08/08 22:18:54
+ Log: integrate maint-5.005 changes into mainline
+ Branch: perl
+ +> Porting/fixCORE README.os390 ebcdic.c win32/des_fcrypt.patch
+ !> (integrate 138 files)
+____________________________________________________________________________
+[ 1672] By: gsar on 1998/07/27 18:35:28
+ Log: create new Changes
+ Branch: perl
+ + Changes
+ ! Changes5.005 MANIFEST
+____________________________________________________________________________
+[ 1671] By: gsar on 1998/07/27 18:30:57
+ Log: rename Changes --> Changes5.005
+ Branch: perl
+ +> Changes5.005
+ - Changes
+____________________________________________________________________________
+[ 1670] By: gsar on 1998/07/27 18:10:14
+ Log: integrate 5.005_01 changes from maint
+ Branch: perl
+ ! Changes
+ !> README.win32 pod/perldelta.pod proto.h toke.c win32/GenCAPI.pl
+ !> win32/win32.c
+____________________________________________________________________________
+[ 1667] By: nick on 1998/07/26 14:31:01
+ Log: Add dTHR so that it compiles miniperl in threaded mode
+ Branch: perl
+ ! doop.c mg.c regcomp.c regexec.c
+____________________________________________________________________________
+[ 1666] By: nick on 1998/07/26 13:01:10
+ Log: Resolve ansiperl against mainline (@1648?)
+ Unclear that change number has "taken".
+ Branch: ansiperl
+ +> (branch 169 files)
+ - ObjXSub.h XSLock.h compat3.sym fixvars pod/perld4.pod
+ !> (integrate 131 files)
+
+----------------
+Version 5.005_50
----------------
____________________________________________________________________________
README.beos Notes about BeOS port
README.cygwin32 Notes about Cygwin32 port
README.dos Notes about dos/djgpp port
+README.lexwarn Notes about lexical warnings
README.mpeix Notes about MPE/iX port
README.os2 Notes about OS/2 port
README.os390 Notes about OS/390 (nee MVS) port
lib/utf8_heavy.pl Support routines for utf8 pragma
lib/validate.pl Perl library supporting wholesale file mode validation
lib/vars.pm Declare pseudo-imported global variables
+lib/warning.pm For "use warning"
makeaperl.SH perl script that produces a new perl binary
makedepend.SH Precursor to makedepend
makedir.SH Precursor to makedir
t/pragma/strict.t See if strictures work
t/pragma/subs.t See if subroutine pseudo-importation works
t/pragma/warn-1global Tests of global warnings for warning.t
+t/pragma/warn-2use Tests for "use warning" for warning.t
+t/pragma/warn-doio Tests for doio.c for warning.t
+t/pragma/warn-gv Tests for gv.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-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_hot Tests for pp_hot.c for warning.t
+t/pragma/warn-pp_sys Tests for pp_sys.c for warning.t
+t/pragma/warn-regcomp Tests for regcomp.c for warning.t
+t/pragma/warn-regexec Tests for regexec.c for warning.t
+t/pragma/warn-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/warning.t See if warning controls work
taint.c Tainting code
thrdvar.h Per-thread variables
vms/vms_yfix.pl convert Unix perly.[ch] to VMS perly_[ch].vms
vms/vmsish.h VMS-specific C header for Perl core
vms/writemain.pl Generate perlmain.c from miniperlmain.c+extensions
+warning.h The warning numbers
+warning.pl Program to write warning.h and lib/warning.pm
win32/GenCAPI.pl Win32 port for C API with PERL_OBJECT
win32/Makefile Win32 makefile for NMAKE (Visual C++ build)
win32/TEST Win32 port
h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h
h3 = opcode.h patchlevel.h perl.h perly.h pp.h proto.h regcomp.h
h4 = regexp.h scope.h sv.h unixish.h util.h iperlsys.h thread.h
-h5 = bytecode.h byterun.h utf8.h
+h5 = bytecode.h byterun.h utf8.h warning.h
h = $(h1) $(h2) $(h3) $(h4) $(h5)
c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c byterun.c
# byterun.c: bytecode.pl
# lib/B/Asmdata.pm: bytecode.pl
# regnodes.h: regcomp.pl
+# warning.h lib/warning.pm: warning.pl
# The correct versions should be already supplied with the perl kit,
# in case you don't have perl available.
# To force them to run, type
perl embed.pl
perl bytecode.pl
perl regcomp.pl
+ perl warning.pl
# Extensions:
# Names added to $(dynamic_ext) or $(static_ext) or $(nonxs_ext) will
--- /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.
U32 cop_seq; /* parse sequence number */
I32 cop_arybase; /* array base this line was compiled with */
line_t cop_line; /* line # of this command */
+ SV * cop_warnings; /* lexical warnings bitmask */
};
#define Nullcop Null(COP*)
TAINT_PROPER("piped open");
if (name[strlen(name)-1] == '|') {
name[strlen(name)-1] = '\0' ;
- if (PL_dowarn)
- warn("Can't do bidirectional pipe");
+ if (ckWARN(WARN_PIPE))
+ warner(WARN_PIPE, "Can't do bidirectional pipe");
}
fp = PerlProc_popen(name,"w");
writing = 1;
}
}
if (!fp) {
- if (PL_dowarn && IoTYPE(io) == '<' && strchr(name, '\n'))
- warn(warn_nl, "open");
+ if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == '<' && strchr(name, '\n'))
+ warner(WARN_NEWLINE, warn_nl, "open");
goto say_false;
}
if (IoTYPE(io) &&
io = GvIO(gv);
if (!io) { /* never opened */
if (not_implicit) {
- if (PL_dowarn)
- warn("Close on unopened file <%s>",GvENAME(gv));
+ if (ckWARN(WARN_UNOPENED))
+ warner(WARN_UNOPENED,
+ "Close on unopened file <%s>",GvENAME(gv));
SETERRNO(EBADF,SS$_IVCHAN);
}
return FALSE;
#endif
return PerlIO_tell(fp);
}
- if (PL_dowarn)
- warn("tell() on unopened file");
+ if (ckWARN(WARN_UNOPENED))
+ warner(WARN_UNOPENED, "tell() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
return -1L;
}
#endif
return PerlIO_seek(fp, pos, whence) >= 0;
}
- if (PL_dowarn)
- warn("seek() on unopened file");
+ if (ckWARN(WARN_UNOPENED))
+ warner(WARN_UNOPENED, "seek() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
return FALSE;
}
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
- if (PL_dowarn)
- warn("sysseek() on unopened file");
+ if (ckWARN(WARN_UNOPENED))
+ warner(WARN_UNOPENED, "sysseek() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
return -1L;
}
}
switch (SvTYPE(sv)) {
case SVt_NULL:
- if (PL_dowarn)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, warn_uninit);
return TRUE;
case SVt_IV:
if (SvIOK(sv)) {
else {
if (tmpgv == PL_defgv)
return PL_laststatval;
- if (PL_dowarn)
- warn("Stat on unopened file <%s>",
+ if (ckWARN(WARN_UNOPENED))
+ warner(WARN_UNOPENED, "Stat on unopened file <%s>",
GvENAME(tmpgv));
PL_statgv = Nullgv;
sv_setpv(PL_statname,"");
sv_setpv(PL_statname, s);
PL_laststype = OP_STAT;
PL_laststatval = PerlLIO_stat(s, &PL_statcache);
- if (PL_laststatval < 0 && PL_dowarn && strchr(s, '\n'))
- warn(warn_nl, "stat");
+ if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n'))
+ warner(WARN_NEWLINE, warn_nl, "stat");
return PL_laststatval;
}
}
#else
PL_laststatval = PerlLIO_stat(SvPV(sv, PL_na),&PL_statcache);
#endif
- if (PL_laststatval < 0 && PL_dowarn && strchr(SvPV(sv, PL_na), '\n'))
- warn(warn_nl, "lstat");
+ if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, PL_na), '\n'))
+ warner(WARN_NEWLINE, warn_nl, "lstat");
return PL_laststatval;
}
PerlProc_execvp(tmps,PL_Argv);
else
PerlProc_execvp(PL_Argv[0],PL_Argv);
- if (PL_dowarn)
- warn("Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno));
+ if (ckWARN(WARN_EXEC))
+ warner(WARN_EXEC, "Can't exec \"%s\": %s",
+ PL_Argv[0], Strerror(errno));
}
do_execfree();
return FALSE;
do_execfree();
goto doshell;
}
- if (PL_dowarn)
- warn("Can't exec \"%s\": %s", PL_Argv[0], Strerror(errno));
+ if (ckWARN(WARN_EXEC))
+ warner(WARN_EXEC, "Can't exec \"%s\": %s",
+ PL_Argv[0], Strerror(errno));
}
do_execfree();
return FALSE;
uv_to_utf8
wait4pid
warn
+warner
watch
whichsig
yydestruct
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
- if (PL_dowarn)
- warn("Can't locate package %s for @%s::ISA",
+ if (ckWARN(WARN_MISC))
+ warner(WARN_MISC, "Can't locate package %s for @%s::ISA",
SvPVX(sv), HvNAME(stash));
continue;
}
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
- if (PL_dowarn && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash))
- warn(
+ if (ckWARN(WARN_DEPRECATED) && !method &&
+ (GvCVGEN(gv) || GvSTASH(gv) != stash))
+ warner(WARN_DEPRECATED,
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
HvNAME(stash), (int)len, name);
goto magicalize;
case '#':
case '*':
- if (PL_dowarn && len == 1 && sv_type == SVt_PV)
- warn("Use of $%s is deprecated", name);
+ if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
+ warner(WARN_DEPRECATED, "Use of $%s is deprecated", name);
/* FALL THROUGH */
case '[':
case '^':
case '/':
case '|':
case '\001':
+ case '\002':
case '\004':
case '\005':
case '\006':
PL_curcop->cop_filegv = filegv;
if (filegv && GvMULTI(filegv)) /* Filename began with slash */
continue;
- warn("Name \"%s::%s\" used only once: possible typo",
+ warner(WARN_ONCE,
+ "Name \"%s::%s\" used only once: possible typo",
HvNAME(stash), GvNAME(gv));
}
}
$transmo = <<EOFUNC;
sub transmo {
- local \$^W = 0; # recursive warnings we do NOT need!
+ #local \$^W = 0; # recursive warnings we do NOT need!
study;
EOFUNC
sub import {
shift;
- $old_w = $^W;
+ #$old_w = $^W;
$^W = 1; # yup, clobbered the global variable; tough, if you
# want diags, you want diags.
return if $SIG{__WARN__} eq \&warn_trap;
sub disable {
shift;
- $^W = $old_w;
+ #$^W = $old_w;
return unless $SIG{__WARN__} eq \&warn_trap;
$SIG{__WARN__} = $oldwarn;
$SIG{__DIE__} = $olddie;
--- /dev/null
+
+# This file was created by warning.pl
+# Any changes made here will be lost.
+#
+
+package warning;
+
+=head1 NAME
+
+warning - Perl pragma to control
+
+=head1 SYNOPSIS
+
+ use warning;
+
+ use warning "all";
+ use warning "deprecated";
+
+ use warning;
+ no warning "unsafe";
+
+=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
+
+See L<perlmod/Pragmatic Modules>.
+
+
+=cut
+
+use Carp ;
+
+%Bits = (
+ 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55", # [0..31]
+ 'ambiguous' => "\x00\x00\x00\x00\x10\x00\x00\x00", # [18]
+ 'closed' => "\x00\x00\x00\x00\x00\x40\x00\x00", # [23]
+ 'closure' => "\x00\x04\x00\x00\x00\x00\x00\x00", # [5]
+ 'default' => "\x00\x00\x10\x00\x00\x00\x00\x00", # [10]
+ 'deprecated' => "\x00\x00\x00\x10\x00\x00\x00\x00", # [14]
+ 'exec' => "\x00\x00\x00\x00\x00\x00\x01\x00", # [24]
+ 'io' => "\x00\x00\x00\x00\x00\x54\x15\x00", # [21..26]
+ 'misc' => "\x00\x00\x00\x00\x00\x00\x00\x04", # [29]
+ 'newline' => "\x00\x00\x00\x00\x00\x10\x00\x00", # [22]
+ 'numeric' => "\x00\x00\x04\x00\x00\x00\x00\x00", # [9]
+ 'octal' => "\x00\x00\x00\x00\x04\x00\x00\x00", # [17]
+ 'once' => "\x00\x00\x40\x00\x00\x00\x00\x00", # [11]
+ 'parenthesis' => "\x00\x00\x00\x00\x40\x00\x00\x00", # [19]
+ 'pipe' => "\x00\x00\x00\x00\x00\x00\x10\x00", # [26]
+ 'precedence' => "\x00\x00\x00\x00\x00\x01\x00\x00", # [20]
+ 'printf' => "\x00\x00\x00\x00\x01\x00\x00\x00", # [16]
+ 'recursion' => "\x00\x00\x00\x00\x00\x00\x00\x01", # [28]
+ 'redefine' => "\x01\x00\x00\x00\x00\x00\x00\x00", # [0]
+ 'reserved' => "\x00\x00\x00\x04\x00\x00\x00\x00", # [13]
+ 'semicolon' => "\x00\x00\x00\x40\x00\x00\x00\x00", # [15]
+ 'signal' => "\x00\x40\x00\x00\x00\x00\x00\x00", # [7]
+ 'substr' => "\x00\x01\x00\x00\x00\x00\x00\x00", # [4]
+ 'syntax' => "\x00\x00\x00\x55\x55\x01\x00\x00", # [12..20]
+ 'taint' => "\x40\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x40\x00", # [27]
+ 'unopened' => "\x00\x00\x00\x00\x00\x00\x04\x00", # [25]
+ 'unsafe' => "\x50\x55\x01\x00\x00\x00\x00\x00", # [2..8]
+ 'untie' => "\x00\x10\x00\x00\x00\x00\x00\x00", # [6]
+ 'utf8' => "\x00\x00\x01\x00\x00\x00\x00\x00", # [8]
+ 'void' => "\x04\x00\x00\x00\x00\x00\x00\x00", # [1]
+ );
+
+%DeadBits = (
+ 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..31]
+ 'ambiguous' => "\x00\x00\x00\x00\x20\x00\x00\x00", # [18]
+ 'closed' => "\x00\x00\x00\x00\x00\x80\x00\x00", # [23]
+ 'closure' => "\x00\x08\x00\x00\x00\x00\x00\x00", # [5]
+ 'default' => "\x00\x00\x20\x00\x00\x00\x00\x00", # [10]
+ 'deprecated' => "\x00\x00\x00\x20\x00\x00\x00\x00", # [14]
+ 'exec' => "\x00\x00\x00\x00\x00\x00\x02\x00", # [24]
+ 'io' => "\x00\x00\x00\x00\x00\xa8\x2a\x00", # [21..26]
+ 'misc' => "\x00\x00\x00\x00\x00\x00\x00\x08", # [29]
+ 'newline' => "\x00\x00\x00\x00\x00\x20\x00\x00", # [22]
+ 'numeric' => "\x00\x00\x08\x00\x00\x00\x00\x00", # [9]
+ 'octal' => "\x00\x00\x00\x00\x08\x00\x00\x00", # [17]
+ 'once' => "\x00\x00\x80\x00\x00\x00\x00\x00", # [11]
+ 'parenthesis' => "\x00\x00\x00\x00\x80\x00\x00\x00", # [19]
+ 'pipe' => "\x00\x00\x00\x00\x00\x00\x20\x00", # [26]
+ 'precedence' => "\x00\x00\x00\x00\x00\x02\x00\x00", # [20]
+ 'printf' => "\x00\x00\x00\x00\x02\x00\x00\x00", # [16]
+ 'recursion' => "\x00\x00\x00\x00\x00\x00\x00\x02", # [28]
+ 'redefine' => "\x02\x00\x00\x00\x00\x00\x00\x00", # [0]
+ 'reserved' => "\x00\x00\x00\x08\x00\x00\x00\x00", # [13]
+ 'semicolon' => "\x00\x00\x00\x80\x00\x00\x00\x00", # [15]
+ 'signal' => "\x00\x80\x00\x00\x00\x00\x00\x00", # [7]
+ 'substr' => "\x00\x02\x00\x00\x00\x00\x00\x00", # [4]
+ 'syntax' => "\x00\x00\x00\xaa\xaa\x02\x00\x00", # [12..20]
+ 'taint' => "\x80\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x80\x00", # [27]
+ 'unopened' => "\x00\x00\x00\x00\x00\x00\x08\x00", # [25]
+ 'unsafe' => "\xa0\xaa\x02\x00\x00\x00\x00\x00", # [2..8]
+ 'untie' => "\x00\x20\x00\x00\x00\x00\x00\x00", # [6]
+ 'utf8' => "\x00\x00\x02\x00\x00\x00\x00\x00", # [8]
+ 'void' => "\x08\x00\x00\x00\x00\x00\x00\x00", # [1]
+ );
+
+
+sub bits {
+ my $mask ;
+ my $catmask ;
+ my $fatal = 0 ;
+ foreach my $word (@_) {
+ if ($word eq 'FATAL')
+ { $fatal = 1 }
+ elsif ($catmask = $Bits{$word}) {
+ $mask |= $catmask ;
+ $mask |= $DeadBits{$word} if $fatal ;
+ }
+ else
+ { croak "unknown warning category '$word'" }
+ }
+
+ return $mask ;
+}
+
+sub import {
+ shift;
+ $^B |= bits(@_ ? @_ : 'all') ;
+}
+
+sub unimport {
+ shift;
+ $^B &= ~ bits(@_ ? @_ : 'all') ;
+}
+
+
+sub make_fatal
+{
+ my $self = shift ;
+ my $bitmask = $self->bits(@_) ;
+ $SIG{__WARN__} =
+ sub
+ {
+ die @_ if $^B & $bitmask ;
+ warn @_
+ } ;
+}
+
+sub bitmask
+{
+ return $^B ;
+}
+
+sub enabled
+{
+ my $string = shift ;
+
+ return 1
+ if $bits{$string} && $^B & $bits{$string} ;
+
+ return 0 ;
+}
+
+1;
return 0;
}
+#if 0
+static char *
+printW(sv)
+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
magic_get(SV *sv, MAGIC *mg)
{
case '\001': /* ^A */
sv_setsv(sv, PL_bodytarget);
break;
+ case '\002': /* ^B */
+ /* printf("magic_get $^B: ") ; */
+ if (curcop->cop_warnings == WARN_NONE)
+ /* printf("WARN_NONE\n"), */
+ sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
+ else if (curcop->cop_warnings == WARN_ALL)
+ /* printf("WARN_ALL\n"), */
+ sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
+ else
+ /* printf("some %s\n", printW(curcop->cop_warnings)), */
+ sv_setsv(sv, curcop->cop_warnings);
+ break;
case '\004': /* ^D */
sv_setiv(sv, (IV)(PL_debug & 32767));
break;
#endif
break;
case '\027': /* ^W */
- sv_setiv(sv, (IV)PL_dowarn);
+ sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) == G_WARN_ON));
break;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
else {
i = whichsig(s); /* ...no, a brick */
if (!i) {
- if (PL_dowarn || strEQ(s,"ALARM"))
- warn("No such signal: SIG%s", s);
+ if (ckWARN(WARN_SIGNAL) || strEQ(s,"ALARM"))
+ warner(WARN_SIGNAL, "No such signal: SIG%s", s);
return 0;
}
SvREFCNT_dec(psig_name[i]);
case '\001': /* ^A */
sv_setsv(PL_bodytarget, sv);
break;
+ case '\002': /* ^B */
+ if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
+ if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize))
+ compiling.cop_warnings = WARN_ALL;
+ else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize))
+ compiling.cop_warnings = WARN_NONE;
+ else {
+ if (compiling.cop_warnings != WARN_NONE &&
+ compiling.cop_warnings != WARN_ALL)
+ sv_setsv(compiling.cop_warnings, sv);
+ else
+ compiling.cop_warnings = newSVsv(sv) ;
+ }
+ }
+ break;
case '\004': /* ^D */
PL_debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
DEBUG_x(dump_all());
#endif
break;
case '\027': /* ^W */
- PL_dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
+ if ( ! (PL_dowarn & G_WARN_ALL_MASK)) {
+ i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
+ PL_dowarn = (i ? G_WARN_ON : G_WARN_OFF) ;
+ }
break;
case '.':
if (PL_localizing) {
cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
if (!cv || !CvROOT(cv)) {
- if (PL_dowarn)
- warn("SIG%s handler \"%s\" not defined.\n",
+ if (ckWARN(WARN_SIGNAL))
+ warner(WARN_SIGNAL, "SIG%s handler \"%s\" not defined.\n",
sig_name[sig], (gv ? GvENAME(gv)
: ((cv && CvGV(cv))
? GvENAME(CvGV(cv))
}
croak("Can't use global %s in \"my\"",name);
}
- if (PL_dowarn && AvFILLp(PL_comppad_name) >= 0) {
+ if (ckWARN(WARN_UNSAFE) && AvFILLp(PL_comppad_name) >= 0) {
SV **svp = AvARRAY(PL_comppad_name);
for (off = AvFILLp(PL_comppad_name); off > PL_comppad_name_floor; off--) {
if ((sv = svp[off])
&& SvIVX(sv) == 999999999 /* var is in open scope */
&& strEQ(name, SvPVX(sv)))
{
- warn("\"my\" variable %s masks earlier declaration in same scope", name);
+ warner(WARN_UNSAFE,
+ "\"my\" variable %s masks earlier declaration in same scope",
+ name);
break;
}
}
if (CvANON(bcv))
CvCLONE_on(bcv);
else {
- if (PL_dowarn && !CvUNIQUE(cv))
- warn(
+ if (ckWARN(WARN_CLOSURE) && !CvUNIQUE(cv))
+ warner(WARN_CLOSURE,
"Variable \"%s\" may be unavailable",
name);
break;
}
}
else if (!CvUNIQUE(PL_compcv)) {
- if (PL_dowarn && !SvFAKE(sv) && !CvUNIQUE(cv))
- warn("Variable \"%s\" will not stay shared", name);
+ if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) && !CvUNIQUE(cv))
+ warner(WARN_CLOSURE,
+ "Variable \"%s\" will not stay shared", name);
}
}
av_store(PL_comppad, newoff, SvREFCNT_inc(oldsv));
case OP_DBSTATE:
Safefree(cCOPo->cop_label);
SvREFCNT_dec(cCOPo->cop_filegv);
+ if (cCOPo->cop_warnings != WARN_NONE && cCOPo->cop_warnings != WARN_ALL)
+ SvREFCNT_dec(cCOPo->cop_warnings);
break;
case OP_CONST:
SvREFCNT_dec(cSVOPo->op_sv);
STATIC OP *
scalarboolean(OP *o)
{
- if (PL_dowarn &&
+ if (ckWARN(WARN_SYNTAX) &&
o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
dTHR;
line_t oldline = PL_curcop->cop_line;
if (PL_copline != NOLINE)
PL_curcop->cop_line = PL_copline;
- warn("Found = in conditional, should be ==");
+ warner(WARN_SYNTAX, "Found = in conditional, should be ==");
PL_curcop->cop_line = oldline;
}
return scalar(o);
case OP_CONST:
sv = cSVOPo->op_sv;
- if (PL_dowarn) {
+ if (ckWARN(WARN_VOID)) {
useless = "a constant";
if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = 0;
}
break;
}
- if (useless && PL_dowarn)
- warn("Useless use of %s in void context", useless);
+ if (useless && ckWARN(WARN_VOID))
+ warner(WARN_VOID, "Useless use of %s in void context", useless);
return o;
}
{
OP *o;
- if (PL_dowarn &&
- (left->op_type == OP_RV2AV ||
- left->op_type == OP_RV2HV ||
- left->op_type == OP_PADAV ||
- left->op_type == OP_PADHV)) {
- char *desc = op_desc[(right->op_type == OP_SUBST ||
- right->op_type == OP_TRANS)
- ? right->op_type : OP_MATCH];
- char *sample = ((left->op_type == OP_RV2AV ||
- left->op_type == OP_PADAV)
- ? "@array" : "%hash");
- warn("Applying %s to %s will act on scalar(%s)", desc, sample, sample);
+ if (ckWARN(WARN_UNSAFE) &&
+ (left->op_type == OP_RV2AV ||
+ left->op_type == OP_RV2HV ||
+ left->op_type == OP_PADAV ||
+ left->op_type == OP_PADHV)) {
+ char *desc = op_desc[(right->op_type == OP_SUBST ||
+ right->op_type == OP_TRANS)
+ ? right->op_type : OP_MATCH];
+ char *sample = ((left->op_type == OP_RV2AV ||
+ left->op_type == OP_PADAV)
+ ? "@array" : "%hash");
+ warner(WARN_UNSAFE,
+ "Applying %s to %s will act on scalar(%s)",
+ desc, sample, sample);
}
if (right->op_type == OP_MATCH ||
PL_pad_reset_pending = FALSE;
SAVEHINTS();
PL_hints &= ~HINT_BLOCK_SCOPE;
+ SAVEPPTR(compiling.cop_warnings);
+ if (PL_compiling.cop_warnings != WARN_ALL &&
+ PL_compiling.cop_warnings != WARN_NONE) {
+ PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
+ SAVEFREESV(PL_compiling.cop_warnings) ;
+ }
+
+
return retval;
}
if (o->op_flags & OPf_PARENS)
list(o);
else {
- if (PL_dowarn && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
+ if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
char *s;
for (s = PL_bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ;
if (*s == ';' || *s == '=')
- warn("Parens missing around \"%s\" list", lex ? "my" : "local");
+ warner(WARN_PARENTHESIS, "Parens missing around \"%s\" list",
+ lex ? "my" : "local");
}
}
PL_in_my = FALSE;
}
cop->cop_seq = seq;
cop->cop_arybase = PL_curcop->cop_arybase;
+ if (PL_curcop->cop_warnings == WARN_NONE
+ || PL_curcop->cop_warnings == WARN_ALL)
+ cop->cop_warnings = PL_curcop->cop_warnings ;
+ else
+ cop->cop_warnings = newSVsv(PL_curcop->cop_warnings) ;
+
if (PL_copline == NOLINE)
cop->cop_line = PL_curcop->cop_line;
}
}
if (first->op_type == OP_CONST) {
- if (PL_dowarn && (first->op_private & OPpCONST_BARE))
- warn("Probable precedence problem on %s", op_desc[type]);
+ if (ckWARN(WARN_PRECEDENCE) && (first->op_private & OPpCONST_BARE))
+ warner(WARN_PRECEDENCE, "Probable precedence problem on %s",
+ op_desc[type]);
if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
op_free(first);
*firstp = Nullop;
else
scalar(other);
}
- else if (PL_dowarn && (first->op_flags & OPf_KIDS)) {
+ else if (ckWARN(WARN_UNSAFE) && (first->op_flags & OPf_KIDS)) {
OP *k1 = ((UNOP*)first)->op_first;
OP *k2 = k1->op_sibling;
OPCODE warnop = 0;
if (warnop) {
line_t oldline = PL_curcop->cop_line;
PL_curcop->cop_line = PL_copline;
- warn("Value of %s%s can be \"0\"; test with defined()",
+ warner(WARN_UNSAFE,
+ "Value of %s%s can be \"0\"; test with defined()",
op_desc[warnop],
((warnop == OP_READLINE || warnop == OP_GLOB)
? " construct" : "() operator"));
croak("Can't redefine active sort subroutine %s", name);
if(const_sv = cv_const_sv(cv))
const_changed = sv_cmp(const_sv, op_const_sv(block, Nullcv));
- if ((const_sv && const_changed) || PL_dowarn && !(CvGV(cv) && GvSTASH(CvGV(cv))
+ if ((const_sv && const_changed) || ckWARN(WARN_REDEFINE)
+ && !(CvGV(cv) && GvSTASH(CvGV(cv))
&& HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))),
"autouse"))) {
line_t oldline = PL_curcop->cop_line;
PL_curcop->cop_line = PL_copline;
- warn(const_sv ? "Constant subroutine %s redefined"
- : "Subroutine %s redefined", name);
+ warner(WARN_REDEFINE,
+ const_sv ? "Constant subroutine %s redefined"
+ : "Subroutine %s redefined", name);
PL_curcop->cop_line = oldline;
}
SvREFCNT_dec(cv);
}
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
- if (PL_dowarn && !(CvGV(cv) && GvSTASH(CvGV(cv))
+ if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
&& HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
line_t oldline = PL_curcop->cop_line;
PL_curcop->cop_line = PL_copline;
- warn("Subroutine %s redefined",name);
+ warner(WARN_REDEFINE, "Subroutine %s redefined",name);
PL_curcop->cop_line = oldline;
}
SvREFCNT_dec(cv);
gv = gv_fetchpv(name,TRUE, SVt_PVFM);
GvMULTI_on(gv);
if (cv = GvFORM(gv)) {
- if (PL_dowarn) {
+ if (ckWARN(WARN_REDEFINE)) {
line_t oldline = PL_curcop->cop_line;
PL_curcop->cop_line = PL_copline;
- warn("Format %s redefined",name);
+ warner(WARN_REDEFINE, "Format %s redefined",name);
PL_curcop->cop_line = oldline;
}
SvREFCNT_dec(cv);
char *name = SvPVx(((SVOP*)kid)->op_sv, PL_na);
OP *newop = newAVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVAV) ));
- if (PL_dowarn)
- warn("Array @%s missing the @ in argument %ld of %s()",
+ if (ckWARN(WARN_SYNTAX))
+ warner(WARN_SYNTAX,
+ "Array @%s missing the @ in argument %ld of %s()",
name, (long)numargs, op_desc[type]);
op_free(kid);
kid = newop;
char *name = SvPVx(((SVOP*)kid)->op_sv, PL_na);
OP *newop = newHVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVHV) ));
- if (PL_dowarn)
- warn("Hash %%%s missing the %% in argument %ld of %s()",
+ if (ckWARN(WARN_SYNTAX))
+ warner(WARN_SYNTAX,
+ "Hash %%%s missing the %% in argument %ld of %s()",
name, (long)numargs, op_desc[type]);
op_free(kid);
kid = newop;
case OP_EXEC:
o->op_seq = PL_op_seqmax++;
- if (PL_dowarn && o->op_next && o->op_next->op_type == OP_NEXTSTATE) {
+ if (ckWARN(WARN_SYNTAX) && o->op_next
+ && o->op_next->op_type == OP_NEXTSTATE) {
if (o->op_next->op_sibling &&
o->op_next->op_sibling->op_type != OP_EXIT &&
o->op_next->op_sibling->op_type != OP_WARN &&
line_t oldline = PL_curcop->cop_line;
PL_curcop->cop_line = ((COP*)o->op_next)->cop_line;
- warn("Statement unlikely to be reached");
- warn("(Maybe you meant system() when you said exec()?)\n");
+ warner(WARN_SYNTAX, "Statement unlikely to be reached");
+ warner(WARN_SYNTAX, "(Maybe you meant system() when you said exec()?)\n");
PL_curcop->cop_line = oldline;
}
}
#define OPpCONST_ENTERED 16 /* Has been entered as symbol. */
#define OPpCONST_ARYBASE 32 /* Was a $[ translated to constant. */
#define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */
+#define OPpCONST_WARNING 128 /* Was a $^W translated to constant. */
/* Private for OP_FLIP/FLOP */
#define OPpFLIP_LINENUM 64 /* Range arg potentially a line num. */
PL_minus_a = FALSE;
PL_minus_F = FALSE;
PL_doswitches = FALSE;
- PL_dowarn = FALSE;
+ PL_dowarn = G_WARN_OFF;
PL_doextract = FALSE;
PL_sawampersand = FALSE; /* must save all match strings */
PL_sawstudy = FALSE; /* do fbm_instr on all strings */
time(&PL_basetime);
oldscope = PL_scopestack_ix;
+ PL_dowarn = G_WARN_OFF;
JMPENV_PUSH(ret);
switch (ret) {
case 'u':
case 'U':
case 'v':
+ case 'W':
+ case 'X':
case 'w':
if (s = moreswitches(s))
goto reswitch;
if (PL_do_undump)
my_unexec();
- if (PL_dowarn)
+ if (ckWARN(WARN_ONCE))
gv_check(PL_defstash);
LEAVE;
Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
PerlProc_exit(0);
case 'w':
- PL_dowarn = TRUE;
+ if (! (PL_dowarn & G_WARN_ALL_MASK))
+ PL_dowarn |= G_WARN_ON;
+ s++;
+ return s;
+ case 'W':
+ PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
+ compiling.cop_warnings = WARN_ALL ;
+ s++;
+ return s;
+ case 'X':
+ PL_dowarn = G_WARN_ALL_OFF;
+ compiling.cop_warnings = WARN_NONE ;
s++;
return s;
case '*':
#include "hv.h"
#include "mg.h"
#include "scope.h"
+#include "warning.h"
#include "bytecode.h"
#include "byterun.h"
#include "utf8.h"
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "a symbol");
- if (PL_dowarn)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, PL_na);
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "a SCALAR");
- if (PL_dowarn)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, PL_na);
SV *ssv = POPs;
STRLEN len;
char *ptr = SvPV(ssv,len);
- if (PL_dowarn && len == 0)
- warn("Explicit blessing to '' (assuming package main)");
+ if (ckWARN(WARN_UNSAFE) && len == 0)
+ warner(WARN_UNSAFE,
+ "Explicit blessing to '' (assuming package main)");
stash = gv_stashpvn(ptr, len, TRUE);
}
hv_undef((HV*)sv);
break;
case SVt_PVCV:
- if (PL_dowarn && cv_const_sv((CV*)sv))
- warn("Constant subroutine %s undefined",
+ if (ckWARN(WARN_UNSAFE) && cv_const_sv((CV*)sv))
+ warner(WARN_UNSAFE, "Constant subroutine %s undefined",
CvANON((CV*)sv) ? "(anonymous)" : GvENAME(CvGV((CV*)sv)));
/* FALL THROUGH */
case SVt_PVFM:
rem -= pos;
}
if (fail < 0) {
- if (PL_dowarn || lvalue || repl)
- warn("substr outside of string");
+ if (ckWARN(WARN_SUBSTR) || lvalue || repl)
+ warner(WARN_SUBSTR, "substr outside of string");
RETPUSHUNDEF;
}
else {
if (!SvGMAGICAL(sv)) {
if (SvROK(sv)) {
SvPV_force(sv,PL_na);
- if (PL_dowarn)
- warn("Attempt to use reference as lvalue in substr");
+ if (ckWARN(WARN_SUBSTR))
+ warner(WARN_SUBSTR,
+ "Attempt to use reference as lvalue in substr");
}
if (SvOK(sv)) /* is it defined ? */
(void)SvPOK_only(sv);
SV *val = NEWSV(46, 0);
if (MARK < SP)
sv_setsv(val, *++MARK);
- else if (PL_dowarn)
- warn("Odd number of elements in hash assignment");
+ else if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
default:
croak("Invalid type in unpack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
- if (commas++ == 0 && PL_dowarn)
- warn("Invalid type in unpack: '%c'", (int)datumtype);
+ if (commas++ == 0 && ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
break;
case '%':
if (len == 1 && pat[-1] != '1')
default:
croak("Invalid type in pack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
- if (commas++ == 0 && PL_dowarn)
- warn("Invalid type in pack: '%c'", (int)datumtype);
+ if (commas++ == 0 && ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
break;
case '%':
DIE("%% may only be used in unpack");
* of pack() (and all copies of the result) are
* gone.
*/
- if (PL_dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
- warn("Attempt to pack pointer to temporary value");
+ if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
+ warner(WARN_UNSAFE,
+ "Attempt to pack pointer to temporary value");
if (SvPOK(fromstr) || SvNIOK(fromstr))
aptr = SvPV(fromstr,PL_na);
else
sv = *++MARK;
else {
sv = &PL_sv_no;
- if (PL_dowarn)
- warn("Not enough format arguments");
+ if (ckWARN(WARN_SYNTAX))
+ warner(WARN_SYNTAX, "Not enough format arguments");
}
break;
cx = &cxstack[i];
switch (cx->cx_type) {
case CXt_SUBST:
- if (PL_dowarn)
- warn("Exiting substitution via %s", op_name[PL_op->op_type]);
+ if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Exiting substitution via %s",
+ op_name[PL_op->op_type]);
break;
case CXt_SUB:
- if (PL_dowarn)
- warn("Exiting subroutine via %s", op_name[PL_op->op_type]);
+ if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Exiting subroutine via %s",
+ op_name[PL_op->op_type]);
break;
case CXt_EVAL:
- if (PL_dowarn)
- warn("Exiting eval via %s", op_name[PL_op->op_type]);
+ if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Exiting eval via %s",
+ op_name[PL_op->op_type]);
break;
case CXt_NULL:
- if (PL_dowarn)
- warn("Exiting pseudo-block via %s", op_name[PL_op->op_type]);
+ if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
+ op_name[PL_op->op_type]);
return -1;
case CXt_LOOP:
if (!cx->blk_loop.label ||
cx = &cxstack[i];
switch (cx->cx_type) {
case CXt_SUBST:
- if (PL_dowarn)
- warn("Exiting substitution via %s", op_name[PL_op->op_type]);
+ if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Exiting substitution via %s",
+ op_name[PL_op->op_type]);
break;
case CXt_SUB:
- if (PL_dowarn)
- warn("Exiting subroutine via %s", op_name[PL_op->op_type]);
+ if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Exiting subroutine via %s",
+ op_name[PL_op->op_type]);
break;
case CXt_EVAL:
- if (PL_dowarn)
- warn("Exiting eval via %s", op_name[PL_op->op_type]);
+ if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Exiting eval via %s",
+ op_name[PL_op->op_type]);
break;
case CXt_NULL:
- if (PL_dowarn)
- warn("Exiting pseudo-block via %s", op_name[PL_op->op_type]);
+ if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
+ op_name[PL_op->op_type]);
return -1;
case CXt_LOOP:
DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
- if (CvDEPTH(cv) == 100 && PL_dowarn)
+ if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILLp(padlist)) {
AV *newpad = newAV();
SAVEFREEPV(name);
SAVEHINTS();
PL_hints = 0;
+ SAVEPPTR(PL_compiling.cop_warnings);
+ PL_compiling.cop_warnings = ((PL_dowarn & G_WARN_ALL_ON) ? WARN_ALL
+ : WARN_NONE);
/* switch to eval mode */
SAVEDELETE(PL_defstash, safestr, strlen(safestr));
SAVEHINTS();
PL_hints = PL_op->op_targ;
+ SAVEPPTR(compiling.cop_warnings);
+ if (PL_compiling.cop_warnings != WARN_ALL
+ && PL_compiling.cop_warnings != WARN_NONE){
+ PL_compiling.cop_warnings = newSVsv(PL_compiling.cop_warnings) ;
+ SAVEFREESV(PL_compiling.cop_warnings) ;
+ }
push_return(PL_op->op_next);
PUSHBLOCK(cx, CXt_EVAL, SP);
RETURN;
}
if (!(io = GvIO(gv))) {
- if (PL_dowarn) {
+ if (ckWARN(WARN_UNOPENED)) {
SV* sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
- warn("Filehandle %s never opened", SvPV(sv,PL_na));
+ warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,PL_na));
}
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
- if (PL_dowarn) {
+ if (ckWARN2(WARN_CLOSED, WARN_IO)) {
SV* sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
- warn("Filehandle %s opened only for input", SvPV(sv,PL_na));
- else
- warn("print on closed filehandle %s", SvPV(sv,PL_na));
+ warner(WARN_IO, "Filehandle %s opened only for input",
+ SvPV(sv,PL_na));
+ else if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "print on closed filehandle %s",
+ SvPV(sv,PL_na));
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "an ARRAY");
- if (PL_dowarn)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, warn_uninit);
if (GIMME == G_ARRAY)
RETURN;
RETPUSHUNDEF;
if (PL_op->op_flags & OPf_REF ||
PL_op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "a HASH");
- if (PL_dowarn)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, warn_uninit);
if (GIMME == G_ARRAY) {
SP--;
RETURN;
if (relem == lastrelem) {
if (*relem) {
HE *didstore;
- if (PL_dowarn) {
+ if (ckWARN(WARN_UNSAFE)) {
if (relem == firstrelem &&
SvROK(*relem) &&
( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
- warn("Reference found where even-sized list expected");
+ warner(WARN_UNSAFE, "Reference found where even-sized list expected");
else
- warn("Odd number of elements in hash assignment");
+ warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
}
tmpstr = NEWSV(29,0);
didstore = hv_store_ent(hash,*relem,tmpstr,0);
SP--;
}
if (!fp) {
- if (PL_dowarn && io && !(IoFLAGS(io) & IOf_START))
- warn("Read on closed filehandle <%s>", GvENAME(PL_last_in_gv));
+ if (ckWARN(WARN_CLOSED) && io && !(IoFLAGS(io) & IOf_START))
+ warner(WARN_CLOSED,
+ "Read on closed filehandle <%s>", GvENAME(PL_last_in_gv));
if (gimme == G_SCALAR) {
(void)SvOK_off(TARG);
PUSHTARG;
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
- if (CvDEPTH(cv) == 100 && PL_dowarn
+ if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
&& !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILLp(padlist)) {
sub_crush_depth(CV *cv)
{
if (CvANON(cv))
- warn("Deep recursion on anonymous subroutine");
+ warner(WARN_RECURSION, "Deep recursion on anonymous subroutine");
else {
SV* tmpstr = sv_newmortal();
gv_efullname3(tmpstr, CvGV(cv), Nullch);
- warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr));
+ warner(WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
+ SvPVX(tmpstr));
}
}
sv = POPs;
- if (PL_dowarn) {
+ if (ckWARN(WARN_UNTIE)) {
MAGIC * mg ;
if (SvMAGICAL(sv)) {
if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
mg = mg_find(sv, 'q') ;
if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
- warn("untie attempted while %lu inner references still exist",
- (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
+ warner(WARN_UNTIE,
+ "untie attempted while %lu inner references still exist",
+ (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
}
}
fp = IoOFP(io);
if (!fp) {
- if (PL_dowarn) {
+ if (ckWARN2(WARN_CLOSED,WARN_IO)) {
if (IoIFP(io))
- warn("Filehandle only opened for input");
- else
- warn("Write on closed filehandle");
+ warner(WARN_IO, "Filehandle only opened for input");
+ else if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "Write on closed filehandle");
}
PUSHs(&PL_sv_no);
}
else {
if ((IoLINES_LEFT(io) -= FmLINES(PL_formtarget)) < 0) {
- if (PL_dowarn)
- warn("page overflow");
+ if (ckWARN(WARN_IO))
+ warner(WARN_IO, "page overflow");
}
if (!PerlIO_write(ofp, SvPVX(PL_formtarget), SvCUR(PL_formtarget)) ||
PerlIO_error(fp))
sv = NEWSV(0,0);
if (!(io = GvIO(gv))) {
- if (PL_dowarn) {
+ if (ckWARN(WARN_UNOPENED)) {
gv_fullname3(sv, gv, Nullch);
- warn("Filehandle %s never opened", SvPV(sv,PL_na));
+ warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,PL_na));
}
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
- if (PL_dowarn) {
+ if (ckWARN2(WARN_CLOSED,WARN_IO)) {
gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
- warn("Filehandle %s opened only for input", SvPV(sv,PL_na));
- else
- warn("printf on closed filehandle %s", SvPV(sv,PL_na));
+ warner(WARN_IO, "Filehandle %s opened only for input",
+ SvPV(sv,PL_na));
+ else if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "printf on closed filehandle %s",
+ SvPV(sv,PL_na));
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
io = GvIO(gv);
if (!io || !IoIFP(io)) {
length = -1;
- if (PL_dowarn) {
+ if (ckWARN(WARN_CLOSED)) {
if (PL_op->op_type == OP_SYSWRITE)
- warn("Syswrite on closed filehandle");
+ warner(WARN_CLOSED, "Syswrite on closed filehandle");
else
- warn("Send on closed socket");
+ warner(WARN_CLOSED, "Send on closed socket");
}
}
else if (PL_op->op_type == OP_SYSWRITE) {
RETPUSHUNDEF;
nuts:
- if (PL_dowarn)
- warn("bind() on closed fd");
+ if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "bind() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
RETPUSHUNDEF;
nuts:
- if (PL_dowarn)
- warn("connect() on closed fd");
+ if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "connect() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
RETPUSHUNDEF;
nuts:
- if (PL_dowarn)
- warn("listen() on closed fd");
+ if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "listen() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
RETURN;
nuts:
- if (PL_dowarn)
- warn("accept() on closed fd");
+ if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "accept() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
badexit:
RETURN;
nuts:
- if (PL_dowarn)
- warn("shutdown() on closed fd");
+ if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "shutdown() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
RETURN;
nuts:
- if (PL_dowarn)
- warn("[gs]etsockopt() on closed fd");
+ if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "[gs]etsockopt() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
RETURN;
nuts:
- if (PL_dowarn)
- warn("get{sock, peer}name() on closed fd");
+ if (ckWARN(WARN_CLOSED))
+ warner(WARN_CLOSED, "get{sock, peer}name() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
#endif
PL_laststatval = PerlLIO_stat(SvPV(PL_statname, PL_na), &PL_statcache);
if (PL_laststatval < 0) {
- if (PL_dowarn && strchr(SvPV(PL_statname, PL_na), '\n'))
- warn(warn_nl, "stat");
+ if (ckWARN(WARN_NEWLINE) && strchr(SvPV(PL_statname, PL_na), '\n'))
+ warner(WARN_NEWLINE, warn_nl, "stat");
max = 0;
}
}
len = 512;
}
else {
- if (PL_dowarn)
- warn("Test on unopened file <%s>",
+ if (ckWARN(WARN_UNOPENED))
+ warner(WARN_UNOPENED, "Test on unopened file <%s>",
GvENAME(cGVOP->op_gv));
SETERRNO(EBADF,RMS$_IFI);
RETPUSHUNDEF;
i = PerlLIO_open(SvPV(sv, PL_na), 0);
#endif
if (i < 0) {
- if (PL_dowarn && strchr(SvPV(sv, PL_na), '\n'))
- warn(warn_nl, "open");
+ if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, PL_na), '\n'))
+ warner(WARN_NEWLINE, warn_nl, "open");
RETPUSHUNDEF;
}
PL_laststatval = PerlLIO_fstat(i, &PL_statcache);
VIRTUAL void vivify_ref _((SV* sv, U32 to_what));
VIRTUAL I32 wait4pid _((int pid, int* statusp, int flags));
VIRTUAL void warn _((const char* pat,...));
+VIRTUAL void warner _((U32 err, const char* pat,...));
VIRTUAL void watch _((char** addr));
VIRTUAL I32 whichsig _((char* sig));
VIRTUAL int yyerror _((char* s));
? (flags & ~SCF_DO_SUBSTR) : flags);
if (!scan) /* It was not CURLYX, but CURLY. */
scan = next;
- if (PL_dowarn && (minnext + deltanext == 0)
+ if (ckWARN(WARN_UNSAFE) && (minnext + deltanext == 0)
&& !(data->flags & (SF_HAS_PAR|SF_IN_PAR))
&& maxcount <= 10000) /* Complement check for big count */
- warn("Strange *+?{} on zero-length expression");
+ warner(WARN_UNSAFE, "Strange *+?{} on zero-length expression");
min += minnext * mincount;
is_inf |= (maxcount == REG_INFTY && (minnext + deltanext) > 0
|| deltanext == I32_MAX);
goto do_curly;
}
nest_check:
- if (PL_dowarn && !SIZE_ONLY && !(flags&HASWIDTH) && max > 10000) {
- warn("%.*s matches null string many times",
+ if (ckWARN(WARN_UNSAFE) && !SIZE_ONLY && !(flags&HASWIDTH) && max > 10000) {
+ warner(WARN_UNSAFE, "%.*s matches null string many times",
PL_regcomp_parse - origparse, origparse);
}
* (POSIX Extended Character Classes, that is)
* The text between e.g. [: and :] would start
* at posixccs + 1 and stop at regcomp_parse - 2. */
- if (PL_dowarn && !SIZE_ONLY)
- warn("Character class syntax [%c %c] is reserved for future extensions", posixccc, posixccc);
+ if (ckWARN(WARN_UNSAFE) && !SIZE_ONLY)
+ warner(WARN_UNSAFE,
+ "Character class syntax [%c %c] is reserved for future extensions", posixccc, posixccc);
PL_regcomp_parse++; /* skip over the ending ] */
}
}
* (POSIX Extended Character Classes, that is)
* The text between e.g. [: and :] would start
* at posixccs + 1 and stop at regcomp_parse - 2. */
- if (PL_dowarn && !SIZE_ONLY)
- warn("Character class syntax [%c %c] is reserved for future extensions", posixccc, posixccc);
+ if (ckWARN(WARN_UNSAFE) && !SIZE_ONLY)
+ warner(WARN_UNSAFE,
+ "Character class syntax [%c %c] is reserved for future extensions", posixccc, posixccc);
PL_regcomp_parse++; /* skip over the ending ] */
}
}
PL_regcc = cc;
if (n >= cc->max) { /* Maximum greed exceeded? */
- if (PL_dowarn && n >= REG_INFTY
+ if (ckWARN(WARN_UNSAFE) && n >= REG_INFTY
&& !(PL_reg_flags & RF_warned)) {
PL_reg_flags |= RF_warned;
- warn("%s limit (%d) exceeded",
+ warner(WARN_UNSAFE, "%s limit (%d) exceeded",
"Complex regular subexpression recursion",
REG_INFTY - 1);
}
REPORT_CODE_OFF+PL_regindent*2, "")
);
}
- if (PL_dowarn && n >= REG_INFTY && !(PL_reg_flags & RF_warned)) {
+ if (ckWARN(WARN_UNSAFE) && n >= REG_INFTY
+ && !(PL_reg_flags & RF_warned)) {
PL_reg_flags |= RF_warned;
- warn("%s limit (%d) exceeded",
+ warner(WARN_UNSAFE, "%s limit (%d) exceeded",
"Complex regular subexpression recursion",
REG_INFTY - 1);
}
*d = '\0';
if (PL_op)
- warn("Argument \"%s\" isn't numeric in %s", tmpbuf,
+ warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
op_name[PL_op->op_type]);
else
- warn("Argument \"%s\" isn't numeric", tmpbuf);
+ warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
}
IV
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
if (!SvROK(sv)) {
- if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!PL_localizing)
- warn(warn_uninit);
+ warner(WARN_UNINITIALIZED, warn_uninit);
}
return 0;
}
}
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
- if (PL_dowarn)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, warn_uninit);
return 0;
}
}
}
else {
dTHR;
- if (PL_dowarn && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ warner(WARN_UNINITIALIZED, warn_uninit);
return 0;
}
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
if (SvPOKp(sv) && SvLEN(sv))
return asUV(sv);
if (!SvROK(sv)) {
- if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!PL_localizing)
- warn(warn_uninit);
+ warner(WARN_UNINITIALIZED, warn_uninit);
}
return 0;
}
}
if (SvPOKp(sv) && SvLEN(sv))
return asUV(sv);
- if (PL_dowarn)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, warn_uninit);
return 0;
}
}
SvUVX(sv) = asUV(sv);
}
else {
- if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!PL_localizing)
- warn(warn_uninit);
+ warner(WARN_UNINITIALIZED, warn_uninit);
}
return 0;
}
if (SvNOKp(sv))
return SvNVX(sv);
if (SvPOKp(sv) && SvLEN(sv)) {
- if (PL_dowarn && !SvIOKp(sv) && !looks_like_number(sv))
+ if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
if (SvIOKp(sv))
return (double)SvIVX(sv);
if (!SvROK(sv)) {
- if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!PL_localizing)
- warn(warn_uninit);
+ warner(WARN_UNINITIALIZED, warn_uninit);
}
return 0;
}
}
if (SvREADONLY(sv)) {
if (SvPOKp(sv) && SvLEN(sv)) {
- if (PL_dowarn && !SvIOKp(sv) && !looks_like_number(sv))
+ if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
}
if (SvIOKp(sv))
return (double)SvIVX(sv);
- if (PL_dowarn)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, warn_uninit);
return 0.0;
}
}
SvNVX(sv) = (double)SvIVX(sv);
}
else if (SvPOKp(sv) && SvLEN(sv)) {
- if (PL_dowarn && !SvIOKp(sv) && !looks_like_number(sv))
+ if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SET_NUMERIC_STANDARD();
SvNVX(sv) = atof(SvPVX(sv));
}
else {
dTHR;
- if (PL_dowarn && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ warner(WARN_UNINITIALIZED, warn_uninit);
return 0.0;
}
SvNOK_on(sv);
if (numtype == 1)
return atol(SvPVX(sv));
- if (!numtype && PL_dowarn)
+ if (!numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
SET_NUMERIC_STANDARD();
d = atof(SvPVX(sv));
if (numtype == 1)
return strtoul(SvPVX(sv), Null(char**), 10);
#endif
- if (!numtype && PL_dowarn)
+ if (!numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
SET_NUMERIC_STANDARD();
return U_V(atof(SvPVX(sv)));
goto tokensave;
}
if (!SvROK(sv)) {
- if (PL_dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
+ if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!PL_localizing)
- warn(warn_uninit);
+ warner(WARN_UNINITIALIZED, warn_uninit);
}
*lp = 0;
return "";
tsv = Nullsv;
goto tokensave;
}
- if (PL_dowarn)
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED))
+ warner(WARN_UNINITIALIZED, warn_uninit);
*lp = 0;
return "";
}
}
else {
dTHR;
- if (PL_dowarn && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- warn(warn_uninit);
+ if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ warner(WARN_UNINITIALIZED, warn_uninit);
*lp = 0;
return "";
}
croak(
"Can't redefine active sort subroutine %s",
GvENAME((GV*)dstr));
- if (PL_dowarn || (const_changed && const_sv)) {
+ if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
if (!(CvGV(cv) && GvSTASH(CvGV(cv))
&& HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))),
"autouse")))
- warn(const_sv ?
+ warner(WARN_REDEFINE, const_sv ?
"Constant subroutine %s redefined"
: "Subroutine %s redefined",
GvENAME((GV*)dstr));
}
else {
if (dtype == SVt_PVGV) {
- if (PL_dowarn)
- warn("Undefined value assigned to typeglob");
+ if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE, "Undefined value assigned to typeglob");
}
else
(void)SvOK_off(dstr);
default:
unknown:
- if (!args && PL_dowarn &&
+ if (!args && ckWARN(WARN_PRINTF) &&
(PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
SV *msg = sv_newmortal();
sv_setpvf(msg, "Invalid conversion in %s: ",
c & 0xFF);
else
sv_catpv(msg, "end of string");
- warn("%_", msg); /* yes, this is reentrant */
+ warner(WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
}
/* output mangled stuff ... */
########
# strict behaviour, without any extra references
-#use warning 'untie';
-local $^W = 1 ;
+use warning 'untie';
+#local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
########
# strict behaviour, with 1 extra references generating an error
-#use warning 'untie';
-local $^W = 1 ;
+use warning 'untie';
+#local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
untie %h;
########
# strict behaviour, with 1 extra references via tied generating an error
-#use warning 'untie';
-local $^W = 1 ;
+use warning 'untie';
+#local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
########
# strict behaviour, with 1 extra references which are destroyed
-#use warning 'untie';
-local $^W = 1 ;
+use warning 'untie';
+#local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$a = 0 ;
########
# strict behaviour, with extra 1 references via tied which are destroyed
-#use warning 'untie';
-local $^W = 1 ;
+use warning 'untie';
+#local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
########
# strict error behaviour, with 2 extra references
-#use warning 'untie';
-local $^W = 1 ;
+use warning 'untie';
+#local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$b = tied %h ;
########
# strict behaviour, check scope of strictness.
-#no warning 'untie';
-local $^W = 0 ;
+no warning 'untie';
+#local $^W = 0 ;
use Tie::Hash ;
$A = tie %H, Tie::StdHash;
$C = $B = tied %H ;
{
- #use warning 'untie';
- local $^W = 1 ;
+ use warning 'untie';
+ #local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
Check existing $^W functionality
+
__END__
# warnable code, warnings disabled
########
$^W = 1;
-eval "my $b ; chop $b ;" ;
+eval 'my $b ; chop $b ;' ;
+print $@ ;
EXPECT
-Use of uninitialized value at - line 3.
-Use of uninitialized value at - line 3.
+Use of uninitialized value at (eval 1) line 1.
########
-eval "$^W = 1;" ;
+eval '$^W = 1;' ;
+print $@ ;
my $b ; chop $b ;
EXPECT
-
+Use of uninitialized value at - line 4.
########
eval {$^W = 1;} ;
+print $@ ;
my $b ; chop $b ;
EXPECT
-Use of uninitialized value at - line 3.
+Use of uninitialized value at - line 4.
########
{
-e undef
EXPECT
Use of uninitialized value at - line 2.
+########
+
+$^W = 1 + 2 ;
+EXPECT
+
+########
+
+$^W = $a ;
+EXPECT
+
+########
+
+sub fred {}
+$^W = fred() ;
+EXPECT
+
+########
+
+sub fred { my $b ; chop $b ;}
+{ local $^W = 0 ;
+ fred() ;
+}
+EXPECT
+
+########
+
+sub fred { my $b ; chop $b ;}
+{ local $^W = 1 ;
+ fred() ;
+}
+EXPECT
+Use of uninitialized value at - line 2.
--- /dev/null
+Check lexical warning functionality
+
+TODO
+ check that the warning hierarchy works.
+
+__END__
+
+# check illegal category is caught
+use warning 'blah' ;
+EXPECT
+unknown warning category 'blah' at - line 3
+BEGIN failed--compilation aborted at - line 3.
+########
+
+# Check compile time scope of pragma
+use warning 'deprecated' ;
+{
+ no warning ;
+ 1 if $a EQ $b ;
+}
+1 if $a EQ $b ;
+EXPECT
+Use of EQ is deprecated at - line 8.
+########
+
+# Check compile time scope of pragma
+no warning;
+{
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+}
+1 if $a EQ $b ;
+EXPECT
+Use of EQ is deprecated at - line 6.
+########
+
+# Check runtime scope of pragma
+use warning 'uninitialized' ;
+{
+ no warning ;
+ my $b ; chop $b ;
+}
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at - line 8.
+########
+
+# Check runtime scope of pragma
+no warning ;
+{
+ use warning 'uninitialized' ;
+ my $b ; chop $b ;
+}
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at - line 6.
+########
+
+# Check runtime scope of pragma
+no warning ;
+{
+ use warning 'uninitialized' ;
+ $a = sub { my $b ; chop $b ; }
+}
+&$a ;
+EXPECT
+Use of uninitialized value at - line 6.
+########
+
+use warning 'deprecated' ;
+1 if $a EQ $b ;
+EXPECT
+Use of EQ is deprecated at - line 3.
+########
+
+--FILE-- abc
+1 if $a EQ $b ;
+1;
+--FILE--
+use warning 'deprecated' ;
+require "./abc";
+EXPECT
+
+########
+
+--FILE-- abc
+use warning 'deprecated' ;
+1;
+--FILE--
+require "./abc";
+1 if $a EQ $b ;
+EXPECT
+
+########
+
+--FILE-- abc
+use warning 'deprecated' ;
+1 if $a EQ $b ;
+1;
+--FILE--
+use warning 'uninitialized' ;
+require "./abc";
+my $a ; chop $a ;
+EXPECT
+Use of EQ is deprecated at ./abc line 2.
+Use of uninitialized value at - line 3.
+########
+
+--FILE-- abc.pm
+use warning 'deprecated' ;
+1 if $a EQ $b ;
+1;
+--FILE--
+use warning 'uninitialized' ;
+use abc;
+my $a ; chop $a ;
+EXPECT
+Use of EQ is deprecated at abc.pm line 2.
+Use of uninitialized value at - line 3.
+########
+
+# Check scope of pragma with eval
+no warning ;
+eval {
+ my $b ; chop $b ;
+}; print STDERR $@ ;
+my $b ; chop $b ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no warning ;
+eval {
+ use warning 'uninitialized' ;
+ my $b ; chop $b ;
+}; print STDERR $@ ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at - line 6.
+########
+
+# Check scope of pragma with eval
+use warning 'uninitialized' ;
+eval {
+ my $b ; chop $b ;
+}; print STDERR $@ ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at - line 5.
+Use of uninitialized value at - line 7.
+########
+
+# Check scope of pragma with eval
+use warning 'uninitialized' ;
+eval {
+ no warning ;
+ my $b ; chop $b ;
+}; print STDERR $@ ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at - line 8.
+########
+
+# Check scope of pragma with eval
+no warning ;
+eval {
+ 1 if $a EQ $b ;
+}; print STDERR $@ ;
+1 if $a EQ $b ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no warning ;
+eval {
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+}; print STDERR $@ ;
+1 if $a EQ $b ;
+EXPECT
+Use of EQ is deprecated at - line 6.
+########
+
+# Check scope of pragma with eval
+use warning 'deprecated' ;
+eval {
+ 1 if $a EQ $b ;
+}; print STDERR $@ ;
+1 if $a EQ $b ;
+EXPECT
+Use of EQ is deprecated at - line 5.
+Use of EQ is deprecated at - line 7.
+########
+
+# Check scope of pragma with eval
+use warning 'deprecated' ;
+eval {
+ no warning ;
+ 1 if $a EQ $b ;
+}; print STDERR $@ ;
+1 if $a EQ $b ;
+EXPECT
+Use of EQ is deprecated at - line 8.
+########
+
+# Check scope of pragma with eval
+no warning ;
+eval '
+ my $b ; chop $b ;
+'; print STDERR $@ ;
+my $b ; chop $b ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no warning ;
+eval q[
+ use warning 'uninitialized' ;
+ my $b ; chop $b ;
+]; print STDERR $@;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at (eval 1) line 3.
+########
+
+# Check scope of pragma with eval
+use warning 'uninitialized' ;
+eval '
+ my $b ; chop $b ;
+'; print STDERR $@ ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at (eval 1) line 2.
+Use of uninitialized value at - line 7.
+########
+
+# Check scope of pragma with eval
+use warning 'uninitialized' ;
+eval '
+ no warning ;
+ my $b ; chop $b ;
+'; print STDERR $@ ;
+my $b ; chop $b ;
+EXPECT
+Use of uninitialized value at - line 8.
+########
+
+# Check scope of pragma with eval
+no warning ;
+eval '
+ 1 if $a EQ $b ;
+'; print STDERR $@ ;
+1 if $a EQ $b ;
+EXPECT
+
+########
+
+# Check scope of pragma with eval
+no warning ;
+eval q[
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+]; print STDERR $@;
+1 if $a EQ $b ;
+EXPECT
+Use of EQ is deprecated at (eval 1) line 3.
+########
+
+# Check scope of pragma with eval
+use warning 'deprecated' ;
+eval '
+ 1 if $a EQ $b ;
+'; print STDERR $@;
+1 if $a EQ $b ;
+EXPECT
+Use of EQ is deprecated at - line 7.
+Use of EQ is deprecated at (eval 1) line 2.
+########
+
+# Check scope of pragma with eval
+use warning 'deprecated' ;
+eval '
+ no warning ;
+ 1 if $a EQ $b ;
+'; print STDERR $@;
+1 if $a EQ $b ;
+EXPECT
+Use of EQ is deprecated at - line 8.
--- /dev/null
+Check interaction of $^W and lexical
+
+__END__
+
+# Check interaction of $^W and use warning
+sub fred {
+ use warning ;
+ my $b ;
+ chop $b ;
+}
+{ local $^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 ;
+}
+{ local $^W = 1 ;
+ fred() ;
+}
+
+EXPECT
+Use of uninitialized value at - line 6.
+########
+
+# Check interaction of $^W and use warning
+use warning ;
+$^W = 1 ;
+my $b ;
+chop $b ;
+EXPECT
+Use of uninitialized value at - line 6.
+########
+
+# Check interaction of $^W and use warning
+$^W = 1 ;
+use warning ;
+my $b ;
+chop $b ;
+EXPECT
+Use of uninitialized value at - line 6.
+########
+
+# Check interaction of $^W and use warning
+$^W = 1 ;
+no warning ;
+my $b ;
+chop $b ;
+EXPECT
+Use of uninitialized value at - line 6.
+########
+
+# Check interaction of $^W and use warning
+no warning ;
+$^W = 1 ;
+my $b ;
+chop $b ;
+EXPECT
+Use of uninitialized value at - line 6.
--- /dev/null
+Check lint
+
+__END__
+-W
+# lint: check compile time $^W is zapped
+BEGIN { $^W = 0 ;}
+$a = $b = 1 ;
+$a = 1 if $a EQ $b ;
+close STDIN ; print STDIN "abc" ;
+EXPECT
+Use of EQ is deprecated at - line 5.
+print on closed filehandle main::STDIN at - line 6.
+########
+-W
+# lint: check runtime $^W is zapped
+$^W = 0 ;
+close STDIN ; print STDIN "abc" ;
+EXPECT
+print on closed filehandle main::STDIN at - line 4.
+########
+-W
+# lint: check runtime $^W is zapped
+{
+ $^W = 0 ;
+ close STDIN ; print STDIN "abc" ;
+}
+EXPECT
+print on closed filehandle main::STDIN at - line 5.
+########
+-W
+# lint: check "no warning" is zapped
+no warning ;
+$a = $b = 1 ;
+$a = 1 if $a EQ $b ;
+close STDIN ; print STDIN "abc" ;
+EXPECT
+Use of EQ is deprecated at - line 5.
+print on closed filehandle main::STDIN at - line 6.
+########
+-W
+# lint: check "no warning" is zapped
+{
+ no warning ;
+ close STDIN ; print STDIN "abc" ;
+}
+EXPECT
+print on closed filehandle main::STDIN at - line 5.
+########
+-Ww
+# lint: check combination of -w and -W
+{
+ $^W = 0 ;
+ close STDIN ; print STDIN "abc" ;
+}
+EXPECT
+print on closed filehandle main::STDIN at - line 5.
+########
+-W
+--FILE-- abc.pm
+no warning 'deprecated' ;
+my ($a, $b) = (0,0);
+1 if $a EQ $b ;
+1;
+--FILE--
+no warning 'uninitialized' ;
+use abc;
+my $a ; chop $a ;
+EXPECT
+Use of EQ is deprecated at abc.pm line 3.
+Use of uninitialized value at - line 3.
+########
+-W
+--FILE-- abc
+no warning 'deprecated' ;
+my ($a, $b) = (0,0);
+1 if $a EQ $b ;
+1;
+--FILE--
+no warning 'uninitialized' ;
+require "./abc";
+my $a ; chop $a ;
+EXPECT
+Use of EQ is deprecated at ./abc line 3.
+Use of uninitialized value at - line 3.
+########
+-W
+--FILE-- abc.pm
+BEGIN {$^W = 0}
+my ($a, $b) = (0,0);
+1 if $a EQ $b ;
+1;
+--FILE--
+$^W = 0 ;
+use abc;
+my $a ; chop $a ;
+EXPECT
+Use of EQ is deprecated at abc.pm line 3.
+Use of uninitialized value at - line 3.
+########
+-W
+--FILE-- abc
+BEGIN {$^W = 0}
+my ($a, $b) = (0,0);
+1 if $a EQ $b ;
+1;
+--FILE--
+$^W = 0 ;
+require "./abc";
+my $a ; chop $a ;
+EXPECT
+Use of EQ is deprecated at ./abc line 3.
+Use of uninitialized value at - line 3.
--- /dev/null
+Check anti-lint
+
+__END__
+-X
+# nolint: check compile time $^W is zapped
+BEGIN { $^W = 1 ;}
+$a = $b = 1 ;
+$a = 1 if $a EQ $b ;
+close STDIN ; print STDIN "abc" ;
+EXPECT
+########
+-X
+# nolint: check runtime $^W is zapped
+$^W = 1 ;
+close STDIN ; print STDIN "abc" ;
+EXPECT
+########
+-X
+# nolint: check runtime $^W is zapped
+{
+ $^W = 1 ;
+ close STDIN ; print STDIN "abc" ;
+}
+EXPECT
+########
+-X
+# nolint: check "no warning" is zapped
+use warning ;
+$a = $b = 1 ;
+$a = 1 if $a EQ $b ;
+close STDIN ; print STDIN "abc" ;
+EXPECT
+########
+-X
+# nolint: check "no warning" is zapped
+{
+ use warning ;
+ close STDIN ; print STDIN "abc" ;
+}
+EXPECT
+########
+-Xw
+# nolint: check combination of -w and -X
+{
+ $^W = 1 ;
+ close STDIN ; print STDIN "abc" ;
+}
+EXPECT
+########
+-X
+--FILE-- abc.pm
+use warning 'deprecated' ;
+my ($a, $b) = (0,0);
+1 if $a EQ $b ;
+1;
+--FILE--
+use warning 'uninitialized' ;
+use abc;
+my $a ; chop $a ;
+EXPECT
+########
+-X
+--FILE-- abc
+use warning 'deprecated' ;
+my ($a, $b) = (0,0);
+1 if $a EQ $b ;
+1;
+--FILE--
+use warning 'uninitialized' ;
+require "./abc";
+my $a ; chop $a ;
+EXPECT
+########
+-X
+--FILE-- abc.pm
+BEGIN {$^W = 1}
+my ($a, $b) = (0,0);
+1 if $a EQ $b ;
+1;
+--FILE--
+$^W = 1 ;
+use abc;
+my $a ; chop $a ;
+EXPECT
+########
+-X
+--FILE-- abc
+BEGIN {$^W = 1}
+my ($a, $b) = (0,0);
+1 if $a EQ $b ;
+1;
+--FILE--
+$^W = 1 ;
+require "./abc";
+my $a ; chop $a ;
+EXPECT
--- /dev/null
+ doio.c AOK
+
+ Can't do bidirectional pipe
+ open(F, "| true |");
+
+ warn(warn_nl, "open");
+ open(F, "true\ncd")
+
+ Close on unopened file <%s>
+ $a = "fred";close($a)
+
+ tell() on unopened file
+ $a = "fred";$a = tell($a)
+
+ seek() on unopened file
+ $a = "fred";$a = seek($a,1,1)
+
+ sysseek() on unopened file
+ $a = "fred";$a = seek($a,1,1)
+
+ warn(warn_uninit);
+ print $a ;
+
+ Stat on unopened file <%s>
+ close STDIN ; -x STDIN ;
+
+ warn(warn_nl, "stat");
+ stat "ab\ncd"
+
+ warn(warn_nl, "lstat");
+ lstat "ab\ncd"
+
+ Can't exec \"%s\": %s
+
+ Can't exec \"%s\": %s
+
+
+__END__
+# doio.c
+use warning 'io' ;
+open(F, "|true|")
+EXPECT
+Can't do bidirectional pipe at - line 3.
+########
+# doio.c
+use warning 'io' ;
+open(F, "<true\ncd")
+EXPECT
+Unsuccessful open on filename containing newline at - line 3.
+########
+# doio.c
+use 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.
+sysseek() on unopened file at - line 6.
+Stat on unopened file <STDIN> at - line 7.
+########
+# doio.c
+use warning 'uninitialized' ;
+print $a ;
+EXPECT
+Use of uninitialized value at - line 3.
+########
+# doio.c
+use warning 'io' ;
+
+EXPECT
+
+########
+# doio.c
+use 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" ;
+EXPECT
+Can't exec "lskdjfalksdjfdjfkls": No such file or directory at - line 3.
+########
+# doio.c
+use warning 'io' ;
+exec "lskdjfalksdjfdjfkls", "abc" ;
+EXPECT
+Can't exec "lskdjfalksdjfdjfkls": No such file or directory at - line 3.
--- /dev/null
+ gv.c AOK
+
+ Can't locate package %s for @%s::ISA
+ @ISA = qw(Fred); joe()
+
+ Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated
+ sub Other::AUTOLOAD { 1 } sub Other::fred {}
+ @ISA = qw(Other) ;
+ fred() ;
+
+ Use of $# is deprecated
+ Use of $* is deprecated
+
+ $a = ${"#"} ;
+ $a = ${"*"} ;
+
+
+__END__
+# gv.c
+use warning 'misc' ;
+@ISA = qw(Fred); joe()
+EXPECT
+Can't locate package Fred for @main::ISA at - line 3.
+Undefined subroutine &main::joe called at - line 3.
+########
+# gv.c
+sub Other::AUTOLOAD { 1 } sub Other::fred {}
+@ISA = qw(Other) ;
+use warning 'deprecated' ;
+fred() ;
+EXPECT
+Use of inherited AUTOLOAD for non-method main::fred() is deprecated at - line 5.
+########
+# gv.c
+use warning 'deprecated' ;
+$a = ${"#"};
+$a = ${"*"};
+EXPECT
+Use of $# is deprecated at - line 3.
+Use of $* is deprecated at - line 4.
--- /dev/null
+ mg.c AOK
+
+ No such signal: SIG%s
+ $SIG{FRED} = sub {}
+
+ SIG%s handler \"%s\" not defined.
+ $SIG{"INT"} = "ok3"; kill "INT",$$;
+
+
+__END__
+# mg.c
+use warning 'signal' ;
+$SIG{FRED} = sub {};
+EXPECT
+No such signal: SIGFRED at - line 3.
+########
+# mg.c
+use warning 'signal' ;
+$SIG{"INT"} = "fred"; kill "INT",$$;
+EXPECT
+SIGINT handler "fred" not defined.
--- /dev/null
+ op.c AOK
+
+ "my" variable %s masks earlier declaration in same scope
+ my $x;
+ my $x ;
+
+ Variable "%s" may be unavailable
+ sub x {
+ my $x;
+ sub y {
+ $x
+ }
+ }
+
+ Variable "%s" will not stay shared
+ sub x {
+ my $x;
+ sub y {
+ sub { $x }
+ }
+ }
+
+ Found = in conditional, should be ==
+ 1 if $a = 1 ;
+
+ Use of implicit split to @_ is deprecated
+ split ;
+
+ Use of implicit split to @_ is deprecated
+ $a = split ;
+
+ Useless use of time in void context
+ Useless use of a variable in void context
+ Useless use of a constant in void context
+ time ;
+ $a ;
+ "abc"
+
+ Applying %s to %s will act on scalar(%s)
+ 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/ ;
+
+
+ Parens missing around "my" list at -e line 1.
+ my $a, $b = (1,2);
+
+ Parens missing around "local" list at -e line 1.
+ local $a, $b = (1,2);
+
+ Probable precedence problem on logical or at -e line 1.
+ use warning 'syntax'; my $x = print(ABC || 1);
+
+ Value of %s may be \"0\"; use \"defined\"
+ $x = 1 if $x = <FH> ;
+ $x = 1 while $x = <FH> ;
+
+ Subroutine fred redefined at -e line 1.
+ sub fred{1;} sub fred{1;}
+
+ Constant subroutine %s redefined
+ sub fred() {1;} sub fred() {1;}
+
+ Format FRED redefined at /tmp/x line 5.
+ format FRED =
+ .
+ format FRED =
+ .
+
+ Array @%s missing the @ in argument %d of %s()
+ push fred ;
+
+ Hash %%%s missing the %% in argument %d of %s()
+ keys joe ;
+
+ Statement unlikely to be reached
+ (Maybe you meant system() when you said exec()?
+ exec "true" ; my $a
+
+
+__END__
+# op.c
+use warning 'unsafe' ;
+my $x ;
+my $x ;
+EXPECT
+"my" variable $x masks earlier declaration in same scope at - line 4.
+########
+# op.c
+use warning 'unsafe' ;
+sub x {
+ my $x;
+ sub y {
+ $x
+ }
+ }
+EXPECT
+Variable "$x" will not stay shared at - line 7.
+########
+# op.c
+use warning 'unsafe' ;
+sub x {
+ my $x;
+ sub y {
+ sub { $x }
+ }
+ }
+EXPECT
+Variable "$x" may be unavailable at - line 6.
+########
+# op.c
+use warning 'syntax' ;
+1 if $a = 1 ;
+EXPECT
+Found = in conditional, should be == at - line 3.
+########
+# op.c
+use warning 'deprecated' ;
+split ;
+EXPECT
+Use of implicit split to @_ is deprecated at - line 3.
+########
+# op.c
+use warning 'deprecated' ;
+$a = split ;
+EXPECT
+Use of implicit split to @_ is deprecated at - line 3.
+########
+# op.c
+use 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
+getgrnam 1; # OP_GGRNAM
+getgrgid 1 ; # OP_GGRGID
+getpwnam 1; # OP_GPWNAM
+getpwuid 1; # OP_GPWUID
+EXPECT
+Useless use of repeat in void context at - line 3.
+Useless use of wantarray in void context at - line 5.
+Useless use of reference-type operator in void context at - line 12.
+Useless use of reference constructor in void context at - line 13.
+Useless use of scalar ref constructor in void context at - line 14.
+Useless use of defined operator in void context at - line 15.
+Useless use of hex in void context at - line 16.
+Useless use of oct in void context at - line 17.
+Useless use of length in void context at - line 18.
+Useless use of substr in void context at - line 19.
+Useless use of vec in void context at - line 20.
+Useless use of index in void context at - line 21.
+Useless use of rindex in void context at - line 22.
+Useless use of sprintf in void context at - line 23.
+Useless use of array element in void context at - line 24.
+Useless use of array slice in void context at - line 26.
+Useless use of hash elem in void context at - line 29.
+Useless use of hash slice in void context at - line 30.
+Useless use of unpack in void context at - line 31.
+Useless use of pack in void context at - line 32.
+Useless use of join in void context at - line 33.
+Useless use of list slice in void context at - line 34.
+Useless use of sort in void context at - line 37.
+Useless use of reverse in void context at - line 38.
+Useless use of range (or flop) in void context at - line 41.
+Useless use of caller in void context at - line 42.
+Useless use of fileno in void context at - line 43.
+Useless use of eof in void context at - line 44.
+Useless use of tell in void context at - line 45.
+Useless use of readlink in void context at - line 46.
+Useless use of time in void context at - line 47.
+Useless use of localtime in void context at - line 48.
+Useless use of gmtime in void context at - line 49.
+Useless use of getgrnam in void context at - line 50.
+Useless use of getgrgid in void context at - line 51.
+Useless use of getpwnam in void context at - line 52.
+Useless use of getpwuid in void context at - line 53.
+########
+# op.c
+use warning 'void' ;
+use Config ;
+BEGIN {
+ if ( ! $Config{d_telldir}) {
+ print <<EOM ;
+SKIPPED
+# telldir not present
+EOM
+ exit
+ }
+}
+telldir 1 ; # OP_TELLDIR
+EXPECT
+Useless use of telldir in void context at - line 13.
+########
+# op.c
+use warning 'void' ;
+use Config ;
+BEGIN {
+ if ( ! $Config{d_getppid}) {
+ print <<EOM ;
+SKIPPED
+# getppid not present
+EOM
+ exit
+ }
+}
+getppid ; # OP_GETPPID
+EXPECT
+Useless use of getppid in void context at - line 13.
+########
+# op.c
+use warning 'void' ;
+use Config ;
+BEGIN {
+ if ( ! $Config{d_getpgrp}) {
+ print <<EOM ;
+SKIPPED
+# getpgrp not present
+EOM
+ exit
+ }
+}
+getpgrp ; # OP_GETPGRP
+EXPECT
+Useless use of getpgrp in void context at - line 13.
+########
+# op.c
+use warning 'void' ;
+use Config ;
+BEGIN {
+ if ( ! $Config{d_times}) {
+ print <<EOM ;
+SKIPPED
+# times not present
+EOM
+ exit
+ }
+}
+times ; # OP_TMS
+EXPECT
+Useless use of times in void context at - line 13.
+########
+# op.c
+use warning 'void' ;
+use Config ;
+BEGIN {
+ if ( ! $Config{d_getprior}) {
+ print <<EOM ;
+SKIPPED
+# getpriority not present
+EOM
+ exit
+ }
+}
+getpriority 1,2; # OP_GETPRIORITY
+EXPECT
+Useless use of getpriority in void context at - line 13.
+########
+# op.c
+use warning 'void' ;
+use Config ;
+BEGIN {
+ if ( ! $Config{d_getlogin}) {
+ print <<EOM ;
+SKIPPED
+# getlogin not present
+EOM
+ exit
+ }
+}
+getlogin ; # OP_GETLOGIN
+EXPECT
+Useless use of getlogin in void context at - line 13.
+########
+# op.c
+use warning 'void' ;
+use Config ; BEGIN {
+if ( ! $Config{d_socket}) {
+ print <<EOM ;
+SKIPPED
+# getsockname not present
+# getpeername not present
+# gethostbyname not present
+# gethostbyaddr not present
+# gethostent not present
+# getnetbyname not present
+# getnetbyaddr not present
+# getnetent not present
+# getprotobyname not present
+# getprotobynumber not present
+# getprotoent not present
+# getservbyname not present
+# getservbyport not present
+# getservent not present
+EOM
+ exit
+} }
+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
+EXPECT
+Useless use of getsockname in void context at - line 24.
+Useless use of getpeername in void context at - line 25.
+Useless use of gethostbyname in void context at - line 26.
+Useless use of gethostbyaddr in void context at - line 27.
+Useless use of gethostent in void context at - line 28.
+Useless use of getnetbyname in void context at - line 29.
+Useless use of getnetbyaddr in void context at - line 30.
+Useless use of getnetent in void context at - line 31.
+Useless use of getprotobyname in void context at - line 32.
+Useless use of getprotobynumber in void context at - line 33.
+Useless use of getprotoent in void context at - line 34.
+Useless use of getservbyname in void context at - line 35.
+Useless use of getservbyport in void context at - line 36.
+Useless use of getservent in void context at - line 37.
+########
+# op.c
+use 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.
+Useless use of a variable in void context at - line 5.
+Useless use of a variable in void context at - line 6.
+########
+# op.c
+use 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.
+########
+# op.c
+use 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.
+Can't modify private array in substitution at - line 5, near "s/a/b/ ;"
+Applying character translation to @array will act on scalar(@array) at - line 6.
+Applying pattern match to @array will act on scalar(@array) at - line 7.
+Applying substitution to @array will act on scalar(@array) at - line 8.
+Applying character translation to @array will act on scalar(@array) at - line 9.
+Applying pattern match to %hash will act on scalar(%hash) at - line 10.
+Applying substitution to %hash will act on scalar(%hash) at - line 11.
+Applying character translation to %hash will act on scalar(%hash) at - line 12.
+Applying pattern match to %hash will act on scalar(%hash) at - line 13.
+Applying substitution to %hash will act on scalar(%hash) at - line 14.
+Applying character translation to %hash will act on scalar(%hash) at - line 15.
+Execution of - aborted due to compilation errors.
+########
+# op.c
+use warning 'syntax' ;
+my $a, $b = (1,2);
+EXPECT
+Parens missing around "my" list at - line 3.
+########
+# op.c
+use warning 'syntax' ;
+local $a, $b = (1,2);
+EXPECT
+Parens missing around "local" list at - line 3.
+########
+# op.c
+use warning 'syntax' ;
+print (ABC || 1) ;
+EXPECT
+Probable precedence problem on logical or at - line 3.
+########
+--FILE-- abc
+
+--FILE--
+# op.c
+use warning 'unsafe' ;
+open FH, "<abc" ;
+$x = 1 if $x = <FH> ;
+EXPECT
+Value of <HANDLE> construct can be "0"; test with defined() at - line 4.
+########
+# op.c
+use warning 'unsafe' ;
+opendir FH, "." ;
+$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 = <*> ;
+EXPECT
+Value of glob construct can be "0"; test with defined() at - line 3.
+########
+# op.c
+use warning 'unsafe' ;
+%a = (1,2,3,4) ;
+$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 ;
+EXPECT
+Value of glob construct can be "0"; test with defined() at - line 3.
+########
+# op.c
+use warning 'unsafe' ;
+opendir FH, "." ;
+$x = 1 while $x = readdir FH and 0 ;
+closedir FH ;
+EXPECT
+Value of readdir() operator can be "0"; test with defined() at - line 4.
+########
+# op.c
+use warning 'redefine' ;
+sub fred {}
+sub fred {}
+EXPECT
+Subroutine fred redefined at - line 4.
+########
+# op.c
+use warning 'redefine' ;
+sub fred () { 1 }
+sub fred () { 1 }
+EXPECT
+Constant subroutine fred redefined at - line 4.
+########
+# op.c
+use warning 'redefine' ;
+format FRED =
+.
+format FRED =
+.
+EXPECT
+Format FRED redefined at - line 5.
+########
+# op.c
+use 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 ;
+EXPECT
+Hash %FRED missing the % in argument 1 of keys() at - line 3.
+########
+# op.c
+use warning 'syntax' ;
+exec "true" ;
+my $a
+EXPECT
+Statement unlikely to be reached at - line 4.
+(Maybe you meant system() when you said exec()?)
--- /dev/null
+ perl.c AOK
+
+ gv_check(defstash)
+ Name \"%s::%s\" used only once: possible typo
+
+
+__END__
+# perl.c
+use warning 'once' ;
+$x = 3 ;
+EXPECT
+Name "main::x" used only once: possible typo at - line 3.
--- /dev/null
+ perly.y AOK
+
+ dep() => deprecate("\"do\" to call subroutines")
+ Use of "do" to call subroutines is deprecated
+
+ sub fred {} do fred()
+ sub fred {} do fred(1)
+ sub fred {} $a = "fred" ; do $a()
+ sub fred {} $a = "fred" ; do $a(1)
+
+
+__END__
+# perly.y
+use warning 'deprecated' ;
+sub fred {}
+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.
+Use of "do" to call subroutines is deprecated at - line 7.
+Use of "do" to call subroutines is deprecated at - line 8.
--- /dev/null
+ pp.c TODO
+
+ substr outside of string
+ $a = "ab" ; $a = substr($a, 4,5)
+
+ Attempt to use reference as lvalue in substr
+ $a = "ab" ; $b = \$a ; substr($b, 1,1) = $b
+
+ uninitialized in pp_rv2gv()
+ my *b = *{ undef()}
+
+ uninitialized in pp_rv2sv()
+ my $a = undef ; my $b = $$a
+
+ Odd number of elements in hash list
+ my $a = { 1,2,3 } ;
+
+ Invalid type in unpack: '%c
+ my $A = pack ("A,A", 1,2) ;
+ my @A = unpack ("A,A", "22") ;
+
+ Attempt to pack pointer to temporary value
+ pack("p", "abc") ;
+
+ Explicit blessing to '' (assuming package main)
+ bless \[], "";
+
+ Constant subroutine %s undefined <<<
+ Constant subroutine (anonymous) undefined <<<
+
+__END__
+# pp.c
+use warning 'substr' ;
+$a = "ab" ;
+$a = substr($a, 4,5)
+EXPECT
+substr outside of string at - line 4.
+########
+# pp.c
+use warning 'substr' ;
+$a = "ab" ;
+$b = \$a ;
+substr($b, 1,1) = "ab" ;
+EXPECT
+Attempt to use reference as lvalue in substr at - line 5.
+########
+# pp.c
+use warning 'uninitialized' ;
+# TODO
+EXPECT
+
+########
+# pp.c
+use warning 'unsafe' ;
+my $a = { 1,2,3};
+EXPECT
+Odd number of elements in hash assignment at - line 3.
+########
+# pp.c
+use warning 'unsafe' ;
+my @a = unpack ("A,A", "22") ;
+my $a = 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
+EXPECT
+Use of uninitialized value at - line 4.
+########
+# pp.c
+use warning 'unsafe' ;
+sub foo { my $a = "a"; return $a . $a++ . $a++ }
+my $a = pack("p", &foo) ;
+EXPECT
+Attempt to pack pointer to temporary value at - line 4.
+########
+# pp.c
+use warning 'unsafe' ;
+bless \[], "" ;
+EXPECT
+Explicit blessing to '' (assuming package main) at - line 3.
--- /dev/null
+ pp_ctl.c AOK
+
+ Not enough format arguments
+ format STDOUT =
+ @<<< @<<<
+ $a
+ .
+ write;
+
+
+ Exiting substitution via %s
+ $_ = "abc" ;
+ while ($i ++ == 0)
+ {
+ s/ab/last/e ;
+ }
+
+ Exiting subroutine via %s
+ sub fred { last }
+ { fred() }
+
+ Exiting eval via %s
+ { eval "last" }
+
+ Exiting pseudo-block via %s
+ @a = (1,2) ; @b = sort { last } @a ;
+
+ Exiting substitution via %s
+ $_ = "abc" ;
+ last fred:
+ while ($i ++ == 0)
+ {
+ s/ab/last fred/e ;
+ }
+
+
+ Exiting subroutine via %s
+ sub fred { last joe }
+ joe: { fred() }
+
+ Exiting eval via %s
+ fred: { eval "last fred" }
+
+ Exiting pseudo-block via %s
+ @a = (1,2) ; fred: @b = sort { last fred } @a ;
+
+
+ Deep recursion on subroutine \"%s\"
+ sub fred
+ {
+ goto &fred() if $a++ < 200
+ }
+
+ goto &fred()
+
+
+__END__
+# pp_ctl.c
+use warning 'syntax' ;
+format STDOUT =
+@<<< @<<<
+1
+.
+write;
+EXPECT
+Not enough format arguments at - line 5.
+1
+########
+# pp_ctl.c
+use warning 'unsafe' ;
+$_ = "abc" ;
+
+while ($i ++ == 0)
+{
+ s/ab/last/e ;
+}
+EXPECT
+Exiting substitution via last at - line 7.
+########
+# pp_ctl.c
+use warning 'unsafe' ;
+sub fred { last }
+{ fred() }
+EXPECT
+Exiting subroutine via last at - line 3.
+########
+# pp_ctl.c
+use warning 'unsafe' ;
+{ eval "last" }
+print STDERR $@ ;
+EXPECT
+Exiting eval via last at (eval 1) line 1.
+########
+# pp_ctl.c
+use warning 'unsafe' ;
+@a = (1,2) ;
+@b = sort { last } @a ;
+EXPECT
+Exiting pseudo-block via last at - line 4.
+Can't "last" outside a block at - line 4.
+########
+# pp_ctl.c
+use warning 'unsafe' ;
+$_ = "abc" ;
+fred:
+while ($i ++ == 0)
+{
+ s/ab/last fred/e ;
+}
+EXPECT
+Exiting substitution via last at - line 7.
+########
+# pp_ctl.c
+use 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" }
+print STDERR $@ ;
+EXPECT
+Exiting eval via last at (eval 1) line 2.
+########
+# pp_ctl.c
+use warning 'unsafe' ;
+@a = (1,2) ;
+fred: @b = sort { last fred } @a ;
+EXPECT
+Exiting pseudo-block via last at - line 4.
+Label not found for "last fred" at - line 4.
+########
+# pp_ctl.c
+use warning 'recursion' ;
+BEGIN { warn "PREFIX\n" ;}
+sub fred
+{
+ goto &fred() if $a++ < 200
+}
+
+goto &fred()
+EXPECT
+Deep recursion on subroutine "main::fred" at - line 6.
--- /dev/null
+ pp_hot.c AOK
+
+ Filehandle %s never opened
+ $f = $a = "abc" ; print $f $a
+
+ Filehandle %s opened only for input
+ print STDIN "abc" ;
+
+
+ print on closed filehandle %s
+ close STDIN ; print STDIN "abc" ;
+
+ uninitialized
+ my $a = undef ; my @b = @$a
+
+ uninitialized
+ my $a = undef ; my %b = %$a
+
+ Odd number of elements in hash list
+ %X = (1,2,3) ;
+
+ Reference found where even-sized list expected
+ $X = [ 1 ..3 ];
+
+ Read on closed filehandle <%s>
+ close STDIN ; $a = <STDIN>;
+
+ Deep recursion on subroutine \"%s\"
+ sub fred { fred() if $a++ < 200} fred()
+
+ Deep recursion on anonymous subroutine
+ $a = sub { &$a if $a++ < 200} &$a
+
+__END__
+# pp_hot.c
+use warning 'unopened' ;
+$f = $a = "abc" ;
+print $f $a
+EXPECT
+Filehandle main::abc never opened at - line 4.
+########
+# pp_hot.c
+use warning 'io' ;
+print STDIN "anc";
+EXPECT
+Filehandle main::STDIN opened only for input at - line 3.
+########
+# pp_hot.c
+use warning 'closed' ;
+close STDIN ;
+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
+EXPECT
+Use of uninitialized value at - line 4.
+########
+# pp_hot.c
+use warning 'uninitialized' ;
+my $a = undef ;
+my %b = %$a
+EXPECT
+Use of uninitialized value at - line 4.
+########
+# pp_hot.c
+use warning 'unsafe' ;
+my %X ; %X = (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] ;
+EXPECT
+Reference found where even-sized list expected at - line 3.
+########
+# pp_hot.c
+use warning 'closed' ;
+close STDIN ; $a = <STDIN> ;
+EXPECT
+Read on closed filehandle <STDIN> at - line 3.
+########
+# pp_hot.c
+use warning 'recursion' ;
+sub fred
+{
+ fred() if $a++ < 200
+}
+
+fred()
+EXPECT
+Deep recursion on subroutine "main::fred" at - line 5.
+########
+# pp_hot.c
+use warning 'recursion' ;
+$b = sub
+{
+ &$b if $a++ < 200
+} ;
+
+&$b ;
+EXPECT
+Deep recursion on anonymous subroutine at - line 5.
--- /dev/null
+ pp_sys.c AOK
+
+ untie attempted while %d inner references still exist
+ sub TIESCALAR { bless [] } ; tie $a, 'main'; untie $a ;
+
+ Filehandle only opened for input
+ format STDIN =
+ .
+ write STDIN;
+
+ Write on closed filehandle
+ format STDIN =
+ .
+ close STDIN;
+ write STDIN ;
+
+ page overflow
+
+ Filehandle %s never opened
+ $a = "abc"; printf $a "fred"
+
+ Filehandle %s opened only for input
+ $a = "abc";
+ printf $a "fred"
+
+ printf on closed filehandle %s
+ close STDIN ;
+ printf STDIN "fred"
+
+ Syswrite on closed filehandle
+ close STDIN;
+ syswrite STDIN, "fred", 1;
+
+ Send on closed socket
+ close STDIN;
+ send STDIN, "fred", 1
+
+ bind() on closed fd
+ close STDIN;
+ bind STDIN, "fred" ;
+
+
+ connect() on closed fd
+ close STDIN;
+ connect STDIN, "fred" ;
+
+ listen() on closed fd
+ close STDIN;
+ listen STDIN, 2;
+
+ accept() on closed fd
+ close STDIN;
+ accept STDIN, "fred" ;
+
+ shutdown() on closed fd
+ close STDIN;
+ shutdown STDIN, 0;
+
+ [gs]etsockopt() on closed fd
+ close STDIN;
+ setsockopt STDIN, 1,2,3;
+ getsockopt STDIN, 1,2;
+
+ get{sock, peer}name() on closed fd
+ close STDIN;
+ getsockname STDIN;
+ getpeername STDIN;
+
+ warn(warn_nl, "stat");
+
+ Test on unopened file <%s>
+ close STDIN ; -T STDIN ;
+
+ warn(warn_nl, "open");
+ -T "abc\ndef" ;
+
+
+
+__END__
+# pp_sys.c
+use warning 'untie' ;
+sub TIESCALAR { bless [] } ;
+$b = tie $a, 'main';
+untie $a ;
+EXPECT
+untie attempted while 1 inner references still exist at - line 5.
+########
+# pp_sys.c
+use warning 'io' ;
+format STDIN =
+.
+write STDIN;
+EXPECT
+Filehandle only opened for input at - line 5.
+########
+# pp_sys.c
+use warning 'closed' ;
+format STDIN =
+.
+close STDIN;
+write STDIN;
+EXPECT
+Write on closed filehandle at - line 6.
+########
+# pp_sys.c
+use warning 'io' ;
+format STDOUT_TOP =
+abc
+.
+format STDOUT =
+def
+ghi
+.
+$= = 1 ;
+$- =1 ;
+open STDOUT, ">/dev/null" ;
+write ;
+EXPECT
+page overflow at - line 13.
+########
+# pp_sys.c
+use warning 'unopened' ;
+$a = "abc";
+printf $a "fred"
+EXPECT
+Filehandle main::abc never opened at - line 4.
+########
+# pp_sys.c
+use warning 'closed' ;
+close STDIN ;
+printf STDIN "fred"
+EXPECT
+printf on closed filehandle main::STDIN at - line 4.
+########
+# pp_sys.c
+use warning 'io' ;
+printf STDIN "fred"
+EXPECT
+Filehandle main::STDIN opened only for input at - line 3.
+########
+# pp_sys.c
+use warning 'closed' ;
+close STDIN;
+syswrite STDIN, "fred", 1;
+EXPECT
+Syswrite on closed filehandle at - line 4.
+########
+# pp_sys.c
+use warning 'io' ;
+use Config;
+BEGIN {
+ if ( $^O ne 'VMS' and ! $Config{d_socket}) {
+ print <<EOM ;
+SKIPPED
+# send not present
+# bind not present
+# connect not present
+# accept not present
+# shutdown not present
+# setsockopt not present
+# getsockopt not present
+# getsockname not present
+# getpeername not present
+EOM
+ exit ;
+ }
+}
+close STDIN;
+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.
+connect() on closed fd at - line 24.
+listen() on closed fd at - line 25.
+accept() on closed fd at - line 26.
+shutdown() on closed fd at - line 27.
+[gs]etsockopt() on closed fd at - line 28.
+[gs]etsockopt() on closed fd at - line 29.
+get{sock, peer}name() on closed fd at - line 30.
+get{sock, peer}name() on closed fd at - line 31.
+########
+# pp_sys.c
+use warning 'newline' ;
+stat "abc\ndef";
+EXPECT
+Unsuccessful stat on filename containing newline at - line 3.
+########
+# pp_sys.c
+use warning 'unopened' ;
+close STDIN ;
+-T STDIN ;
+EXPECT
+Test on unopened file <STDIN> at - line 4.
+########
+# pp_sys.c
+use warning 'newline' ;
+-T "abc\ndef" ;
+EXPECT
+Unsuccessful open on filename containing newline at - line 3.
--- /dev/null
+ regcomp.c AOK
+
+ %.*s matches null string many times
+
+ $a = "ABC123" ; $a =~ /(?=a)*/'
+
+ Strange *+?{} on zero-length expression
+
+ /(?=a)?/
+
+ Character class syntax [: :] is reserved for future extensions
+ /[a[:xyz:]b]/
+
+ Character class syntax [. .] is reserved for future extensions
+ Character class syntax [= =] is reserved for future extensions
+
+__END__
+# regcomp.c
+use warning 'unsafe' ;
+my $a = "ABC123" ;
+$a =~ /(?=a)*/ ;
+EXPECT
+(?=a)* matches null string many times at - line 4.
+########
+# regcomp.c
+use warning 'unsafe' ;
+$_ = "" ;
+/(?=a)?/;
+EXPECT
+Strange *+?{} on zero-length expression at - line 4.
+########
+# regcomp.c
+use 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.
+Character class syntax [= =] is reserved for future extensions at - line 6.
+########
+# regcomp.c
+use warning 'unsafe' ;
+# use utf8 ; # Note this line should be uncommented when utf8 gets fixed.
+$_ = "" ;
+/[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.
+Character class syntax [= =] is reserved for future extensions at - line 7.
--- /dev/null
+ regexec.c
+
+ count exceeded %d
+
+ $_ = 'a' x (2**15+1); /^()(a\1)*$/ ;
+ count exceeded %d
+
+ $_ = 'a' x (2**15+1); /^()(a\1)*?$/ ;
+
+__END__
+# regexec.c
+use warning 'unsafe' ;
+$_ = 'a' x (2**15+1);
+/^()(a\1)*$/ ;
+EXPECT
+count exceeded 32766 at - line 4.
+########
+# regexec.c
+use warning 'unsafe' ;
+$_ = 'a' x (2**15+1);
+/^()(a\1)*?$/ ;
+EXPECT
+Complex regular subexpression recursion limit (32766) exceeded at - line 4.
--- /dev/null
+ sv.c AOK
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ not_a_number(sv);
+
+ not_a_number(sv);
+
+ warn(warn_uninit);
+
+ not_a_number(sv);
+
+ warn(warn_uninit);
+
+ not_a_number(sv);
+
+ not_a_number(sv);
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ Subroutine %s redefined
+
+ Invalid conversion in %s:
+
+ Undefined value assigned to typeglob
+
+
+__END__
+# sv.c
+use integer ;
+use warning 'uninitialized' ;
+$x = 1 + $a[0] ; # a
+EXPECT
+Use of uninitialized value at - line 4.
+########
+# sv.c (sv_2iv)
+package fred ;
+sub TIESCALAR { my $x ; bless \$x}
+sub FETCH { return undef }
+sub STORE { return 1 }
+package main ;
+tie $A, 'fred' ;
+use integer ;
+use warning 'uninitialized' ;
+$A *= 2 ;
+EXPECT
+Use of uninitialized value at - line 10.
+########
+# sv.c
+use integer ;
+use warning 'uninitialized' ;
+my $x *= 2 ; #b
+EXPECT
+Use of uninitialized value at - line 4.
+########
+# sv.c (sv_2uv)
+package fred ;
+sub TIESCALAR { my $x ; bless \$x}
+sub FETCH { return undef }
+sub STORE { return 1 }
+package main ;
+tie $A, 'fred' ;
+use 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]
+EXPECT
+Use of uninitialized value at - line 4.
+########
+# sv.c
+use warning 'uninitialized' ;
+my $x *= 1 ; # d
+EXPECT
+Use of uninitialized value at - line 3.
+########
+# sv.c
+use warning 'uninitialized' ;
+$x = 1 + $a[0] ; # e
+EXPECT
+Use of uninitialized value at - line 3.
+########
+# sv.c (sv_2nv)
+package fred ;
+sub TIESCALAR { my $x ; bless \$x}
+sub FETCH { return undef }
+sub STORE { return 1 }
+package main ;
+tie $A, 'fred' ;
+use warning 'uninitialized' ;
+$A *= 2 ;
+EXPECT
+Use of uninitialized value at - line 9.
+########
+# sv.c
+use warning 'uninitialized' ;
+$x = $y + 1 ; # f
+EXPECT
+Use of uninitialized value at - line 3.
+########
+# sv.c
+use warning 'uninitialized' ;
+$x = chop undef ; # g
+EXPECT
+Use of uninitialized value at - line 3.
+########
+# sv.c
+use warning 'uninitialized' ;
+$x = chop $y ; # h
+EXPECT
+Use of uninitialized value at - line 3.
+########
+# sv.c (sv_2pv)
+package fred ;
+sub TIESCALAR { my $x ; bless \$x}
+sub FETCH { return undef }
+sub STORE { return 1 }
+package main ;
+tie $A, 'fred' ;
+use warning 'uninitialized' ;
+$B = "" ;
+$B .= $A ;
+EXPECT
+Use of uninitialized value at - line 10.
+########
+# sv.c
+use warning 'numeric' ;
+sub TIESCALAR{bless[]} ;
+sub FETCH {"def"} ;
+tie $a,"main" ;
+my $b = 1 + $a
+EXPECT
+Argument "def" isn't numeric in add at - line 6.
+########
+# sv.c
+use warning 'numeric' ;
+my $x = 1 + "def" ;
+EXPECT
+Argument "def" isn't numeric in add at - line 3.
+########
+# sv.c
+use warning 'numeric' ;
+my $a = "def" ;
+my $x = 1 + $a ;
+EXPECT
+Argument "def" isn't numeric in add at - line 4.
+########
+# sv.c
+use warning 'numeric' ; use integer ;
+my $a = "def" ;
+my $x = 1 + $a ;
+EXPECT
+Argument "def" isn't numeric in i_add at - line 4.
+########
+# sv.c
+use warning 'numeric' ;
+my $x = 1 & "def" ;
+EXPECT
+Argument "def" isn't numeric in bit_and at - line 3.
+########
+# sv.c
+use warning 'redefine' ;
+sub fred {}
+sub joe {}
+*fred = \&joe ;
+EXPECT
+Subroutine fred redefined at - line 5.
+########
+# sv.c
+use warning 'printf' ;
+open F, ">/dev/null" ;
+printf F "%q\n" ;
+my $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.
+Invalid conversion in sprintf: "%\002" at - line 9.
+Invalid conversion in printf: "%q" at - line 4.
+Invalid conversion in printf: end of string at - line 6.
+Invalid conversion in printf: "%\002" at - line 8.
+########
+# sv.c
+use warning 'unsafe' ;
+*a = undef ;
+EXPECT
+Undefined value assigned to typeglob at - line 3.
--- /dev/null
+ taint.c TODO
+
+ 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__
+# taint.c
+use warning 'misc' ;
+
+EXPECT
+
+########
+# taint.c
+use warning 'misc' ;
+
+EXPECT
+
--- /dev/null
+toke.c AOK
+
+ we seem to have lost a few ambiguous warnings!!
+
+
+ 1 if $a EQ $b ;
+ 1 if $a NE $b ;
+ 1 if $a LT $b ;
+ 1 if $a GT $b ;
+ 1 if $a GE $b ;
+ 1 if $a LE $b ;
+ $a = <<;
+ Use of comma-less variable list is deprecated
+ (called 3 times via depcom)
+
+ \1 better written as $1
+ use warning 'syntax' ;
+ s/(abc)/\1/;
+
+ warn(warn_nosemi)
+ Semicolon seems to be missing
+ $a = 1
+ &time ;
+
+
+ Reversed %c= operator
+ my $a =+ 2 ;
+ $a =- 2 ;
+ $a =* 2 ;
+ $a =% 2 ;
+ $a =& 2 ;
+ $a =. 2 ;
+ $a =^ 2 ;
+ $a =| 2 ;
+ $a =< 2 ;
+ $a =/ 2 ;
+
+ Multidimensional syntax %.*s not supported
+ my $a = $a[1,2] ;
+
+ You need to quote \"%s\""
+ sub fred {} ; $SIG{TERM} = fred;
+
+ Scalar value %.*s better written as $%.*s"
+ @a[3] = 2;
+ @a{3} = 2;
+
+ Can't use \\%c to mean $%c in expression
+ $_ = "ab" ; s/(ab)/\1/e;
+
+ Unquoted string "abc" may clash with future reserved word at - line 3.
+ warn(warn_reserved
+ $a = abc;
+
+ chmod: mode argument is missing initial 0
+ chmod 3;
+
+ Possible attempt to separate words with commas
+ @a = qw(a, b, c) ;
+
+ Possible attempt to put comments in qw() list
+ @a = qw(a b # c) ;
+
+ umask: argument is missing initial 0
+ umask 3;
+
+ %s (...) interpreted as function
+ print ("")
+ printf ("")
+ sort ("")
+
+ Ambiguous use of %c{%s%s} resolved to %c%s%s
+ $a = ${time[2]}
+ $a = ${time{2}}
+
+
+ Ambiguous use of %c{%s} resolved to %c%s
+ $a = ${time}
+ sub fred {} $a = ${fred}
+
+ Misplaced _ in number
+ $a = 1_2;
+ $a = 1_2345_6;
+
+ Bareword \"%s\" refers to nonexistent package
+ $a = FRED:: ;
+
+ Ambiguous call resolved as CORE::%s(), qualify as such or use &
+ sub time {}
+ my $a = time()
+
+ Use of \\x{} without utf8 declaration
+ $_ = " \x{123} " ;
+
+
+ \x%.*s will produce malformed UTF-8 character; use \x{%.*s} for that
+ use utf8 ;
+ $_ = "\xffe"
+
+__END__
+# toke.c
+use 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.
+Use of GT is deprecated at - line 5.
+Use of LT is deprecated at - line 6.
+Use of GE is deprecated at - line 7.
+Use of LE is deprecated at - line 8.
+########
+# toke.c
+use warning 'deprecated' ;
+format STDOUT =
+@<<< @||| @>>> @>>>
+$a $b "abc" 'def'
+.
+($a, $b) = (1,2,3);
+write;
+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 = <<;
+
+EXPECT
+Use of bare << to mean <<"" is deprecated at - line 3.
+########
+# toke.c
+use warning 'syntax' ;
+s/(abc)/\1/;
+EXPECT
+\1 better written as $1 at - line 3.
+########
+# toke.c
+use warning 'semicolon' ;
+$a = 1
+&time ;
+EXPECT
+Semicolon seems to be missing at - line 3.
+########
+# toke.c
+use warning 'syntax' ;
+my $a =+ 2 ;
+$a =- 2 ;
+$a =* 2 ;
+$a =% 2 ;
+$a =& 2 ;
+$a =. 2 ;
+$a =^ 2 ;
+$a =| 2 ;
+$a =< 2 ;
+$a =/ 2 ;
+EXPECT
+Reversed += operator at - line 3.
+Reversed -= operator at - line 4.
+Reversed *= operator at - line 5.
+Reversed %= operator at - line 6.
+Reversed &= operator at - line 7.
+Reversed .= operator at - line 8.
+syntax error at - line 8, near "=."
+Reversed ^= operator at - line 9.
+syntax error at - line 9, near "=^"
+Reversed |= operator at - line 10.
+syntax error at - line 10, near "=|"
+Reversed <= operator at - line 11.
+Unterminated <> operator at - line 11.
+########
+# toke.c
+use 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;
+EXPECT
+You need to quote "fred" at - line 3.
+########
+# toke.c
+use 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.
+########
+# toke.c
+use 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;
+EXPECT
+Unquoted string "abc" may clash with future reserved word at - line 3.
+########
+# toke.c
+use 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) ;
+EXPECT
+Possible attempt to separate words with commas at - line 3.
+########
+# toke.c
+use 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;
+EXPECT
+umask: argument is missing initial 0 at - line 3, at end of line
+########
+# toke.c
+use warning 'syntax' ;
+print ("")
+EXPECT
+print (...) interpreted as function at - line 3.
+########
+# toke.c
+use warning 'syntax' ;
+printf ("")
+EXPECT
+printf (...) interpreted as function at - line 3.
+########
+# toke.c
+use warning 'syntax' ;
+sort ("")
+EXPECT
+sort (...) interpreted as function at - line 3.
+########
+# toke.c
+use warning 'ambiguous' ;
+$a = ${time[2]};
+EXPECT
+Ambiguous use of ${time[...]} resolved to $time[...] at - line 3.
+########
+# toke.c
+use warning 'ambiguous' ;
+$a = ${time{2}};
+EXPECT
+Ambiguous use of ${time{...}} resolved to $time{...} at - line 3.
+########
+# toke.c
+use warning 'ambiguous' ;
+$a = ${time} ;
+EXPECT
+Ambiguous use of ${time} resolved to $time at - line 3.
+########
+# toke.c
+use warning 'ambiguous' ;
+sub fred {}
+$a = ${fred} ;
+EXPECT
+Ambiguous use of ${fred} resolved to $fred at - line 4.
+########
+# toke.c
+use warning 'syntax' ;
+$a = 1_2;
+$a = 1_2345_6;
+EXPECT
+Misplaced _ in number at - line 3.
+Misplaced _ in number at - line 4.
+Misplaced _ in number at - line 4.
+########
+# toke.c
+use warning 'unsafe' ;
+$a = FRED:: ;
+EXPECT
+Bareword "FRED::" refers to nonexistent package at - line 3.
+########
+# toke.c
+use warning 'ambiguous' ;
+sub time {}
+my $a = time()
+EXPECT
+Ambiguous call resolved as CORE::time(), qualify as such or use & at - line 4.
+########
+# toke.c
+use warning 'utf8' ;
+$_ = " \x{123} " ;
+EXPECT
+Use of \x{} without utf8 declaration at - line 3.
+########
+# toke.c
+use warning 'utf8' ;
+use utf8 ;
+$_ = " \xffe " ;
+EXPECT
+\xff will produce malformed UTF-8 character; use \x{ff} for that at - line 4.
--- /dev/null
+ universal.c
+
+ Can't locate package %s for @%s::ISA
+
+
+__END__
+# universal.c
+use warning 'misc' ;
+
+EXPECT
+
--- /dev/null
+ util.c AOK
+
+ Illegal octal digit ignored
+ my $a = oct "029" ;
+
+ Illegal hex digit ignored
+ my $a = hex "0xv9" ;
+
+
+__END__
+# util.c
+use warning 'octal' ;
+my $a = oct "029" ;
+EXPECT
+Illegal octal digit ignored at - line 3.
+########
+# util.c
+use warning 'unsafe' ;
+*a = hex "0xv9" ;
+EXPECT
+Illegal hex digit ignored at - line 3.
END { if ($tmpfile) { 1 while unlink $tmpfile} }
my @prgs = () ;
+my @w_files = () ;
-foreach (sort glob("pragma/warn-*")) {
+if (@ARGV)
+ { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./pragma/warn-#; $_ } @ARGV }
+else
+ { @w_files = sort glob("pragma/warn-*") }
+
+foreach (@w_files) {
+
+ next if /\.orig$/ ;
next if /(~|\.orig)$/;
ug = " while running with -T switch";
if (!PL_unsafe)
croak(f, s, ug);
- else if (PL_dowarn)
- warn(f, s, ug);
+ else if (ckWARN(WARN_TAINT))
+ warner(WARN_TAINT, f, s, ug);
}
}
void
deprecate(char *s)
{
- if (PL_dowarn)
- warn("Use of %s is deprecated", s);
+ if (ckWARN(WARN_DEPRECATED))
+ warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
}
STATIC void
/* (now in tr/// code again) */
- if (*s & 0x80 && PL_dowarn && thisutf) {
+ if (*s & 0x80 && ckWARN(WARN_UTF8) && thisutf) {
(void)utf8_to_uv(s, &len); /* could cvt latin-1 to utf8 here... */
if (len) {
while (len--)
if (PL_lex_inwhat == OP_SUBST && !PL_lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
{
- if (PL_dowarn)
- warn("\\%c better written as $%c", *s, *s);
+ if (ckWARN(WARN_SYNTAX))
+ warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
*--s = '$';
break;
}
if (!e)
yyerror("Missing right brace on \\x{}");
- if (PL_dowarn && !utf)
- warn("Use of \\x{} without utf8 declaration");
+ if (ckWARN(WARN_UTF8) && !utf)
+ warner(WARN_UTF8,"Use of \\x{} without utf8 declaration");
/* note: utf always shorter than hex */
d = uv_to_utf8(d, scan_hex(s + 1, e - s - 1, &len));
s = e + 1;
d = uv_to_utf8(d, uv); /* doing a CU or UC */
}
else {
- if (PL_dowarn && uv >= 127 && UTF)
- warn(
+ if (ckWARN(WARN_UTF8) && uv >= 127 && UTF)
+ warner(WARN_UTF8,
"\\x%.*s will produce malformed UTF-8 character; use \\x{%.*s} for that",
len,s,len,s);
*d++ = (char)uv;
AOPERATOR(ANDAND);
s--;
if (PL_expect == XOPERATOR) {
- if (PL_dowarn && isALPHA(*s) && PL_bufptr == PL_linestart) {
+ if (ckWARN(WARN_SEMICOLON) && isALPHA(*s) && PL_bufptr == PL_linestart) {
PL_curcop->cop_line--;
- warn(warn_nosemi);
+ warner(WARN_SEMICOLON, warn_nosemi);
PL_curcop->cop_line++;
}
BAop(OP_BIT_AND);
OPERATOR(',');
if (tmp == '~')
PMop(OP_MATCH);
- if (PL_dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
- warn("Reversed %c= operator",(int)tmp);
+ if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
+ warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
s--;
if (PL_expect == XSTATE && isALPHA(tmp) &&
(s == PL_linestart+1 || s[-2] == '\n') )
char *t;
if (*s == '[') {
PL_tokenbuf[0] = '@';
- if (PL_dowarn) {
+ if (ckWARN(WARN_SYNTAX)) {
for(t = s + 1;
isSPACE(*t) || isALNUM(*t) || *t == '$';
t++) ;
PL_bufptr = skipspace(PL_bufptr);
while (t < PL_bufend && *t != ']')
t++;
- warn("Multidimensional syntax %.*s not supported",
- (t - PL_bufptr) + 1, PL_bufptr);
+ warner(WARN_SYNTAX,
+ "Multidimensional syntax %.*s not supported",
+ (t - PL_bufptr) + 1, PL_bufptr);
}
}
}
else if (*s == '{') {
PL_tokenbuf[0] = '%';
- if (PL_dowarn && strEQ(PL_tokenbuf+1, "SIG") &&
+ if (ckWARN(WARN_SYNTAX) && strEQ(PL_tokenbuf+1, "SIG") &&
(t = strchr(s, '}')) && (t = strchr(t, '=')))
{
char tmpbuf[sizeof PL_tokenbuf];
if (isIDFIRST(*t)) {
t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
- warn("You need to quote \"%s\"", tmpbuf);
+ warner(WARN_SYNTAX,
+ "You need to quote \"%s\"", tmpbuf);
}
}
}
PL_tokenbuf[0] = '%';
/* Warn about @ where they meant $. */
- if (PL_dowarn) {
+ if (ckWARN(WARN_SYNTAX)) {
if (*s == '[' || *s == '{') {
char *t = s + 1;
while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
if (*t == '}' || *t == ']') {
t++;
PL_bufptr = skipspace(PL_bufptr);
- warn("Scalar value %.*s better written as $%.*s",
+ warner(WARN_SYNTAX,
+ "Scalar value %.*s better written as $%.*s",
t-PL_bufptr, PL_bufptr, t-PL_bufptr-1, PL_bufptr+1);
}
}
case '\\':
s++;
- if (PL_dowarn && PL_lex_inwhat && isDIGIT(*s))
- warn("Can't use \\%c to mean $%c in expression", *s, *s);
+ if (ckWARN(WARN_SYNTAX) && PL_lex_inwhat && isDIGIT(*s))
+ warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
+ *s, *s);
if (PL_expect == XOPERATOR)
no_op("Backslash",s);
OPERATOR(REFGEN);
tmp = -tmp;
gv = Nullgv;
gvp = 0;
- if (PL_dowarn && hgv)
- warn("Ambiguous call resolved as CORE::%s(), %s",
+ if (ckWARN(WARN_AMBIGUOUS) && hgv)
+ warner(WARN_AMBIGUOUS,
+ "Ambiguous call resolved as CORE::%s(), %s",
GvENAME(hgv), "qualify as such or use &");
}
}
if (PL_expect == XOPERATOR) {
if (PL_bufptr == PL_linestart) {
PL_curcop->cop_line--;
- warn(warn_nosemi);
+ warner(WARN_SEMICOLON, warn_nosemi);
PL_curcop->cop_line++;
}
else
if (len > 2 &&
PL_tokenbuf[len - 2] == ':' && PL_tokenbuf[len - 1] == ':')
{
- if (PL_dowarn && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
- warn("Bareword \"%s\" refers to nonexistent package",
+ if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(PL_tokenbuf, FALSE, SVt_PVHV))
+ warner(WARN_UNSAFE,
+ "Bareword \"%s\" refers to nonexistent package",
PL_tokenbuf);
len -= 2;
PL_tokenbuf[len] = '\0';
/* Call it a bare word */
bareword:
- if (PL_dowarn) {
+ if (ckWARN(WARN_RESERVED)) {
if (lastchar != '-') {
for (d = PL_tokenbuf; *d && isLOWER(*d); d++) ;
if (!*d)
- warn(warn_reserved, PL_tokenbuf);
+ warner(WARN_RESERVED, warn_reserved, PL_tokenbuf);
}
}
LOP(OP_CRYPT,XTERM);
case KEY_chmod:
- if (PL_dowarn) {
+ if (ckWARN(WARN_OCTAL)) {
for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
if (*d != '0' && isDIGIT(*d))
yywarn("chmod: mode argument is missing initial 0");
s = scan_str(s);
if (!s)
missingterm((char*)0);
- if (PL_dowarn && SvLEN(PL_lex_stuff)) {
+ if (ckWARN(WARN_SYNTAX) && SvLEN(PL_lex_stuff)) {
d = SvPV_force(PL_lex_stuff, len);
for (; len; --len, ++d) {
if (*d == ',') {
- warn("Possible attempt to separate words with commas");
+ warner(WARN_SYNTAX,
+ "Possible attempt to separate words with commas");
break;
}
if (*d == '#') {
- warn("Possible attempt to put comments in qw() list");
+ warner(WARN_SYNTAX,
+ "Possible attempt to put comments in qw() list");
break;
}
}
LOP(OP_UTIME,XTERM);
case KEY_umask:
- if (PL_dowarn) {
+ if (ckWARN(WARN_OCTAL)) {
for (d = s; d < PL_bufend && (isSPACE(*d) || *d == '('); d++) ;
if (*d != '0' && isDIGIT(*d))
yywarn("umask: argument is missing initial 0");
{
char *w;
- if (PL_dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
+ if (ckWARN(WARN_SYNTAX) && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
int level = 1;
for (w = s+2; *w && level; w++) {
if (*w == '(')
if (*w)
for (; *w && isSPACE(*w); w++) ;
if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
- warn("%s (...) interpreted as function",name);
+ warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
}
while (s < PL_bufend && isSPACE(*s))
s++;
*d = '\0';
while (s < send && (*s == ' ' || *s == '\t')) s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
- if (PL_dowarn && keyword(dest, d - dest)) {
+ if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
char *brack = *s == '[' ? "[...]" : "{...}";
- warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
+ warner(WARN_AMBIGUOUS,
+ "Ambiguous use of %c{%s%s} resolved to %c%s%s",
funny, dest, brack, funny, dest, brack);
}
PL_lex_fakebrack = PL_lex_brackets+1;
PL_lex_state = LEX_INTERPEND;
if (funny == '#')
funny = '@';
- if (PL_dowarn && PL_lex_state == LEX_NORMAL &&
+ if (ckWARN(WARN_AMBIGUOUS) && PL_lex_state == LEX_NORMAL &&
(keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
- warn("Ambiguous use of %c{%s} resolved to %c%s",
+ warner(WARN_AMBIGUOUS,
+ "Ambiguous use of %c{%s} resolved to %c%s",
funny, dest, funny, dest);
}
else {
if -w is on
*/
if (*s == '_') {
- if (PL_dowarn && lastub && s - lastub != 3)
- warn("Misplaced _ in number");
+ if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
+ warner(WARN_SYNTAX, "Misplaced _ in number");
lastub = ++s;
}
else {
}
/* final misplaced underbar check */
- if (PL_dowarn && lastub && s - lastub != 3)
- warn("Misplaced _ in number");
+ if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
+ warner(WARN_SYNTAX, "Misplaced _ in number");
/* read a decimal portion if there is one. avoid
3..5 being interpreted as the number 3. followed
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
- if (PL_dowarn)
- warn("Can't locate package %s for @%s::ISA",
+ if (ckWARN(WARN_MISC))
+ warner(WARN_SYNTAX,
+ "Can't locate package %s for @%s::ISA",
SvPVX(sv), HvNAME(stash));
continue;
}
(void)PerlIO_flush(PerlIO_stderr());
}
+void
+warner(U32 err, const char* pat,...)
+{
+ va_list args;
+ char *message;
+ HV *stash;
+ GV *gv;
+ CV *cv;
+
+ va_start(args, pat);
+ message = mess(pat, &args);
+ va_end(args);
+
+ if (ckDEAD(err)) {
+#ifdef USE_THREADS
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
+#endif /* USE_THREADS */
+ if (PL_diehook) {
+ /* sv_2cv might call croak() */
+ SV *olddiehook = PL_diehook;
+ ENTER;
+ SAVESPTR(PL_diehook);
+ PL_diehook = Nullsv;
+ cv = sv_2cv(olddiehook, &stash, &gv, 0);
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
+ dSP;
+ SV *msg;
+
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
+
+ PUSHMARK(sp);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+
+ LEAVE;
+ }
+ }
+ if (PL_in_eval) {
+ PL_restartop = die_where(message);
+ JMPENV_JUMP(3);
+ }
+ PerlIO_puts(PerlIO_stderr(),message);
+ (void)PerlIO_flush(PerlIO_stderr());
+ my_failure_exit();
+
+ }
+ else {
+ if (PL_warnhook) {
+ /* sv_2cv might call warn() */
+ dTHR;
+ SV *oldwarnhook = PL_warnhook;
+ ENTER;
+ SAVESPTR(PL_warnhook);
+ PL_warnhook = Nullsv;
+ cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
+ dSP;
+ SV *msg;
+
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
+
+ PUSHMARK(sp);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+
+ LEAVE;
+ return;
+ }
+ }
+ PerlIO_puts(PerlIO_stderr(),message);
+#ifdef LEAKTEST
+ DEBUG_L(xstat());
+#endif
+ (void)PerlIO_flush(PerlIO_stderr());
+ }
+}
+
#ifndef VMS /* VMS' my_setenv() is in VMS.c */
#ifndef WIN32
void
retval = n | (*s++ - '0');
len--;
}
- if (PL_dowarn && len && (*s == '8' || *s == '9'))
- warn("Illegal octal digit ignored");
+ if (len && (*s == '8' || *s == '9') && ckWARN(WARN_OCTAL))
+ warner(WARN_OCTAL, "Illegal octal digit ignored");
*retlen = s - start;
return retval;
}
continue;
else {
--s;
- if (PL_dowarn)
- warn("Illegal hex digit ignored");
+ if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE,"Illegal hex digit ignored");
break;
}
}
--- /dev/null
+/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by warning.pl
+ Any changes made here will be lost!
+*/
+
+
+#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_ALL_ON 2 /* -W flag */
+#define G_WARN_ALL_OFF 4 /* -X flag */
+#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
+
+#if 1
+
+/* Part of the logic below assumes that WARN_NONE is NULL */
+
+#define ckDEAD(x) \
+ (curcop->cop_warnings != WARN_ALL && \
+ curcop->cop_warnings != WARN_NONE && \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x+1))
+
+#define ckWARN(x) \
+ ( (curcop->cop_warnings && \
+ (curcop->cop_warnings == WARN_ALL || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x) ) ) \
+ || (PL_dowarn & G_WARN_ON) )
+
+#define ckWARN2(x,y) \
+ ( (curcop->cop_warnings && \
+ (curcop->cop_warnings == WARN_ALL || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x) || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*y) ) ) \
+ || (PL_dowarn & G_WARN_ON) )
+
+#else
+
+#define ckDEAD(x) \
+ (curcop->cop_warnings != WARN_ALL && \
+ curcop->cop_warnings != WARN_NONE && \
+ SvPVX(curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) )
+
+#define ckWARN(x) \
+ ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \
+ curcop->cop_warnings && \
+ ( curcop->cop_warnings == WARN_ALL || \
+ SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) ) ) )
+
+#define ckWARN2(x,y) \
+ ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \
+ curcop->cop_warnings && \
+ ( curcop->cop_warnings == WARN_ALL || \
+ SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || \
+ SvPVX(curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) )
+
+#endif
+
+#define WARN_NONE NULL
+#define WARN_ALL (&sv_yes)
+
+#define WARN_REDEFINE 0
+#define WARN_VOID 1
+#define WARN_UNSAFE 2
+#define WARN_TAINT 3
+#define WARN_SUBSTR 4
+#define WARN_CLOSURE 5
+#define WARN_UNTIE 6
+#define WARN_SIGNAL 7
+#define WARN_UTF8 8
+#define WARN_NUMERIC 9
+#define WARN_DEFAULT 10
+#define WARN_ONCE 11
+#define WARN_SYNTAX 12
+#define WARN_RESERVED 13
+#define WARN_DEPRECATED 14
+#define WARN_SEMICOLON 15
+#define WARN_PRINTF 16
+#define WARN_OCTAL 17
+#define WARN_AMBIGUOUS 18
+#define WARN_PARENTHESIS 19
+#define WARN_PRECEDENCE 20
+#define WARN_IO 21
+#define WARN_NEWLINE 22
+#define WARN_CLOSED 23
+#define WARN_EXEC 24
+#define WARN_UNOPENED 25
+#define WARN_PIPE 26
+#define WARN_UNINITIALIZED 27
+#define WARN_RECURSION 28
+#define WARN_MISC 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"
+
+/* end of file warning.h */
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict ;
+
+sub DEFAULT_ON () { 1 }
+sub DEFAULT_OFF () { 2 }
+
+my $tree = {
+ 'unsafe' => { 'untie' => DEFAULT_OFF,
+ 'substr' => DEFAULT_OFF,
+ 'taint' => DEFAULT_OFF,
+ 'signal' => DEFAULT_OFF,
+ 'closure' => DEFAULT_OFF,
+ 'utf8' => DEFAULT_OFF,
+ } ,
+ 'io' => { 'pipe' => DEFAULT_OFF,
+ 'unopened' => DEFAULT_OFF,
+ 'closed' => DEFAULT_OFF,
+ 'newline' => DEFAULT_OFF,
+ 'exec' => DEFAULT_OFF,
+ #'wr in in file'=> DEFAULT_OFF,
+ },
+ 'syntax' => { 'ambiguous' => DEFAULT_OFF,
+ 'semicolon' => DEFAULT_OFF,
+ 'precedence' => DEFAULT_OFF,
+ 'reserved' => DEFAULT_OFF,
+ 'octal' => DEFAULT_OFF,
+ 'parenthesis' => DEFAULT_OFF,
+ 'deprecated' => DEFAULT_OFF,
+ 'printf' => DEFAULT_OFF,
+ },
+ 'void' => DEFAULT_OFF,
+ 'recursion' => DEFAULT_OFF,
+ 'redefine' => DEFAULT_OFF,
+ 'numeric' => DEFAULT_OFF,
+ 'uninitialized'=> DEFAULT_OFF,
+ 'once' => DEFAULT_OFF,
+ 'misc' => DEFAULT_OFF,
+ 'default' => DEFAULT_ON,
+ } ;
+
+
+###########################################################################
+sub tab {
+ my($l, $t) = @_;
+ $t .= "\t" x ($l - (length($t) + 1) / 8);
+ $t;
+}
+
+###########################################################################
+
+my %list ;
+my %Value ;
+my $index = 0 ;
+
+sub walk
+{
+ my $tre = shift ;
+ my @list = () ;
+ my ($k, $v) ;
+
+ while (($k, $v) = each %$tre) {
+
+ die "duplicate key $k\n" if defined $list{$k} ;
+ $Value{$index} = uc $k ;
+ push @{ $list{$k} }, $index ++ ;
+ if (ref $v)
+ { push (@{ $list{$k} }, walk ($v)) }
+ push @list, @{ $list{$k} } ;
+ }
+
+ return @list ;
+
+}
+
+###########################################################################
+
+sub mkRange
+{
+ my @a = @_ ;
+ my @out = @a ;
+ my $i ;
+
+
+ for ($i = 1 ; $i < @a; ++ $i) {
+ $out[$i] = ".."
+ if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
+ }
+
+ my $out = join(",",@out);
+
+ $out =~ s/,(\.\.,)+/../g ;
+ return $out;
+}
+
+###########################################################################
+
+sub mkHex
+{
+ my ($max, @a) = @_ ;
+ my $mask = "\x00" x $max ;
+ my $string = "" ;
+
+ foreach (@a) {
+ vec($mask, $_, 1) = 1 ;
+ }
+
+ #$string = unpack("H$max", $mask) ;
+ #$string =~ s/(..)/\x$1/g;
+ foreach (unpack("C*", $mask)) {
+ $string .= '\x' . sprintf("%2.2x", $_) ;
+ }
+ return $string ;
+}
+
+###########################################################################
+
+
+#unlink "warning.h";
+#unlink "lib/warning.pm";
+open(WARN, ">warning.h") || die "Can't create warning.h: $!\n";
+open(PM, ">lib/warning.pm") || die "Can't create lib/warning.pm: $!\n";
+
+print WARN <<'EOM' ;
+/* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by warning.pl
+ Any changes made here will be lost!
+*/
+
+
+#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_ALL_ON 2 /* -W flag */
+#define G_WARN_ALL_OFF 4 /* -X flag */
+#define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
+
+#if 1
+
+/* Part of the logic below assumes that WARN_NONE is NULL */
+
+#define ckDEAD(x) \
+ (curcop->cop_warnings != WARN_ALL && \
+ curcop->cop_warnings != WARN_NONE && \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x+1))
+
+#define ckWARN(x) \
+ ( (curcop->cop_warnings && \
+ (curcop->cop_warnings == WARN_ALL || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x) ) ) \
+ || (PL_dowarn & G_WARN_ON) )
+
+#define ckWARN2(x,y) \
+ ( (curcop->cop_warnings && \
+ (curcop->cop_warnings == WARN_ALL || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x) || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*y) ) ) \
+ || (PL_dowarn & G_WARN_ON) )
+
+#else
+
+#define ckDEAD(x) \
+ (curcop->cop_warnings != WARN_ALL && \
+ curcop->cop_warnings != WARN_NONE && \
+ SvPVX(curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) )
+
+#define ckWARN(x) \
+ ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \
+ curcop->cop_warnings && \
+ ( curcop->cop_warnings == WARN_ALL || \
+ SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) ) ) )
+
+#define ckWARN2(x,y) \
+ ( (PL_dowarn & G_WARN_ON) || ( (PL_dowarn & G_WARN_DISABLE) && \
+ curcop->cop_warnings && \
+ ( curcop->cop_warnings == WARN_ALL || \
+ SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || \
+ SvPVX(curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) )
+
+#endif
+
+#define WARN_NONE NULL
+#define WARN_ALL (&sv_yes)
+
+EOM
+
+
+$index = 0 ;
+@{ $list{"all"} } = walk ($tree) ;
+
+$index *= 2 ;
+my $warn_size = int($index / 8) + ($index % 8 != 0) ;
+
+my $k ;
+foreach $k (sort { $a <=> $b } keys %Value) {
+ print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
+}
+print WARN "\n" ;
+
+print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
+#print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
+print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
+print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
+
+print WARN <<'EOM';
+
+/* end of file warning.h */
+
+EOM
+
+close WARN ;
+
+while (<DATA>) {
+ last if /^KEYWORDS$/ ;
+ print PM $_ ;
+}
+
+$list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
+print PM "%Bits = (\n" ;
+foreach $k (sort keys %list) {
+
+ my $v = $list{$k} ;
+ my @list = sort { $a <=> $b } @$v ;
+
+ print PM tab(4, " '$k'"), '=> "',
+ # mkHex($warn_size, @list),
+ mkHex($warn_size, map $_ * 2 , @list),
+ '", # [', mkRange(@list), "]\n" ;
+}
+
+print PM " );\n\n" ;
+
+print PM "%DeadBits = (\n" ;
+foreach $k (sort keys %list) {
+
+ my $v = $list{$k} ;
+ my @list = sort { $a <=> $b } @$v ;
+
+ print PM tab(4, " '$k'"), '=> "',
+ # mkHex($warn_size, @list),
+ mkHex($warn_size, map $_ * 2 + 1 , @list),
+ '", # [', mkRange(@list), "]\n" ;
+}
+
+print PM " );\n\n" ;
+while (<DATA>) {
+ print PM $_ ;
+}
+
+close PM ;
+
+__END__
+
+# This file was created by warning.pl
+# Any changes made here will be lost.
+#
+
+package warning;
+
+=head1 NAME
+
+warning - Perl pragma to control
+
+=head1 SYNOPSIS
+
+ use warning;
+
+ use warning "all";
+ use warning "deprecated";
+
+ use warning;
+ no warning "unsafe";
+
+=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
+
+See L<perlmod/Pragmatic Modules>.
+
+
+=cut
+
+use Carp ;
+
+KEYWORDS
+
+sub bits {
+ my $mask ;
+ my $catmask ;
+ my $fatal = 0 ;
+ foreach my $word (@_) {
+ if ($word eq 'FATAL')
+ { $fatal = 1 }
+ elsif ($catmask = $Bits{$word}) {
+ $mask |= $catmask ;
+ $mask |= $DeadBits{$word} if $fatal ;
+ }
+ else
+ { croak "unknown warning category '$word'" }
+ }
+
+ return $mask ;
+}
+
+sub import {
+ shift;
+ $^B |= bits(@_ ? @_ : 'all') ;
+}
+
+sub unimport {
+ shift;
+ $^B &= ~ bits(@_ ? @_ : 'all') ;
+}
+
+
+sub make_fatal
+{
+ my $self = shift ;
+ my $bitmask = $self->bits(@_) ;
+ $SIG{__WARN__} =
+ sub
+ {
+ die @_ if $^B & $bitmask ;
+ warn @_
+ } ;
+}
+
+sub bitmask
+{
+ return $^B ;
+}
+
+sub enabled
+{
+ my $string = shift ;
+
+ return 1
+ if $bits{$string} && $^B & $bits{$string} ;
+
+ return 0 ;
+}
+
+1;
projects / p5sagit/p5-mst-13.2.git / commitdiff