# See README.warning for information of what the patch does. exit 0 ----------------------------------------------------------------------- *** MANIFEST.orig Tue Feb 25 08:48:01 1997 --- MANIFEST Thu Feb 27 11:31:26 1997 *************** *** 404,409 **** --- 404,410 ---- lib/timelocal.pl Perl library supporting inverse of localtime, gmtime 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 *************** *** 708,713 **** --- 709,731 ---- 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-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 toke.c The tokener *************** *** 756,761 **** --- 774,781 ---- 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/EXTERN.h Win32 port win32/Fcntl.mak Win32 port win32/IO.mak Win32 port *** Makefile.SH.orig Fri Jan 17 08:52:58 1997 --- Makefile.SH Thu Feb 27 11:31:26 1997 *************** *** 167,173 **** 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 perlio.h h = $(h1) $(h2) $(h3) $(h4) c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c --- 167,173 ---- 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 perlio.h warning.h h = $(h1) $(h2) $(h3) $(h4) c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c *************** *** 362,371 **** perly.h: perly.y -@sh -c true ! # The following three header files are generated automatically # keywords.h: keywords.pl # opcode.h: opcode.pl # embed.h: embed.pl global.sym interp.sym # 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 --- 362,372 ---- perly.h: perly.y -@sh -c true ! # The following four header files are generated automatically # keywords.h: keywords.pl # opcode.h: opcode.pl # embed.h: embed.pl global.sym interp.sym + # 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 *************** *** 374,379 **** --- 375,381 ---- perl keywords.pl perl opcode.pl perl embed.pl + perl warning.pl # Extensions: # Names added to $(dynamic_ext) or $(static_ext) will automatically *** /dev/null Thu Feb 27 12:04:47 1997 --- README.warning Thu Feb 27 11:31:27 1997 *************** *** 0 **** --- 1,210 ---- + Date: 27th Feb 1997 + + This patch adds lexical warnings to Perl. It should apply over + 5.003_90 + + NOTE: This is a prototype. Do not assume that lexical warnings will + necessarily be anything like this implementation. + + Changes + ======= + + 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 work just like the "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 by either of these: + + use warning ; + use warning 'all' ; + + Similarly all warnings are disabled 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) ; + + + Backward Compatability + ====================== + + -w and $^W + + Although they should really be considered deprecated once lexical + warnings are released, both -w and $^W will continue to work as + they currently do. + + $^W cannot be used to disable warnings that have been enabled by + "use warning". + + One minor change to $^W. It is now a boolean. + + 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. + + + 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 ; + + + 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. + + 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. *** /dev/null Thu Feb 27 12:04:47 1997 --- README.warning Thu Feb 27 11:31:27 1997 *************** *** 0 **** --- 1,210 ---- + Date: 27th Feb 1997 + + This patch adds lexical warnings to Perl. It should apply over + 5.003_90 + + NOTE: This is a prototype. Do not assume that lexical warnings will + necessarily be anything like this implementation. + + Changes + ======= + + 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 work just like the "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 by either of these: + + use warning ; + use warning 'all' ; + + Similarly all warnings are disabled 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) ; + + + Backward Compatability + ====================== + + -w and $^W + + Although they should really be considered deprecated once lexical + warnings are released, both -w and $^W will continue to work as + they currently do. + + $^W cannot be used to disable warnings that have been enabled by + "use warning". + + One minor change to $^W. It is now a boolean. + + 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. + + + 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 ; + + + 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. + + 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. *** cop.h.orig Mon Feb 10 19:57:48 1997 --- cop.h Thu Feb 27 11:34:57 1997 *************** *** 15,20 **** --- 15,21 ---- 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*) *** doio.c.orig Tue Feb 25 08:48:03 1997 --- doio.c Thu Feb 27 11:31:28 1997 *************** *** 157,164 **** if (strNE(name,"-")) TAINT_ENV(); TAINT_PROPER("piped open"); ! if (dowarn && name[strlen(name)-1] == '|') ! warn("Can't do bidirectional pipe"); fp = my_popen(name,"w"); writing = 1; } --- 157,164 ---- if (strNE(name,"-")) TAINT_ENV(); TAINT_PROPER("piped open"); ! if (ckWARN(WARN_PIPE) && name[strlen(name)-1] == '|') ! warner(WARN_PIPE, "Can't do bidirectional pipe"); fp = my_popen(name,"w"); writing = 1; } *************** *** 264,271 **** } } if (!fp) { ! if (dowarn && IoTYPE(io) == '<' && strchr(name, '\n')) ! warn(warn_nl, "open"); goto say_false; } if (IoTYPE(io) && --- 264,271 ---- } } if (!fp) { ! if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == '<' && strchr(name, '\n')) ! warner(WARN_NEWLINE, warn_nl, "open"); goto say_false; } if (IoTYPE(io) && *************** *** 560,567 **** } io = GvIO(gv); if (!io) { /* never opened */ ! if (dowarn && not_implicit) ! warn("Close on unopened file <%s>",GvENAME(gv)); return FALSE; } retval = io_close(io); --- 560,567 ---- } io = GvIO(gv); if (!io) { /* never opened */ ! if (ckWARN(WARN_UNOPENED) && not_implicit) ! warner(WARN_UNOPENED, "Close on unopened file <%s>",GvENAME(gv)); return FALSE; } retval = io_close(io); *************** *** 662,669 **** return PerlIO_tell(IoIFP(io)); phooey: ! if (dowarn) ! warn("tell() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return -1L; } --- 662,669 ---- return PerlIO_tell(IoIFP(io)); phooey: ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "tell() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return -1L; } *************** *** 691,698 **** return PerlIO_seek(IoIFP(io), pos, whence) >= 0; nuts: ! if (dowarn) ! warn("seek() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return FALSE; } --- 691,698 ---- return PerlIO_seek(IoIFP(io), pos, whence) >= 0; nuts: ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "seek() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return FALSE; } *************** *** 775,782 **** } switch (SvTYPE(sv)) { case SVt_NULL: ! if (dowarn) ! warn(warn_uninit); return TRUE; case SVt_IV: if (SvIOK(sv)) { --- 775,782 ---- } switch (SvTYPE(sv)) { case SVt_NULL: ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); return TRUE; case SVt_IV: if (SvIOK(sv)) { *************** *** 817,824 **** else { if (tmpgv == defgv) return laststatval; ! if (dowarn) ! warn("Stat on unopened file <%s>", GvENAME(tmpgv)); statgv = Nullgv; sv_setpv(statname,""); --- 817,824 ---- else { if (tmpgv == defgv) return laststatval; ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "Stat on unopened file <%s>", GvENAME(tmpgv)); statgv = Nullgv; sv_setpv(statname,""); *************** *** 841,848 **** sv_setpv(statname,SvPV(sv, na)); laststype = OP_STAT; laststatval = Stat(SvPV(sv, na),&statcache); ! if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n')) ! warn(warn_nl, "stat"); return laststatval; } } --- 841,848 ---- sv_setpv(statname,SvPV(sv, na)); laststype = OP_STAT; laststatval = Stat(SvPV(sv, na),&statcache); ! if (laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, na), '\n')) ! warner(WARN_NEWLINE, warn_nl, "stat"); return laststatval; } } *************** *** 873,880 **** #else laststatval = Stat(SvPV(sv, na),&statcache); #endif ! if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n')) ! warn(warn_nl, "lstat"); return laststatval; } --- 873,880 ---- #else laststatval = Stat(SvPV(sv, na),&statcache); #endif ! if (laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, na), '\n')) ! warner(WARN_NEWLINE, warn_nl, "lstat"); return laststatval; } *************** *** 903,910 **** execvp(tmps,Argv); else execvp(Argv[0],Argv); ! if (dowarn) ! warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno)); } do_execfree(); return FALSE; --- 903,911 ---- execvp(tmps,Argv); else execvp(Argv[0],Argv); ! if (ckWARN(WARN_EXEC)) ! warner(WARN_EXEC, "Can't exec \"%s\": %s", ! Argv[0], Strerror(errno)); } do_execfree(); return FALSE; *************** *** 1007,1014 **** do_execfree(); goto doshell; } ! if (dowarn) ! warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno)); } do_execfree(); return FALSE; --- 1008,1016 ---- do_execfree(); goto doshell; } ! if (ckWARN(WARN_EXEC)) ! warner(WARN_EXEC, "Can't exec \"%s\": %s", Argv[0], ! Strerror(errno)); } do_execfree(); return FALSE; *** global.sym.orig Tue Feb 4 08:54:58 1997 --- global.sym Thu Feb 27 11:31:29 1997 *************** *** 1129,1134 **** --- 1129,1135 ---- utilize wait4pid warn + warner watch whichsig xiv_arenaroot *** gv.c.orig Fri Feb 21 23:04:40 1997 --- gv.c Thu Feb 27 11:31:29 1997 *************** *** 167,174 **** SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { ! if (dowarn) ! warn("Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } --- 167,174 ---- SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { ! if (ckWARN(WARN_MISC)) ! warner(WARN_MISC, "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } *************** *** 646,653 **** case '#': case '*': ! if (dowarn && len == 1 && sv_type == SVt_PV) ! warn("Use of $%s is deprecated", name); /* FALL THROUGH */ case '[': case '!': --- 646,653 ---- case '#': case '*': ! if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV) ! warner(WARN_DEPRECATED, "Use of $%s is deprecated", name); /* FALL THROUGH */ case '[': case '!': *************** *** 666,671 **** --- 666,672 ---- case '/': case '|': case '\001': + case '\002': case '\004': case '\005': case '\006': *************** *** 810,816 **** curcop->cop_filegv = filegv; if (filegv && GvMULTI(filegv)) /* Filename began with slash */ continue; ! warn("Name \"%s::%s\" used only once: possible typo", HvNAME(stash), GvNAME(gv)); } } --- 811,818 ---- curcop->cop_filegv = filegv; if (filegv && GvMULTI(filegv)) /* Filename began with slash */ continue; ! warner(WARN_ONCE, ! "Name \"%s::%s\" used only once: possible typo", HvNAME(stash), GvNAME(gv)); } } *** interp.sym.orig Tue Feb 4 08:55:00 1997 --- interp.sym Thu Feb 27 11:31:30 1997 *************** *** 69,74 **** --- 69,75 ---- laststatval laststype leftgv + lexwarn lineary localizing localpatches *** lib/diagnostics.pm.orig Fri Feb 21 23:04:44 1997 --- lib/diagnostics.pm Thu Feb 27 11:31:30 1997 *************** *** 268,274 **** $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", # [0..27] + 'ambiguous' => "\x00\x00\x00\x40\x00\x00\x00", # [15] + 'closed' => "\x00\x00\x00\x00\x00\x01\x00", # [20] + 'closure' => "\x00\x04\x00\x00\x00\x00\x00", # [5] + 'deprecated' => "\x00\x00\x00\x01\x00\x00\x00", # [12] + 'exec' => "\x00\x00\x00\x00\x00\x04\x00", # [21] + 'io' => "\x00\x00\x00\x00\x50\x55\x00", # [18..23] + 'misc' => "\x00\x00\x00\x00\x00\x00\x10", # [26] + 'newline' => "\x00\x00\x00\x00\x40\x00\x00", # [19] + 'numeric' => "\x00\x00\x01\x00\x00\x00\x00", # [8] + 'octal' => "\x00\x00\x00\x10\x00\x00\x00", # [14] + 'once' => "\x00\x00\x04\x00\x00\x00\x00", # [9] + 'parenthesis' => "\x00\x00\x00\x00\x01\x00\x00", # [16] + 'pipe' => "\x00\x00\x00\x00\x00\x40\x00", # [23] + 'precedence' => "\x00\x00\x00\x00\x04\x00\x00", # [17] + 'recursion' => "\x00\x00\x00\x00\x00\x00\x04", # [25] + 'redefine' => "\x01\x00\x00\x00\x00\x00\x00", # [0] + 'reserved' => "\x00\x00\x40\x00\x00\x00\x00", # [11] + 'semicolon' => "\x00\x00\x00\x04\x00\x00\x00", # [13] + 'signal' => "\x00\x40\x00\x00\x00\x00\x00", # [7] + 'substr' => "\x00\x01\x00\x00\x00\x00\x00", # [4] + 'syntax' => "\x00\x00\x50\x55\x05\x00\x00", # [10..17] + 'taint' => "\x40\x00\x00\x00\x00\x00\x00", # [3] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x01", # [24] + 'unopened' => "\x00\x00\x00\x00\x00\x10\x00", # [22] + 'unsafe' => "\x50\x55\x00\x00\x00\x00\x00", # [2..7] + 'untie' => "\x00\x10\x00\x00\x00\x00\x00", # [6] + 'void' => "\x04\x00\x00\x00\x00\x00\x00", # [1] + ); + + %DeadBits = ( + 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..27] + 'ambiguous' => "\x00\x00\x00\x80\x00\x00\x00", # [15] + 'closed' => "\x00\x00\x00\x00\x00\x02\x00", # [20] + 'closure' => "\x00\x08\x00\x00\x00\x00\x00", # [5] + 'deprecated' => "\x00\x00\x00\x02\x00\x00\x00", # [12] + 'exec' => "\x00\x00\x00\x00\x00\x08\x00", # [21] + 'io' => "\x00\x00\x00\x00\xa0\xaa\x00", # [18..23] + 'misc' => "\x00\x00\x00\x00\x00\x00\x20", # [26] + 'newline' => "\x00\x00\x00\x00\x80\x00\x00", # [19] + 'numeric' => "\x00\x00\x02\x00\x00\x00\x00", # [8] + 'octal' => "\x00\x00\x00\x20\x00\x00\x00", # [14] + 'once' => "\x00\x00\x08\x00\x00\x00\x00", # [9] + 'parenthesis' => "\x00\x00\x00\x00\x02\x00\x00", # [16] + 'pipe' => "\x00\x00\x00\x00\x00\x80\x00", # [23] + 'precedence' => "\x00\x00\x00\x00\x08\x00\x00", # [17] + 'recursion' => "\x00\x00\x00\x00\x00\x00\x08", # [25] + 'redefine' => "\x02\x00\x00\x00\x00\x00\x00", # [0] + 'reserved' => "\x00\x00\x80\x00\x00\x00\x00", # [11] + 'semicolon' => "\x00\x00\x00\x08\x00\x00\x00", # [13] + 'signal' => "\x00\x80\x00\x00\x00\x00\x00", # [7] + 'substr' => "\x00\x02\x00\x00\x00\x00\x00", # [4] + 'syntax' => "\x00\x00\xa0\xaa\x0a\x00\x00", # [10..17] + 'taint' => "\x80\x00\x00\x00\x00\x00\x00", # [3] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x02", # [24] + 'unopened' => "\x00\x00\x00\x00\x00\x20\x00", # [22] + 'unsafe' => "\xa0\xaa\x00\x00\x00\x00\x00", # [2..7] + 'untie' => "\x00\x20\x00\x00\x00\x00\x00", # [6] + 'void' => "\x08\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') ; + } + + + 1; *** mg.c.orig Fri Feb 21 23:04:45 1997 --- mg.c Thu Feb 27 11:36:54 1997 *************** *** 341,346 **** --- 341,354 ---- case '\001': /* ^A */ sv_setsv(sv, bodytarget); break; + case '\002': /* ^B */ + if (curcop->cop_warnings == WARN_NONE) + sv_setpvn(sv, WARN_NONEstring, WARNsize) ; + else if (curcop->cop_warnings == WARN_ALL) + sv_setpvn(sv, WARN_ALLstring, WARNsize) ; + else + sv_setsv(sv, curcop->cop_warnings); + break; case '\004': /* ^D */ sv_setiv(sv, (IV)(debug & 32767)); break; *************** *** 394,400 **** #endif break; case '\027': /* ^W */ ! sv_setiv(sv, (IV)dowarn); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': --- 402,408 ---- #endif break; case '\027': /* ^W */ ! sv_setiv(sv, (IV)(dowarn != 0)); break; case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': *************** *** 702,709 **** else { i = whichsig(s); /* ...no, a brick */ if (!i) { ! if (dowarn || strEQ(s,"ALARM")) ! warn("No such signal: SIG%s", s); return 0; } SvREFCNT_dec(psig_name[i]); --- 710,717 ---- else { i = whichsig(s); /* ...no, a brick */ if (!i) { ! if (ckWARN(WARN_SIGNAL) || strEQ(s,"ALARM")) ! warner(WARN_SIGNAL, "No such signal: SIG%s", s); return 0; } SvREFCNT_dec(psig_name[i]); *************** *** 1221,1226 **** --- 1229,1246 ---- case '\001': /* ^A */ sv_setsv(bodytarget, sv); break; + case '\002': /* ^B */ + if ((dowarn & G_WARN_FLAG) || 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 */ debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000; DEBUG_x(dump_all()); *************** *** 1273,1279 **** #endif break; case '\027': /* ^W */ ! dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '.': if (localizing) { --- 1293,1300 ---- #endif break; case '\027': /* ^W */ ! i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv); ! dowarn = (dowarn & G_WARN_FLAG) | (i ? G_WARN_ON : G_WARN_OFF) ; break; case '.': if (localizing) { *************** *** 1552,1559 **** cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE); if (!cv || !CvROOT(cv)) { ! if (dowarn) ! warn("SIG%s handler \"%s\" not defined.\n", sig_name[sig], GvENAME(gv) ); return; } --- 1573,1580 ---- cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE); if (!cv || !CvROOT(cv)) { ! if (ckWARN(WARN_SIGNAL)) ! warner(WARN_SIGNAL, "SIG%s handler \"%s\" not defined.\n", sig_name[sig], GvENAME(gv) ); return; } *** op.c.orig Fri Feb 21 23:04:46 1997 --- op.c Thu Feb 27 11:39:23 1997 *************** *** 106,114 **** if (type != OP_AELEM && type != OP_HELEM) { sprintf(tokenbuf, "Can't use subscript on %s", op_desc[type]); yyerror(tokenbuf); ! if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV) warn("(Did you mean $ or @ instead of %c?)\n", ! type == OP_ENTERSUB ? '&' : '%'); } } --- 106,114 ---- if (type != OP_AELEM && type != OP_HELEM) { sprintf(tokenbuf, "Can't use subscript on %s", op_desc[type]); yyerror(tokenbuf); ! if (type == OP_RV2HV || type == OP_ENTERSUB) warn("(Did you mean $ or @ instead of %c?)\n", ! type == OP_RV2HV ? '%' : '&'); } } *************** *** 225,232 **** if (CvANON(bcv)) CvCLONE_on(bcv); else { ! if (dowarn && !CvUNIQUE(cv)) ! warn( "Variable \"%s\" may be unavailable", name); break; --- 225,232 ---- if (CvANON(bcv)) CvCLONE_on(bcv); else { ! if (ckWARN(WARN_CLOSURE) && !CvUNIQUE(cv)) ! warner(WARN_CLOSURE, "Variable \"%s\" may be unavailable", name); break; *************** *** 235,242 **** } } else if (!CvUNIQUE(compcv)) { ! if (dowarn && !CvUNIQUE(cv)) ! warn("Variable \"%s\" will not stay shared", name); } } av_store(comppad, newoff, SvREFCNT_inc(oldsv)); --- 235,243 ---- } } else if (!CvUNIQUE(compcv)) { ! if (ckWARN(WARN_CLOSURE) && !CvUNIQUE(cv)) ! warner(WARN_CLOSURE, ! "Variable \"%s\" will not stay shared", name); } } av_store(comppad, newoff, SvREFCNT_inc(oldsv)); *************** *** 488,493 **** --- 489,496 ---- case OP_DBSTATE: Safefree(cCOP->cop_label); SvREFCNT_dec(cCOP->cop_filegv); + if (cCOP->cop_warnings != WARN_NONE && cCOP->cop_warnings != WARN_ALL) + SvREFCNT_dec(cCOP->cop_warnings); break; case OP_CONST: SvREFCNT_dec(cSVOP->op_sv); *************** *** 574,586 **** scalarboolean(op) OP *op; { ! if (dowarn && op->op_type == OP_SASSIGN && cBINOP->op_first->op_type == OP_CONST) { line_t oldline = curcop->cop_line; if (copline != NOLINE) curcop->cop_line = copline; ! warn("Found = in conditional, should be =="); curcop->cop_line = oldline; } return scalar(op); --- 577,589 ---- scalarboolean(op) OP *op; { ! if (ckWARN(WARN_SYNTAX) && op->op_type == OP_SASSIGN && cBINOP->op_first->op_type == OP_CONST) { line_t oldline = curcop->cop_line; if (copline != NOLINE) curcop->cop_line = copline; ! warner(WARN_SYNTAX, "Found = in conditional, should be =="); curcop->cop_line = oldline; } return scalar(op); *************** *** 758,764 **** case OP_CONST: sv = cSVOP->op_sv; ! if (dowarn) { useless = "a constant"; if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = 0; --- 761,767 ---- case OP_CONST: sv = cSVOP->op_sv; ! if (ckWARN(WARN_VOID)) { useless = "a constant"; if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = 0; *************** *** 821,828 **** op->op_private |= OPpLEAVE_VOID; break; } ! if (useless && dowarn) ! warn("Useless use of %s in void context", useless); return op; } --- 824,831 ---- op->op_private |= OPpLEAVE_VOID; break; } ! if (useless && ckWARN(WARN_VOID)) ! warner(WARN_VOID, "Useless use of %s in void context", useless); return op; } *************** *** 949,968 **** switch (op->op_type) { case OP_CONST: ! if (!(op->op_private & (OPpCONST_ARYBASE))) goto nomod; ! if (eval_start && eval_start->op_type == OP_CONST) { ! compiling.cop_arybase = (I32)SvIV(((SVOP*)eval_start)->op_sv); ! eval_start = 0; ! } ! else if (!type) { ! SAVEI32(compiling.cop_arybase); ! compiling.cop_arybase = 0; } - else if (type == OP_REFGEN) - goto nomod; - else - croak("That use of $[ is unsupported"); break; case OP_STUB: if (op->op_flags & OPf_PARENS) --- 952,973 ---- switch (op->op_type) { case OP_CONST: ! if (!(op->op_private & (OPpCONST_ARYBASE|OPpCONST_WARNING))) goto nomod; ! if (op->op_private & OPpCONST_ARYBASE) { ! if (eval_start && eval_start->op_type == OP_CONST) { ! compiling.cop_arybase = (I32)SvIV(((SVOP*)eval_start)->op_sv); ! eval_start = 0; ! } ! else if (!type) { ! SAVEI32(compiling.cop_arybase); ! compiling.cop_arybase = 0; ! } ! else if (type == OP_REFGEN) ! goto nomod; ! else ! croak("That use of $[ is unsupported"); } break; case OP_STUB: if (op->op_flags & OPf_PARENS) *************** *** 1340,1345 **** --- 1345,1355 ---- pad_reset_pending = FALSE; SAVEI32(hints); hints &= ~HINT_BLOCK_SCOPE; + SAVEPPTR(compiling.cop_warnings); + if (compiling.cop_warnings != WARN_ALL && compiling.cop_warnings != WARN_NONE) { + compiling.cop_warnings = newSVsv(compiling.cop_warnings) ; + SAVEFREESV(compiling.cop_warnings) ; + } return retval; } *************** *** 1402,1412 **** list(o); else { scalar(o); ! if (dowarn && bufptr > oldbufptr && bufptr[-1] == ',') { char *s; for (s = bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ; if (*s == ';' || *s == '=') ! warn("Parens missing around \"%s\" list", lex ? "my" : "local"); } } in_my = FALSE; --- 1412,1423 ---- list(o); else { scalar(o); ! if (ckWARN(WARN_PARENTHESIS) && bufptr > oldbufptr && bufptr[-1] == ',') { char *s; for (s = bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ; if (*s == ';' || *s == '=') ! warner(WARN_PARENTHESIS, "Parens missing around \"%s\" list", ! lex ? "my" : "local"); } } in_my = FALSE; *************** *** 2388,2393 **** --- 2399,2408 ---- } cop->cop_seq = seq; cop->cop_arybase = curcop->cop_arybase; + if (curcop->cop_warnings == WARN_NONE || curcop->cop_warnings == WARN_ALL) + cop->cop_warnings = curcop->cop_warnings ; + else + cop->cop_warnings = newSVsv(curcop->cop_warnings) ; if (copline == NOLINE) cop->cop_line = curcop->cop_line; *************** *** 2463,2470 **** } } if (first->op_type == OP_CONST) { ! if (dowarn && (first->op_private & OPpCONST_BARE)) ! warn("Probable precedence problem on %s", op_desc[type]); if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) { op_free(first); return other; --- 2478,2486 ---- } } if (first->op_type == OP_CONST) { ! 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); return other; *************** *** 2480,2486 **** else scalar(other); } ! else if (dowarn && (first->op_flags & OPf_KIDS)) { OP *k1 = ((UNOP*)first)->op_first; OP *k2 = k1->op_sibling; OPCODE warnop = 0; --- 2496,2502 ---- else scalar(other); } ! else if (ckWARN(WARN_UNSAFE) && (first->op_flags & OPf_KIDS)) { OP *k1 = ((UNOP*)first)->op_first; OP *k2 = k1->op_sibling; OPCODE warnop = 0; *************** *** 2501,2507 **** if (warnop) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warn("Value of %s construct can be \"0\"; test with defined()", op_desc[warnop]); curcop->cop_line = oldline; } --- 2517,2524 ---- if (warnop) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warner(WARN_UNSAFE, ! "Value of %s construct can be \"0\"; test with defined()", op_desc[warnop]); curcop->cop_line = oldline; } *************** *** 3083,3093 **** SAVEFREESV(compcv); goto done; } ! if (const_sv || dowarn) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warn(const_sv ? "Constant subroutine %s redefined" ! : "Subroutine %s redefined",name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); --- 3100,3111 ---- SAVEFREESV(compcv); goto done; } ! if (const_sv || ckWARN(WARN_REDEFINE)) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warner(WARN_REDEFINE, ! const_sv ? "Constant subroutine %s redefined" ! : "Subroutine %s redefined",name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); *************** *** 3252,3261 **** } else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { /* already defined (or promised) */ ! if (dowarn) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warn("Subroutine %s redefined",name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); --- 3270,3279 ---- } else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) { /* already defined (or promised) */ ! if (ckWARN(WARN_REDEFINE)) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warner(WARN_REDEFINE, "Subroutine %s redefined",name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); *************** *** 3322,3332 **** gv = gv_fetchpv(name,TRUE, SVt_PVFM); GvMULTI_on(gv); if (cv = GvFORM(gv)) { ! if (dowarn) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warn("Format %s redefined",name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); --- 3340,3350 ---- gv = gv_fetchpv(name,TRUE, SVt_PVFM); GvMULTI_on(gv); if (cv = GvFORM(gv)) { ! if (ckWARN(WARN_REDEFINE)) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warner(WARN_REDEFINE, "Format %s redefined",name); curcop->cop_line = oldline; } SvREFCNT_dec(cv); *************** *** 3811,3818 **** char *name = SvPVx(((SVOP*)kid)->op_sv, na); OP *newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVAV) )); ! if (dowarn) ! warn("Array @%s missing the @ in argument %ld of %s()", name, (long)numargs, op_desc[type]); op_free(kid); kid = newop; --- 3829,3837 ---- char *name = SvPVx(((SVOP*)kid)->op_sv, na); OP *newop = newAVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVAV) )); ! 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; *************** *** 3829,3836 **** char *name = SvPVx(((SVOP*)kid)->op_sv, na); OP *newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVHV) )); ! if (dowarn) ! warn("Hash %%%s missing the %% in argument %ld of %s()", name, (long)numargs, op_desc[type]); op_free(kid); kid = newop; --- 3848,3856 ---- char *name = SvPVx(((SVOP*)kid)->op_sv, na); OP *newop = newHVREF(newGVOP(OP_GV, 0, gv_fetchpv(name, TRUE, SVt_PVHV) )); ! 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; *************** *** 4551,4564 **** case OP_EXEC: o->op_seq = op_seqmax++; ! if (dowarn && o->op_next && o->op_next->op_type == OP_NEXTSTATE) { if (o->op_next->op_sibling && o->op_next->op_sibling->op_type != OP_DIE) { line_t oldline = curcop->cop_line; 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"); curcop->cop_line = oldline; } } --- 4571,4585 ---- case OP_EXEC: o->op_seq = op_seqmax++; ! 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_DIE) { line_t oldline = curcop->cop_line; curcop->cop_line = ((COP*)o->op_next)->cop_line; ! warner(WARN_SYNTAX, "Statement unlikely to be reached"); ! warner(WARN_SYNTAX, ! "(Maybe you meant system() when you said exec()?)\n"); curcop->cop_line = oldline; } } *** op.h.orig Thu Dec 19 10:59:06 1996 --- op.h Thu Feb 27 11:31:34 1997 *************** *** 95,100 **** --- 95,101 ---- #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. */ *** perl.c.orig Fri Feb 21 23:04:49 1997 --- perl.c Thu Feb 27 11:31:35 1997 *************** *** 496,501 **** --- 496,502 ---- main_cv = Nullcv; time(&basetime); + dowarn = FALSE ; switch (Sigsetjmp(top_env,1)) { case 1: *************** *** 545,550 **** --- 546,552 ---- case 'u': case 'U': case 'v': + case 'W': case 'w': if (s = moreswitches(s)) goto reswitch; *************** *** 761,767 **** if (do_undump) my_unexec(); ! if (dowarn) gv_check(defstash); LEAVE; --- 763,769 ---- if (do_undump) my_unexec(); ! if (ckWARN(WARN_ONCE)) gv_check(defstash); LEAVE; *************** *** 1426,1432 **** GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n"); exit(0); case 'w': ! dowarn = TRUE; s++; return s; case '*': --- 1428,1439 ---- GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n"); exit(0); case 'w': ! dowarn |= G_WARN_ON; ! s++; ! return s; ! case 'W': ! dowarn |= G_WARN_FLAG|G_WARN_ON; ! compiling.cop_warnings = WARN_ALL ; s++; return s; case '*': *** perl.h.orig Tue Feb 18 08:43:26 1997 --- perl.h Thu Feb 27 11:34:45 1997 *************** *** 990,995 **** --- 990,996 ---- #include "hv.h" #include "mg.h" #include "scope.h" + #include "warning.h" /* work around some libPW problems */ #ifdef DOINIT *** pp.c.orig Tue Feb 25 08:48:13 1997 --- pp.c Thu Feb 27 11:31:37 1997 *************** *** 1517,1524 **** if (pos < 0) pos += curlen + arybase; if (pos < 0 || pos > curlen) { ! if (dowarn || lvalue) ! warn("substr outside of string"); RETPUSHUNDEF; } else { --- 1517,1524 ---- if (pos < 0) pos += curlen + arybase; if (pos < 0 || pos > curlen) { ! if (lvalue || ckWARN(WARN_SUBSTR)) ! warner(WARN_SUBSTR, "substr outside of string"); RETPUSHUNDEF; } else { *************** *** 1538,1545 **** if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { SvPV_force(sv,na); ! if (dowarn) ! warn("Attempt to use reference as lvalue in substr"); } if (SvOK(sv)) /* is it defined ? */ (void)SvPOK_only(sv); --- 1538,1546 ---- if (!SvGMAGICAL(sv)) { if (SvROK(sv)) { SvPV_force(sv,na); ! 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); *** pp_ctl.c.orig Fri Feb 21 23:04:54 1997 --- pp_ctl.c Thu Feb 27 11:41:18 1997 *************** *** 249,256 **** sv = *++MARK; else { sv = &sv_no; ! if (dowarn) ! warn("Not enough format arguments"); } break; --- 249,256 ---- sv = *++MARK; else { sv = &sv_no; ! if (ckWARN(WARN_SYNTAX)) ! warner(WARN_SYNTAX, "Not enough format arguments"); } break; *************** *** 774,793 **** cx = &cxstack[i]; switch (cx->cx_type) { case CXt_SUBST: ! if (dowarn) ! warn("Exiting substitution via %s", op_name[op->op_type]); break; case CXt_SUB: ! if (dowarn) ! warn("Exiting subroutine via %s", op_name[op->op_type]); break; case CXt_EVAL: ! if (dowarn) ! warn("Exiting eval via %s", op_name[op->op_type]); break; case CXt_NULL: ! if (dowarn) ! warn("Exiting pseudo-block via %s", op_name[op->op_type]); return -1; case CXt_LOOP: if (!cx->blk_loop.label || --- 774,797 ---- cx = &cxstack[i]; switch (cx->cx_type) { case CXt_SUBST: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting substitution via %s", ! op_name[op->op_type]); break; case CXt_SUB: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting subroutine via %s", ! op_name[op->op_type]); break; case CXt_EVAL: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting eval via %s", ! op_name[op->op_type]); break; case CXt_NULL: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting pseudo-block via %s", ! op_name[op->op_type]); return -1; case CXt_LOOP: if (!cx->blk_loop.label || *************** *** 867,886 **** cx = &cxstack[i]; switch (cx->cx_type) { case CXt_SUBST: ! if (dowarn) ! warn("Exiting substitution via %s", op_name[op->op_type]); break; case CXt_SUB: ! if (dowarn) ! warn("Exiting subroutine via %s", op_name[op->op_type]); break; case CXt_EVAL: ! if (dowarn) ! warn("Exiting eval via %s", op_name[op->op_type]); break; case CXt_NULL: ! if (dowarn) ! warn("Exiting pseudo-block via %s", op_name[op->op_type]); return -1; case CXt_LOOP: DEBUG_l( deb("(Found loop #%d)\n", i)); --- 871,894 ---- cx = &cxstack[i]; switch (cx->cx_type) { case CXt_SUBST: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting substitution via %s", ! op_name[op->op_type]); break; case CXt_SUB: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting subroutine via %s", ! op_name[op->op_type]); break; case CXt_EVAL: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting eval via %s", ! op_name[op->op_type]); break; case CXt_NULL: ! if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Exiting pseudo-block via %s", ! op_name[op->op_type]); return -1; case CXt_LOOP: DEBUG_l( deb("(Found loop #%d)\n", i)); *************** *** 1658,1664 **** if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ ! if (CvDEPTH(cv) == 100 && dowarn) sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { AV *newpad = newAV(); --- 1666,1672 ---- if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ ! if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)) sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { AV *newpad = newAV(); *************** *** 2167,2172 **** --- 2175,2182 ---- SAVEFREEPV(name); SAVEI32(hints); hints = 0; + SAVEPPTR(compiling.cop_warnings); + compiling.cop_warnings = ((dowarn & G_WARN_FLAG) ? WARN_ALL : WARN_NONE) ; /* switch to eval mode */ *************** *** 2218,2223 **** --- 2228,2238 ---- SAVEDELETE(defstash, safestr, strlen(safestr)); SAVEI32(hints); hints = op->op_targ; + SAVEPPTR(compiling.cop_warnings); + if (compiling.cop_warnings != WARN_ALL && compiling.cop_warnings != WARN_NONE){ + compiling.cop_warnings = newSVsv(compiling.cop_warnings) ; + SAVEFREESV(compiling.cop_warnings) ; + } push_return(op->op_next); PUSHBLOCK(cx, CXt_EVAL, SP); *** pp_hot.c.orig Fri Feb 21 23:04:55 1997 --- pp_hot.c Thu Feb 27 11:31:39 1997 *************** *** 344,366 **** RETURN; } if (!(io = GvIO(gv))) { ! if (dowarn) { SV* sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); ! warn("Filehandle %s never opened", SvPV(sv,na)); } SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { ! if (dowarn) { SV* sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); if (IoIFP(io)) ! warn("Filehandle %s opened only for input", SvPV(sv,na)); ! else ! warn("print on closed filehandle %s", SvPV(sv,na)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; --- 344,368 ---- RETURN; } if (!(io = GvIO(gv))) { ! if (ckWARN(WARN_UNOPENED)) { SV* sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); ! warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,na)); } SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { ! if (ckWARN2(WARN_CLOSED, WARN_IO)) { SV* sv = sv_newmortal(); gv_fullname3(sv, gv, Nullch); if (IoIFP(io)) ! warner(WARN_IO, "Filehandle %s opened only for input", ! SvPV(sv,na)); ! else if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "print on closed filehandle %s", ! SvPV(sv,na)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; *************** *** 1123,1130 **** SP--; } if (!fp) { ! if (dowarn && io && !(IoFLAGS(io) & IOf_START)) ! warn("Read on closed filehandle <%s>", GvENAME(last_in_gv)); if (GIMME == G_SCALAR) { (void)SvOK_off(TARG); PUSHTARG; --- 1125,1133 ---- SP--; } if (!fp) { ! if (io && ckWARN(WARN_CLOSED) && !(IoFLAGS(io) & IOf_START)) ! warner(WARN_CLOSED, "Read on closed filehandle <%s>", ! GvENAME(last_in_gv)); if (GIMME == G_SCALAR) { (void)SvOK_off(TARG); PUSHTARG; *************** *** 1868,1874 **** if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ ! if (CvDEPTH(cv) == 100 && dowarn && !(perldb && cv == GvCV(DBsub))) sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { --- 1871,1877 ---- if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ ! if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION) && !(perldb && cv == GvCV(DBsub))) sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { *************** *** 1955,1965 **** CV* cv; { if (CvANON(cv)) ! warn("Deep recursion on anonymous subroutine"); else { SV* tmpstr = sv_newmortal(); gv_efullname3(tmpstr, CvGV(cv), Nullch); ! warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr)); } } --- 1958,1969 ---- CV* cv; { if (CvANON(cv)) ! warner(WARN_RECURSION, "Deep recursion on anonymous subroutine"); else { SV* tmpstr = sv_newmortal(); gv_efullname3(tmpstr, CvGV(cv), Nullch); ! warner(WARN_RECURSION, "Deep recursion on subroutine \"%s\"", ! SvPVX(tmpstr)); } } *** pp_sys.c.orig Fri Feb 21 23:04:55 1997 --- pp_sys.c Thu Feb 27 11:31:40 1997 *************** *** 517,523 **** sv = POPs; ! if (dowarn) { MAGIC * mg ; if (SvMAGICAL(sv)) { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) --- 517,523 ---- sv = POPs; ! if (ckWARN(WARN_UNTIE)) { MAGIC * mg ; if (SvMAGICAL(sv)) { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) *************** *** 526,533 **** 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 ) ; } } --- 526,534 ---- mg = mg_find(sv, 'q') ; if (mg && 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 ) ; } } *************** *** 993,1010 **** fp = IoOFP(io); if (!fp) { ! if (dowarn) { if (IoIFP(io)) ! warn("Filehandle only opened for input"); ! else ! warn("Write on closed filehandle"); } PUSHs(&sv_no); } else { if ((IoLINES_LEFT(io) -= FmLINES(formtarget)) < 0) { ! if (dowarn) ! warn("page overflow"); } if (!PerlIO_write(ofp, SvPVX(formtarget), SvCUR(formtarget)) || PerlIO_error(fp)) --- 994,1011 ---- fp = IoOFP(io); if (!fp) { ! if (ckWARN2(WARN_CLOSED,WARN_IO)) { if (IoIFP(io)) ! warner(WARN_IO, "Filehandle only opened for input"); ! else if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "Write on closed filehandle"); } PUSHs(&sv_no); } else { if ((IoLINES_LEFT(io) -= FmLINES(formtarget)) < 0) { ! if (ckWARN(WARN_IO)) ! warner(WARN_IO, "page overflow"); } if (!PerlIO_write(ofp, SvPVX(formtarget), SvCUR(formtarget)) || PerlIO_error(fp)) *************** *** 1036,1055 **** else gv = defoutgv; if (!(io = GvIO(gv))) { ! if (dowarn) { gv_fullname3(sv, gv, Nullch); ! warn("Filehandle %s never opened", SvPV(sv,na)); } SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { ! if (dowarn) { gv_fullname3(sv, gv, Nullch); if (IoIFP(io)) ! warn("Filehandle %s opened only for input", SvPV(sv,na)); ! else ! warn("printf on closed filehandle %s", SvPV(sv,na)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; --- 1037,1058 ---- else gv = defoutgv; if (!(io = GvIO(gv))) { ! if (ckWARN(WARN_UNOPENED)) { gv_fullname3(sv, gv, Nullch); ! warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,na)); } SETERRNO(EBADF,RMS$_IFI); goto just_say_no; } else if (!(fp = IoOFP(io))) { ! if (ckWARN2(WARN_CLOSED,WARN_IO)) { gv_fullname3(sv, gv, Nullch); if (IoIFP(io)) ! warner(WARN_IO, "Filehandle %s opened only for input", ! SvPV(sv,na)); ! else if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "printf on closed filehandle %s", ! SvPV(sv,na)); } SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI); goto just_say_no; *************** *** 1233,1243 **** io = GvIO(gv); if (!io || !IoIFP(io)) { length = -1; ! if (dowarn) { if (op->op_type == OP_SYSWRITE) ! warn("Syswrite on closed filehandle"); else ! warn("Send on closed socket"); } } else if (op->op_type == OP_SYSWRITE) { --- 1236,1246 ---- io = GvIO(gv); if (!io || !IoIFP(io)) { length = -1; ! if (ckWARN(WARN_CLOSED)) { if (op->op_type == OP_SYSWRITE) ! warner(WARN_CLOSED, "Syswrite on closed filehandle"); else ! warner(WARN_CLOSED, "Send on closed socket"); } } else if (op->op_type == OP_SYSWRITE) { *************** *** 1605,1612 **** RETPUSHUNDEF; nuts: ! if (dowarn) ! warn("bind() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1608,1615 ---- RETPUSHUNDEF; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "bind() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1635,1642 **** RETPUSHUNDEF; nuts: ! if (dowarn) ! warn("connect() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1638,1645 ---- RETPUSHUNDEF; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "connect() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1661,1668 **** RETPUSHUNDEF; nuts: ! if (dowarn) ! warn("listen() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1664,1671 ---- RETPUSHUNDEF; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "listen() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1715,1722 **** RETURN; nuts: ! if (dowarn) ! warn("accept() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); badexit: --- 1718,1725 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "accept() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); badexit: *************** *** 1742,1749 **** RETURN; nuts: ! if (dowarn) ! warn("shutdown() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1745,1752 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "shutdown() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1818,1825 **** RETURN; nuts: ! if (dowarn) ! warn("[gs]etsockopt() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; --- 1821,1828 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "[gs]etsockopt() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; *************** *** 1880,1887 **** RETURN; nuts: ! if (dowarn) ! warn("get{sock, peer}name() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; --- 1883,1890 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "get{sock, peer}name() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; *************** *** 1937,1944 **** #endif laststatval = Stat(SvPV(statname, na), &statcache); if (laststatval < 0) { ! if (dowarn && strchr(SvPV(statname, na), '\n')) ! warn(warn_nl, "stat"); max = 0; } } --- 1940,1947 ---- #endif laststatval = Stat(SvPV(statname, na), &statcache); if (laststatval < 0) { ! if (ckWARN(WARN_NEWLINE) && strchr(SvPV(statname, na), '\n')) ! warner(WARN_NEWLINE, warn_nl, "stat"); max = 0; } } *************** *** 2340,2347 **** len = 512; } else { ! if (dowarn) ! warn("Test on unopened file <%s>", GvENAME(cGVOP->op_gv)); SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; --- 2343,2350 ---- len = 512; } else { ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "Test on unopened file <%s>", GvENAME(cGVOP->op_gv)); SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; *************** *** 2359,2366 **** i = open(SvPV(sv, na), 0); #endif if (i < 0) { ! if (dowarn && strchr(SvPV(sv, na), '\n')) ! warn(warn_nl, "open"); RETPUSHUNDEF; } laststatval = Fstat(i, &statcache); --- 2362,2369 ---- i = open(SvPV(sv, na), 0); #endif if (i < 0) { ! if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, na), '\n')) ! warner(WARN_NEWLINE, warn_nl, "open"); RETPUSHUNDEF; } laststatval = Fstat(i, &statcache); *** proto.h.orig Tue Feb 4 08:55:19 1997 --- proto.h Thu Feb 27 11:31:40 1997 *************** *** 501,506 **** --- 501,507 ---- void vivify_itervar _((SV* sv)); I32 wait4pid _((int pid, int* statusp, int flags)); void warn _((const char* pat,...)) __attribute__((format(printf,1,2))); + void warner _((U32 err, const char* pat,...)) __attribute__((format(printf,1,2))); void watch _((char **addr)); I32 whichsig _((char* sig)); int yyerror _((char* s)); *** regcomp.c.orig Tue Feb 18 08:43:33 1997 --- regcomp.c Thu Feb 27 11:31:41 1997 *************** *** 719,726 **** goto do_curly; } nest_check: ! if (dowarn && regcode != ®dummy && !(flags&HASWIDTH) && max > 10000) { ! warn("%.*s matches null string many times", regparse - origparse, origparse); } --- 719,726 ---- goto do_curly; } nest_check: ! if (ckWARN(WARN_UNSAFE) && regcode != ®dummy && !(flags&HASWIDTH) && max > 10000) { ! warner(WARN_UNSAFE, "%.*s matches null string many times", regparse - origparse, origparse); } *** sv.c.orig Tue Feb 18 08:43:33 1997 --- sv.c Thu Feb 27 11:31:42 1997 *************** *** 1237,1246 **** *d = '\0'; if (op) ! warn("Argument \"%s\" isn't numeric in %s", tmpbuf, op_name[op->op_type]); else ! warn("Argument \"%s\" isn't numeric", tmpbuf); } IV --- 1237,1246 ---- *d = '\0'; if (op) ! warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf, op_name[op->op_type]); else ! warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf); } IV *************** *** 1282,1289 **** } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); ! if (dowarn) ! warn(warn_uninit); return 0; } } --- 1282,1289 ---- } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } } *************** *** 1310,1317 **** SvIVX(sv) = asIV(sv); } else { ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", --- 1310,1317 ---- SvIVX(sv) = asIV(sv); } else { ! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", *************** *** 1351,1358 **** } if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); ! if (dowarn) ! warn(warn_uninit); return 0; } } --- 1351,1358 ---- } if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } } *************** *** 1376,1383 **** SvUVX(sv) = asUV(sv); } else { ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n", --- 1376,1383 ---- SvUVX(sv) = asUV(sv); } else { ! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n", *************** *** 1396,1402 **** if (SvNOKp(sv)) return SvNVX(sv); if (SvPOKp(sv) && SvLEN(sv)) { ! if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); return atof(SvPVX(sv)); --- 1396,1402 ---- if (SvNOKp(sv)) return SvNVX(sv); if (SvPOKp(sv) && SvLEN(sv)) { ! if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); return atof(SvPVX(sv)); *************** *** 1418,1432 **** } if (SvREADONLY(sv)) { if (SvPOKp(sv) && SvLEN(sv)) { ! if (dowarn && !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 (dowarn) ! warn(warn_uninit); return 0.0; } } --- 1418,1432 ---- } if (SvREADONLY(sv)) { if (SvPOKp(sv) && SvLEN(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 (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0.0; } } *************** *** 1447,1460 **** SvNVX(sv) = (double)SvIVX(sv); } else if (SvPOKp(sv) && SvLEN(sv)) { ! if (dowarn && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); SvNVX(sv) = atof(SvPVX(sv)); } else { ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); return 0.0; } SvNOK_on(sv); --- 1447,1460 ---- SvNVX(sv) = (double)SvIVX(sv); } else if (SvPOKp(sv) && SvLEN(sv)) { ! if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) not_a_number(sv); SET_NUMERIC_STANDARD(); SvNVX(sv) = atof(SvPVX(sv)); } else { ! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0.0; } SvNOK_on(sv); *************** *** 1473,1479 **** if (numtype == 1) return atol(SvPVX(sv)); ! if (!numtype && dowarn) not_a_number(sv); SET_NUMERIC_STANDARD(); d = atof(SvPVX(sv)); --- 1473,1479 ---- if (numtype == 1) return atol(SvPVX(sv)); ! if (!numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); SET_NUMERIC_STANDARD(); d = atof(SvPVX(sv)); *************** *** 1491,1497 **** if (numtype == 1) return atol(SvPVX(sv)); ! if (!numtype && dowarn) not_a_number(sv); SET_NUMERIC_STANDARD(); return U_V(atof(SvPVX(sv))); --- 1491,1497 ---- if (numtype == 1) return atol(SvPVX(sv)); ! if (!numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); SET_NUMERIC_STANDARD(); return U_V(atof(SvPVX(sv))); *************** *** 1659,1666 **** (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv)); goto tokensave; } ! if (dowarn) ! warn(warn_uninit); *lp = 0; return ""; } --- 1659,1666 ---- (void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv)); goto tokensave; } ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); *lp = 0; return ""; } *************** *** 1704,1711 **** while (*s) s++; } else { ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); *lp = 0; return ""; } --- 1704,1711 ---- while (*s) s++; } else { ! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); *lp = 0; return ""; } *************** *** 1973,1982 **** CV* cv = GvCV(dstr); if (cv) { dref = (SV*)cv; ! if (dowarn && sref != dref && !GvCVGEN((GV*)dstr) && (CvROOT(cv) || CvXSUB(cv)) ) ! warn("Subroutine %s redefined", GvENAME((GV*)dstr)); } } --- 1973,1983 ---- CV* cv = GvCV(dstr); if (cv) { dref = (SV*)cv; ! if (ckWARN(WARN_REDEFINE) && sref != dref && !GvCVGEN((GV*)dstr) && (CvROOT(cv) || CvXSUB(cv)) ) ! warner(WARN_REDEFINE, ! "Subroutine %s redefined", GvENAME((GV*)dstr)); } } *** t/op/tie.t.orig Tue Nov 19 14:45:04 1996 --- t/op/tie.t Thu Feb 27 11:31:43 1997 *************** *** 77,84 **** ######## # strict behaviour, without any extra references ! #use warning 'untie'; ! local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; --- 77,84 ---- ######## # strict behaviour, without any extra references ! use warning 'untie'; ! #local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; untie %h; *************** *** 86,93 **** ######## # strict behaviour, with 1 extra references generating an error ! #use warning 'untie'; ! local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; untie %h; --- 86,93 ---- ######## # strict behaviour, with 1 extra references generating an error ! use warning 'untie'; ! #local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; untie %h; *************** *** 96,103 **** ######## # strict behaviour, with 1 extra references via tied generating an error ! #use warning 'untie'; ! local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; --- 96,103 ---- ######## # strict behaviour, with 1 extra references via tied generating an error ! use warning 'untie'; ! #local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; *************** *** 107,114 **** ######## # strict behaviour, with 1 extra references which are destroyed ! #use warning 'untie'; ! local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $a = 0 ; --- 107,114 ---- ######## # strict behaviour, with 1 extra references which are destroyed ! use warning 'untie'; ! #local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $a = 0 ; *************** *** 117,124 **** ######## # strict behaviour, with extra 1 references via tied which are destroyed ! #use warning 'untie'; ! local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; --- 117,124 ---- ######## # strict behaviour, with extra 1 references via tied which are destroyed ! use warning 'untie'; ! #local $^W = 1 ; use Tie::Hash ; tie %h, Tie::StdHash; $a = tied %h; *************** *** 128,135 **** ######## # strict error behaviour, with 2 extra references ! #use warning 'untie'; ! local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $b = tied %h ; --- 128,135 ---- ######## # strict error behaviour, with 2 extra references ! use warning 'untie'; ! #local $^W = 1 ; use Tie::Hash ; $a = tie %h, Tie::StdHash; $b = tied %h ; *************** *** 139,152 **** ######## # strict behaviour, check scope of strictness. ! #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 Tie::Hash ; tie %h, Tie::StdHash; untie %h; --- 139,152 ---- ######## # strict behaviour, check scope of strictness. ! 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 Tie::Hash ; tie %h, Tie::StdHash; untie %h; *** t/pragma/warn-1global.orig Sat Jan 4 09:46:21 1997 --- t/pragma/warn-1global Thu Feb 27 11:31:44 1997 *************** *** 110,131 **** ######## $^W = 1; ! eval "my $b ; chop $b ;" ; EXPECT ! Use of uninitialized value at - line 3. ! Use of uninitialized value at - line 3. ######## ! eval "$^W = 1;" ; my $b ; chop $b ; EXPECT ! ######## eval {$^W = 1;} ; my $b ; chop $b ; EXPECT ! Use of uninitialized value at - line 3. ######## { --- 110,133 ---- ######## $^W = 1; ! eval 'my $b ; chop $b ;' ; ! print $@ ; EXPECT ! Use of uninitialized value at (eval 1) line 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 4. ######## { *************** *** 144,146 **** --- 146,180 ---- my $c ; chop $c ; EXPECT Use of uninitialized value at - line 5. + ######## + + $^W = 1 + 2 ; + EXPECT + + ######## + + $^W = $a ; + EXPECT + + ######## + + sub fred {} + $^W = fred() ; + EXPECT + + ######## + + sub fred { my $b ; chop $b ;} + { local $^W = 0 ; + fred() ; + } + EXPECT + + ######## + + sub fred { my $b ; chop $b ;} + { local $^W = 1 ; + fred() ; + } + EXPECT + Use of uninitialized value at - line 2. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-2use Thu Feb 27 11:31:44 1997 *************** *** 0 **** --- 1,291 ---- + Check lexical warning functionality + + TODO + check that the hierarchy works. + + __END__ + + # check illegal category is caught + use warning 'blah' ; + EXPECT + unknown warning category 'blah' at - line 3 + BEGIN failed--compilation aborted at - line 3. + ######## + + # Check compile time scope of pragma + use warning 'deprecated' ; + { + no warning ; + 1 if $a EQ $b ; + } + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 8. + ######## + + # Check compile time scope of pragma + no warning; + { + use warning 'deprecated' ; + 1 if $a EQ $b ; + } + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 6. + ######## + + # Check runtime scope of pragma + use warning 'uninitialized' ; + { + no warning ; + my $b ; chop $b ; + } + my $b ; chop $b ; + EXPECT + Use of uninitialized value at - line 8. + ######## + + # Check runtime scope of pragma + no warning ; + { + use warning 'uninitialized' ; + my $b ; chop $b ; + } + my $b ; chop $b ; + EXPECT + Use of uninitialized value at - line 6. + ######## + + # Check runtime scope of pragma + no warning ; + { + use warning 'uninitialized' ; + $a = sub { my $b ; chop $b ; } + } + &$a ; + EXPECT + Use of uninitialized value at - line 6. + ######## + + use warning 'deprecated' ; + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 3. + ######## + + --FILE-- abc + 1 if $a EQ $b ; + 1; + --FILE-- + use warning 'deprecated' ; + require "./abc"; + EXPECT + + ######## + + --FILE-- abc + use warning 'deprecated' ; + 1; + --FILE-- + require "./abc"; + 1 if $a EQ $b ; + EXPECT + + ######## + + --FILE-- abc + use warning 'deprecated' ; + 1 if $a EQ $b ; + 1; + --FILE-- + use warning 'uninitialized' ; + require "./abc"; + my $a ; chop $a ; + EXPECT + Use of EQ is deprecated at ./abc line 2. + Use of uninitialized value at - line 3. + ######## + + --FILE-- abc.pm + use warning 'deprecated' ; + 1 if $a EQ $b ; + 1; + --FILE-- + use warning 'uninitialized' ; + use abc; + my $a ; chop $a ; + EXPECT + Use of EQ is deprecated at abc.pm line 2. + Use of uninitialized value at - line 3. + ######## + + # Check scope of pragma with eval + no warning ; + eval { + my $b ; chop $b ; + }; print STDERR $@ ; + my $b ; chop $b ; + EXPECT + + ######## + + # Check scope of pragma with eval + no warning ; + eval { + use warning 'uninitialized' ; + my $b ; chop $b ; + }; print STDERR $@ ; + my $b ; chop $b ; + EXPECT + Use of uninitialized value at - line 6. + ######## + + # Check scope of pragma with eval + use warning 'uninitialized' ; + eval { + my $b ; chop $b ; + }; print STDERR $@ ; + my $b ; chop $b ; + EXPECT + Use of uninitialized value at - line 5. + Use of uninitialized value at - line 7. + ######## + + # Check scope of pragma with eval + use warning 'uninitialized' ; + eval { + no warning ; + my $b ; chop $b ; + }; print STDERR $@ ; + my $b ; chop $b ; + EXPECT + Use of uninitialized value at - line 8. + ######## + + # Check scope of pragma with eval + no warning ; + eval { + 1 if $a EQ $b ; + }; print STDERR $@ ; + 1 if $a EQ $b ; + EXPECT + + ######## + + # Check scope of pragma with eval + no warning ; + eval { + use warning 'deprecated' ; + 1 if $a EQ $b ; + }; print STDERR $@ ; + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 6. + ######## + + # Check scope of pragma with eval + use warning 'deprecated' ; + eval { + 1 if $a EQ $b ; + }; print STDERR $@ ; + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 5. + Use of EQ is deprecated at - line 7. + ######## + + # Check scope of pragma with eval + use warning 'deprecated' ; + eval { + no warning ; + 1 if $a EQ $b ; + }; print STDERR $@ ; + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 8. + ######## + + # Check scope of pragma with eval + no warning ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; + EXPECT + + ######## + + # Check scope of pragma with eval + no warning ; + eval q[ + use warning 'uninitialized' ; + my $b ; chop $b ; + ]; print STDERR $@; + my $b ; chop $b ; + EXPECT + Use of uninitialized value at (eval 1) line 3. + ######## + + # Check scope of pragma with eval + use warning 'uninitialized' ; + eval ' + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; + EXPECT + Use of uninitialized value at (eval 1) line 2. + Use of uninitialized value at - line 7. + ######## + + # Check scope of pragma with eval + use warning 'uninitialized' ; + eval ' + no warning ; + my $b ; chop $b ; + '; print STDERR $@ ; + my $b ; chop $b ; + EXPECT + Use of uninitialized value at - line 8. + ######## + + # Check scope of pragma with eval + no warning ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@ ; + 1 if $a EQ $b ; + EXPECT + + ######## + + # Check scope of pragma with eval + no warning ; + eval q[ + use warning 'deprecated' ; + 1 if $a EQ $b ; + ]; print STDERR $@; + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at (eval 1) line 3. + ######## + + # Check scope of pragma with eval + use warning 'deprecated' ; + eval ' + 1 if $a EQ $b ; + '; print STDERR $@; + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 7. + Use of EQ is deprecated at (eval 1) line 2. + ######## + + # Check scope of pragma with eval + use warning 'deprecated' ; + eval ' + no warning ; + 1 if $a EQ $b ; + '; print STDERR $@; + 1 if $a EQ $b ; + EXPECT + Use of EQ is deprecated at - line 8. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-3both Thu Feb 27 11:31:44 1997 *************** *** 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. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-4lint Thu Feb 27 11:31:45 1997 *************** *** 0 **** --- 1,41 ---- + Check lint + + TODO + check that -W will override both $^W and no warning. + check that any required/used files also have warnings enabled. + + __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 combination of -w and -W + { + $^W = 0 ; + close STDIN ; print STDIN "abc" ; + } + EXPECT + print on closed filehandle main::STDIN at - line 5. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-doio Thu Feb 27 11:31:45 1997 *************** *** 0 **** --- 1,89 ---- + 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) + + 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 6. + ######## + # doio.c + use warning 'uninitialized' ; + print $a ; + EXPECT + Use of uninitialized value at - line 3. + ######## + # doio.c + use warning 'io' ; + + EXPECT + + ######## + # doio.c + use warning 'io' ; + stat "ab\ncd"; + lstat "ab\ncd"; + EXPECT + Unsuccessful stat on filename containing newline at - line 3. + Unsuccessful stat on filename containing newline at - line 4. + ######## + # doio.c + use warning 'io' ; + exec "lskdjfalksdjfdjfkls" ; + EXPECT + Can't exec "lskdjfalksdjfdjfkls": No such file or directory at - line 3. + ######## + # doio.c + use warning 'io' ; + exec "lskdjfalksdjfdjfkls", "abc" ; + EXPECT + Can't exec "lskdjfalksdjfdjfkls": No such file or directory at - line 3. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-gv Thu Feb 27 11:31:45 1997 *************** *** 0 **** --- 1,28 ---- + gv.c AOK + + Can't locate package %s for @%s::ISA + @ISA = qw(Fred); joe() + + + 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 + use warning 'deprecated' ; + $a = ${"#"}; + $a = ${"*"}; + EXPECT + Use of $# is deprecated at - line 3. + Use of $* is deprecated at - line 4. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-mg Thu Feb 27 11:31:46 1997 *************** *** 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. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-op Thu Feb 27 11:31:46 1997 *************** *** 0 **** --- 1,481 ---- + op.c + + 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" + + + 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' ; + 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, "" ; # 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. + ######## + --FILE-- abc + + --FILE-- + # op.c + use warning 'unsafe' ; + open FH, " ; + 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 construct 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' ; + $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 construct can be "0"; test with defined() at - line 4. + ######## + # op.c + use warning 'redefine' ; + sub fred {} + sub fred {} + EXPECT + Subroutine fred redefined at - line 4. + ######## + # op.c + use warning 'redefine' ; + sub fred () { 1 } + sub fred () { 1 } + EXPECT + Constant subroutine fred redefined at - line 4. + ######## + # op.c + use warning 'redefine' ; + format FRED = + . + format FRED = + . + EXPECT + Format FRED redefined at - line 5. + ######## + # op.c + use warning 'syntax' ; + push FRED; + EXPECT + Array @FRED missing the @ in argument 1 of push() at - line 3. + ######## + # op.c + use warning 'syntax' ; + @a = keys FRED ; + EXPECT + Hash %FRED missing the % in argument 1 of keys() at - line 3. + ######## + # op.c + use warning 'syntax' ; + exec "true" ; + my $a + EXPECT + Statement unlikely to be reached at - line 4. + (Maybe you meant system() when you said exec()?) *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-perl Thu Feb 27 11:31:47 1997 *************** *** 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. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-perly Thu Feb 27 11:31:47 1997 *************** *** 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. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-pp Thu Feb 27 11:31:47 1997 *************** *** 0 **** --- 1,24 ---- + pp.c AOK + + 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 + + + __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. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-pp_ctl Thu Feb 27 11:31:48 1997 *************** *** 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. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-pp_hot Thu Feb 27 11:31:48 1997 *************** *** 0 **** --- 1,69 ---- + 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" ; + + 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 '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. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-pp_sys Thu Feb 27 11:31:49 1997 *************** *** 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. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-regcomp Thu Feb 27 11:31:49 1997 *************** *** 0 **** --- 1,13 ---- + regcomp.c AOK + + %.*s matches null string many times + + $a = "ABC123" ; $a =~ /(C*)*/' + + __END__ + # regcomp.c + use warning 'unsafe' ; + my $a = "ABC123" ; + $a =~ /(C*)*/ ; + EXPECT + (C*)* matches null string many times at - line 4. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-sv Thu Feb 27 11:31:49 1997 *************** *** 0 **** --- 1,125 ---- + 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 + + + __END__ + # sv.c + use integer ; + use warning 'uninitialized' ; + $x = 1 + $a[0] ; # a + EXPECT + Use of uninitialized value at - line 4. + ######## + # sv.c + use integer ; + use warning 'uninitialized' ; + my $x *= 2 ; #b + EXPECT + Use of uninitialized value at - line 4. + ######## + # 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 + 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 + 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. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-taint Thu Feb 27 11:31:50 1997 *************** *** 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 + *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-toke Thu Feb 27 11:31:50 1997 *************** *** 0 **** --- 1,308 ---- + toke.c AOK + + 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/; + + Ambiguous use of -%c => resolved to \"-%c\" =>" + -a => 2; + + Ambiguous use of {%s} resolved to {\"%s\"} + $a = $a{time} ; + sub fred {} $a = $a{fred} ; + + 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; + + Ambiguous use of %s => resolved to \"%s\" => + $a = { print => 1}; + sub fred{} $a = { fred => 1}; + + + 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; + + + + __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 'ambiguous' ; + $a = $a{time} ; + sub fred {} $a = $a{fred} ; + EXPECT + Ambiguous use of {time} resolved to {"time"} at - line 3. + Ambiguous use of {fred} resolved to {"fred"} at - line 4. + ######## + # toke.c + use warning 'ambiguous' ; + -a => 2; + EXPECT + Ambiguous use of -a => resolved to "-a" => 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 'ambiguous' ; + sub fred {} + $a = { fred => 1}; + EXPECT + Ambiguous use of fred => resolved to "fred" => at - line 4. + ######## + # toke.c + use warning 'ambiguous' ; + $a = { print => 1}; + EXPECT + Ambiguous use of print => resolved to "print" => 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. *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-universal Thu Feb 27 11:31:51 1997 *************** *** 0 **** --- 1,11 ---- + universal.c + + Can't locate package %s for @%s::ISA + + + __END__ + # universal.c + use warning 'misc' ; + + EXPECT + *** /dev/null Thu Feb 27 12:04:47 1997 --- t/pragma/warn-util Thu Feb 27 11:31:51 1997 *************** *** 0 **** --- 1,12 ---- + util.c AOK + + Illegal octal digit ignored + my $a = oct "029" ; + + + __END__ + # util.c + use warning 'octal' ; + my $a = oct "029" ; + EXPECT + Illegal octal digit ignored at - line 3. *** t/pragma/warning.t.orig Thu Jan 16 08:54:13 1997 --- t/pragma/warning.t Thu Feb 27 11:31:51 1997 *************** *** 15,22 **** END { if ($tmpfile) { 1 while unlink $tmpfile} } my @prgs = () ; ! foreach (sort glob("pragma/warn-*")) { open F, "<$_" or die "Cannot open $_: $!\n" ; while () { --- 15,30 ---- END { if ($tmpfile) { 1 while unlink $tmpfile} } my @prgs = () ; + my @w_files = () ; ! 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$/ ; open F, "<$_" or die "Cannot open $_: $!\n" ; while () { *** taint.c.orig Mon Dec 23 20:16:40 1996 --- taint.c Thu Feb 27 11:31:52 1997 *************** *** 25,32 **** ug = " while running with -T switch"; if (!unsafe) croak(f, s, ug); ! else if (dowarn) ! warn(f, s, ug); } } --- 25,32 ---- ug = " while running with -T switch"; if (!unsafe) croak(f, s, ug); ! else if (ckWARN(WARN_TAINT)) ! warner(WARN_TAINT, f, s, ug); } } *** toke.c.orig Tue Feb 18 08:43:34 1997 --- toke.c Thu Feb 27 11:31:53 1997 *************** *** 209,216 **** deprecate(s) char *s; { ! if (dowarn) ! warn("Use of %s is deprecated", s); } static void --- 209,216 ---- deprecate(s) char *s; { ! if (ckWARN(WARN_DEPRECATED)) ! warner(WARN_DEPRECATED, "Use of %s is deprecated", s); } static void *************** *** 800,807 **** if (lex_inwhat == OP_SUBST && !lex_inpat && isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) { ! if (dowarn) ! warn("\\%c better written as $%c", *s, *s); *--s = '$'; break; } --- 800,807 ---- if (lex_inwhat == OP_SUBST && !lex_inpat && isDIGIT(*s) && *s != '0' && !isDIGIT(s[1])) { ! if (ckWARN(WARN_SYNTAX)) ! warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s); *--s = '$'; break; } *************** *** 1731,1738 **** s++; if (strnEQ(s,"=>",2)) { ! if (dowarn) ! warn("Ambiguous use of -%c => resolved to \"-%c\" =>", (int)tmp, (int)tmp); s = force_word(bufptr,WORD,FALSE,FALSE,FALSE); OPERATOR('-'); /* unary minus */ --- 1731,1739 ---- s++; if (strnEQ(s,"=>",2)) { ! if (ckWARN(WARN_AMBIGUOUS)) ! warner(WARN_AMBIGUOUS, ! "Ambiguous use of -%c => resolved to \"-%c\" =>", (int)tmp, (int)tmp); s = force_word(bufptr,WORD,FALSE,FALSE,FALSE); OPERATOR('-'); /* unary minus */ *************** *** 1935,1945 **** d++; if (*d == '}') { char minus = (tokenbuf[0] == '-'); ! if (dowarn && (keyword(tokenbuf + 1, len) || (minus && len == 1 && isALPHA(tokenbuf[1])) || perl_get_cv(tokenbuf + 1, FALSE) )) ! warn("Ambiguous use of {%s} resolved to {\"%s\"}", tokenbuf + !minus, tokenbuf + !minus); s = force_word(s + minus, WORD, FALSE, TRUE, FALSE); if (minus) --- 1936,1947 ---- d++; if (*d == '}') { char minus = (tokenbuf[0] == '-'); ! if (ckWARN(WARN_AMBIGUOUS) && (keyword(tokenbuf + 1, len) || (minus && len == 1 && isALPHA(tokenbuf[1])) || perl_get_cv(tokenbuf + 1, FALSE) )) ! warner(WARN_AMBIGUOUS, ! "Ambiguous use of {%s} resolved to {\"%s\"}", tokenbuf + !minus, tokenbuf + !minus); s = force_word(s + minus, WORD, FALSE, TRUE, FALSE); if (minus) *************** *** 2027,2035 **** AOPERATOR(ANDAND); s--; if (expect == XOPERATOR) { ! if (dowarn && isALPHA(*s) && bufptr == linestart) { curcop->cop_line--; ! warn(warn_nosemi); curcop->cop_line++; } BAop(OP_BIT_AND); --- 2029,2037 ---- AOPERATOR(ANDAND); s--; if (expect == XOPERATOR) { ! if (ckWARN(WARN_SEMICOLON) && isALPHA(*s) && bufptr == linestart) { curcop->cop_line--; ! warner(WARN_SEMICOLON, warn_nosemi); curcop->cop_line++; } BAop(OP_BIT_AND); *************** *** 2061,2068 **** OPERATOR(','); if (tmp == '~') PMop(OP_MATCH); ! if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp)) ! warn("Reversed %c= operator",(int)tmp); s--; if (expect == XSTATE && isALPHA(tmp) && (s == linestart+1 || s[-2] == '\n') ) --- 2063,2070 ---- OPERATOR(','); if (tmp == '~') PMop(OP_MATCH); ! if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp)) ! warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp); s--; if (expect == XSTATE && isALPHA(tmp) && (s == linestart+1 || s[-2] == '\n') ) *************** *** 2183,2188 **** --- 2185,2200 ---- TERM(THING); } + #if 0 + /* ... and neither is this one */ + if (tokenbuf[1] == '\027' && !tokenbuf[2]) { /* $^W */ + yylval.opval = newSVOP(OP_CONST, 0, + newSViv((IV)compiling.cop_warnings)); + yylval.opval->op_private = OPpCONST_WARNING; + TERM(THING); + } + #endif + d = s; if (lex_state == LEX_NORMAL) s = skipspace(s); *************** *** 2191,2197 **** char *t; if (*s == '[') { tokenbuf[0] = '@'; ! if (dowarn) { for(t = s + 1; isSPACE(*t) || isALNUM(*t) || *t == '$'; t++) ; --- 2203,2209 ---- char *t; if (*s == '[') { tokenbuf[0] = '@'; ! if (ckWARN(WARN_SYNTAX)) { for(t = s + 1; isSPACE(*t) || isALNUM(*t) || *t == '$'; t++) ; *************** *** 2199,2212 **** bufptr = skipspace(bufptr); while (t < bufend && *t != ']') t++; ! warn("Multidimensional syntax %.*s not supported", (t - bufptr) + 1, bufptr); } } } else if (*s == '{') { tokenbuf[0] = '%'; ! if (dowarn && strEQ(tokenbuf+1, "SIG") && (t = strchr(s, '}')) && (t = strchr(t, '='))) { char tmpbuf[1024]; --- 2211,2225 ---- bufptr = skipspace(bufptr); while (t < bufend && *t != ']') t++; ! warner(WARN_SYNTAX, ! "Multidimensional syntax %.*s not supported", (t - bufptr) + 1, bufptr); } } } else if (*s == '{') { tokenbuf[0] = '%'; ! if (ckWARN(WARN_SYNTAX) && strEQ(tokenbuf+1, "SIG") && (t = strchr(s, '}')) && (t = strchr(t, '='))) { char tmpbuf[1024]; *************** *** 2215,2221 **** if (isIDFIRST(*t)) { t = scan_word(t, tmpbuf, TRUE, &len); if (*t != '(' && perl_get_cv(tmpbuf, FALSE)) ! warn("You need to quote \"%s\"", tmpbuf); } } } --- 2228,2235 ---- if (isIDFIRST(*t)) { t = scan_word(t, tmpbuf, TRUE, &len); if (*t != '(' && perl_get_cv(tmpbuf, FALSE)) ! warner(WARN_SYNTAX, ! "You need to quote \"%s\"", tmpbuf); } } } *************** *** 2259,2265 **** tokenbuf[0] = '%'; /* Warn about @ where they meant $. */ ! if (dowarn) { if (*s == '[' || *s == '{') { char *t = s + 1; while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t))) --- 2273,2279 ---- tokenbuf[0] = '%'; /* Warn about @ where they meant $. */ ! if (ckWARN(WARN_SYNTAX)) { if (*s == '[' || *s == '{') { char *t = s + 1; while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t))) *************** *** 2267,2273 **** if (*t == '}' || *t == ']') { t++; bufptr = skipspace(bufptr); ! warn("Scalar value %.*s better written as $%.*s", t-bufptr, bufptr, t-bufptr-1, bufptr+1); } } --- 2281,2288 ---- if (*t == '}' || *t == ']') { t++; bufptr = skipspace(bufptr); ! warner(WARN_SYNTAX, ! "Scalar value %.*s better written as $%.*s", t-bufptr, bufptr, t-bufptr-1, bufptr+1); } } *************** *** 2369,2376 **** case '\\': s++; ! if (dowarn && lex_inwhat && isDIGIT(*s)) ! warn("Can't use \\%c to mean $%c in expression", *s, *s); if (expect == XOPERATOR) no_op("Backslash",s); OPERATOR(REFGEN); --- 2384,2392 ---- case '\\': s++; ! if (ckWARN(WARN_SYNTAX) && lex_inwhat && isDIGIT(*s)) ! warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression", ! *s, *s); if (expect == XOPERATOR) no_op("Backslash",s); OPERATOR(REFGEN); *************** *** 2443,2450 **** /* Is this a word before a => operator? */ if (strnEQ(d,"=>",2)) { CLINE; ! if (dowarn && (tmp || perl_get_cv(tokenbuf, FALSE))) ! warn("Ambiguous use of %s => resolved to \"%s\" =>", tokenbuf, tokenbuf); yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0)); yylval.opval->op_private = OPpCONST_BARE; --- 2459,2467 ---- /* Is this a word before a => operator? */ if (strnEQ(d,"=>",2)) { CLINE; ! if (ckWARN(WARN_AMBIGUOUS) && (tmp || perl_get_cv(tokenbuf, FALSE))) ! warner(WARN_AMBIGUOUS, ! "Ambiguous use of %s => resolved to \"%s\" =>", tokenbuf, tokenbuf); yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0)); yylval.opval->op_private = OPpCONST_BARE; *************** *** 2483,2489 **** if (expect == XOPERATOR) { if (bufptr == linestart) { curcop->cop_line--; ! warn(warn_nosemi); curcop->cop_line++; } else --- 2500,2506 ---- if (expect == XOPERATOR) { if (bufptr == linestart) { curcop->cop_line--; ! warner(WARN_SEMICOLON, warn_nosemi); curcop->cop_line++; } else *************** *** 2622,2632 **** /* Call it a bare word */ bareword: ! if (dowarn) { if (lastchar != '-') { for (d = tokenbuf; *d && isLOWER(*d); d++) ; if (!*d) ! warn(warn_reserved, tokenbuf); } } if (lastchar && strchr("*%&", lastchar)) { --- 2639,2649 ---- /* Call it a bare word */ bareword: ! if (ckWARN(WARN_RESERVED)) { if (lastchar != '-') { for (d = tokenbuf; *d && isLOWER(*d); d++) ; if (!*d) ! warner(WARN_RESERVED, warn_reserved, tokenbuf); } } if (lastchar && strchr("*%&", lastchar)) { *************** *** 2759,2765 **** LOP(OP_CRYPT,XTERM); case KEY_chmod: ! if (dowarn) { for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ; if (*d != '0' && isDIGIT(*d)) yywarn("chmod: mode argument is missing initial 0"); --- 2776,2782 ---- LOP(OP_CRYPT,XTERM); case KEY_chmod: ! if (ckWARN(WARN_OCTAL)) { for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ; if (*d != '0' && isDIGIT(*d)) yywarn("chmod: mode argument is missing initial 0"); *************** *** 3165,3179 **** s = scan_str(s); if (!s) missingterm((char*)0); ! if (dowarn && SvLEN(lex_stuff)) { d = SvPV_force(lex_stuff, len); for (; len; --len, ++d) { if (*d == ',') { ! warn("Possible attempt to separate words with commas"); break; } if (*d == '#') { ! warn("Possible attempt to put comments in qw() list"); break; } } --- 3182,3198 ---- s = scan_str(s); if (!s) missingterm((char*)0); ! if (ckWARN(WARN_SYNTAX) && SvLEN(lex_stuff)) { d = SvPV_force(lex_stuff, len); for (; len; --len, ++d) { if (*d == ',') { ! warner(WARN_SYNTAX, ! "Possible attempt to separate words with commas"); break; } if (*d == '#') { ! warner(WARN_SYNTAX, ! "Possible attempt to put comments in qw() list"); break; } } *************** *** 3529,3535 **** LOP(OP_UTIME,XTERM); case KEY_umask: ! if (dowarn) { for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ; if (*d != '0' && isDIGIT(*d)) yywarn("umask: argument is missing initial 0"); --- 3548,3554 ---- LOP(OP_UTIME,XTERM); case KEY_umask: ! if (ckWARN(WARN_OCTAL)) { for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ; if (*d != '0' && isDIGIT(*d)) yywarn("umask: argument is missing initial 0"); *************** *** 4222,4228 **** { char *w; ! if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */ int level = 1; for (w = s+2; *w && level; w++) { if (*w == '(') --- 4241,4247 ---- { char *w; ! 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 == '(') *************** *** 4233,4239 **** if (*w) for (; *w && isSPACE(*w); w++) ; if (!*w || !strchr(";|})]oa!=", *w)) /* an advisory hack only... */ ! warn("%s (...) interpreted as function",name); } while (s < bufend && isSPACE(*s)) s++; --- 4252,4258 ---- if (*w) for (; *w && isSPACE(*w); w++) ; if (!*w || !strchr(";|})]oa!=", *w)) /* an advisory hack only... */ ! warner(WARN_SYNTAX, "%s (...) interpreted as function",name); } while (s < bufend && isSPACE(*s)) s++; *************** *** 4364,4372 **** *d = '\0'; while (s < send && (*s == ' ' || *s == '\t')) s++; if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { ! if (dowarn && keyword(dest, d - dest)) { char *brack = *s == '[' ? "[...]" : "{...}"; ! warn("Ambiguous use of %c{%s%s} resolved to %c%s%s", funny, dest, brack, funny, dest, brack); } lex_fakebrack = lex_brackets+1; --- 4383,4392 ---- *d = '\0'; while (s < send && (*s == ' ' || *s == '\t')) s++; if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) { ! if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) { char *brack = *s == '[' ? "[...]" : "{...}"; ! warner(WARN_AMBIGUOUS, ! "Ambiguous use of %c{%s%s} resolved to %c%s%s", funny, dest, brack, funny, dest, brack); } lex_fakebrack = lex_brackets+1; *************** *** 4381,4389 **** lex_state = LEX_INTERPEND; if (funny == '#') funny = '@'; ! if (dowarn && (keyword(dest, d - dest) || perl_get_cv(dest, FALSE))) ! warn("Ambiguous use of %c{%s} resolved to %c%s", funny, dest, funny, dest); } else { --- 4401,4410 ---- lex_state = LEX_INTERPEND; if (funny == '#') funny = '@'; ! if (ckWARN(WARN_AMBIGUOUS) && (keyword(dest, d - dest) || perl_get_cv(dest, FALSE))) ! warner(WARN_AMBIGUOUS, ! "Ambiguous use of %c{%s} resolved to %c%s", funny, dest, funny, dest); } else { *************** *** 4946,4960 **** floatit = FALSE; while (isDIGIT(*s) || *s == '_') { if (*s == '_') { ! if (dowarn && lastub && s - lastub != 3) ! warn("Misplaced _ in number"); lastub = ++s; } else *d++ = *s++; } ! if (dowarn && lastub && s - lastub != 3) ! warn("Misplaced _ in number"); if (*s == '.' && s[1] != '.') { floatit = TRUE; *d++ = *s++; --- 4967,4981 ---- floatit = FALSE; while (isDIGIT(*s) || *s == '_') { if (*s == '_') { ! if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3) ! warner(WARN_SYNTAX, "Misplaced _ in number"); lastub = ++s; } else *d++ = *s++; } ! if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3) ! warner(WARN_SYNTAX, "Misplaced _ in number"); if (*s == '.' && s[1] != '.') { floatit = TRUE; *d++ = *s++; *** universal.c.orig Tue Feb 18 08:43:35 1997 --- universal.c Thu Feb 27 11:31:54 1997 *************** *** 57,64 **** SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { ! if (dowarn) ! warn("Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } --- 57,65 ---- SV* sv = *svp++; HV* basestash = gv_stashsv(sv, FALSE); if (!basestash) { ! if (ckWARN(WARN_MISC)) ! warner(WARN_SYNTAX, ! "Can't locate package %s for @%s::ISA", SvPVX(sv), HvNAME(stash)); continue; } *** util.c.orig Tue Feb 4 08:55:21 1997 --- util.c Thu Feb 27 11:31:55 1997 *************** *** 1213,1241 **** return restartop; } #ifdef I_STDARG ! void ! croak(const char* pat, ...) #else /*VARARGS0*/ ! void ! croak(pat, va_alist) char *pat; ! va_dcl #endif { ! va_list args; char *message; HV *stash; GV *gv; CV *cv; ! #ifdef I_STDARG ! va_start(args, pat); ! #else ! va_start(args); ! #endif ! message = mess(pat, &args); va_end(args); if (diehook) { /* sv_2cv might call croak() */ --- 1213,1240 ---- return restartop; } + static void #ifdef I_STDARG ! do_croak(const char *pat, va_list *args) #else /*VARARGS0*/ ! do_croak(pat, args) char *pat; ! va_list *args; #endif { ! /* va_list args; */ char *message; HV *stash; GV *gv; CV *cv; ! /* #ifdef I_STDARG */ ! /* va_start(args, pat); */ ! /* #else */ ! /* va_start(args); */ ! /* #endif */ ! message = mess(pat, args); va_end(args); if (diehook) { /* sv_2cv might call croak() */ *************** *** 1273,1298 **** void #ifdef I_STDARG ! warn(const char* pat,...) #else /*VARARGS0*/ ! warn(pat,va_alist) ! const char *pat; va_dcl #endif { ! va_list args; ! char *message; ! HV *stash; ! GV *gv; ! CV *cv; #ifdef I_STDARG va_start(args, pat); #else va_start(args); #endif ! message = mess(pat, &args); va_end(args); if (warnhook) { --- 1272,1318 ---- void #ifdef I_STDARG ! croak(const char *pat,...) #else /*VARARGS0*/ ! croak(pat, va_alist) ! char *pat; va_dcl #endif { ! va_list args; #ifdef I_STDARG va_start(args, pat); #else va_start(args); #endif ! do_croak(pat, &args); ! va_end(args); ! } ! ! static void ! #ifdef I_STDARG ! do_warn(const char *pat, va_list *args) ! #else ! /*VARARGS0*/ ! do_warn(pat,args) ! const char *pat; ! va_list *args; ! #endif ! { ! /* va_list args; */ ! char *message; ! HV *stash; ! GV *gv; ! CV *cv; ! ! /* #ifdef I_STDARG */ ! /* va_start(args, pat); */ ! /* #else */ ! /* va_start(args); */ ! /* #endif */ ! message = mess(pat, args); va_end(args); if (warnhook) { *************** *** 1328,1333 **** --- 1348,1400 ---- (void)PerlIO_flush(PerlIO_stderr()); } + void + #ifdef I_STDARG + warn(const char* pat,...) + #else + /*VARARGS0*/ + warn(pat,va_alist) + const char *pat; + va_dcl + #endif + { + va_list args; + + #ifdef I_STDARG + va_start(args, pat); + #else + va_start(args); + #endif + do_warn(pat, &args); + va_end(args); + } + + void + #ifdef I_STDARG + warner(U32 err, const char* pat,...) + #else + /*VARARGS0*/ + warner(err,pat,va_alist) + U32 err; + const char *pat; + va_dcl + #endif + { + va_list args; + + #ifdef I_STDARG + va_start(args, pat); + #else + va_start(args); + #endif + + if (ckDEAD(err)) + do_croak(pat, &args) ; + else + do_warn(pat, &args) ; + va_end(args); + } + #ifndef VMS /* VMS' my_setenv() is in VMS.c */ void my_setenv(nam,val) *************** *** 2184,2191 **** retval = n | (*s++ - '0'); len--; } ! if (dowarn && len && (*s == '8' || *s == '9')) ! warn("Illegal octal digit ignored"); *retlen = s - start; return retval; } --- 2251,2258 ---- retval = n | (*s++ - '0'); len--; } ! if (len && (*s == '8' || *s == '9') && ckWARN(WARN_OCTAL)) ! warner(WARN_OCTAL, "Illegal octal digit ignored"); *retlen = s - start; return retval; } *** /dev/null Thu Feb 27 12:04:47 1997 --- warning.h Thu Feb 27 11:52:03 1997 *************** *** 0 **** --- 1,67 ---- + /* !!!!!!! 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 + #define G_WARN_ON 1 + #define G_WARN_FLAG 2 /* -W flag */ + + #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) ) ) \ + || (curcop->cop_warnings == WARN_NONE && dowarn) ) + + #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) ) ) \ + || (curcop->cop_warnings == WARN_NONE && dowarn) ) + + #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_NUMERIC 8 + #define WARN_ONCE 9 + #define WARN_SYNTAX 10 + #define WARN_RESERVED 11 + #define WARN_DEPRECATED 12 + #define WARN_SEMICOLON 13 + #define WARN_OCTAL 14 + #define WARN_AMBIGUOUS 15 + #define WARN_PARENTHESIS 16 + #define WARN_PRECEDENCE 17 + #define WARN_IO 18 + #define WARN_NEWLINE 19 + #define WARN_CLOSED 20 + #define WARN_EXEC 21 + #define WARN_UNOPENED 22 + #define WARN_PIPE 23 + #define WARN_UNINITIALIZED 24 + #define WARN_RECURSION 25 + #define WARN_MISC 26 + + #define WARNsize 7 + #define WARN_ALLstring "\125\125\125\125\125\125\125" + #define WARN_NONEstring "\0\0\0\0\0\0\0" + *** /dev/null Thu Feb 27 12:04:47 1997 --- warning.pl Thu Feb 27 11:52:50 1997 *************** *** 0 **** --- 1,290 ---- + #!/usr/bin/perl + + $tree = { + 'unsafe' => { 'untie' => 1, + 'substr' => 1, + 'taint' => 1, + 'signal' => 1, + 'closure' => 1, + } , + 'io' => { 'pipe' => 1, + 'unopened' => 1, + 'closed' => 1, + 'newline' => 1, + 'exec' => 1, + #'wr in in file'=> 1, + }, + 'syntax' => { 'ambiguous' => 1, + 'semicolon' => 1, + 'precedence' => 1, + 'reserved' => 1, + 'octal' => 1, + 'parenthesis' => 1, + 'deprecated' => 1, + }, + 'void' => 1, + 'recursion' => 1, + 'redefine' => 1, + 'numeric' => 1, + 'uninitialized'=> 1, + 'once' => 1, + 'misc' => 1, + } ; + + + ########################################################################### + sub tab { + local($l, $t) = @_; + $t .= "\t" x ($l - (length($t) + 1) / 8); + $t; + } + + ########################################################################### + + 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 + #define G_WARN_ON 1 + #define G_WARN_FLAG 2 /* -W flag */ + + #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) ) ) \ + || (curcop->cop_warnings == WARN_NONE && dowarn) ) + + #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) ) ) \ + || (curcop->cop_warnings == WARN_NONE && dowarn) ) + + #define WARN_NONE NULL + #define WARN_ALL (&sv_yes) + + EOM + + + $index = 0 ; + @{ $list{"all"} } = walk ($tree) ; + + $index *= 2 ; + $warn_size = int($index / 8) + ($index % 8 != 0) ; + + 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'; + + 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) { + + $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) { + + $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') ; + } + + + 1; *** /dev/null Thu Feb 27 12:04:47 1997 --- warning.pl Thu Feb 27 11:52:50 1997 *************** *** 0 **** --- 1,290 ---- + #!/usr/bin/perl + + $tree = { + 'unsafe' => { 'untie' => 1, + 'substr' => 1, + 'taint' => 1, + 'signal' => 1, + 'closure' => 1, + } , + 'io' => { 'pipe' => 1, + 'unopened' => 1, + 'closed' => 1, + 'newline' => 1, + 'exec' => 1, + #'wr in in file'=> 1, + }, + 'syntax' => { 'ambiguous' => 1, + 'semicolon' => 1, + 'precedence' => 1, + 'reserved' => 1, + 'octal' => 1, + 'parenthesis' => 1, + 'deprecated' => 1, + }, + 'void' => 1, + 'recursion' => 1, + 'redefine' => 1, + 'numeric' => 1, + 'uninitialized'=> 1, + 'once' => 1, + 'misc' => 1, + } ; + + + ########################################################################### + sub tab { + local($l, $t) = @_; + $t .= "\t" x ($l - (length($t) + 1) / 8); + $t; + } + + ########################################################################### + + 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 + #define G_WARN_ON 1 + #define G_WARN_FLAG 2 /* -W flag */ + + #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) ) ) \ + || (curcop->cop_warnings == WARN_NONE && dowarn) ) + + #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) ) ) \ + || (curcop->cop_warnings == WARN_NONE && dowarn) ) + + #define WARN_NONE NULL + #define WARN_ALL (&sv_yes) + + EOM + + + $index = 0 ; + @{ $list{"all"} } = walk ($tree) ; + + $index *= 2 ; + $warn_size = int($index / 8) + ($index % 8 != 0) ; + + 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'; + + 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) { + + $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) { + + $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') ; + } + + + 1;