From: Paul Marquess Date: Wed, 29 Jul 1998 09:28:45 +0000 (+0100) Subject: lexical warnings; tweaks to places that didn't apply correctly X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=599cee73f2261c5e09cde7ceba3f9a896989e117;p=p5sagit%2Fp5-mst-13.2.git lexical warnings; tweaks to places that didn't apply correctly Message-Id: <9807290828.AA26286@claudius.bfsec.bt.co.uk> Subject: lexical warnings patch for 5.005_50 p4raw-id: //depot/perl@1773 --- diff --git a/Changes b/Changes index fc7488a..cd9e864 100644 --- a/Changes +++ b/Changes @@ -74,7 +74,152 @@ indicator: ---------------- -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 + 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 + Date: 06 Aug 1998 23:28:57 +0200 + Message-ID: + 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 + Date: 05 Aug 1998 00:41:04 +0200 + Message-ID: + 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 + Date: 04 Aug 1998 22:56:11 +0200 + Message-ID: + 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 + 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 + 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 + 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 ---------------- ____________________________________________________________________________ diff --git a/MANIFEST b/MANIFEST index 3f0d481..9cdf7ae 100644 --- a/MANIFEST +++ b/MANIFEST @@ -33,6 +33,7 @@ README.amiga Notes about AmigaOS port 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 @@ -754,6 +755,7 @@ lib/utf8.pm Pragma to control Unicode support 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 @@ -1129,6 +1131,24 @@ t/pragma/strict-vars Tests of "use strict 'vars'" for strict.t 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 @@ -1184,6 +1204,8 @@ vms/vms.c VMS-specific C code for Perl core 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 diff --git a/Makefile.SH b/Makefile.SH index 34bf4c4..ff2008f 100644 --- a/Makefile.SH +++ b/Makefile.SH @@ -210,7 +210,7 @@ h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h 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 @@ -462,6 +462,7 @@ SYMH = perlvars.h thrdvar.h # 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 @@ -472,6 +473,7 @@ regen_headers: FORCE 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 diff --git a/README.lexwarn b/README.lexwarn new file mode 100644 index 0000000..27e5ec8 --- /dev/null +++ b/README.lexwarn @@ -0,0 +1,244 @@ +Date: 29th July 1998 + +This patch adds lexical warnings to Perl. It should apply over +5.005_50 + +NOTE: This is a prototype. Do not assume that lexical warnings will + necessarily be anything like this implementation. + +Changes +======= + + Date: 8th April 1998 + + * patch now applies cleanly over 5.004_64 + + * added the -X switch (the inverse "lint" command) + + Date: 26th Feb 1997 + + * By popular demand, the warnings bitmask can now be of arbitrary + length. The code uses an SV* to store the bitmask. + + * Rationalised the warning categories a bit. This area still needs + a lot of work. + + * Added -W switch (the "lint" command). + + * Added an experimental feature to allow warnings to be excalated + to fatal errors. + + +The "use warning" pragma +======================== + + The "use warning" pragma is intended to replace both the use of the + command line flag "-w" and its equivalent variable $^W with a pragma + that works like the existing "strict" pragma. + + This means that the scope of the pragma is limited to the enclosing + block. It also means that that a pragma setting will not leak across + files (via use/require/do). This will allow authors to define the + degree of warning checks that will be applied to their module. + + By default warnings are disabled. + + All warnings are enabled in a block by either of these: + + use warning ; + use warning 'all' ; + + Similarly all warnings are disabled in a block by either of these: + + no warning ; + no warning 'all' ; + + A hierarchy of "categories" have been defined to allow groups of + warnings to be enabled/disabled in isolation. The current + hierarchy is: + + all - +--- unsafe -------+--- taint + | | + | +--- substr + | | + | +--- signal + | | + | +--- closure + | | + | +--- untie + | + +--- io ---------+--- pipe + | | + | +--- unopened + | | + | +--- closed + | | + | +--- newline + | | + | +--- exec + | + +--- syntax ----+--- ambiguous + | | + | +--- semicolon + | | + | +--- precedence + | | + | +--- reserved + | | + | +--- octal + | | + | +--- parenthesis + | | + | +--- deprecated + | + |--- uninitialized + | + +--- void + | + +--- recursion + | + +--- redefine + | + +--- numeric + | + +--- once + | + +--- misc + + This hierarchy is very tentative. Feedback is needed. + + Just like the "strict" pragma any of these categories can be + combined + + use warning qw(void redefine) ; + no warning qw(io syntax untie) ; + +The "lint" flag, -W +=================== + +If the -W flag is used on the command line, it will enable all warnings +throughout the program regardless of whether warnings were disabled +locally using "no warning" or $^W =0. This includes any file that gets +included during compilation via use/require. + +The inverse "lint" flag, -X +=========================== +Does exactly the same as the -W flag, except it disables all warnings. + + +Backward Compatability +====================== + + How Lexical Warnings interact with -w/$^W + + 1. The -w flag just sets the global $^W variable as in 5.004 + This means that any legacy code that currently relies on + manipulating $^W to control warning behaviour will still work. + + 2. Apart from now being a boolean, the $^W variable operates in + exactly the same horrible uncontrolled global way as in 5.004, + except... + + 3. If a piece of code is under the control of a lexical warning + pragma, the $^W variable will be ignored. + + The combined effect of 2 & 3 is that it will will allow new code + which will use the lexical warning pragma to control old + $^W-type code (using a local $^W=0) if it really wants to, but + not vice-versa. + + 4. The only way to override a lexical warnings setting is with the + new -W or -X command line flags. + + +Fatal Warnings +============== + +This feature is very experimental. + +The presence of the word "FATAL" in the category list will escalate any +warnings from the category specified that are detected in the lexical +scope into fatal errors. In the code below, there are 3 places where a +deprecated warning will be detected, the middle one will produce a +fatal error. + + + use warning ; + + $a = 1 if $a EQ $b ; + + { + use warning qw(FATAL deprecated) ; + $a = 1 if $a EQ $b ; + } + + $a = 1 if $a EQ $b ; + + +TODO +==== + +test harness for -X (assuming it is a permanent fixture). +win32, os2 & vms all have warnings. These need to be included. + +Unresolved Issues +================= + + The pragma name? + A few possibilities: + warning + warnings + warn + + Hierarchy of Warnings + The current patch has a fairly arbitrary hierarchy. + Ideas for a useful hierarchy would be most welcome. + + A command line option to turn off all warnings? + -X or -q, perhaps. + + Current mandatory warnings. + May be useful to bring them under the control of this pragma. + + Severity + Do we want/need a severity classification? + pedantic + high/strict/precise + medium/default + low/common + + Versions + This is a thorhy issue. Say someone writes a script using Perl + 5.004 and places this at the top: + + use warning ; + + Time passes and 5.005 comes out. It has added a few extra warnings. + The script prints warning messages. + + A possibility is to allow the warnings that are checked to be + limited to those available in a given version of Perl. A possible + syntax could be: + + use warning 5.004 ; + + or + + use warning 5.004 qw(void uninitialized) ; + + Do we really need this amount of control? + + Documentation + There isn't any yet. + + + perl5db.pl + The debugger saves and restores $^W at runtime. I haven't checked + whether the debugger will still work with the lexical warnings + patch applied. + + diagnostics.pm + I *think* I've got diagnostics to work with the lexiacal warnings + patch, but there were design decisions made in diagnostics to work + around the limitations of $^W. Now that those limitations are gone, + the module should be revisited. diff --git a/cop.h b/cop.h index 9c8eae6..4d02019 100644 --- a/cop.h +++ b/cop.h @@ -15,6 +15,7 @@ struct cop { 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*) diff --git a/doio.c b/doio.c index 85d604b..87672ed 100644 --- a/doio.c +++ b/doio.c @@ -188,8 +188,8 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe 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; @@ -298,8 +298,8 @@ do_open(GV *gv, register char *name, I32 len, int as_raw, int rawmode, int rawpe } } 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) && @@ -616,8 +616,9 @@ do_close(GV *gv, bool not_implicit) 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; @@ -714,8 +715,8 @@ do_tell(GV *gv) #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; } @@ -733,8 +734,8 @@ do_seek(GV *gv, long int pos, int whence) #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; } @@ -747,8 +748,8 @@ do_sysseek(GV *gv, long int pos, int whence) 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; } @@ -868,8 +869,8 @@ do_print(register SV *sv, PerlIO *fp) } 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)) { @@ -909,8 +910,8 @@ my_stat(ARGSproto) 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,""); @@ -935,8 +936,8 @@ my_stat(ARGSproto) 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; } } @@ -966,8 +967,8 @@ my_lstat(ARGSproto) #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; } @@ -994,8 +995,9 @@ do_aexec(SV *really, register SV **mark, register SV **sp) 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; @@ -1097,8 +1099,9 @@ do_exec(char *cmd) 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; diff --git a/global.sym b/global.sym index 9426128..6bce314 100644 --- a/global.sym +++ b/global.sym @@ -1106,6 +1106,7 @@ utilize uv_to_utf8 wait4pid warn +warner watch whichsig yydestruct diff --git a/gv.c b/gv.c index 0d96ffa..be55a02 100644 --- a/gv.c +++ b/gv.c @@ -221,8 +221,8 @@ gv_fetchmeth(HV *stash, char *name, STRLEN len, I32 level) 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; } @@ -356,8 +356,9 @@ gv_autoload4(HV *stash, char *name, STRLEN len, I32 method) /* * 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); @@ -728,8 +729,8 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) 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 '^': @@ -747,6 +748,7 @@ gv_fetchpv(char *nambeg, I32 add, I32 sv_type) case '/': case '|': case '\001': + case '\002': case '\004': case '\005': case '\006': @@ -885,7 +887,8 @@ gv_check(HV *stash) 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)); } } diff --git a/lib/diagnostics.pm b/lib/diagnostics.pm index 78bf445..f74e735 100755 --- a/lib/diagnostics.pm +++ b/lib/diagnostics.pm @@ -274,7 +274,7 @@ if (eof(POD_DIAG)) { $transmo = < + +This generates a runtime error if you use deprecated + + use warning 'deprecated'; + +=back + +See L. + + +=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; diff --git a/mg.c b/mg.c index adf8552..f003905 100644 --- a/mg.c +++ b/mg.c @@ -346,6 +346,34 @@ magic_len(SV *sv, MAGIC *mg) 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) { @@ -360,6 +388,18 @@ 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; @@ -453,7 +493,7 @@ magic_get(SV *sv, MAGIC *mg) #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 '&': @@ -847,8 +887,8 @@ magic_setsig(SV *sv, MAGIC *mg) 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]); @@ -1519,6 +1559,21 @@ magic_set(SV *sv, MAGIC *mg) 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()); @@ -1568,7 +1623,10 @@ magic_set(SV *sv, MAGIC *mg) #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) { @@ -1958,8 +2016,8 @@ sighandler(int sig) 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)) diff --git a/op.c b/op.c index d72d313..f64a59e 100644 --- a/op.c +++ b/op.c @@ -126,7 +126,7 @@ pad_allocmy(char *name) } 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]) @@ -134,7 +134,9 @@ pad_allocmy(char *name) && 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; } } @@ -231,8 +233,8 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) 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; @@ -241,8 +243,9 @@ pad_findlex(char *name, PADOFFSET newoff, U32 seq, CV* startcv, I32 cx_ix) } } 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)); @@ -604,6 +607,8 @@ op_free(OP *o) 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); @@ -689,14 +694,14 @@ scalarkids(OP *o) 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); @@ -884,7 +889,7 @@ scalarvoid(OP *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; @@ -951,8 +956,8 @@ scalarvoid(OP *o) } 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; } @@ -1462,18 +1467,20 @@ bind_match(I32 type, OP *left, OP *right) { 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 || @@ -1562,6 +1569,14 @@ block_start(int full) 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; } @@ -1633,11 +1648,12 @@ localize(OP *o, I32 lex) 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; @@ -2820,6 +2836,12 @@ newSTATEOP(I32 flags, char *label, OP *o) } cop->cop_seq = seq; cop->cop_arybase = PL_curcop->cop_arybase; + if (PL_curcop->cop_warnings == WARN_NONE + || PL_curcop->cop_warnings == WARN_ALL) + 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; @@ -2900,8 +2922,9 @@ new_logop(I32 type, I32 flags, OP** firstp, OP** otherp) } } 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; @@ -2919,7 +2942,7 @@ new_logop(I32 type, I32 flags, OP** firstp, OP** otherp) 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; @@ -2942,7 +2965,8 @@ new_logop(I32 type, I32 flags, OP** firstp, OP** otherp) 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")); @@ -3691,14 +3715,16 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) 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); @@ -3919,12 +3945,12 @@ newXS(char *name, void (*subaddr) (CV * _CPERLproto), char *filename) } 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); @@ -3999,11 +4025,11 @@ newFORM(I32 floor, OP *o, OP *block) 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); @@ -4471,8 +4497,9 @@ ck_fun(OP *o) 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; @@ -4489,8 +4516,9 @@ ck_fun(OP *o) 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; @@ -5223,7 +5251,8 @@ peep(register OP *o) 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 && @@ -5231,8 +5260,8 @@ peep(register OP *o) 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; } } diff --git a/op.h b/op.h index 9ec72e9..cbb2ac3 100644 --- a/op.h +++ b/op.h @@ -130,6 +130,7 @@ typedef U32 PADOFFSET; #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. */ diff --git a/perl.c b/perl.c index e76d83a..16e8bc9 100644 --- a/perl.c +++ b/perl.c @@ -403,7 +403,7 @@ perl_destruct(register PerlInterpreter *sv_interp) 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 */ @@ -680,6 +680,7 @@ setuid perl scripts securely.\n"); time(&PL_basetime); oldscope = PL_scopestack_ix; + PL_dowarn = G_WARN_OFF; JMPENV_PUSH(ret); switch (ret) { @@ -737,6 +738,8 @@ setuid perl scripts securely.\n"); case 'u': case 'U': case 'v': + case 'W': + case 'X': case 'w': if (s = moreswitches(s)) goto reswitch; @@ -990,7 +993,7 @@ print \" \\@INC:\\n @INC\\n\";"); if (PL_do_undump) my_unexec(); - if (PL_dowarn) + if (ckWARN(WARN_ONCE)) gv_check(PL_defstash); LEAVE; @@ -1748,7 +1751,18 @@ this system using `man perl' or `perldoc perl'. If you have access to the\n\ 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 '*': diff --git a/perl.h b/perl.h index 0e9b9b3..547dc87 100644 --- a/perl.h +++ b/perl.h @@ -1257,6 +1257,7 @@ union any { #include "hv.h" #include "mg.h" #include "scope.h" +#include "warning.h" #include "bytecode.h" #include "byterun.h" #include "utf8.h" diff --git a/pp.c b/pp.c index a6f26f5..626c5b1 100644 --- a/pp.c +++ b/pp.c @@ -234,8 +234,8 @@ PP(pp_rv2gv) 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); @@ -278,8 +278,8 @@ PP(pp_rv2sv) 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); @@ -520,8 +520,9 @@ PP(pp_bless) 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); } @@ -770,8 +771,8 @@ PP(pp_undef) 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: @@ -1876,8 +1877,8 @@ PP(pp_substr) 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 { @@ -1889,8 +1890,9 @@ PP(pp_substr) 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); @@ -2712,8 +2714,8 @@ PP(pp_anonhash) 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; @@ -3195,8 +3197,8 @@ PP(pp_unpack) 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') @@ -4026,8 +4028,8 @@ PP(pp_pack) 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"); @@ -4408,8 +4410,9 @@ PP(pp_pack) * 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 diff --git a/pp_ctl.c b/pp_ctl.c index 467f268..a886bef 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -357,8 +357,8 @@ PP(pp_formline) 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; @@ -979,20 +979,24 @@ dopoptolabel(char *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: if (!cx->blk_loop.label || @@ -1095,20 +1099,24 @@ dopoptoloop(I32 startingblock) 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)); @@ -1966,7 +1974,7 @@ PP(pp_goto) 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(); @@ -2684,6 +2692,9 @@ PP(pp_require) 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 */ @@ -2744,6 +2755,12 @@ PP(pp_entereval) 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); diff --git a/pp_hot.c b/pp_hot.c index 51934e1..fcbdb14 100644 --- a/pp_hot.c +++ b/pp_hot.c @@ -334,23 +334,25 @@ PP(pp_print) 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; @@ -437,8 +439,8 @@ PP(pp_rv2av) 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; @@ -521,8 +523,8 @@ PP(pp_rv2hv) 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; @@ -660,14 +662,14 @@ PP(pp_aassign) 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); @@ -1218,8 +1220,9 @@ do_readline(void) 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; @@ -2268,7 +2271,7 @@ PP(pp_entersub) 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)) { @@ -2382,11 +2385,12 @@ void 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)); } } diff --git a/pp_sys.c b/pp_sys.c index 2630e05..40628af 100644 --- a/pp_sys.c +++ b/pp_sys.c @@ -612,7 +612,7 @@ PP(pp_untie) sv = POPs; - if (PL_dowarn) { + if (ckWARN(WARN_UNTIE)) { MAGIC * mg ; if (SvMAGICAL(sv)) { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) @@ -621,8 +621,9 @@ PP(pp_untie) 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 ) ; } } @@ -1083,18 +1084,18 @@ PP(pp_leavewrite) 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)) @@ -1149,20 +1150,22 @@ PP(pp_prtf) 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; @@ -1396,11 +1399,11 @@ PP(pp_send) 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) { @@ -1813,8 +1816,8 @@ PP(pp_bind) 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 @@ -1843,8 +1846,8 @@ PP(pp_connect) 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 @@ -1869,8 +1872,8 @@ PP(pp_listen) 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 @@ -1923,8 +1926,8 @@ PP(pp_accept) 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: @@ -1950,8 +1953,8 @@ PP(pp_shutdown) 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 @@ -2028,8 +2031,8 @@ PP(pp_ssockopt) 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; @@ -2101,8 +2104,8 @@ PP(pp_getpeername) 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; @@ -2159,8 +2162,8 @@ PP(pp_stat) #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; } } @@ -2564,8 +2567,8 @@ PP(pp_fttext) 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; @@ -2583,8 +2586,8 @@ PP(pp_fttext) 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); diff --git a/proto.h b/proto.h index 69c41f5..56d62a7 100644 --- a/proto.h +++ b/proto.h @@ -662,6 +662,7 @@ VIRTUAL void vivify_defelem _((SV* sv)); 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)); diff --git a/regcomp.c b/regcomp.c index 3c047b6..710d936 100644 --- a/regcomp.c +++ b/regcomp.c @@ -490,10 +490,10 @@ study_chunk(regnode **scanp, I32 *deltap, regnode *last, scan_data_t *data, U32 ? (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); @@ -1558,8 +1558,8 @@ regpiece(I32 *flagp) 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); } @@ -2115,8 +2115,9 @@ regclass(void) * (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 ] */ } } @@ -2317,8 +2318,9 @@ regclassutf8(void) * (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 ] */ } } diff --git a/regexec.c b/regexec.c index 59aabdf..33b50ee 100644 --- a/regexec.c +++ b/regexec.c @@ -1668,10 +1668,10 @@ regmatch(regnode *prog) 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); } @@ -1725,9 +1725,10 @@ regmatch(regnode *prog) 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); } diff --git a/sv.c b/sv.c index b77c399..6f9ad54 100644 --- a/sv.c +++ b/sv.c @@ -1289,10 +1289,10 @@ not_a_number(SV *sv) *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 @@ -1313,10 +1313,10 @@ sv_2iv(register SV *sv) 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; } @@ -1339,8 +1339,8 @@ sv_2iv(register SV *sv) } 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; } } @@ -1368,8 +1368,8 @@ sv_2iv(register SV *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; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", @@ -1391,10 +1391,10 @@ sv_2uv(register SV *sv) 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; } @@ -1414,8 +1414,8 @@ sv_2uv(register SV *sv) } 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; } } @@ -1439,10 +1439,10 @@ sv_2uv(register SV *sv) 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; } @@ -1461,7 +1461,7 @@ sv_2nv(register SV *sv) 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)); @@ -1469,10 +1469,10 @@ sv_2nv(register SV *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; } @@ -1488,15 +1488,15 @@ sv_2nv(register SV *sv) } 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; } } @@ -1517,15 +1517,15 @@ sv_2nv(register SV *sv) 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); @@ -1543,7 +1543,7 @@ asIV(SV *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)); @@ -1562,7 +1562,7 @@ asUV(SV *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))); @@ -1677,10 +1677,10 @@ sv_2pv(register SV *sv, STRLEN *lp) 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 ""; @@ -1785,8 +1785,8 @@ sv_2pv(register SV *sv, STRLEN *lp) tsv = Nullsv; goto tokensave; } - if (PL_dowarn) - warn(warn_uninit); + if (ckWARN(WARN_UNINITIALIZED)) + warner(WARN_UNINITIALIZED, warn_uninit); *lp = 0; return ""; } @@ -1833,8 +1833,8 @@ sv_2pv(register SV *sv, STRLEN *lp) } 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 ""; } @@ -2162,12 +2162,12 @@ sv_setsv(SV *dstr, register SV *sstr) 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)); @@ -2296,8 +2296,8 @@ sv_setsv(SV *dstr, register SV *sstr) } 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); @@ -4915,7 +4915,7 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, 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: ", @@ -4925,7 +4925,7 @@ sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, 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 ... */ diff --git a/t/op/tie.t b/t/op/tie.t index 77e74db..f1b12d6 100755 --- a/t/op/tie.t +++ b/t/op/tie.t @@ -77,8 +77,8 @@ EXPECT ######## # 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; @@ -86,8 +86,8 @@ EXPECT ######## # 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; @@ -96,8 +96,8 @@ untie attempted while 1 inner references still exist ######## # 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; @@ -107,8 +107,8 @@ untie attempted while 1 inner references still exist ######## # 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 ; @@ -117,8 +117,8 @@ EXPECT ######## # 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; @@ -128,8 +128,8 @@ EXPECT ######## # 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 ; @@ -139,14 +139,14 @@ untie attempted while 2 inner references still exist ######## # 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; diff --git a/t/pragma/warn-1global b/t/pragma/warn-1global index 07b5bc8..dca47e9 100644 --- a/t/pragma/warn-1global +++ b/t/pragma/warn-1global @@ -1,5 +1,6 @@ Check existing $^W functionality + __END__ # warnable code, warnings disabled @@ -110,22 +111,24 @@ Use of uninitialized value at - line 3. ######## $^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. ######## { @@ -149,3 +152,35 @@ Use of uninitialized value at - line 5. -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. diff --git a/t/pragma/warn-2use b/t/pragma/warn-2use new file mode 100644 index 0000000..764a843 --- /dev/null +++ b/t/pragma/warn-2use @@ -0,0 +1,291 @@ +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. diff --git a/t/pragma/warn-3both b/t/pragma/warn-3both new file mode 100644 index 0000000..7c32601 --- /dev/null +++ b/t/pragma/warn-3both @@ -0,0 +1,66 @@ +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. diff --git a/t/pragma/warn-4lint b/t/pragma/warn-4lint new file mode 100644 index 0000000..87cd7dc --- /dev/null +++ b/t/pragma/warn-4lint @@ -0,0 +1,112 @@ +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. diff --git a/t/pragma/warn-5nolint b/t/pragma/warn-5nolint new file mode 100644 index 0000000..979423e --- /dev/null +++ b/t/pragma/warn-5nolint @@ -0,0 +1,96 @@ +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 diff --git a/t/pragma/warn-doio b/t/pragma/warn-doio new file mode 100644 index 0000000..0efa4c6 --- /dev/null +++ b/t/pragma/warn-doio @@ -0,0 +1,94 @@ + 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, " 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. diff --git a/t/pragma/warn-gv b/t/pragma/warn-gv new file mode 100644 index 0000000..bd442b9 --- /dev/null +++ b/t/pragma/warn-gv @@ -0,0 +1,40 @@ + 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. diff --git a/t/pragma/warn-mg b/t/pragma/warn-mg new file mode 100644 index 0000000..6345b30 --- /dev/null +++ b/t/pragma/warn-mg @@ -0,0 +1,21 @@ + 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. diff --git a/t/pragma/warn-op b/t/pragma/warn-op new file mode 100644 index 0000000..8ca6a5f --- /dev/null +++ b/t/pragma/warn-op @@ -0,0 +1,535 @@ + 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 = ; + $x = 1 while $x = ; + + 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 < ; +EXPECT +Value of 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()?) diff --git a/t/pragma/warn-perl b/t/pragma/warn-perl new file mode 100644 index 0000000..5211990 --- /dev/null +++ b/t/pragma/warn-perl @@ -0,0 +1,12 @@ + 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. diff --git a/t/pragma/warn-perly b/t/pragma/warn-perly new file mode 100644 index 0000000..fd420d3 --- /dev/null +++ b/t/pragma/warn-perly @@ -0,0 +1,25 @@ + 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. diff --git a/t/pragma/warn-pp b/t/pragma/warn-pp new file mode 100644 index 0000000..7a3b289 --- /dev/null +++ b/t/pragma/warn-pp @@ -0,0 +1,85 @@ + 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. diff --git a/t/pragma/warn-pp_ctl b/t/pragma/warn-pp_ctl new file mode 100644 index 0000000..e017d8a --- /dev/null +++ b/t/pragma/warn-pp_ctl @@ -0,0 +1,145 @@ + 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. diff --git a/t/pragma/warn-pp_hot b/t/pragma/warn-pp_hot new file mode 100644 index 0000000..ab18094 --- /dev/null +++ b/t/pragma/warn-pp_hot @@ -0,0 +1,107 @@ + 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 = ; + + 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 = ; +EXPECT +Read on closed filehandle 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. diff --git a/t/pragma/warn-pp_sys b/t/pragma/warn-pp_sys new file mode 100644 index 0000000..7588827 --- /dev/null +++ b/t/pragma/warn-pp_sys @@ -0,0 +1,208 @@ + 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 < at - line 4. +######## +# pp_sys.c +use warning 'newline' ; +-T "abc\ndef" ; +EXPECT +Unsuccessful open on filename containing newline at - line 3. diff --git a/t/pragma/warn-regcomp b/t/pragma/warn-regcomp new file mode 100644 index 0000000..52a163a --- /dev/null +++ b/t/pragma/warn-regcomp @@ -0,0 +1,53 @@ + 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. diff --git a/t/pragma/warn-regexec b/t/pragma/warn-regexec new file mode 100644 index 0000000..3d9b566 --- /dev/null +++ b/t/pragma/warn-regexec @@ -0,0 +1,23 @@ + 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. diff --git a/t/pragma/warn-sv b/t/pragma/warn-sv new file mode 100644 index 0000000..0f1d83c --- /dev/null +++ b/t/pragma/warn-sv @@ -0,0 +1,203 @@ + 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. diff --git a/t/pragma/warn-taint b/t/pragma/warn-taint new file mode 100644 index 0000000..40fadd0 --- /dev/null +++ b/t/pragma/warn-taint @@ -0,0 +1,25 @@ + 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 + diff --git a/t/pragma/warn-toke b/t/pragma/warn-toke new file mode 100644 index 0000000..254b1e4 --- /dev/null +++ b/t/pragma/warn-toke @@ -0,0 +1,311 @@ +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. diff --git a/t/pragma/warn-universal b/t/pragma/warn-universal new file mode 100644 index 0000000..e2814e1 --- /dev/null +++ b/t/pragma/warn-universal @@ -0,0 +1,11 @@ + universal.c + + Can't locate package %s for @%s::ISA + + +__END__ +# universal.c +use warning 'misc' ; + +EXPECT + diff --git a/t/pragma/warn-util b/t/pragma/warn-util new file mode 100644 index 0000000..649a292 --- /dev/null +++ b/t/pragma/warn-util @@ -0,0 +1,21 @@ + 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. diff --git a/t/pragma/warning.t b/t/pragma/warning.t index fa0301e..9440bc3 100755 --- a/t/pragma/warning.t +++ b/t/pragma/warning.t @@ -16,8 +16,16 @@ my $i = 0 ; 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)$/; diff --git a/taint.c b/taint.c index 4c031de..05a1a44 100644 --- a/taint.c +++ b/taint.c @@ -25,8 +25,8 @@ taint_proper(const char *f, char *s) 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); } } diff --git a/toke.c b/toke.c index b71394f..0f43034 100644 --- a/toke.c +++ b/toke.c @@ -212,8 +212,8 @@ missingterm(char *s) 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 @@ -981,7 +981,7 @@ scan_const(char *start) /* (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--) @@ -1005,8 +1005,8 @@ scan_const(char *start) 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; } @@ -1047,8 +1047,8 @@ scan_const(char *start) 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; @@ -1062,8 +1062,8 @@ scan_const(char *start) 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; @@ -2469,9 +2469,9 @@ yylex(void) 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); @@ -2503,8 +2503,8 @@ yylex(void) 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') ) @@ -2634,7 +2634,7 @@ yylex(void) char *t; if (*s == '[') { PL_tokenbuf[0] = '@'; - if (PL_dowarn) { + if (ckWARN(WARN_SYNTAX)) { for(t = s + 1; isSPACE(*t) || isALNUM(*t) || *t == '$'; t++) ; @@ -2642,14 +2642,15 @@ yylex(void) 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]; @@ -2658,7 +2659,8 @@ yylex(void) 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); } } } @@ -2728,7 +2730,7 @@ yylex(void) 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))) @@ -2736,7 +2738,8 @@ yylex(void) 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); } } @@ -2842,8 +2845,9 @@ yylex(void) 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); @@ -2958,8 +2962,9 @@ yylex(void) 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 &"); } } @@ -2987,7 +2992,7 @@ yylex(void) 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 @@ -3001,8 +3006,9 @@ yylex(void) 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'; @@ -3160,11 +3166,11 @@ yylex(void) /* 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); } } @@ -3305,7 +3311,7 @@ yylex(void) 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"); @@ -3725,15 +3731,17 @@ yylex(void) 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; } } @@ -4108,7 +4116,7 @@ yylex(void) 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"); @@ -4815,7 +4823,7 @@ checkcomma(register char *s, char *name, char *what) { 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 == '(') @@ -4826,7 +4834,7 @@ checkcomma(register char *s, char *name, char *what) 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++; @@ -5066,9 +5074,10 @@ scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I3 *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; @@ -5083,9 +5092,10 @@ scan_ident(register char *s, register char *send, char *dest, STRLEN destlen, I3 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 { @@ -5931,8 +5941,8 @@ scan_num(char *start) 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 { @@ -5945,8 +5955,8 @@ scan_num(char *start) } /* 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 diff --git a/universal.c b/universal.c index bf03261..2707e46 100644 --- a/universal.c +++ b/universal.c @@ -53,8 +53,9 @@ isa_lookup(HV *stash, char *name, int len, int level) 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; } diff --git a/util.c b/util.c index 3f66b24..3788de2 100644 --- a/util.c +++ b/util.c @@ -1407,6 +1407,93 @@ warn(const char* pat,...) (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 @@ -2341,8 +2428,8 @@ scan_oct(char *start, I32 len, I32 *retlen) 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; } @@ -2363,8 +2450,8 @@ scan_hex(char *start, I32 len, I32 *retlen) continue; else { --s; - if (PL_dowarn) - warn("Illegal hex digit ignored"); + if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE,"Illegal hex digit ignored"); break; } } diff --git a/warning.h b/warning.h new file mode 100644 index 0000000..235c075 --- /dev/null +++ b/warning.h @@ -0,0 +1,100 @@ +/* !!!!!!! 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 */ + diff --git a/warning.pl b/warning.pl new file mode 100644 index 0000000..497630d --- /dev/null +++ b/warning.pl @@ -0,0 +1,359 @@ +#!/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 () { + 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 () { + 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 + +This generates a runtime error if you use deprecated + + use warning 'deprecated'; + +=back + +See L. + + +=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;