# See README.warning for information of what the patch does. exit 0 ----------------------------------------------------------------------- *** MANIFEST.orig Wed Oct 8 16:16:23 1997 --- MANIFEST Thu Oct 16 22:45:57 1997 *************** *** 446,451 **** --- 446,452 ---- 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 *************** *** 768,773 **** --- 769,791 ---- 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 *************** *** 817,822 **** --- 835,842 ---- 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/Makefile Win32 makefile for NMAKE (Visual C++ build) win32/TEST Win32 port win32/autosplit.pl Win32 port *** Makefile.SH.orig Wed Oct 15 10:33:16 1997 --- Makefile.SH Thu Oct 16 22:45:58 1997 *************** *** 186,192 **** 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 --- 186,192 ---- 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 *************** *** 405,414 **** 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 --- 405,415 ---- 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 *************** *** 417,422 **** --- 418,424 ---- 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 Sun Oct 19 10:24:17 1997 --- README.warning Thu Oct 16 22:45:58 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 Sat May 10 01:23:51 1997 --- cop.h Thu Oct 16 22:45:59 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 Jul 29 02:08:11 1997 --- doio.c Thu Oct 16 22:46:00 1997 *************** *** 170,177 **** 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; } --- 170,177 ---- 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; } *************** *** 277,284 **** } } if (!fp) { ! if (dowarn && IoTYPE(io) == '<' && strchr(name, '\n')) ! warn(warn_nl, "open"); goto say_false; } if (IoTYPE(io) && --- 277,284 ---- } } if (!fp) { ! if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == '<' && strchr(name, '\n')) ! warner(WARN_NEWLINE, warn_nl, "open"); goto say_false; } if (IoTYPE(io) && *************** *** 577,584 **** } 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); --- 577,584 ---- } 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); *************** *** 672,679 **** #endif return PerlIO_tell(fp); } ! if (dowarn) ! warn("tell() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return -1L; } --- 672,679 ---- #endif return PerlIO_tell(fp); } ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "tell() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return -1L; } *************** *** 694,701 **** #endif return PerlIO_seek(fp, pos, whence) >= 0; } ! if (dowarn) ! warn("seek() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return FALSE; } --- 694,701 ---- #endif return PerlIO_seek(fp, pos, whence) >= 0; } ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "seek() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return FALSE; } *************** *** 711,718 **** if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) return lseek(PerlIO_fileno(fp), pos, whence); ! if (dowarn) ! warn("sysseek() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return -1L; } --- 711,718 ---- if (gv && (io = GvIO(gv)) && (fp = IoIFP(io))) return lseek(PerlIO_fileno(fp), pos, whence); ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "sysseek() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return -1L; } *************** *** 794,801 **** } switch (SvTYPE(sv)) { case SVt_NULL: ! if (dowarn) ! warn(warn_uninit); return TRUE; case SVt_IV: if (SvIOK(sv)) { --- 794,801 ---- } switch (SvTYPE(sv)) { case SVt_NULL: ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); return TRUE; case SVt_IV: if (SvIOK(sv)) { *************** *** 836,843 **** else { if (tmpgv == defgv) return laststatval; ! if (dowarn) ! warn("Stat on unopened file <%s>", GvENAME(tmpgv)); statgv = Nullgv; sv_setpv(statname,""); --- 836,843 ---- 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,""); *************** *** 860,867 **** 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; } } --- 860,867 ---- 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; } } *************** *** 892,899 **** #else laststatval = Stat(SvPV(sv, na),&statcache); #endif ! if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n')) ! warn(warn_nl, "lstat"); return laststatval; } --- 892,899 ---- #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; } *************** *** 922,929 **** execvp(tmps,Argv); else execvp(Argv[0],Argv); ! if (dowarn) ! warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno)); } do_execfree(); return FALSE; --- 922,930 ---- 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; *************** *** 1026,1033 **** do_execfree(); goto doshell; } ! if (dowarn) ! warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno)); } do_execfree(); return FALSE; --- 1027,1035 ---- 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 Mon Oct 6 18:20:06 1997 --- global.sym Thu Oct 16 22:46:01 1997 *************** *** 1147,1152 **** --- 1147,1153 ---- utilize wait4pid warn + warner watch whichsig xiv_arenaroot *** gv.c.orig Mon Oct 6 18:20:07 1997 --- gv.c Thu Oct 16 22:46:02 1997 *************** *** 200,207 **** 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; } --- 200,207 ---- 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; } *************** *** 339,346 **** /* * Inheriting AUTOLOAD for non-methods works ... for now. */ ! if (dowarn && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash)) ! warn( "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", HvNAME(stash), (int)len, name); --- 339,347 ---- /* * Inheriting AUTOLOAD for non-methods works ... for now. */ ! if (ckWARN(WARN_DEPRECATED) && !method && ! (GvCVGEN(gv) || GvSTASH(gv) != stash)) ! warner(WARN_DEPRECATED, "Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated", HvNAME(stash), (int)len, name); *************** *** 697,704 **** case '#': case '*': ! if (dowarn && len == 1 && sv_type == SVt_PV) ! warn("Use of $%s is deprecated", name); /* FALL THROUGH */ case '[': case '!': --- 698,705 ---- 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 '!': *************** *** 717,722 **** --- 718,724 ---- case '/': case '|': case '\001': + case '\002': case '\004': case '\005': case '\006': *************** *** 864,870 **** 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)); } } --- 866,873 ---- 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 Wed Apr 23 20:08:58 1997 --- interp.sym Thu Oct 16 22:46:02 1997 *************** *** 69,74 **** --- 69,75 ---- laststatval laststype leftgv + lexwarn lineary localizing localpatches *** lib/diagnostics.pm.orig Thu Sep 11 15:25:08 1997 --- lib/diagnostics.pm Thu Oct 16 22:46:03 1997 *************** *** 274,280 **** $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\x00\x01\x00\x00", # [16] + 'closed' => "\x00\x00\x00\x00\x00\x04\x00", # [21] + 'closure' => "\x00\x04\x00\x00\x00\x00\x00", # [5] + 'deprecated' => "\x00\x00\x00\x01\x00\x00\x00", # [12] + 'exec' => "\x00\x00\x00\x00\x00\x10\x00", # [22] + 'io' => "\x00\x00\x00\x00\x40\x55\x01", # [19..24] + 'misc' => "\x00\x00\x00\x00\x00\x00\x40", # [27] + 'newline' => "\x00\x00\x00\x00\x00\x01\x00", # [20] + 'numeric' => "\x00\x00\x01\x00\x00\x00\x00", # [8] + 'octal' => "\x00\x00\x00\x40\x00\x00\x00", # [15] + 'once' => "\x00\x00\x04\x00\x00\x00\x00", # [9] + 'parenthesis' => "\x00\x00\x00\x00\x04\x00\x00", # [17] + 'pipe' => "\x00\x00\x00\x00\x00\x00\x01", # [24] + 'precedence' => "\x00\x00\x00\x00\x10\x00\x00", # [18] + 'printf' => "\x00\x00\x00\x10\x00\x00\x00", # [14] + 'recursion' => "\x00\x00\x00\x00\x00\x00\x10", # [26] + '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\x15\x00\x00", # [10..18] + 'taint' => "\x40\x00\x00\x00\x00\x00\x00", # [3] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x04", # [25] + 'unopened' => "\x00\x00\x00\x00\x00\x40\x00", # [23] + '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\x00\x02\x00\x00", # [16] + 'closed' => "\x00\x00\x00\x00\x00\x08\x00", # [21] + 'closure' => "\x00\x08\x00\x00\x00\x00\x00", # [5] + 'deprecated' => "\x00\x00\x00\x02\x00\x00\x00", # [12] + 'exec' => "\x00\x00\x00\x00\x00\x20\x00", # [22] + 'io' => "\x00\x00\x00\x00\x80\xaa\x02", # [19..24] + 'misc' => "\x00\x00\x00\x00\x00\x00\x80", # [27] + 'newline' => "\x00\x00\x00\x00\x00\x02\x00", # [20] + 'numeric' => "\x00\x00\x02\x00\x00\x00\x00", # [8] + 'octal' => "\x00\x00\x00\x80\x00\x00\x00", # [15] + 'once' => "\x00\x00\x08\x00\x00\x00\x00", # [9] + 'parenthesis' => "\x00\x00\x00\x00\x08\x00\x00", # [17] + 'pipe' => "\x00\x00\x00\x00\x00\x00\x02", # [24] + 'precedence' => "\x00\x00\x00\x00\x20\x00\x00", # [18] + 'printf' => "\x00\x00\x00\x20\x00\x00\x00", # [14] + 'recursion' => "\x00\x00\x00\x00\x00\x00\x20", # [26] + '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\x2a\x00\x00", # [10..18] + 'taint' => "\x80\x00\x00\x00\x00\x00\x00", # [3] + 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x08", # [25] + 'unopened' => "\x00\x00\x00\x00\x00\x80\x00", # [23] + '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') ; + } + + + sub make_fatal + { + my $self = shift ; + my $bitmask = $self->bits(@_) ; + $SIG{__WARN__} = + sub + { + die @_ if $^B & $bitmask ; + warn @_ + } ; + } + + sub bitmask + { + return $^B ; + } + + sub enabled + { + my $string = shift ; + + return 1 + if $bits{$string} && $^B & $bits{$string} ; + + return 0 ; + } + + 1; *** mg.c.orig Tue Oct 14 13:49:08 1997 --- mg.c Thu Oct 16 22:46:04 1997 *************** *** 324,329 **** --- 324,355 ---- return 0; } + static char * + printW(sv) + SV * sv ; + { + #if 1 + return "" ; + + #else + int i ; + static char buffer[50] ; + char buf1[20] ; + char * p ; + + + sprintf(buffer, "Buffer %d, Length = %d - ", sv, SvCUR(sv)) ; + p = SvPVX(sv) ; + for (i = 0; i < SvCUR(sv) ; ++ i) { + sprintf (buf1, " %x [%x]", (p+i), *(p+i)) ; + strcat(buffer, buf1) ; + } + + return buffer ; + + #endif + } + int magic_get(sv, mg) SV *sv; *************** *** 339,344 **** --- 365,382 ---- case '\001': /* ^A */ sv_setsv(sv, bodytarget); break; + case '\002': /* ^B */ + /* printf("magic_get $^B: ") ; */ + if (curcop->cop_warnings == WARN_NONE) + /* printf("WARN_NONE\n"), */ + sv_setpvn(sv, WARN_NONEstring, WARNsize) ; + else if (curcop->cop_warnings == WARN_ALL) + /* printf("WARN_ALL\n"), */ + sv_setpvn(sv, WARN_ALLstring, WARNsize) ; + else + /* printf("some %s\n", printW(curcop->cop_warnings)), */ + sv_setsv(sv, curcop->cop_warnings); + break; case '\004': /* ^D */ sv_setiv(sv, (IV)(debug & 32767)); break; *************** *** 407,413 **** #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 '&': --- 445,451 ---- #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 '&': *************** *** 803,810 **** 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]); --- 841,848 ---- 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]); *************** *** 1355,1360 **** --- 1393,1410 ---- 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()); *************** *** 1400,1406 **** #endif break; case '\027': /* ^W */ ! dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '.': if (localizing) { --- 1450,1457 ---- #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) { *************** *** 1781,1788 **** 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; } --- 1832,1839 ---- 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 Wed Oct 8 16:51:51 1997 --- op.c Thu Oct 16 22:58:25 1997 *************** *** 125,131 **** } croak("Can't use global %s in \"my\"",name); } ! if (dowarn && AvFILL(comppad_name) >= 0) { SV **svp = AvARRAY(comppad_name); for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) { if ((sv = svp[off]) --- 125,131 ---- } croak("Can't use global %s in \"my\"",name); } ! if (ckWARN(WARN_UNSAFE) && AvFILL(comppad_name) >= 0) { SV **svp = AvARRAY(comppad_name); for (off = AvFILL(comppad_name); off > comppad_name_floor; off--) { if ((sv = svp[off]) *************** *** 133,139 **** && SvIVX(sv) == 999999999 /* var is in open scope */ && strEQ(name, SvPVX(sv))) { ! warn("\"my\" variable %s masks earlier declaration in same scope", name); break; } } --- 133,141 ---- && SvIVX(sv) == 999999999 /* var is in open scope */ && strEQ(name, SvPVX(sv))) { ! warner(WARN_UNSAFE, ! "\"my\" variable %s masks earlier declaration in same scope", ! name); break; } } *************** *** 230,237 **** if (CvANON(bcv)) CvCLONE_on(bcv); else { ! if (dowarn && !CvUNIQUE(cv)) ! warn( "Variable \"%s\" may be unavailable", name); break; --- 232,239 ---- if (CvANON(bcv)) CvCLONE_on(bcv); else { ! if (ckWARN(WARN_CLOSURE) && !CvUNIQUE(cv)) ! warner(WARN_CLOSURE, "Variable \"%s\" may be unavailable", name); break; *************** *** 240,247 **** } } else if (!CvUNIQUE(compcv)) { ! if (dowarn && !SvFAKE(sv) && !CvUNIQUE(cv)) ! warn("Variable \"%s\" will not stay shared", name); } } av_store(comppad, newoff, SvREFCNT_inc(oldsv)); --- 242,251 ---- } } else if (!CvUNIQUE(compcv)) { ! if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv) ! && !CvUNIQUE(cv)) ! warner(WARN_CLOSURE, ! "Variable \"%s\" will not stay shared", name); } } av_store(comppad, newoff, SvREFCNT_inc(oldsv)); *************** *** 501,506 **** --- 505,512 ---- 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); *************** *** 587,599 **** 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); --- 593,605 ---- 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); *************** *** 778,784 **** 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; --- 784,790 ---- 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; *************** *** 845,852 **** } break; } ! if (useless && dowarn) ! warn("Useless use of %s in void context", useless); return op; } --- 851,858 ---- } break; } ! if (useless && ckWARN(WARN_VOID)) ! warner(WARN_VOID, "Useless use of %s in void context", useless); return op; } *************** *** 988,1007 **** modcount++; return op; 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) --- 994,1015 ---- modcount++; return op; 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) *************** *** 1353,1370 **** { OP *op; ! if (dowarn && ! (left->op_type == OP_RV2AV || ! left->op_type == OP_RV2HV || ! left->op_type == OP_PADAV || ! left->op_type == OP_PADHV)) { ! char *desc = op_desc[(right->op_type == OP_SUBST || ! right->op_type == OP_TRANS) ! ? right->op_type : OP_MATCH]; ! char *sample = ((left->op_type == OP_RV2AV || ! left->op_type == OP_PADAV) ! ? "@array" : "%hash"); ! warn("Applying %s to %s will act on scalar(%s)", desc, sample, sample); } if (right->op_type == OP_MATCH || --- 1361,1380 ---- { OP *op; ! if (ckWARN(WARN_UNSAFE) && ! (left->op_type == OP_RV2AV || ! left->op_type == OP_RV2HV || ! left->op_type == OP_PADAV || ! left->op_type == OP_PADHV)) { ! char *desc = op_desc[(right->op_type == OP_SUBST || ! right->op_type == OP_TRANS) ! ? right->op_type : OP_MATCH]; ! char *sample = ((left->op_type == OP_RV2AV || ! left->op_type == OP_PADAV) ! ? "@array" : "%hash"); ! warner(WARN_UNSAFE, ! "Applying %s to %s will act on scalar(%s)", ! desc, sample, sample); } if (right->op_type == OP_MATCH || *************** *** 1445,1450 **** --- 1455,1466 ---- 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; } *************** *** 1507,1517 **** 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; --- 1523,1534 ---- 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; *************** *** 2504,2509 **** --- 2521,2530 ---- } 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; *************** *** 2579,2586 **** } } 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; --- 2600,2608 ---- } } 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; *************** *** 2596,2602 **** 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; --- 2618,2624 ---- 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; *************** *** 2619,2625 **** if (warnop) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warn("Value of %s%s can be \"0\"; test with defined()", op_desc[warnop], ((warnop == OP_READLINE || warnop == OP_GLOB) ? " construct" : "() operator")); --- 2641,2648 ---- if (warnop) { line_t oldline = curcop->cop_line; curcop->cop_line = copline; ! warner(WARN_UNSAFE, ! "Value of %s%s can be \"0\"; test with defined()", op_desc[warnop], ((warnop == OP_READLINE || warnop == OP_GLOB) ? " construct" : "() operator")); *************** *** 3267,3277 **** if (curstack == sortstack && sortcop == CvSTART(cv)) croak("Can't redefine active sort subroutine %s", name); const_sv = cv_const_sv(cv); ! 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); --- 3290,3301 ---- if (curstack == sortstack && sortcop == CvSTART(cv)) croak("Can't redefine active sort subroutine %s", name); const_sv = cv_const_sv(cv); ! 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); *************** *** 3472,3481 **** } 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); --- 3496,3505 ---- } 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); *************** *** 3542,3552 **** 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); --- 3566,3576 ---- 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); *************** *** 4031,4038 **** 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; --- 4055,4063 ---- 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; *************** *** 4049,4056 **** 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; --- 4074,4082 ---- 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; *************** *** 4787,4800 **** 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; } } --- 4813,4827 ---- 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 Tue May 13 19:59:40 1997 --- op.h Thu Oct 16 22:46:06 1997 *************** *** 116,121 **** --- 116,122 ---- #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 Tue Oct 14 19:09:18 1997 --- perl.c Thu Oct 16 22:46:07 1997 *************** *** 518,523 **** --- 518,524 ---- time(&basetime); oldscope = scopestack_ix; + dowarn = FALSE ; JMPENV_PUSH(ret); switch (ret) { *************** *** 574,579 **** --- 575,581 ---- case 'u': case 'U': case 'v': + case 'W': case 'w': if (s = moreswitches(s)) goto reswitch; *************** *** 827,833 **** if (do_undump) my_unexec(); ! if (dowarn) gv_check(defstash); LEAVE; --- 829,835 ---- if (do_undump) my_unexec(); ! if (ckWARN(WARN_ONCE)) gv_check(defstash); LEAVE; *************** *** 1551,1557 **** 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 '*': --- 1553,1564 ---- 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 Mon Oct 6 18:20:06 1997 --- perl.h Thu Oct 16 22:46:08 1997 *************** *** 1014,1019 **** --- 1014,1020 ---- #include "hv.h" #include "mg.h" #include "scope.h" + #include "warning.h" /* work around some libPW problems */ #ifdef DOINIT *** pp.c.orig Tue Oct 14 13:58:42 1997 --- pp.c Thu Oct 16 23:15:13 1997 *************** *** 207,214 **** if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a symbol"); ! if (dowarn) ! warn(warn_uninit); RETSETUNDEF; } sym = SvPV(sv, na); --- 207,214 ---- if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a symbol"); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); RETSETUNDEF; } sym = SvPV(sv, na); *************** *** 251,258 **** if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a SCALAR"); ! if (dowarn) ! warn(warn_uninit); RETSETUNDEF; } sym = SvPV(sv, na); --- 251,258 ---- if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a SCALAR"); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); RETSETUNDEF; } sym = SvPV(sv, na); *************** *** 1736,1743 **** rem -= pos; } if (fail < 0) { ! if (dowarn || lvalue) ! warn("substr outside of string"); RETPUSHUNDEF; } else { --- 1736,1743 ---- rem -= pos; } if (fail < 0) { ! if (lvalue || ckWARN(WARN_SUBSTR)) ! warner(WARN_SUBSTR, "substr outside of string"); RETPUSHUNDEF; } else { *************** *** 1747,1754 **** 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); --- 1747,1755 ---- 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); *************** *** 2386,2393 **** SV *val = NEWSV(46, 0); if (MARK < SP) sv_setsv(val, *++MARK); ! else if (dowarn) ! warn("Odd number of elements in hash list"); (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; --- 2387,2394 ---- SV *val = NEWSV(46, 0); if (MARK < SP) sv_setsv(val, *++MARK); ! else if (ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Odd number of elements in hash list"); (void)hv_store_ent(hv,key,val,0); } SP = ORIGMARK; *************** *** 2797,2804 **** default: croak("Invalid type in unpack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ ! if (commas++ == 0 && dowarn) ! warn("Invalid type in unpack: '%c'", (int)datumtype); break; case '%': if (len == 1 && pat[-1] != '1') --- 2798,2805 ---- default: croak("Invalid type in unpack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ ! if (commas++ == 0 && ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype); break; case '%': if (len == 1 && pat[-1] != '1') *************** *** 3577,3584 **** default: croak("Invalid type in pack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ ! if (commas++ == 0 && dowarn) ! warn("Invalid type in pack: '%c'", (int)datumtype); break; case '%': DIE("%% may only be used in unpack"); --- 3578,3585 ---- default: croak("Invalid type in pack: '%c'", (int)datumtype); case ',': /* grandfather in commas but with a warning */ ! if (commas++ == 0 && ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype); break; case '%': DIE("%% may only be used in unpack"); *************** *** 3950,3957 **** * of pack() (and all copies of the result) are * gone. */ ! if (dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr))) ! warn("Attempt to pack pointer to temporary value"); if (SvPOK(fromstr) || SvNIOK(fromstr)) aptr = SvPV(fromstr,na); else --- 3951,3959 ---- * of pack() (and all copies of the result) are * gone. */ ! if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr))) ! warner(WARN_UNSAFE, ! "Attempt to pack pointer to temporary value"); if (SvPOK(fromstr) || SvNIOK(fromstr)) aptr = SvPV(fromstr,na); else *** pp_ctl.c.orig Tue Sep 9 16:55:36 1997 --- pp_ctl.c Thu Oct 16 22:46:11 1997 *************** *** 318,325 **** sv = *++MARK; else { sv = &sv_no; ! if (dowarn) ! warn("Not enough format arguments"); } break; --- 318,325 ---- sv = *++MARK; else { sv = &sv_no; ! if (ckWARN(WARN_SYNTAX)) ! warner(WARN_SYNTAX, "Not enough format arguments"); } break; *************** *** 857,876 **** 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 || --- 857,880 ---- 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 || *************** *** 963,982 **** 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 #%ld)\n", (long)i)); --- 967,990 ---- 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 #%ld)\n", (long)i)); *************** *** 1776,1782 **** 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(); --- 1784,1790 ---- 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(); *************** *** 2354,2359 **** --- 2362,2369 ---- 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 */ *************** *** 2406,2411 **** --- 2416,2426 ---- 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 Wed Oct 8 15:51:20 1997 --- pp_hot.c Thu Oct 16 23:04:56 1997 *************** *** 289,311 **** 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; --- 289,313 ---- 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; *************** *** 392,399 **** if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "an ARRAY"); ! if (dowarn) ! warn(warn_uninit); if (GIMME == G_ARRAY) RETURN; RETPUSHUNDEF; --- 394,401 ---- if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "an ARRAY"); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); if (GIMME == G_ARRAY) RETURN; RETPUSHUNDEF; *************** *** 467,474 **** if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a HASH"); ! if (dowarn) ! warn(warn_uninit); if (GIMME == G_ARRAY) { SP--; RETURN; --- 469,476 ---- if (op->op_flags & OPf_REF || op->op_private & HINT_STRICT_REFS) DIE(no_usym, "a HASH"); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); if (GIMME == G_ARRAY) { SP--; RETURN; *************** *** 601,608 **** } TAINT_NOT; } ! if (relem == lastrelem && dowarn) ! warn("Odd number of elements in hash list"); } break; default: --- 603,610 ---- } TAINT_NOT; } ! if (relem == lastrelem && ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Odd number of elements in hash list"); } break; default: *************** *** 1088,1095 **** 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; --- 1090,1098 ---- 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; *************** *** 1855,1861 **** if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ ! if (CvDEPTH(cv) == 100 && dowarn && !(PERLDB_SUB && cv == GvCV(DBsub))) sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { --- 1858,1864 ---- if (CvDEPTH(cv) < 2) (void)SvREFCNT_inc(cv); else { /* save temporaries on recursion? */ ! if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION) && !(PERLDB_SUB && cv == GvCV(DBsub))) sub_crush_depth(cv); if (CvDEPTH(cv) > AvFILL(padlist)) { *************** *** 1942,1952 **** 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)); } } --- 1945,1956 ---- 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 Wed Oct 8 15:10:30 1997 --- pp_sys.c Thu Oct 16 22:46:14 1997 *************** *** 570,576 **** sv = POPs; ! if (dowarn) { MAGIC * mg ; if (SvMAGICAL(sv)) { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) --- 570,576 ---- sv = POPs; ! if (ckWARN(WARN_UNTIE)) { MAGIC * mg ; if (SvMAGICAL(sv)) { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) *************** *** 579,586 **** 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 ) ; } } --- 579,587 ---- 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 ) ; } } *************** *** 1064,1081 **** 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)) --- 1065,1082 ---- 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)) *************** *** 1130,1149 **** sv = NEWSV(0,0); 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; --- 1131,1152 ---- sv = NEWSV(0,0); 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; *************** *** 1355,1365 **** 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) { --- 1358,1368 ---- 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) { *************** *** 1743,1750 **** RETPUSHUNDEF; nuts: ! if (dowarn) ! warn("bind() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1746,1753 ---- RETPUSHUNDEF; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "bind() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1773,1780 **** RETPUSHUNDEF; nuts: ! if (dowarn) ! warn("connect() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1776,1783 ---- RETPUSHUNDEF; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "connect() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1799,1806 **** RETPUSHUNDEF; nuts: ! if (dowarn) ! warn("listen() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1802,1809 ---- RETPUSHUNDEF; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "listen() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1853,1860 **** RETURN; nuts: ! if (dowarn) ! warn("accept() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); badexit: --- 1856,1863 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "accept() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); badexit: *************** *** 1880,1887 **** RETURN; nuts: ! if (dowarn) ! warn("shutdown() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1883,1890 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "shutdown() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1958,1965 **** RETURN; nuts: ! if (dowarn) ! warn("[gs]etsockopt() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; --- 1961,1968 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "[gs]etsockopt() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; *************** *** 2031,2038 **** RETURN; nuts: ! if (dowarn) ! warn("get{sock, peer}name() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; --- 2034,2041 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "get{sock, peer}name() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; *************** *** 2089,2096 **** #endif laststatval = Stat(SvPV(statname, na), &statcache); if (laststatval < 0) { ! if (dowarn && strchr(SvPV(statname, na), '\n')) ! warn(warn_nl, "stat"); max = 0; } } --- 2092,2099 ---- #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; } } *************** *** 2494,2501 **** len = 512; } else { ! if (dowarn) ! warn("Test on unopened file <%s>", GvENAME(cGVOP->op_gv)); SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; --- 2497,2504 ---- len = 512; } else { ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "Test on unopened file <%s>", GvENAME(cGVOP->op_gv)); SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; *************** *** 2513,2520 **** 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); --- 2516,2523 ---- 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 Mon Oct 6 18:20:06 1997 --- proto.h Thu Oct 16 22:46:15 1997 *************** *** 527,532 **** --- 527,533 ---- void vivify_ref _((SV* sv, U32 to_what)); I32 wait4pid _((int pid, int* statusp, int flags)); void warn _((const char* pat,...)); + void warner _((U32 err, const char* pat,...)); void watch _((char** addr)); I32 whichsig _((char* sig)); int yyerror _((char* s)); *** regcomp.c.orig Fri Sep 19 15:04:02 1997 --- regcomp.c Thu Oct 16 22:46:16 1997 *************** *** 727,734 **** goto do_curly; } nest_check: ! if (dowarn && regcode != ®dummy && !(flags&HASWIDTH) && max > 10000) { ! warn("%.*s matches null string many times", regparse - origparse, origparse); } --- 727,734 ---- 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 Mon Oct 6 19:03:36 1997 --- sv.c Thu Oct 16 22:46:18 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 *************** *** 1262,1269 **** if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); if (!SvROK(sv)) { ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); return 0; } } --- 1262,1269 ---- if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); if (!SvROK(sv)) { ! if (ckWARN(WARN_UNINITIALIZED) && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } } *************** *** 1285,1292 **** } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); ! if (dowarn) ! warn(warn_uninit); return 0; } } --- 1285,1292 ---- } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } } *************** *** 1313,1320 **** 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", --- 1313,1320 ---- 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", *************** *** 1337,1344 **** if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); if (!SvROK(sv)) { ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); return 0; } } --- 1337,1344 ---- if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); if (!SvROK(sv)) { ! if (ckWARN(WARN_UNINITIALIZED) && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } } *************** *** 1357,1364 **** } if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); ! if (dowarn) ! warn(warn_uninit); return 0; } } --- 1357,1364 ---- } if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } } *************** *** 1382,1389 **** 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", --- 1382,1389 ---- 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", *************** *** 1402,1408 **** 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)); --- 1402,1408 ---- 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)); *************** *** 1410,1417 **** if (SvIOKp(sv)) return (double)SvIVX(sv); if (!SvROK(sv)) { ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); return 0; } } --- 1410,1417 ---- if (SvIOKp(sv)) return (double)SvIVX(sv); if (!SvROK(sv)) { ! if (ckWARN(WARN_UNINITIALIZED) && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } } *************** *** 1426,1440 **** } 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; } } --- 1426,1440 ---- } 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; } } *************** *** 1455,1468 **** 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); --- 1455,1468 ---- 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); *************** *** 1481,1487 **** if (numtype == 1) return atol(SvPVX(sv)); ! if (!numtype && dowarn) not_a_number(sv); SET_NUMERIC_STANDARD(); d = atof(SvPVX(sv)); --- 1481,1487 ---- if (numtype == 1) return atol(SvPVX(sv)); ! if (!numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); SET_NUMERIC_STANDARD(); d = atof(SvPVX(sv)); *************** *** 1501,1507 **** if (numtype == 1) return strtoul(SvPVX(sv), Null(char**), 10); #endif ! if (!numtype && dowarn) not_a_number(sv); SET_NUMERIC_STANDARD(); return U_V(atof(SvPVX(sv))); --- 1501,1507 ---- if (numtype == 1) return strtoul(SvPVX(sv), Null(char**), 10); #endif ! if (!numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); SET_NUMERIC_STANDARD(); return U_V(atof(SvPVX(sv))); *************** *** 1618,1625 **** goto tokensave; } if (!SvROK(sv)) { ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); *lp = 0; return ""; } --- 1618,1625 ---- goto tokensave; } if (!SvROK(sv)) { ! if (ckWARN(WARN_UNINITIALIZED) && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); *lp = 0; return ""; } *************** *** 1677,1684 **** tsv = Nullsv; goto tokensave; } ! if (dowarn) ! warn(warn_uninit); *lp = 0; return ""; } --- 1677,1684 ---- tsv = Nullsv; goto tokensave; } ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); *lp = 0; return ""; } *************** *** 1725,1732 **** SvIOKp_on(sv); } else { ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); *lp = 0; return ""; } --- 1725,1732 ---- SvIOKp_on(sv); } else { ! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); *lp = 0; return ""; } *************** *** 2033,2041 **** if (cv_const_sv(cv)) warn("Constant subroutine %s redefined", GvENAME((GV*)dstr)); ! else if (dowarn) ! warn("Subroutine %s redefined", ! GvENAME((GV*)dstr)); } cv_ckproto(cv, (GV*)dstr, SvPOK(sref) ? SvPVX(sref) : Nullch); --- 2033,2042 ---- if (cv_const_sv(cv)) warn("Constant subroutine %s redefined", GvENAME((GV*)dstr)); ! else if (ckWARN(WARN_REDEFINE)) ! warner(WARN_REDEFINE, ! "Subroutine %s redefined", ! GvENAME((GV*)dstr)); } cv_ckproto(cv, (GV*)dstr, SvPOK(sref) ? SvPVX(sref) : Nullch); *************** *** 4636,4642 **** default: unknown: ! if (!args && dowarn && (op->op_type == OP_PRTF || op->op_type == OP_SPRINTF)) { SV *msg = sv_newmortal(); sv_setpvf(msg, "Invalid conversion in %s: ", --- 4637,4643 ---- default: unknown: ! if (!args && ckWARN(WARN_PRINTF) && (op->op_type == OP_PRTF || op->op_type == OP_SPRINTF)) { SV *msg = sv_newmortal(); sv_setpvf(msg, "Invalid conversion in %s: ", *************** *** 4646,4652 **** c & 0xFF); else sv_catpv(msg, "end of string"); ! warn("%_", msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ --- 4647,4653 ---- c & 0xFF); else sv_catpv(msg, "end of string"); ! warner(WARN_PRINTF, "%_", msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ *** t/op/tie.t.orig Tue Nov 19 00:06:36 1996 --- t/op/tie.t Thu Oct 16 22:46:19 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 Wed Jan 1 18:04:45 1997 --- t/pragma/warn-1global Thu Oct 16 22:46:20 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 Sun Oct 19 10:24:17 1997 --- t/pragma/warn-2use Thu Oct 16 22:46:20 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 Sun Oct 19 10:24:17 1997 --- t/pragma/warn-3both Thu Oct 16 22:46:21 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 Sun Oct 19 10:24:17 1997 --- t/pragma/warn-4lint Thu Oct 16 22:46:21 1997 *************** *** 0 **** --- 1,60 ---- + 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 "no warning" is zapped + no warning ; + $a = $b = 1 ; + $a = 1 if $a EQ $b ; + close STDIN ; print STDIN "abc" ; + EXPECT + Use of EQ is deprecated at - line 5. + print on closed filehandle main::STDIN at - line 6. + ######## + -W + # lint: check "no warning" is zapped + { + no warning ; + close STDIN ; print STDIN "abc" ; + } + EXPECT + print on closed filehandle main::STDIN at - line 5. + ######## + -Ww + # lint: check combination of -w and -W + { + $^W = 0 ; + close STDIN ; print STDIN "abc" ; + } + EXPECT + print on closed filehandle main::STDIN at - line 5. *** /dev/null Sun Oct 19 10:24:17 1997 --- t/pragma/warn-doio Thu Oct 16 22:46:21 1997 *************** *** 0 **** --- 1,94 ---- + doio.c AOK + + Can't do bidirectional pipe + open(F, "| true |"); + + warn(warn_nl, "open"); + open(F, "true\ncd") + + Close on unopened file <%s> + $a = "fred";close($a) + + tell() on unopened file + $a = "fred";$a = tell($a) + + seek() on unopened file + $a = "fred";$a = seek($a,1,1) + + sysseek() on unopened file + $a = "fred";$a = seek($a,1,1) + + warn(warn_uninit); + print $a ; + + Stat on unopened file <%s> + close STDIN ; -x STDIN ; + + warn(warn_nl, "stat"); + stat "ab\ncd" + + warn(warn_nl, "lstat"); + lstat "ab\ncd" + + Can't exec \"%s\": %s + + Can't exec \"%s\": %s + + + __END__ + # doio.c + use warning 'io' ; + open(F, "|true|") + EXPECT + Can't do bidirectional pipe at - line 3. + ######## + # doio.c + use warning 'io' ; + open(F, " at - line 7. + ######## + # doio.c + use warning 'uninitialized' ; + print $a ; + EXPECT + Use of uninitialized value at - line 3. + ######## + # doio.c + use warning 'io' ; + + EXPECT + + ######## + # doio.c + use warning 'io' ; + stat "ab\ncd"; + lstat "ab\ncd"; + EXPECT + Unsuccessful stat on filename containing newline at - line 3. + Unsuccessful stat on filename containing newline at - line 4. + ######## + # doio.c + use warning 'io' ; + exec "lskdjfalksdjfdjfkls" ; + EXPECT + Can't exec "lskdjfalksdjfdjfkls": No such file or directory at - line 3. + ######## + # doio.c + use warning 'io' ; + exec "lskdjfalksdjfdjfkls", "abc" ; + EXPECT + Can't exec "lskdjfalksdjfdjfkls": No such file or directory at - line 3. *** /dev/null Sun Oct 19 10:24:17 1997 --- t/pragma/warn-gv Thu Oct 16 22:46:22 1997 *************** *** 0 **** --- 1,40 ---- + gv.c AOK + + Can't locate package %s for @%s::ISA + @ISA = qw(Fred); joe() + + Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated + sub Other::AUTOLOAD { 1 } sub Other::fred {} + @ISA = qw(Other) ; + fred() ; + + Use of $# is deprecated + Use of $* is deprecated + + $a = ${"#"} ; + $a = ${"*"} ; + + + __END__ + # gv.c + use warning 'misc' ; + @ISA = qw(Fred); joe() + EXPECT + Can't locate package Fred for @main::ISA at - line 3. + Undefined subroutine &main::joe called at - line 3. + ######## + # gv.c + sub Other::AUTOLOAD { 1 } sub Other::fred {} + @ISA = qw(Other) ; + use warning 'deprecated' ; + fred() ; + EXPECT + Use of inherited AUTOLOAD for non-method main::fred() is deprecated at - line 5. + ######## + # gv.c + use warning 'deprecated' ; + $a = ${"#"}; + $a = ${"*"}; + EXPECT + Use of $# is deprecated at - line 3. + Use of $* is deprecated at - line 4. *** /dev/null Sun Oct 19 10:24:17 1997 --- t/pragma/warn-mg Thu Oct 16 22:46:23 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 Sun Oct 19 10:24:17 1997 --- t/pragma/warn-op Fri Oct 17 09:05:35 1997 *************** *** 0 **** --- 1,552 ---- + op.c AOK + + "my" variable %s masks earlier declaration in same scope + my $x; + my $x ; + + Variable "%s" may be unavailable + sub x { + my $x; + sub y { + $x + } + } + + Variable "%s" will not stay shared + sub x { + my $x; + sub y { + sub { $x } + } + } + + Found = in conditional, should be == + 1 if $a = 1 ; + + Use of implicit split to @_ is deprecated + split ; + + Use of implicit split to @_ is deprecated + $a = split ; + + Useless use of time in void context + Useless use of a variable in void context + Useless use of a constant in void context + time ; + $a ; + "abc" + + Applying %s to %s will act on scalar(%s) + my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ; + @a =~ /abc/ ; + @a =~ s/a/b/ ; + @a =~ tr/a/b/ ; + @$b =~ /abc/ ; + @$b =~ s/a/b/ ; + @$b =~ tr/a/b/ ; + %a =~ /abc/ ; + %a =~ s/a/b/ ; + %a =~ tr/a/b/ ; + %$c =~ /abc/ ; + %$c =~ s/a/b/ ; + %$c =~ tr/a/b/ ; + + + Parens missing around "my" list at -e line 1. + my $a, $b = (1,2); + + Parens missing around "local" list at -e line 1. + local $a, $b = (1,2); + + Probable precedence problem on logical or at -e line 1. + use warning 'syntax'; my $x = print(ABC || 1); + + Value of %s may be \"0\"; use \"defined\" + $x = 1 if $x = ; + $x = 1 while $x = ; + + Subroutine fred redefined at -e line 1. + sub fred{1;} sub fred{1;} + + Constant subroutine %s redefined + sub fred() {1;} sub fred() {1;} + + Format FRED redefined at /tmp/x line 5. + format FRED = + . + format FRED = + . + + Array @%s missing the @ in argument %d of %s() + push fred ; + + Hash %%%s missing the %% in argument %d of %s() + keys joe ; + + Statement unlikely to be reached + (Maybe you meant system() when you said exec()? + exec "true" ; my $a + + + __END__ + # op.c + use warning 'unsafe' ; + my $x ; + my $x ; + EXPECT + "my" variable $x masks earlier declaration in same scope at - line 4. + ######## + # op.c + use warning 'unsafe' ; + sub x { + my $x; + sub y { + $x + } + } + EXPECT + Variable "$x" will not stay shared at - line 7. + ######## + # op.c + use warning 'unsafe' ; + sub x { + my $x; + sub y { + sub { $x } + } + } + EXPECT + Variable "$x" may be unavailable at - line 6. + ######## + # op.c + use warning 'syntax' ; + 1 if $a = 1 ; + EXPECT + Found = in conditional, should be == at - line 3. + ######## + # op.c + use warning 'deprecated' ; + split ; + EXPECT + Use of implicit split to @_ is deprecated at - line 3. + ######## + # op.c + use warning 'deprecated' ; + $a = split ; + EXPECT + Use of implicit split to @_ is deprecated at - line 3. + ######## + # op.c + use warning 'void' ; close STDIN ; + 1 x 3 ; # OP_REPEAT + # OP_GVSV + wantarray ; # OP_WANTARRAY + # OP_GV + # OP_PADSV + # OP_PADAV + # OP_PADHV + # OP_PADANY + # OP_AV2ARYLEN + ref ; # OP_REF + \@a ; # OP_REFGEN + \$a ; # OP_SREFGEN + defined $a ; # OP_DEFINED + hex $a ; # OP_HEX + oct $a ; # OP_OCT + length $a ; # OP_LENGTH + substr $a,1 ; # OP_SUBSTR + vec $a,1,2 ; # OP_VEC + index $a,1,2 ; # OP_INDEX + rindex $a,1,2 ; # OP_RINDEX + sprintf $a ; # OP_SPRINTF + $a[0] ; # OP_AELEM + # OP_AELEMFAST + @a[0] ; # OP_ASLICE + #values %a ; # OP_VALUES + #keys %a ; # OP_KEYS + $a{0} ; # OP_HELEM + @a{0} ; # OP_HSLICE + unpack "a", "a" ; # OP_UNPACK + pack $a,"" ; # OP_PACK + join "" ; # OP_JOIN + (@a)[0,1] ; # OP_LSLICE + # OP_ANONLIST + # OP_ANONHASH + sort(1,2) ; # OP_SORT + reverse(1,2) ; # OP_REVERSE + # OP_RANGE + # OP_FLIP + (1 ..2) ; # OP_FLOP + caller ; # OP_CALLER + fileno STDIN ; # OP_FILENO + eof STDIN ; # OP_EOF + tell STDIN ; # OP_TELL + readlink 1; # OP_READLINK + time ; # OP_TIME + localtime ; # OP_LOCALTIME + gmtime ; # OP_GMTIME + getgrnam 1; # OP_GGRNAM + getgrgid 1 ; # OP_GGRGID + getpwnam 1; # OP_GPWNAM + getpwuid 1; # OP_GPWUID + EXPECT + Useless use of repeat in void context at - line 3. + Useless use of wantarray in void context at - line 5. + Useless use of reference-type operator in void context at - line 12. + Useless use of reference constructor in void context at - line 13. + Useless use of scalar ref constructor in void context at - line 14. + Useless use of defined operator in void context at - line 15. + Useless use of hex in void context at - line 16. + Useless use of oct in void context at - line 17. + Useless use of length in void context at - line 18. + Useless use of substr in void context at - line 19. + Useless use of vec in void context at - line 20. + Useless use of index in void context at - line 21. + Useless use of rindex in void context at - line 22. + Useless use of sprintf in void context at - line 23. + Useless use of array element in void context at - line 24. + Useless use of array slice in void context at - line 26. + Useless use of hash elem in void context at - line 29. + Useless use of hash slice in void context at - line 30. + Useless use of unpack in void context at - line 31. + Useless use of pack in void context at - line 32. + Useless use of join in void context at - line 33. + Useless use of list slice in void context at - line 34. + Useless use of sort in void context at - line 37. + Useless use of reverse in void context at - line 38. + Useless use of range (or flop) in void context at - line 41. + Useless use of caller in void context at - line 42. + Useless use of fileno in void context at - line 43. + Useless use of eof in void context at - line 44. + Useless use of tell in void context at - line 45. + Useless use of readlink in void context at - line 46. + Useless use of time in void context at - line 47. + Useless use of localtime in void context at - line 48. + Useless use of gmtime in void context at - line 49. + Useless use of getgrnam in void context at - line 50. + Useless use of getgrgid in void context at - line 51. + Useless use of getpwnam in void context at - line 52. + Useless use of getpwuid in void context at - line 53. + ######## + # op.c + use warning 'void' ; + use Config ; + BEGIN { + if ( ! $Config{d_telldir}) { + print < ; + EXPECT + Value of construct can be "0"; test with defined() at - line 4. + ######## + --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() operator can be "0"; test with defined() at - line 4. + ######## + # op.c + use warning 'unsafe' ; + $x = 1 if $x = <*> ; + EXPECT + Value of glob construct can be "0"; test with defined() at - line 3. + ######## + # op.c + use warning 'unsafe' ; + %a = (1,2,3,4) ; + $x = 1 if $x = each %a ; + EXPECT + Value of each() operator can be "0"; test with defined() at - line 4. + ######## + # op.c + use warning 'unsafe' ; + %a = (1,2,3,4) ; + $x = 1 while $x = each %a ; + EXPECT + Value of each() operator can be "0"; test with defined() at - line 4. + ######## + # op.c + use warning 'unsafe' ; + $x = 1 while $x = <*> and 0 ; + EXPECT + Value of glob construct can be "0"; test with defined() at - line 3. + ######## + # op.c + use warning 'unsafe' ; + opendir FH, "." ; + $x = 1 while $x = readdir FH and 0 ; + closedir FH ; + EXPECT + Value of readdir() operator can be "0"; test with defined() at - line 4. + ######## + # op.c + use warning 'redefine' ; + sub fred {} + sub fred {} + EXPECT + Subroutine fred redefined at - line 4. + ######## + # op.c + use warning 'redefine' ; + sub fred () { 1 } + sub fred () { 1 } + EXPECT + Constant subroutine fred redefined at - line 4. + ######## + # op.c + use warning 'redefine' ; + format FRED = + . + format FRED = + . + EXPECT + Format FRED redefined at - line 5. + ######## + # op.c + use warning 'syntax' ; + push FRED; + EXPECT + Array @FRED missing the @ in argument 1 of push() at - line 3. + ######## + # op.c + use warning 'syntax' ; + @a = keys FRED ; + EXPECT + Hash %FRED missing the % in argument 1 of keys() at - line 3. + ######## + # op.c + use warning 'syntax' ; + exec "true" ; + my $a + EXPECT + Statement unlikely to be reached at - line 4. + (Maybe you meant system() when you said exec()?) *** /dev/null Sun Oct 19 10:24:17 1997 --- t/pragma/warn-perl Thu Oct 16 22:46:27 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 Sun Oct 19 10:24:17 1997 --- t/pragma/warn-perly Thu Oct 16 22:46:27 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 Sun Oct 19 10:24:17 1997 --- t/pragma/warn-pp Fri Oct 17 09:51:24 1997 *************** *** 0 **** --- 1,73 ---- + 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 + + uninitialized << + close STDIN ; $a = ; + + Deep recursion on subroutine \"%s\" + sub fred { fred() if $a++ < 200} fred() + + Deep recursion on anonymous subroutine + $a = sub { &$a if $a++ < 200} &$a + + __END__ + # pp_hot.c + use warning 'unopened' ; + $f = $a = "abc" ; + print $f $a + EXPECT + Filehandle main::abc never opened at - line 4. + ######## + # pp_hot.c + use warning 'io' ; + print STDIN "anc"; + EXPECT + Filehandle main::STDIN opened only for input at - line 3. + ######## + # pp_hot.c + use warning 'closed' ; + close STDIN ; + print STDIN "anc"; + EXPECT + print on closed filehandle main::STDIN at - line 4. + ######## + # pp_hot.c + use warning 'uninitialized' ; + my $a = undef ; + my @b = @$a + EXPECT + Use of uninitialized value at - line 4. + ######## + # pp_hot.c + use warning 'uninitialized' ; + my $a = undef ; + my %b = %$a + EXPECT + Use of uninitialized value at - line 4. + ######## + # pp_hot.c + use warning 'unsafe' ; + my %X ; %X = (1,2,3) ; + EXPECT + Odd number of elements in hash list at - line 3. + ######## + # pp_hot.c + use warning 'closed' ; + close STDIN ; $a = ; + EXPECT + Read on closed filehandle at - line 3. + ######## + # pp_hot.c + use warning 'recursion' ; + sub fred + { + fred() if $a++ < 200 + } + + fred() + EXPECT + Deep recursion on subroutine "main::fred" at - line 5. + ######## + # pp_hot.c + use warning 'recursion' ; + $b = sub + { + &$b if $a++ < 200 + } ; + + &$b ; + EXPECT + Deep recursion on anonymous subroutine at - line 5. *** /dev/null Sun Oct 19 10:24:17 1997 --- t/pragma/warn-pp_sys Thu Oct 16 22:46:30 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 Sun Oct 19 10:24:17 1997 --- t/pragma/warn-regcomp Thu Oct 16 22:46:31 1997 *************** *** 0 **** --- 1,15 ---- + regcomp.c TODO + + %.*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. + EXPECT + *** /dev/null Sun Oct 19 10:24:17 1997 --- t/pragma/warn-sv Fri Oct 17 11:55:44 1997 *************** *** 0 **** --- 1,195 ---- + sv.c AOK + + warn(warn_uninit); + + warn(warn_uninit); + + warn(warn_uninit); + + warn(warn_uninit); + + not_a_number(sv); + + not_a_number(sv); + + warn(warn_uninit); + + not_a_number(sv); + + warn(warn_uninit); + + not_a_number(sv); + + not_a_number(sv); + + warn(warn_uninit); + + warn(warn_uninit); + + Subroutine %s redefined + + Invalid conversion in %s: <<< TODO + + + __END__ + # sv.c + use integer ; + use warning 'uninitialized' ; + $x = 1 + $a[0] ; # a + EXPECT + Use of uninitialized value at - line 4. + ######## + # sv.c (sv_2iv) + package fred ; + sub TIESCALAR { my $x ; bless \$x} + sub FETCH { return undef } + sub STORE { return 1 } + package main ; + tie $A, 'fred' ; + use integer ; + use warning 'uninitialized' ; + $A *= 2 ; + EXPECT + Use of uninitialized value at - line 10. + ######## + # sv.c + use integer ; + use warning 'uninitialized' ; + my $x *= 2 ; #b + EXPECT + Use of uninitialized value at - line 4. + ######## + # sv.c (sv_2uv) + package fred ; + sub TIESCALAR { my $x ; bless \$x} + sub FETCH { return undef } + sub STORE { return 1 } + package main ; + tie $A, 'fred' ; + use warning 'uninitialized' ; + $B = 0 ; + $B |= $A ; + EXPECT + Use of uninitialized value at - line 10. + ######## + # sv.c + use warning 'uninitialized' ; + my $Y = 1 ; + my $x = 1 | $a[$Y] + EXPECT + Use of uninitialized value at - line 4. + ######## + # sv.c + use warning 'uninitialized' ; + my $x *= 1 ; # d + EXPECT + Use of uninitialized value at - line 3. + ######## + # sv.c + use warning 'uninitialized' ; + $x = 1 + $a[0] ; # e + EXPECT + Use of uninitialized value at - line 3. + ######## + # sv.c (sv_2nv) + package fred ; + sub TIESCALAR { my $x ; bless \$x} + sub FETCH { return undef } + sub STORE { return 1 } + package main ; + tie $A, 'fred' ; + use warning 'uninitialized' ; + $A *= 2 ; + EXPECT + Use of uninitialized value at - line 9. + ######## + # sv.c + use warning 'uninitialized' ; + $x = $y + 1 ; # f + EXPECT + Use of uninitialized value at - line 3. + ######## + # sv.c + use warning 'uninitialized' ; + $x = chop undef ; # g + EXPECT + Use of uninitialized value at - line 3. + ######## + # sv.c + use warning 'uninitialized' ; + $x = chop $y ; # h + EXPECT + Use of uninitialized value at - line 3. + ######## + # sv.c (sv_2pv) + package fred ; + sub TIESCALAR { my $x ; bless \$x} + sub FETCH { return undef } + sub STORE { return 1 } + package main ; + tie $A, 'fred' ; + use warning 'uninitialized' ; + $B = "" ; + $B .= $A ; + EXPECT + Use of uninitialized value at - line 10. + ######## + # sv.c + use warning 'numeric' ; + sub TIESCALAR{bless[]} ; + sub FETCH {"def"} ; + tie $a,"main" ; + my $b = 1 + $a + EXPECT + Argument "def" isn't numeric in add at - line 6. + ######## + # sv.c + use warning 'numeric' ; + my $x = 1 + "def" ; + EXPECT + Argument "def" isn't numeric in add at - line 3. + ######## + # sv.c + use warning 'numeric' ; + my $a = "def" ; + my $x = 1 + $a ; + EXPECT + Argument "def" isn't numeric in add at - line 4. + ######## + # sv.c + use warning 'numeric' ; use integer ; + my $a = "def" ; + my $x = 1 + $a ; + EXPECT + Argument "def" isn't numeric in i_add at - line 4. + ######## + # sv.c + use warning 'numeric' ; + my $x = 1 & "def" ; + EXPECT + Argument "def" isn't numeric in bit_and at - line 3. + ######## + # sv.c + use warning 'redefine' ; + sub fred {} + sub joe {} + *fred = \&joe ; + EXPECT + Subroutine fred redefined at - line 5. + ######## + # sv.c + use warning 'printf' ; + open F, ">/dev/null" ; + printf F "%q\n" ; + my $a = sprintf "%q" ; + printf F "%" ; + $a = sprintf "%" ; + printf F "%\x02" ; + $a = sprintf "%\x02" ; + EXPECT + Invalid conversion in sprintf: "%q" at - line 5. + Invalid conversion in sprintf: end of string at - line 7. + Invalid conversion in sprintf: "%\002" at - line 9. + Invalid conversion in printf: "%q" at - line 4. + Invalid conversion in printf: end of string at - line 6. + Invalid conversion in printf: "%\002" at - line 8. *** /dev/null Sun Oct 19 10:24:17 1997 --- t/pragma/warn-taint Thu Oct 16 22:46:32 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 Sun Oct 19 10:24:17 1997 --- t/pragma/warn-toke Thu Oct 16 22:46:33 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 Sun Oct 19 10:24:17 1997 --- t/pragma/warn-universal Thu Oct 16 22:46:34 1997 *************** *** 0 **** --- 1,11 ---- + universal.c + + Can't locate package %s for @%s::ISA + + + __END__ + # universal.c + use warning 'misc' ; + + EXPECT + *** /dev/null Sun Oct 19 10:24:17 1997 --- t/pragma/warn-util Thu Oct 16 22:46:34 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 Fri Mar 21 02:50:35 1997 --- t/pragma/warning.t Thu Oct 16 22:46:34 1997 *************** *** 16,23 **** END { if ($tmpfile) { 1 while unlink $tmpfile} } my @prgs = () ; ! foreach (sort glob("pragma/warn-*")) { next if /(~|\.orig)$/; --- 16,31 ---- 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$/ ; next if /(~|\.orig)$/; *** taint.c.orig Mon Oct 6 17:30:36 1997 --- taint.c Thu Oct 16 22:46:35 1997 *************** *** 26,33 **** ug = " while running with -T switch"; if (!unsafe) croak(f, s, ug); ! else if (dowarn) ! warn(f, s, ug); } } --- 26,33 ---- 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 Fri Sep 19 18:35:31 1997 --- toke.c Thu Oct 16 22:46:38 1997 *************** *** 214,221 **** deprecate(s) char *s; { ! if (dowarn) ! warn("Use of %s is deprecated", s); } static void --- 214,221 ---- deprecate(s) char *s; { ! if (ckWARN(WARN_DEPRECATED)) ! warner(WARN_DEPRECATED, "Use of %s is deprecated", s); } static void *************** *** 813,820 **** 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; } --- 813,820 ---- 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; } *************** *** 1765,1772 **** 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 */ --- 1765,1773 ---- 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 */ *************** *** 1969,1979 **** 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) --- 1970,1981 ---- 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) *************** *** 2115,2123 **** 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); --- 2117,2125 ---- 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); *************** *** 2149,2156 **** 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') ) --- 2151,2158 ---- 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') ) *************** *** 2280,2286 **** char *t; if (*s == '[') { tokenbuf[0] = '@'; ! if (dowarn) { for(t = s + 1; isSPACE(*t) || isALNUM(*t) || *t == '$'; t++) ; --- 2282,2288 ---- char *t; if (*s == '[') { tokenbuf[0] = '@'; ! if (ckWARN(WARN_SYNTAX)) { for(t = s + 1; isSPACE(*t) || isALNUM(*t) || *t == '$'; t++) ; *************** *** 2288,2301 **** 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[sizeof tokenbuf]; --- 2290,2304 ---- 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[sizeof tokenbuf]; *************** *** 2304,2310 **** if (isIDFIRST(*t)) { t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len); if (*t != '(' && perl_get_cv(tmpbuf, FALSE)) ! warn("You need to quote \"%s\"", tmpbuf); } } } --- 2307,2314 ---- if (isIDFIRST(*t)) { t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len); if (*t != '(' && perl_get_cv(tmpbuf, FALSE)) ! warner(WARN_SYNTAX, ! "You need to quote \"%s\"", tmpbuf); } } } *************** *** 2374,2380 **** tokenbuf[0] = '%'; /* Warn about @ where they meant $. */ ! if (dowarn) { if (*s == '[' || *s == '{') { char *t = s + 1; while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t))) --- 2378,2384 ---- 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))) *************** *** 2382,2388 **** if (*t == '}' || *t == ']') { t++; bufptr = skipspace(bufptr); ! warn("Scalar value %.*s better written as $%.*s", t-bufptr, bufptr, t-bufptr-1, bufptr+1); } } --- 2386,2393 ---- 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); } } *************** *** 2484,2491 **** 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); --- 2489,2497 ---- 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); *************** *** 2558,2565 **** /* 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; --- 2564,2572 ---- /* 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; *************** *** 2600,2606 **** if (expect == XOPERATOR) { if (bufptr == linestart) { curcop->cop_line--; ! warn(warn_nosemi); curcop->cop_line++; } else --- 2607,2613 ---- if (expect == XOPERATOR) { if (bufptr == linestart) { curcop->cop_line--; ! warner(WARN_SEMICOLON, warn_nosemi); curcop->cop_line++; } else *************** *** 2738,2748 **** /* 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)) { --- 2745,2755 ---- /* 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)) { *************** *** 2880,2886 **** 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"); --- 2887,2893 ---- 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"); *************** *** 3286,3300 **** 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; } } --- 3293,3309 ---- 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; } } *************** *** 3665,3671 **** 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"); --- 3674,3680 ---- 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"); *************** *** 4360,4366 **** { 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 == '(') --- 4369,4375 ---- { 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 == '(') *************** *** 4371,4377 **** if (*w) for (; *w && isSPACE(*w); w++) ; if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */ ! warn("%s (...) interpreted as function",name); } while (s < bufend && isSPACE(*s)) s++; --- 4380,4386 ---- if (*w) for (; *w && isSPACE(*w); w++) ; if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */ ! warner(WARN_SYNTAX, "%s (...) interpreted as function",name); } while (s < bufend && isSPACE(*s)) s++; *************** *** 4519,4527 **** *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; --- 4528,4537 ---- *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; *************** *** 4536,4544 **** lex_state = LEX_INTERPEND; if (funny == '#') funny = '@'; ! if (dowarn && lex_state == LEX_NORMAL && (keyword(dest, d - dest) || perl_get_cv(dest, FALSE))) ! warn("Ambiguous use of %c{%s} resolved to %c%s", funny, dest, funny, dest); } else { --- 4546,4555 ---- lex_state = LEX_INTERPEND; if (funny == '#') funny = '@'; ! if (ckWARN(WARN_AMBIGUOUS) && lex_state == LEX_NORMAL && (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 { *************** *** 5115,5122 **** floatit = FALSE; while (isDIGIT(*s) || *s == '_') { if (*s == '_') { ! if (dowarn && lastub && s - lastub != 3) ! warn("Misplaced _ in number"); lastub = ++s; } else { --- 5126,5133 ---- 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 { *************** *** 5125,5132 **** *d++ = *s++; } } ! if (dowarn && lastub && s - lastub != 3) ! warn("Misplaced _ in number"); if (*s == '.' && s[1] != '.') { floatit = TRUE; *d++ = *s++; --- 5136,5143 ---- *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 Fri Sep 19 15:04:02 1997 --- universal.c Thu Oct 16 22:46:38 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 Oct 14 14:07:41 1997 --- util.c Fri Oct 17 11:35:47 1997 *************** *** 1218,1246 **** 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() */ --- 1218,1245 ---- 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() */ *************** *** 1278,1303 **** 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) { --- 1277,1323 ---- 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) { *************** *** 1333,1338 **** --- 1353,1405 ---- (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 */ #ifndef WIN32 void *************** *** 2305,2312 **** retval = n | (*s++ - '0'); len--; } ! if (dowarn && len && (*s == '8' || *s == '9')) ! warn("Illegal octal digit ignored"); *retlen = s - start; return retval; } --- 2372,2379 ---- 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 Sun Oct 19 10:24:17 1997 --- warning.h Thu Oct 16 22:46:39 1997 *************** *** 0 **** --- 1,95 ---- + /* !!!!!!! 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_DISABLE 1 */ + #define G_WARN_OFF 0 + #define G_WARN_ON 1 + #define G_WARN_FLAG 2 /* -W flag */ + + #if 1 + + #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) ) + + #else + + #define ckDEAD(x) \ + (curcop->cop_warnings != WARN_ALL && \ + curcop->cop_warnings != WARN_NONE && \ + SvPVX(curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) ) + + #define ckWARN(x) \ + ( (dowarn & G_WARN_ON) || ( (dowarn & G_WARN_DISABLE) && \ + curcop->cop_warnings && \ + ( curcop->cop_warnings == WARN_ALL || \ + SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) ) ) ) + + #define ckWARN2(x,y) \ + ( (dowarn & G_WARN_ON) || ( (dowarn & G_WARN_DISABLE) && \ + curcop->cop_warnings && \ + ( curcop->cop_warnings == WARN_ALL || \ + SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || \ + SvPVX(curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) ) + + #endif + + #define WARN_NONE NULL + #define WARN_ALL (&sv_yes) + + #define WARN_REDEFINE 0 + #define WARN_VOID 1 + #define WARN_UNSAFE 2 + #define WARN_TAINT 3 + #define WARN_SUBSTR 4 + #define WARN_CLOSURE 5 + #define WARN_UNTIE 6 + #define WARN_SIGNAL 7 + #define WARN_NUMERIC 8 + #define WARN_ONCE 9 + #define WARN_SYNTAX 10 + #define WARN_RESERVED 11 + #define WARN_DEPRECATED 12 + #define WARN_SEMICOLON 13 + #define WARN_PRINTF 14 + #define WARN_OCTAL 15 + #define WARN_AMBIGUOUS 16 + #define WARN_PARENTHESIS 17 + #define WARN_PRECEDENCE 18 + #define WARN_IO 19 + #define WARN_NEWLINE 20 + #define WARN_CLOSED 21 + #define WARN_EXEC 22 + #define WARN_UNOPENED 23 + #define WARN_PIPE 24 + #define WARN_UNINITIALIZED 25 + #define WARN_RECURSION 26 + #define WARN_MISC 27 + + #define WARNsize 7 + #define WARN_ALLstring "\125\125\125\125\125\125\125" + #define WARN_NONEstring "\0\0\0\0\0\0\0" + + /* end of file warning.h */ + *** /dev/null Sun Oct 19 10:24:17 1997 --- warning.pl Thu Oct 16 22:46:39 1997 *************** *** 0 **** --- 1,347 ---- + #!/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, + 'printf' => 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! + */ + + + /* sWarning is used for "(S) A severe warning (mandatory)." + #define sWarning warning + + #define Off(x) ((x) / 8) + #define Bit(x) (1 << ((x) % 8)) + #define IsSet(a, x) ((a)[Off(x)] & Bit(x)) + + /* #define G_WARN_DISABLE 1 */ + #define G_WARN_OFF 0 + #define G_WARN_ON 1 + #define G_WARN_FLAG 2 /* -W flag */ + + #if 1 + + #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) ) + + #else + + #define ckDEAD(x) \ + (curcop->cop_warnings != WARN_ALL && \ + curcop->cop_warnings != WARN_NONE && \ + SvPVX(curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) ) + + #define ckWARN(x) \ + ( (dowarn & G_WARN_ON) || ( (dowarn & G_WARN_DISABLE) && \ + curcop->cop_warnings && \ + ( curcop->cop_warnings == WARN_ALL || \ + SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) ) ) ) + + #define ckWARN2(x,y) \ + ( (dowarn & G_WARN_ON) || ( (dowarn & G_WARN_DISABLE) && \ + curcop->cop_warnings && \ + ( curcop->cop_warnings == WARN_ALL || \ + SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || \ + SvPVX(curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) ) + + #endif + + #define WARN_NONE NULL + #define WARN_ALL (&sv_yes) + + EOM + + + $index = 0 ; + @{ $list{"all"} } = walk ($tree) ; + + $index *= 2 ; + $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'; + + /* end of file warning.h */ + + EOM + + close WARN ; + + while () { + last if /^KEYWORDS$/ ; + print PM $_ ; + } + + $list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ; + print PM "%Bits = (\n" ; + foreach $k (sort keys %list) { + + $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') ; + } + + + sub make_fatal + { + my $self = shift ; + my $bitmask = $self->bits(@_) ; + $SIG{__WARN__} = + sub + { + die @_ if $^B & $bitmask ; + warn @_ + } ; + } + + sub bitmask + { + return $^B ; + } + + sub enabled + { + my $string = shift ; + + return 1 + if $bits{$string} && $^B & $bits{$string} ; + + return 0 ; + } + + 1;