# See README.warning for information of what the patch does. exit 0 ----------------------------------------------------------------------- *** MANIFEST.orig Thu Oct 16 17:54:33 1997 --- MANIFEST Thu Oct 16 23:21:55 1997 *************** *** 475,480 **** --- 475,481 ---- 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 *************** *** 797,802 **** --- 798,820 ---- 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 thread.h Threading header *************** *** 847,852 **** --- 865,872 ---- 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 Thu Oct 16 17:45:50 1997 --- Makefile.SH Thu Oct 16 23:32:59 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 thread.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 thread.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 23:21:57 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 Fri Oct 3 16:49:23 1997 --- cop.h Thu Oct 16 23:21:57 1997 *************** *** 15,20 **** --- 15,21 ---- U32 cop_seq; /* parse sequence number */ I32 cop_arybase; /* array base this line was compiled with */ line_t cop_line; /* line # of this command */ + SV * cop_warnings; /* lexical warnings bitmask */ }; #define Nullcop Null(COP*) *** doio.c.orig Wed Oct 8 17:17:12 1997 --- doio.c Thu Oct 16 23:21:58 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) && *************** *** 581,588 **** } 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); --- 581,588 ---- } 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); *************** *** 677,684 **** #endif return PerlIO_tell(fp); } ! if (dowarn) ! warn("tell() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return -1L; } --- 677,684 ---- #endif return PerlIO_tell(fp); } ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "tell() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return -1L; } *************** *** 699,706 **** #endif return PerlIO_seek(fp, pos, whence) >= 0; } ! if (dowarn) ! warn("seek() on unopened file"); SETERRNO(EBADF,RMS$_IFI); return FALSE; } --- 699,706 ---- #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; } *************** *** 716,723 **** 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; } --- 716,723 ---- 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; } *************** *** 799,806 **** } switch (SvTYPE(sv)) { case SVt_NULL: ! if (dowarn) ! warn(warn_uninit); return TRUE; case SVt_IV: if (SvIOK(sv)) { --- 799,806 ---- } switch (SvTYPE(sv)) { case SVt_NULL: ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); return TRUE; case SVt_IV: if (SvIOK(sv)) { *************** *** 841,848 **** else { if (tmpgv == defgv) return laststatval; ! if (dowarn) ! warn("Stat on unopened file <%s>", GvENAME(tmpgv)); statgv = Nullgv; sv_setpv(statname,""); --- 841,848 ---- 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,""); *************** *** 865,872 **** 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; } } --- 865,872 ---- 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; } } *************** *** 897,904 **** #else laststatval = Stat(SvPV(sv, na),&statcache); #endif ! if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n')) ! warn(warn_nl, "lstat"); return laststatval; } --- 897,904 ---- #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; } *************** *** 928,935 **** execvp(tmps,Argv); else execvp(Argv[0],Argv); ! if (dowarn) ! warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno)); } do_execfree(); return FALSE; --- 928,936 ---- 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; *************** *** 1032,1039 **** do_execfree(); goto doshell; } ! if (dowarn) ! warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno)); } do_execfree(); return FALSE; --- 1033,1041 ---- 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 Thu Oct 16 17:45:53 1997 --- global.sym Thu Oct 16 23:21:58 1997 *************** *** 1169,1174 **** --- 1169,1175 ---- utilize wait4pid warn + warner watch whichsig xiv_arenaroot *** gv.c.orig Thu Oct 16 17:45:53 1997 --- gv.c Thu Oct 16 23:21:58 1997 *************** *** 203,210 **** 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; } --- 203,210 ---- 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; } *************** *** 344,351 **** /* * 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); --- 344,352 ---- /* * 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); *************** *** 703,710 **** case '#': case '*': ! if (dowarn && len == 1 && sv_type == SVt_PV) ! warn("Use of $%s is deprecated", name); /* FALL THROUGH */ case '[': case '!': --- 704,711 ---- 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 '!': *************** *** 723,728 **** --- 724,730 ---- case '/': case '|': case '\001': + case '\002': case '\004': case '\005': case '\006': *************** *** 872,878 **** 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)); } } --- 874,881 ---- 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 Thu Oct 16 17:45:54 1997 --- interp.sym Thu Oct 16 23:21:59 1997 *************** *** 70,75 **** --- 70,76 ---- laststatval laststype leftgv + lexwarn lineary localizing localpatches *** lib/diagnostics.pm.orig Thu Oct 16 17:45:56 1997 --- lib/diagnostics.pm Thu Oct 16 23:21:59 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 Thu Oct 16 17:45:56 1997 --- mg.c Thu Oct 16 23:22:00 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; *************** *** 410,416 **** #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 '&': --- 448,454 ---- #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 '&': *************** *** 813,820 **** 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]); --- 851,858 ---- 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]); *************** *** 1377,1382 **** --- 1415,1432 ---- 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()); *************** *** 1422,1428 **** #endif break; case '\027': /* ^W */ ! dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)); break; case '.': if (localizing) { --- 1472,1479 ---- #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) { *************** *** 1822,1829 **** 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; } --- 1873,1880 ---- 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 Thu Oct 16 17:45:56 1997 --- op.c Fri Oct 17 12:27:09 1997 *************** *** 119,125 **** } 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]) --- 119,125 ---- } 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]) *************** *** 127,133 **** && SvIVX(sv) == 999999999 /* var is in open scope */ && strEQ(name, SvPVX(sv))) { ! warn("\"my\" variable %s masks earlier declaration in same scope", name); break; } } --- 127,135 ---- && 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; } } *************** *** 233,240 **** if (CvANON(bcv)) CvCLONE_on(bcv); else { ! if (dowarn && !CvUNIQUE(cv)) ! warn( "Variable \"%s\" may be unavailable", name); break; --- 235,242 ---- if (CvANON(bcv)) CvCLONE_on(bcv); else { ! if (ckWARN(WARN_CLOSURE) && !CvUNIQUE(cv)) ! warner(WARN_CLOSURE, "Variable \"%s\" may be unavailable", name); break; *************** *** 243,250 **** } } 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)); --- 245,254 ---- } } 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)); *************** *** 549,554 **** --- 553,560 ---- case OP_DBSTATE: Safefree(cCOPo->cop_label); SvREFCNT_dec(cCOPo->cop_filegv); + if (cCOPo->cop_warnings != WARN_NONE && cCOPo->cop_warnings != WARN_ALL) + SvREFCNT_dec(cCOPo->cop_warnings); break; case OP_CONST: SvREFCNT_dec(cSVOPo->op_sv); *************** *** 635,648 **** scalarboolean(o) OP *o; { ! if (dowarn && o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { dTHR; 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(o); --- 641,654 ---- scalarboolean(o) OP *o; { ! if (ckWARN(WARN_SYNTAX) && o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) { dTHR; 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(o); *************** *** 827,833 **** case OP_CONST: sv = cSVOPo->op_sv; ! if (dowarn) { useless = "a constant"; if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = 0; --- 833,839 ---- case OP_CONST: sv = cSVOPo->op_sv; ! if (ckWARN(WARN_VOID)) { useless = "a constant"; if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0)) useless = 0; *************** *** 894,901 **** } break; } ! if (useless && dowarn) ! warn("Useless use of %s in void context", useless); return o; } --- 900,907 ---- } break; } ! if (useless && ckWARN(WARN_VOID)) ! warner(WARN_VOID, "Useless use of %s in void context", useless); return o; } *************** *** 1404,1421 **** { OP *o; ! 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 || --- 1410,1429 ---- { OP *o; ! 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 || *************** *** 1497,1502 **** --- 1505,1516 ---- 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; } *************** *** 1561,1571 **** 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; --- 1575,1586 ---- 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; *************** *** 2565,2570 **** --- 2580,2589 ---- } 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; *************** *** 2641,2648 **** } } 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; --- 2660,2668 ---- } } 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; *************** *** 2658,2664 **** 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; --- 2678,2684 ---- 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; *************** *** 2681,2687 **** 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")); --- 2701,2708 ---- 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")); *************** *** 3355,3365 **** 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); --- 3376,3387 ---- 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); *************** *** 3571,3580 **** } 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); --- 3593,3602 ---- } 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); *************** *** 3652,3662 **** 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); --- 3674,3684 ---- 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); *************** *** 4144,4151 **** 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; --- 4166,4174 ---- 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; *************** *** 4162,4169 **** 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; --- 4185,4193 ---- 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; *************** *** 4915,4928 **** 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; } } --- 4939,4953 ---- 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 Fri Oct 3 16:50:54 1997 --- op.h Thu Oct 16 23:22:02 1997 *************** *** 117,122 **** --- 117,123 ---- #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 Thu Oct 16 17:45:57 1997 --- perl.c Thu Oct 16 23:22:02 1997 *************** *** 673,678 **** --- 673,679 ---- time(&basetime); oldscope = scopestack_ix; + dowarn = FALSE ; JMPENV_PUSH(ret); switch (ret) { *************** *** 729,734 **** --- 730,736 ---- case 'u': case 'U': case 'v': + case 'W': case 'w': if (s = moreswitches(s)) goto reswitch; *************** *** 994,1000 **** if (do_undump) my_unexec(); ! if (dowarn) gv_check(defstash); LEAVE; --- 996,1002 ---- if (do_undump) my_unexec(); ! if (ckWARN(WARN_ONCE)) gv_check(defstash); LEAVE; *************** *** 1731,1737 **** 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 '*': --- 1733,1744 ---- 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 Thu Oct 16 17:45:57 1997 --- perl.h Thu Oct 16 23:22:03 1997 *************** *** 1047,1052 **** --- 1047,1053 ---- #include "hv.h" #include "mg.h" #include "scope.h" + #include "warning.h" /* work around some libPW problems */ #ifdef DOINIT *** pp.c.orig Thu Oct 16 17:45:59 1997 --- pp.c Thu Oct 16 23:22:03 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); *************** *** 1738,1745 **** rem -= pos; } if (fail < 0) { ! if (dowarn || lvalue) ! warn("substr outside of string"); RETPUSHUNDEF; } else { --- 1738,1745 ---- rem -= pos; } if (fail < 0) { ! if (lvalue || ckWARN(WARN_SUBSTR)) ! warner(WARN_SUBSTR, "substr outside of string"); RETPUSHUNDEF; } else { *************** *** 1749,1756 **** 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); --- 1749,1757 ---- 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); *************** *** 2409,2416 **** 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; --- 2410,2417 ---- 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; *************** *** 2820,2827 **** 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') --- 2821,2828 ---- 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') *************** *** 3600,3607 **** 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"); --- 3601,3608 ---- 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"); *************** *** 3973,3980 **** * 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 --- 3974,3982 ---- * 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 Thu Oct 16 17:45:59 1997 --- pp_ctl.c Thu Oct 16 23:22:04 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; *************** *** 858,877 **** 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 || --- 858,881 ---- 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 || *************** *** 968,987 **** 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)); --- 972,995 ---- 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)); *************** *** 1786,1792 **** 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(); --- 1794,1800 ---- 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(); *************** *** 2408,2413 **** --- 2416,2423 ---- 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 */ *************** *** 2468,2473 **** --- 2478,2488 ---- 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 Thu Oct 16 17:45:59 1997 --- pp_hot.c Thu Oct 16 23:22:05 1997 *************** *** 312,334 **** 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; --- 312,336 ---- 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; *************** *** 415,422 **** 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; --- 417,424 ---- 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; *************** *** 490,497 **** 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; --- 492,499 ---- 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; *************** *** 626,633 **** } TAINT_NOT; } ! if (relem == lastrelem && dowarn) ! warn("Odd number of elements in hash list"); } break; default: --- 628,635 ---- } TAINT_NOT; } ! if (relem == lastrelem && ckWARN(WARN_UNSAFE)) ! warner(WARN_UNSAFE, "Odd number of elements in hash list"); } break; default: *************** *** 1114,1121 **** 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; --- 1116,1124 ---- 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; *************** *** 2032,2038 **** 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)) { --- 2035,2041 ---- 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)) { *************** *** 2147,2157 **** 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)); } } --- 2150,2161 ---- 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 Thu Oct 16 17:45:59 1997 --- pp_sys.c Thu Oct 16 23:22:05 1997 *************** *** 571,577 **** sv = POPs; ! if (dowarn) { MAGIC * mg ; if (SvMAGICAL(sv)) { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) --- 571,577 ---- sv = POPs; ! if (ckWARN(WARN_UNTIE)) { MAGIC * mg ; if (SvMAGICAL(sv)) { if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) *************** *** 580,587 **** 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 ) ; } } --- 580,588 ---- 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 ) ; } } *************** *** 1067,1084 **** 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)) --- 1068,1085 ---- 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)) *************** *** 1133,1152 **** 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; --- 1134,1155 ---- 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; *************** *** 1358,1368 **** 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) { --- 1361,1371 ---- 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) { *************** *** 1746,1753 **** RETPUSHUNDEF; nuts: ! if (dowarn) ! warn("bind() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1749,1756 ---- RETPUSHUNDEF; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "bind() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1776,1783 **** RETPUSHUNDEF; nuts: ! if (dowarn) ! warn("connect() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1779,1786 ---- RETPUSHUNDEF; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "connect() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1802,1809 **** RETPUSHUNDEF; nuts: ! if (dowarn) ! warn("listen() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1805,1812 ---- RETPUSHUNDEF; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "listen() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1856,1863 **** RETURN; nuts: ! if (dowarn) ! warn("accept() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); badexit: --- 1859,1866 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "accept() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); badexit: *************** *** 1883,1890 **** RETURN; nuts: ! if (dowarn) ! warn("shutdown() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else --- 1886,1893 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "shutdown() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); RETPUSHUNDEF; #else *************** *** 1961,1968 **** RETURN; nuts: ! if (dowarn) ! warn("[gs]etsockopt() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; --- 1964,1971 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "[gs]etsockopt() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; *************** *** 2034,2041 **** RETURN; nuts: ! if (dowarn) ! warn("get{sock, peer}name() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; --- 2037,2044 ---- RETURN; nuts: ! if (ckWARN(WARN_CLOSED)) ! warner(WARN_CLOSED, "get{sock, peer}name() on closed fd"); SETERRNO(EBADF,SS$_IVCHAN); nuts2: RETPUSHUNDEF; *************** *** 2092,2099 **** #endif laststatval = Stat(SvPV(statname, na), &statcache); if (laststatval < 0) { ! if (dowarn && strchr(SvPV(statname, na), '\n')) ! warn(warn_nl, "stat"); max = 0; } } --- 2095,2102 ---- #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; } } *************** *** 2497,2504 **** len = 512; } else { ! if (dowarn) ! warn("Test on unopened file <%s>", GvENAME(cGVOP->op_gv)); SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; --- 2500,2507 ---- len = 512; } else { ! if (ckWARN(WARN_UNOPENED)) ! warner(WARN_UNOPENED, "Test on unopened file <%s>", GvENAME(cGVOP->op_gv)); SETERRNO(EBADF,RMS$_IFI); RETPUSHUNDEF; *************** *** 2516,2523 **** 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); --- 2519,2526 ---- 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 Thu Oct 16 17:45:59 1997 --- proto.h Thu Oct 16 23:22:06 1997 *************** *** 548,553 **** --- 548,554 ---- 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 Thu Oct 16 17:45:59 1997 --- regcomp.c Thu Oct 16 23:22:06 1997 *************** *** 731,738 **** goto do_curly; } nest_check: ! if (dowarn && regcode != ®dummy && !(flags&HASWIDTH) && max > 10000) { ! warn("%.*s matches null string many times", regparse - origparse, origparse); } --- 731,738 ---- 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 Thu Oct 16 17:46:00 1997 --- sv.c Thu Oct 16 23:40:22 1997 *************** *** 1247,1256 **** *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 --- 1247,1256 ---- *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 *************** *** 1273,1280 **** return asIV(sv); if (!SvROK(sv)) { dTHR; /* just for localizing */ ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); return 0; } } --- 1273,1280 ---- return asIV(sv); if (!SvROK(sv)) { dTHR; /* just for localizing */ ! if (ckWARN(WARN_UNINITIALIZED) && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } } *************** *** 1296,1303 **** } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); ! if (dowarn) ! warn(warn_uninit); return 0; } } --- 1296,1303 ---- } if (SvPOKp(sv) && SvLEN(sv)) return asIV(sv); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } } *************** *** 1325,1332 **** } else { dTHR; ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n", --- 1325,1332 ---- } else { dTHR; ! 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", *************** *** 1350,1357 **** return asUV(sv); if (!SvROK(sv)) { dTHR; /* just for localizing */ ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); return 0; } } --- 1350,1357 ---- return asUV(sv); if (!SvROK(sv)) { dTHR; /* just for localizing */ ! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } } *************** *** 1370,1377 **** } if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); ! if (dowarn) ! warn(warn_uninit); return 0; } } --- 1370,1377 ---- } if (SvPOKp(sv) && SvLEN(sv)) return asUV(sv); ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } } *************** *** 1396,1403 **** } else { dTHR; /* just for localizing */ ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n", --- 1396,1403 ---- } else { dTHR; /* just for localizing */ ! 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", *************** *** 1416,1422 **** 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)); --- 1416,1422 ---- 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)); *************** *** 1425,1432 **** return (double)SvIVX(sv); if (!SvROK(sv)) { dTHR; /* just for localizing */ ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); return 0; } } --- 1425,1432 ---- return (double)SvIVX(sv); if (!SvROK(sv)) { dTHR; /* just for localizing */ ! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0; } } *************** *** 1441,1455 **** } 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; } } --- 1441,1455 ---- } 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; } } *************** *** 1470,1484 **** 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 { dTHR; ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); return 0.0; } SvNOK_on(sv); --- 1470,1484 ---- 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 { dTHR; ! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); return 0.0; } SvNOK_on(sv); *************** *** 1497,1503 **** if (numtype == 1) return atol(SvPVX(sv)); ! if (!numtype && dowarn) not_a_number(sv); SET_NUMERIC_STANDARD(); d = atof(SvPVX(sv)); --- 1497,1503 ---- if (numtype == 1) return atol(SvPVX(sv)); ! if (!numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); SET_NUMERIC_STANDARD(); d = atof(SvPVX(sv)); *************** *** 1517,1523 **** 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))); --- 1517,1523 ---- 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))); *************** *** 1636,1643 **** } if (!SvROK(sv)) { dTHR; /* just for localizing */ ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); *lp = 0; return ""; } --- 1636,1643 ---- } if (!SvROK(sv)) { dTHR; /* just for localizing */ ! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); *lp = 0; return ""; } *************** *** 1695,1702 **** tsv = Nullsv; goto tokensave; } ! if (dowarn) ! warn(warn_uninit); *lp = 0; return ""; } --- 1695,1702 ---- tsv = Nullsv; goto tokensave; } ! if (ckWARN(WARN_UNINITIALIZED)) ! warner(WARN_UNINITIALIZED, warn_uninit); *lp = 0; return ""; } *************** *** 1744,1751 **** } else { dTHR; ! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP)) ! warn(warn_uninit); *lp = 0; return ""; } --- 1744,1751 ---- } else { dTHR; ! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) ! warner(WARN_UNINITIALIZED, warn_uninit); *lp = 0; return ""; } *************** *** 2050,2058 **** 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); --- 2050,2059 ---- 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); *************** *** 4670,4676 **** 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: ", --- 4671,4677 ---- 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: ", *************** *** 4680,4686 **** c & 0xFF); else sv_catpv(msg, "end of string"); ! warn("%_", msg); /* yes, this is reentrant */ } /* output mangled stuff ... */ --- 4681,4687 ---- 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 Fri Oct 3 16:51:17 1997 --- t/op/tie.t Thu Oct 16 23:22:08 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 Fri Oct 3 16:51:18 1997 --- t/pragma/warn-1global Thu Oct 16 23:22:08 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 23:22:09 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 23:22:09 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 23:22:09 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 23:22:09 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 23:22:10 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 23:22:10 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:53 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 23:22:10 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 23:22:11 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 Sat Oct 18 21:22:42 1997 *************** *** 0 **** --- 1,72 ---- + 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 23:22:12 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 23:22:12 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:56:35 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 23:22:12 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 23:22:13 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 23:22:13 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 23:22:13 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 Oct 3 16:51:18 1997 --- t/pragma/warning.t Thu Oct 16 23:22:13 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 Thu Oct 16 17:46:01 1997 --- taint.c Thu Oct 16 23:22:14 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 Thu Oct 16 17:46:02 1997 --- toke.c Thu Oct 16 23:22:14 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 *************** *** 819,826 **** 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; } --- 819,826 ---- 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; } *************** *** 1773,1780 **** 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 */ --- 1773,1781 ---- 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 */ *************** *** 1977,1987 **** 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) --- 1978,1989 ---- 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) *************** *** 2123,2131 **** 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); --- 2125,2133 ---- 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); *************** *** 2157,2164 **** 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') ) --- 2159,2166 ---- 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') ) *************** *** 2288,2294 **** char *t; if (*s == '[') { tokenbuf[0] = '@'; ! if (dowarn) { for(t = s + 1; isSPACE(*t) || isALNUM(*t) || *t == '$'; t++) ; --- 2290,2296 ---- char *t; if (*s == '[') { tokenbuf[0] = '@'; ! if (ckWARN(WARN_SYNTAX)) { for(t = s + 1; isSPACE(*t) || isALNUM(*t) || *t == '$'; t++) ; *************** *** 2296,2309 **** 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]; --- 2298,2312 ---- 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]; *************** *** 2312,2318 **** 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); } } } --- 2315,2322 ---- 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); } } } *************** *** 2382,2388 **** tokenbuf[0] = '%'; /* Warn about @ where they meant $. */ ! if (dowarn) { if (*s == '[' || *s == '{') { char *t = s + 1; while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t))) --- 2386,2392 ---- 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))) *************** *** 2390,2396 **** if (*t == '}' || *t == ']') { t++; bufptr = skipspace(bufptr); ! warn("Scalar value %.*s better written as $%.*s", t-bufptr, bufptr, t-bufptr-1, bufptr+1); } } --- 2394,2401 ---- 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); } } *************** *** 2492,2499 **** 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); --- 2497,2505 ---- 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); *************** *** 2566,2573 **** /* 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; --- 2572,2580 ---- /* 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; *************** *** 2608,2614 **** if (expect == XOPERATOR) { if (bufptr == linestart) { curcop->cop_line--; ! warn(warn_nosemi); curcop->cop_line++; } else --- 2615,2621 ---- if (expect == XOPERATOR) { if (bufptr == linestart) { curcop->cop_line--; ! warner(WARN_SEMICOLON, warn_nosemi); curcop->cop_line++; } else *************** *** 2746,2756 **** /* 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)) { --- 2753,2763 ---- /* 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)) { *************** *** 2889,2895 **** 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"); --- 2896,2902 ---- 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"); *************** *** 3309,3323 **** 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; } } --- 3316,3332 ---- 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; } } *************** *** 3688,3694 **** 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"); --- 3697,3703 ---- 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"); *************** *** 4387,4393 **** { 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 == '(') --- 4396,4402 ---- { 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 == '(') *************** *** 4398,4404 **** 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++; --- 4407,4413 ---- 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++; *************** *** 4546,4554 **** *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; --- 4555,4564 ---- *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; *************** *** 4563,4571 **** 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 { --- 4573,4582 ---- 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 { *************** *** 5145,5152 **** floatit = FALSE; while (isDIGIT(*s) || *s == '_') { if (*s == '_') { ! if (dowarn && lastub && s - lastub != 3) ! warn("Misplaced _ in number"); lastub = ++s; } else { --- 5156,5163 ---- 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 { *************** *** 5155,5162 **** *d++ = *s++; } } ! if (dowarn && lastub && s - lastub != 3) ! warn("Misplaced _ in number"); if (*s == '.' && s[1] != '.') { floatit = TRUE; *d++ = *s++; --- 5166,5173 ---- *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 Wed Oct 8 17:17:27 1997 --- universal.c Thu Oct 16 23:22:15 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 Thu Oct 16 17:46:02 1997 --- util.c Fri Oct 17 16:55:35 1997 *************** *** 1227,1238 **** return restartop; } - #ifdef I_STDARG void croak(const char* pat, ...) #else /*VARARGS0*/ - void croak(pat, va_alist) char *pat; va_dcl --- 1227,1237 ---- return restartop; } void + #ifdef I_STDARG croak(const char* pat, ...) #else /*VARARGS0*/ croak(pat, va_alist) char *pat; va_dcl *************** *** 1291,1297 **** void #ifdef I_STDARG ! warn(const char* pat,...) #else /*VARARGS0*/ warn(pat,va_alist) --- 1290,1296 ---- void #ifdef I_STDARG ! warn(const char *pat,...) #else /*VARARGS0*/ warn(pat,va_alist) *************** *** 1347,1352 **** --- 1346,1450 ---- (void)PerlIO_flush(PerlIO_stderr()); } + 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; + 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 (ckDEAD(err)) { + #ifdef USE_THREADS + DEBUG_L(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message)); + #endif /* USE_THREADS */ + if (diehook) { + /* sv_2cv might call croak() */ + SV *olddiehook = diehook; + ENTER; + SAVESPTR(diehook); + diehook = Nullsv; + cv = sv_2cv(olddiehook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; + + ENTER; + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); + + PUSHMARK(sp); + XPUSHs(msg); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + + LEAVE; + } + } + if (in_eval) { + restartop = die_where(message); + JMPENV_JUMP(3); + } + PerlIO_puts(PerlIO_stderr(),message); + (void)PerlIO_flush(PerlIO_stderr()); + my_failure_exit(); + + } + else { + if (warnhook) { + /* sv_2cv might call warn() */ + dTHR; + SV *oldwarnhook = warnhook; + ENTER; + SAVESPTR(warnhook); + warnhook = Nullsv; + cv = sv_2cv(oldwarnhook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; + + ENTER; + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); + + PUSHMARK(sp); + XPUSHs(msg); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + + LEAVE; + return; + } + } + PerlIO_puts(PerlIO_stderr(),message); + #ifdef LEAKTEST + DEBUG_L(xstat()); + #endif + (void)PerlIO_flush(PerlIO_stderr()); + } + } + #ifndef VMS /* VMS' my_setenv() is in VMS.c */ #ifndef WIN32 void *************** *** 2319,2326 **** retval = n | (*s++ - '0'); len--; } ! if (dowarn && len && (*s == '8' || *s == '9')) ! warn("Illegal octal digit ignored"); *retlen = s - start; return retval; } --- 2417,2424 ---- 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 23:22:16 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 23:22:16 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;