# See README.warning for information of what the patch does.
exit 0
-----------------------------------------------------------------------
*** MANIFEST.orig Tue Feb 25 08:48:01 1997
--- MANIFEST Thu Feb 27 11:31:26 1997
***************
*** 404,409 ****
--- 404,410 ----
lib/timelocal.pl Perl library supporting inverse of localtime, gmtime
lib/validate.pl Perl library supporting wholesale file mode validation
lib/vars.pm Declare pseudo-imported global variables
+ lib/warning.pm For "use warning"
makeaperl.SH perl script that produces a new perl binary
makedepend.SH Precursor to makedepend
makedir.SH Precursor to makedir
***************
*** 708,713 ****
--- 709,731 ----
t/pragma/strict.t See if strictures work
t/pragma/subs.t See if subroutine pseudo-importation works
t/pragma/warn-1global Tests of global warnings for warning.t
+ t/pragma/warn-2use Tests for "use warning" for warning.t
+ t/pragma/warn-doio Tests for doio.c for warning.t
+ t/pragma/warn-gv Tests for gv.c for warning.t
+ t/pragma/warn-mg Tests for mg.c for warning.t
+ t/pragma/warn-op Tests for op.c for warning.t
+ t/pragma/warn-perl Tests for perl.c for warning.t
+ t/pragma/warn-perly Tests for perly.y for warning.t
+ t/pragma/warn-pp Tests for pp.c for warning.t
+ t/pragma/warn-pp_ctl Tests for pp_ctl.c for warning.t
+ t/pragma/warn-pp_hot Tests for pp_hot.c for warning.t
+ t/pragma/warn-pp_sys Tests for pp_sys.c for warning.t
+ t/pragma/warn-regcomp Tests for regcomp.c for warning.t
+ t/pragma/warn-sv Tests for sv.c for warning.t
+ t/pragma/warn-taint Tests for taint.c for warning.t
+ t/pragma/warn-toke Tests for toke.c for warning.t
+ t/pragma/warn-universal Tests for universal.c for warning.t
+ t/pragma/warn-util Tests for util.c for warning.t
t/pragma/warning.t See if warning controls work
taint.c Tainting code
toke.c The tokener
***************
*** 756,761 ****
--- 774,781 ----
vms/vms_yfix.pl convert Unix perly.[ch] to VMS perly_[ch].vms
vms/vmsish.h VMS-specific C header for Perl core
vms/writemain.pl Generate perlmain.c from miniperlmain.c+extensions
+ warning.h The warning numbers
+ warning.pl Program to write warning.h and lib/warning.pm
win32/EXTERN.h Win32 port
win32/Fcntl.mak Win32 port
win32/IO.mak Win32 port
*** Makefile.SH.orig Fri Jan 17 08:52:58 1997
--- Makefile.SH Thu Feb 27 11:31:26 1997
***************
*** 167,173 ****
h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h
h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h
h3 = opcode.h patchlevel.h perl.h perly.h pp.h proto.h regcomp.h
! h4 = regexp.h scope.h sv.h unixish.h util.h perlio.h
h = $(h1) $(h2) $(h3) $(h4)
c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c
--- 167,173 ----
h1 = EXTERN.h INTERN.h XSUB.h av.h config.h cop.h cv.h dosish.h
h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h
h3 = opcode.h patchlevel.h perl.h perly.h pp.h proto.h regcomp.h
! h4 = regexp.h scope.h sv.h unixish.h util.h perlio.h warning.h
h = $(h1) $(h2) $(h3) $(h4)
c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c
***************
*** 362,371 ****
perly.h: perly.y
-@sh -c true
! # The following three header files are generated automatically
# keywords.h: keywords.pl
# opcode.h: opcode.pl
# embed.h: embed.pl global.sym interp.sym
# The correct versions should be already supplied with the perl kit,
# in case you don't have perl available.
# To force them to run, type
--- 362,372 ----
perly.h: perly.y
-@sh -c true
! # The following four header files are generated automatically
# keywords.h: keywords.pl
# opcode.h: opcode.pl
# embed.h: embed.pl global.sym interp.sym
+ # warning.h lib/warning.pm: warning.pl
# The correct versions should be already supplied with the perl kit,
# in case you don't have perl available.
# To force them to run, type
***************
*** 374,379 ****
--- 375,381 ----
perl keywords.pl
perl opcode.pl
perl embed.pl
+ perl warning.pl
# Extensions:
# Names added to $(dynamic_ext) or $(static_ext) will automatically
*** /dev/null Thu Feb 27 12:04:47 1997
--- README.warning Thu Feb 27 11:31:27 1997
***************
*** 0 ****
--- 1,210 ----
+ Date: 27th Feb 1997
+
+ This patch adds lexical warnings to Perl. It should apply over
+ 5.003_90
+
+ NOTE: This is a prototype. Do not assume that lexical warnings will
+ necessarily be anything like this implementation.
+
+ Changes
+ =======
+
+ Date: 26th Feb 1997
+
+ * By popular demand, the warnings bitmask can now be of arbitrary
+ length. The code uses an SV* to store the bitmask.
+
+ * Rationalised the warning categories a bit. This area still needs
+ a lot of work.
+
+ * Added -W switch (the "lint" command).
+
+ * Added an experimental feature to allow warnings to be excalated
+ to fatal errors.
+
+
+ The "use warning" pragma
+ ============================
+
+ The "use warning" pragma is intended to work just like the "strict"
+ pragma. This means that the scope of the pragma is limited to the
+ enclosing block. It also means that that a pragma setting will not
+ leak across files (via use/require/do). This will allow authors to
+ define the degree of warning checks that will be applied to their
+ module.
+
+ By default warnings are disabled.
+
+ All warnings are enabled by either of these:
+
+ use warning ;
+ use warning 'all' ;
+
+ Similarly all warnings are disabled by either of these:
+
+ no warning ;
+ no warning 'all' ;
+
+ A hierarchy of "categories" have been defined to allow groups of
+ warnings to be enabled/disabled in isolation. The current
+ hierarchy is:
+
+ all - +--- unsafe -------+--- taint
+ | |
+ | +--- substr
+ | |
+ | +--- signal
+ | |
+ | +--- closure
+ | |
+ | +--- untie
+ |
+ +--- io ---------+--- pipe
+ | |
+ | +--- unopened
+ | |
+ | +--- closed
+ | |
+ | +--- newline
+ | |
+ | +--- exec
+ |
+ +--- syntax ----+--- ambiguous
+ | |
+ | +--- semicolon
+ | |
+ | +--- precedence
+ | |
+ | +--- reserved
+ | |
+ | +--- octal
+ | |
+ | +--- parenthesis
+ | |
+ | +--- deprecated
+ |
+ |--- uninitialized
+ |
+ +--- void
+ |
+ +--- recursion
+ |
+ +--- redefine
+ |
+ +--- numeric
+ |
+ +--- once
+ |
+ +--- misc
+
+ This hierarchy is very tentative. Feedback is needed.
+
+ Just like the "strict" pragma any of these categories can be
+ combined
+
+ use warning qw(void redefine) ;
+ no warning qw(io syntax untie) ;
+
+
+ Backward Compatability
+ ======================
+
+ -w and $^W
+
+ Although they should really be considered deprecated once lexical
+ warnings are released, both -w and $^W will continue to work as
+ they currently do.
+
+ $^W cannot be used to disable warnings that have been enabled by
+ "use warning".
+
+ One minor change to $^W. It is now a boolean.
+
+ The "lint" flag, -W
+ ===================
+
+ If the -W flag is used on the command line, it will enable all warnings
+ throughout the program regardless of whether warnings were disabled
+ locally using "no warning" or $^W =0. This includes any file that gets
+ included during compilation via use/require.
+
+
+ Fatal Warnings
+ ==============
+
+ This feature is very experimental.
+
+ The presence of the word "FATAL" in the category list will escalate any
+ warnings from the category specified that are detected in the lexical
+ scope into fatal errors. In the code below, there are 3 places where a
+ deprecated warning will be detected, the middle one will produce a
+ fatal error.
+
+
+ use warning ;
+
+ $a = 1 if $a EQ $b ;
+
+ {
+ use warning qw(FATAL deprecated) ;
+ $a = 1 if $a EQ $b ;
+ }
+
+ $a = 1 if $a EQ $b ;
+
+
+ Unresolved Issues
+ =================
+
+ The pragma name?
+ A few possibilities:
+ warning
+ warnings
+ warn
+
+ Hierarchy of Warnings
+ The current patch has a fairly arbitrary hierarchy.
+ Ideas for a useful hierarchy would be most welcome.
+
+ Severity
+ Do we want/need a severity classification?
+ pedantic
+ high/strict/precise
+ medium/default
+ low/common
+
+ Versions
+ This is a thorhy issue. Say someone writes a script using Perl
+ 5.004 and places this at the top:
+
+ use warning ;
+
+ Time passes and 5.005 comes out. It has added a few extra warnings.
+ The script prints warning messages.
+
+ A possibility is to allow the warnings that are checked to be
+ limited to those available in a given version of Perl. A possible
+ syntax could be:
+
+ use warning 5.004 ;
+
+ or
+
+ use warning 5.004 qw(void uninitialized) ;
+
+ Do we really need this amount of control?
+
+ Documentation
+ There isn't any yet.
+
+
+ perl5db.pl
+ The debugger saves and restores $^W at runtime. I haven't checked
+ whether the debugger will still work with the lexical warnings
+ patch applied.
+
+ diagnostics.pm
+ I *think* I've got diagnostics to work with the lexiacal warnings
+ patch, but there were design decisions made in diagnostics to work
+ around the limitations of $^W. Now that those limitations are gone,
+ the module should be revisited.
*** /dev/null Thu Feb 27 12:04:47 1997
--- README.warning Thu Feb 27 11:31:27 1997
***************
*** 0 ****
--- 1,210 ----
+ Date: 27th Feb 1997
+
+ This patch adds lexical warnings to Perl. It should apply over
+ 5.003_90
+
+ NOTE: This is a prototype. Do not assume that lexical warnings will
+ necessarily be anything like this implementation.
+
+ Changes
+ =======
+
+ Date: 26th Feb 1997
+
+ * By popular demand, the warnings bitmask can now be of arbitrary
+ length. The code uses an SV* to store the bitmask.
+
+ * Rationalised the warning categories a bit. This area still needs
+ a lot of work.
+
+ * Added -W switch (the "lint" command).
+
+ * Added an experimental feature to allow warnings to be excalated
+ to fatal errors.
+
+
+ The "use warning" pragma
+ ============================
+
+ The "use warning" pragma is intended to work just like the "strict"
+ pragma. This means that the scope of the pragma is limited to the
+ enclosing block. It also means that that a pragma setting will not
+ leak across files (via use/require/do). This will allow authors to
+ define the degree of warning checks that will be applied to their
+ module.
+
+ By default warnings are disabled.
+
+ All warnings are enabled by either of these:
+
+ use warning ;
+ use warning 'all' ;
+
+ Similarly all warnings are disabled by either of these:
+
+ no warning ;
+ no warning 'all' ;
+
+ A hierarchy of "categories" have been defined to allow groups of
+ warnings to be enabled/disabled in isolation. The current
+ hierarchy is:
+
+ all - +--- unsafe -------+--- taint
+ | |
+ | +--- substr
+ | |
+ | +--- signal
+ | |
+ | +--- closure
+ | |
+ | +--- untie
+ |
+ +--- io ---------+--- pipe
+ | |
+ | +--- unopened
+ | |
+ | +--- closed
+ | |
+ | +--- newline
+ | |
+ | +--- exec
+ |
+ +--- syntax ----+--- ambiguous
+ | |
+ | +--- semicolon
+ | |
+ | +--- precedence
+ | |
+ | +--- reserved
+ | |
+ | +--- octal
+ | |
+ | +--- parenthesis
+ | |
+ | +--- deprecated
+ |
+ |--- uninitialized
+ |
+ +--- void
+ |
+ +--- recursion
+ |
+ +--- redefine
+ |
+ +--- numeric
+ |
+ +--- once
+ |
+ +--- misc
+
+ This hierarchy is very tentative. Feedback is needed.
+
+ Just like the "strict" pragma any of these categories can be
+ combined
+
+ use warning qw(void redefine) ;
+ no warning qw(io syntax untie) ;
+
+
+ Backward Compatability
+ ======================
+
+ -w and $^W
+
+ Although they should really be considered deprecated once lexical
+ warnings are released, both -w and $^W will continue to work as
+ they currently do.
+
+ $^W cannot be used to disable warnings that have been enabled by
+ "use warning".
+
+ One minor change to $^W. It is now a boolean.
+
+ The "lint" flag, -W
+ ===================
+
+ If the -W flag is used on the command line, it will enable all warnings
+ throughout the program regardless of whether warnings were disabled
+ locally using "no warning" or $^W =0. This includes any file that gets
+ included during compilation via use/require.
+
+
+ Fatal Warnings
+ ==============
+
+ This feature is very experimental.
+
+ The presence of the word "FATAL" in the category list will escalate any
+ warnings from the category specified that are detected in the lexical
+ scope into fatal errors. In the code below, there are 3 places where a
+ deprecated warning will be detected, the middle one will produce a
+ fatal error.
+
+
+ use warning ;
+
+ $a = 1 if $a EQ $b ;
+
+ {
+ use warning qw(FATAL deprecated) ;
+ $a = 1 if $a EQ $b ;
+ }
+
+ $a = 1 if $a EQ $b ;
+
+
+ Unresolved Issues
+ =================
+
+ The pragma name?
+ A few possibilities:
+ warning
+ warnings
+ warn
+
+ Hierarchy of Warnings
+ The current patch has a fairly arbitrary hierarchy.
+ Ideas for a useful hierarchy would be most welcome.
+
+ Severity
+ Do we want/need a severity classification?
+ pedantic
+ high/strict/precise
+ medium/default
+ low/common
+
+ Versions
+ This is a thorhy issue. Say someone writes a script using Perl
+ 5.004 and places this at the top:
+
+ use warning ;
+
+ Time passes and 5.005 comes out. It has added a few extra warnings.
+ The script prints warning messages.
+
+ A possibility is to allow the warnings that are checked to be
+ limited to those available in a given version of Perl. A possible
+ syntax could be:
+
+ use warning 5.004 ;
+
+ or
+
+ use warning 5.004 qw(void uninitialized) ;
+
+ Do we really need this amount of control?
+
+ Documentation
+ There isn't any yet.
+
+
+ perl5db.pl
+ The debugger saves and restores $^W at runtime. I haven't checked
+ whether the debugger will still work with the lexical warnings
+ patch applied.
+
+ diagnostics.pm
+ I *think* I've got diagnostics to work with the lexiacal warnings
+ patch, but there were design decisions made in diagnostics to work
+ around the limitations of $^W. Now that those limitations are gone,
+ the module should be revisited.
*** cop.h.orig Mon Feb 10 19:57:48 1997
--- cop.h Thu Feb 27 11:34:57 1997
***************
*** 15,20 ****
--- 15,21 ----
U32 cop_seq; /* parse sequence number */
I32 cop_arybase; /* array base this line was compiled with */
line_t cop_line; /* line # of this command */
+ SV * cop_warnings; /* lexical warnings bitmask */
};
#define Nullcop Null(COP*)
*** doio.c.orig Tue Feb 25 08:48:03 1997
--- doio.c Thu Feb 27 11:31:28 1997
***************
*** 157,164 ****
if (strNE(name,"-"))
TAINT_ENV();
TAINT_PROPER("piped open");
! if (dowarn && name[strlen(name)-1] == '|')
! warn("Can't do bidirectional pipe");
fp = my_popen(name,"w");
writing = 1;
}
--- 157,164 ----
if (strNE(name,"-"))
TAINT_ENV();
TAINT_PROPER("piped open");
! if (ckWARN(WARN_PIPE) && name[strlen(name)-1] == '|')
! warner(WARN_PIPE, "Can't do bidirectional pipe");
fp = my_popen(name,"w");
writing = 1;
}
***************
*** 264,271 ****
}
}
if (!fp) {
! if (dowarn && IoTYPE(io) == '<' && strchr(name, '\n'))
! warn(warn_nl, "open");
goto say_false;
}
if (IoTYPE(io) &&
--- 264,271 ----
}
}
if (!fp) {
! if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == '<' && strchr(name, '\n'))
! warner(WARN_NEWLINE, warn_nl, "open");
goto say_false;
}
if (IoTYPE(io) &&
***************
*** 560,567 ****
}
io = GvIO(gv);
if (!io) { /* never opened */
! if (dowarn && not_implicit)
! warn("Close on unopened file <%s>",GvENAME(gv));
return FALSE;
}
retval = io_close(io);
--- 560,567 ----
}
io = GvIO(gv);
if (!io) { /* never opened */
! if (ckWARN(WARN_UNOPENED) && not_implicit)
! warner(WARN_UNOPENED, "Close on unopened file <%s>",GvENAME(gv));
return FALSE;
}
retval = io_close(io);
***************
*** 662,669 ****
return PerlIO_tell(IoIFP(io));
phooey:
! if (dowarn)
! warn("tell() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
return -1L;
}
--- 662,669 ----
return PerlIO_tell(IoIFP(io));
phooey:
! if (ckWARN(WARN_UNOPENED))
! warner(WARN_UNOPENED, "tell() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
return -1L;
}
***************
*** 691,698 ****
return PerlIO_seek(IoIFP(io), pos, whence) >= 0;
nuts:
! if (dowarn)
! warn("seek() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
return FALSE;
}
--- 691,698 ----
return PerlIO_seek(IoIFP(io), pos, whence) >= 0;
nuts:
! if (ckWARN(WARN_UNOPENED))
! warner(WARN_UNOPENED, "seek() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
return FALSE;
}
***************
*** 775,782 ****
}
switch (SvTYPE(sv)) {
case SVt_NULL:
! if (dowarn)
! warn(warn_uninit);
return TRUE;
case SVt_IV:
if (SvIOK(sv)) {
--- 775,782 ----
}
switch (SvTYPE(sv)) {
case SVt_NULL:
! if (ckWARN(WARN_UNINITIALIZED))
! warner(WARN_UNINITIALIZED, warn_uninit);
return TRUE;
case SVt_IV:
if (SvIOK(sv)) {
***************
*** 817,824 ****
else {
if (tmpgv == defgv)
return laststatval;
! if (dowarn)
! warn("Stat on unopened file <%s>",
GvENAME(tmpgv));
statgv = Nullgv;
sv_setpv(statname,"");
--- 817,824 ----
else {
if (tmpgv == defgv)
return laststatval;
! if (ckWARN(WARN_UNOPENED))
! warner(WARN_UNOPENED, "Stat on unopened file <%s>",
GvENAME(tmpgv));
statgv = Nullgv;
sv_setpv(statname,"");
***************
*** 841,848 ****
sv_setpv(statname,SvPV(sv, na));
laststype = OP_STAT;
laststatval = Stat(SvPV(sv, na),&statcache);
! if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n'))
! warn(warn_nl, "stat");
return laststatval;
}
}
--- 841,848 ----
sv_setpv(statname,SvPV(sv, na));
laststype = OP_STAT;
laststatval = Stat(SvPV(sv, na),&statcache);
! if (laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, na), '\n'))
! warner(WARN_NEWLINE, warn_nl, "stat");
return laststatval;
}
}
***************
*** 873,880 ****
#else
laststatval = Stat(SvPV(sv, na),&statcache);
#endif
! if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n'))
! warn(warn_nl, "lstat");
return laststatval;
}
--- 873,880 ----
#else
laststatval = Stat(SvPV(sv, na),&statcache);
#endif
! if (laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, na), '\n'))
! warner(WARN_NEWLINE, warn_nl, "lstat");
return laststatval;
}
***************
*** 903,910 ****
execvp(tmps,Argv);
else
execvp(Argv[0],Argv);
! if (dowarn)
! warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
}
do_execfree();
return FALSE;
--- 903,911 ----
execvp(tmps,Argv);
else
execvp(Argv[0],Argv);
! if (ckWARN(WARN_EXEC))
! warner(WARN_EXEC, "Can't exec \"%s\": %s",
! Argv[0], Strerror(errno));
}
do_execfree();
return FALSE;
***************
*** 1007,1014 ****
do_execfree();
goto doshell;
}
! if (dowarn)
! warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
}
do_execfree();
return FALSE;
--- 1008,1016 ----
do_execfree();
goto doshell;
}
! if (ckWARN(WARN_EXEC))
! warner(WARN_EXEC, "Can't exec \"%s\": %s", Argv[0],
! Strerror(errno));
}
do_execfree();
return FALSE;
*** global.sym.orig Tue Feb 4 08:54:58 1997
--- global.sym Thu Feb 27 11:31:29 1997
***************
*** 1129,1134 ****
--- 1129,1135 ----
utilize
wait4pid
warn
+ warner
watch
whichsig
xiv_arenaroot
*** gv.c.orig Fri Feb 21 23:04:40 1997
--- gv.c Thu Feb 27 11:31:29 1997
***************
*** 167,174 ****
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
! if (dowarn)
! warn("Can't locate package %s for @%s::ISA",
SvPVX(sv), HvNAME(stash));
continue;
}
--- 167,174 ----
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
! if (ckWARN(WARN_MISC))
! warner(WARN_MISC, "Can't locate package %s for @%s::ISA",
SvPVX(sv), HvNAME(stash));
continue;
}
***************
*** 646,653 ****
case '#':
case '*':
! if (dowarn && len == 1 && sv_type == SVt_PV)
! warn("Use of $%s is deprecated", name);
/* FALL THROUGH */
case '[':
case '!':
--- 646,653 ----
case '#':
case '*':
! if (ckWARN(WARN_DEPRECATED) && len == 1 && sv_type == SVt_PV)
! warner(WARN_DEPRECATED, "Use of $%s is deprecated", name);
/* FALL THROUGH */
case '[':
case '!':
***************
*** 666,671 ****
--- 666,672 ----
case '/':
case '|':
case '\001':
+ case '\002':
case '\004':
case '\005':
case '\006':
***************
*** 810,816 ****
curcop->cop_filegv = filegv;
if (filegv && GvMULTI(filegv)) /* Filename began with slash */
continue;
! warn("Name \"%s::%s\" used only once: possible typo",
HvNAME(stash), GvNAME(gv));
}
}
--- 811,818 ----
curcop->cop_filegv = filegv;
if (filegv && GvMULTI(filegv)) /* Filename began with slash */
continue;
! warner(WARN_ONCE,
! "Name \"%s::%s\" used only once: possible typo",
HvNAME(stash), GvNAME(gv));
}
}
*** interp.sym.orig Tue Feb 4 08:55:00 1997
--- interp.sym Thu Feb 27 11:31:30 1997
***************
*** 69,74 ****
--- 69,75 ----
laststatval
laststype
leftgv
+ lexwarn
lineary
localizing
localpatches
*** lib/diagnostics.pm.orig Fri Feb 21 23:04:44 1997
--- lib/diagnostics.pm Thu Feb 27 11:31:30 1997
***************
*** 268,274 ****
$transmo = <<EOFUNC;
sub transmo {
! local \$^W = 0; # recursive warnings we do NOT need!
study;
EOFUNC
--- 268,274 ----
$transmo = <<EOFUNC;
sub transmo {
! #local \$^W = 0; # recursive warnings we do NOT need!
study;
EOFUNC
***************
*** 365,371 ****
sub import {
shift;
! $old_w = $^W;
$^W = 1; # yup, clobbered the global variable; tough, if you
# want diags, you want diags.
return if $SIG{__WARN__} eq \&warn_trap;
--- 365,371 ----
sub import {
shift;
! #$old_w = $^W;
$^W = 1; # yup, clobbered the global variable; tough, if you
# want diags, you want diags.
return if $SIG{__WARN__} eq \&warn_trap;
***************
*** 401,407 ****
sub disable {
shift;
! $^W = $old_w;
return unless $SIG{__WARN__} eq \&warn_trap;
$SIG{__WARN__} = $oldwarn;
$SIG{__DIE__} = $olddie;
--- 401,407 ----
sub disable {
shift;
! #$^W = $old_w;
return unless $SIG{__WARN__} eq \&warn_trap;
$SIG{__WARN__} = $oldwarn;
$SIG{__DIE__} = $olddie;
*** /dev/null Thu Feb 27 12:04:47 1997
--- lib/warning.pm Thu Feb 27 11:42:04 1997
***************
*** 0 ****
--- 1,139 ----
+
+ # This file was created by warning.pl
+ # Any changes made here will be lost.
+ #
+
+ package warning;
+
+ =head1 NAME
+
+ warning - Perl pragma to control
+
+ =head1 SYNOPSIS
+
+ use warning;
+
+ use warning "all";
+ use warning "deprecated";
+
+ use warning;
+ no warning "unsafe";
+
+ =head1 DESCRIPTION
+
+ If no import list is supplied, all possible restrictions are assumed.
+ (This is the safest mode to operate in, but is sometimes too strict for
+ casual programming.) Currently, there are three possible things to be
+ strict about:
+
+ =over 6
+
+ =item C<warning deprecated>
+
+ This generates a runtime error if you use deprecated
+
+ use warning 'deprecated';
+
+ =back
+
+ See L<perlmod/Pragmatic Modules>.
+
+
+ =cut
+
+ use Carp ;
+
+
+ %Bits = (
+ 'all' => "\x55\x55\x55\x55\x55\x55\x55", # [0..27]
+ 'ambiguous' => "\x00\x00\x00\x40\x00\x00\x00", # [15]
+ 'closed' => "\x00\x00\x00\x00\x00\x01\x00", # [20]
+ 'closure' => "\x00\x04\x00\x00\x00\x00\x00", # [5]
+ 'deprecated' => "\x00\x00\x00\x01\x00\x00\x00", # [12]
+ 'exec' => "\x00\x00\x00\x00\x00\x04\x00", # [21]
+ 'io' => "\x00\x00\x00\x00\x50\x55\x00", # [18..23]
+ 'misc' => "\x00\x00\x00\x00\x00\x00\x10", # [26]
+ 'newline' => "\x00\x00\x00\x00\x40\x00\x00", # [19]
+ 'numeric' => "\x00\x00\x01\x00\x00\x00\x00", # [8]
+ 'octal' => "\x00\x00\x00\x10\x00\x00\x00", # [14]
+ 'once' => "\x00\x00\x04\x00\x00\x00\x00", # [9]
+ 'parenthesis' => "\x00\x00\x00\x00\x01\x00\x00", # [16]
+ 'pipe' => "\x00\x00\x00\x00\x00\x40\x00", # [23]
+ 'precedence' => "\x00\x00\x00\x00\x04\x00\x00", # [17]
+ 'recursion' => "\x00\x00\x00\x00\x00\x00\x04", # [25]
+ 'redefine' => "\x01\x00\x00\x00\x00\x00\x00", # [0]
+ 'reserved' => "\x00\x00\x40\x00\x00\x00\x00", # [11]
+ 'semicolon' => "\x00\x00\x00\x04\x00\x00\x00", # [13]
+ 'signal' => "\x00\x40\x00\x00\x00\x00\x00", # [7]
+ 'substr' => "\x00\x01\x00\x00\x00\x00\x00", # [4]
+ 'syntax' => "\x00\x00\x50\x55\x05\x00\x00", # [10..17]
+ 'taint' => "\x40\x00\x00\x00\x00\x00\x00", # [3]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x01", # [24]
+ 'unopened' => "\x00\x00\x00\x00\x00\x10\x00", # [22]
+ 'unsafe' => "\x50\x55\x00\x00\x00\x00\x00", # [2..7]
+ 'untie' => "\x00\x10\x00\x00\x00\x00\x00", # [6]
+ 'void' => "\x04\x00\x00\x00\x00\x00\x00", # [1]
+ );
+
+ %DeadBits = (
+ 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..27]
+ 'ambiguous' => "\x00\x00\x00\x80\x00\x00\x00", # [15]
+ 'closed' => "\x00\x00\x00\x00\x00\x02\x00", # [20]
+ 'closure' => "\x00\x08\x00\x00\x00\x00\x00", # [5]
+ 'deprecated' => "\x00\x00\x00\x02\x00\x00\x00", # [12]
+ 'exec' => "\x00\x00\x00\x00\x00\x08\x00", # [21]
+ 'io' => "\x00\x00\x00\x00\xa0\xaa\x00", # [18..23]
+ 'misc' => "\x00\x00\x00\x00\x00\x00\x20", # [26]
+ 'newline' => "\x00\x00\x00\x00\x80\x00\x00", # [19]
+ 'numeric' => "\x00\x00\x02\x00\x00\x00\x00", # [8]
+ 'octal' => "\x00\x00\x00\x20\x00\x00\x00", # [14]
+ 'once' => "\x00\x00\x08\x00\x00\x00\x00", # [9]
+ 'parenthesis' => "\x00\x00\x00\x00\x02\x00\x00", # [16]
+ 'pipe' => "\x00\x00\x00\x00\x00\x80\x00", # [23]
+ 'precedence' => "\x00\x00\x00\x00\x08\x00\x00", # [17]
+ 'recursion' => "\x00\x00\x00\x00\x00\x00\x08", # [25]
+ 'redefine' => "\x02\x00\x00\x00\x00\x00\x00", # [0]
+ 'reserved' => "\x00\x00\x80\x00\x00\x00\x00", # [11]
+ 'semicolon' => "\x00\x00\x00\x08\x00\x00\x00", # [13]
+ 'signal' => "\x00\x80\x00\x00\x00\x00\x00", # [7]
+ 'substr' => "\x00\x02\x00\x00\x00\x00\x00", # [4]
+ 'syntax' => "\x00\x00\xa0\xaa\x0a\x00\x00", # [10..17]
+ 'taint' => "\x80\x00\x00\x00\x00\x00\x00", # [3]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x02", # [24]
+ 'unopened' => "\x00\x00\x00\x00\x00\x20\x00", # [22]
+ 'unsafe' => "\xa0\xaa\x00\x00\x00\x00\x00", # [2..7]
+ 'untie' => "\x00\x20\x00\x00\x00\x00\x00", # [6]
+ 'void' => "\x08\x00\x00\x00\x00\x00\x00", # [1]
+ );
+
+
+ sub bits {
+ my $mask ;
+ my $catmask ;
+ my $fatal = 0 ;
+ foreach my $word (@_) {
+ if ($word eq 'FATAL')
+ { $fatal = 1 }
+ elsif ($catmask = $Bits{$word}) {
+ $mask |= $catmask ;
+ $mask |= $DeadBits{$word} if $fatal ;
+ }
+ else
+ { croak "unknown warning category '$word'" }
+ }
+
+ return $mask ;
+ }
+
+ sub import {
+ shift;
+ $^B |= bits(@_ ? @_ : 'all') ;
+ }
+
+ sub unimport {
+ shift;
+ $^B &= ~ bits(@_ ? @_ : 'all') ;
+ }
+
+
+ 1;
*** mg.c.orig Fri Feb 21 23:04:45 1997
--- mg.c Thu Feb 27 11:36:54 1997
***************
*** 341,346 ****
--- 341,354 ----
case '\001': /* ^A */
sv_setsv(sv, bodytarget);
break;
+ case '\002': /* ^B */
+ if (curcop->cop_warnings == WARN_NONE)
+ sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
+ else if (curcop->cop_warnings == WARN_ALL)
+ sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
+ else
+ sv_setsv(sv, curcop->cop_warnings);
+ break;
case '\004': /* ^D */
sv_setiv(sv, (IV)(debug & 32767));
break;
***************
*** 394,400 ****
#endif
break;
case '\027': /* ^W */
! sv_setiv(sv, (IV)dowarn);
break;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
--- 402,408 ----
#endif
break;
case '\027': /* ^W */
! sv_setiv(sv, (IV)(dowarn != 0));
break;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
***************
*** 702,709 ****
else {
i = whichsig(s); /* ...no, a brick */
if (!i) {
! if (dowarn || strEQ(s,"ALARM"))
! warn("No such signal: SIG%s", s);
return 0;
}
SvREFCNT_dec(psig_name[i]);
--- 710,717 ----
else {
i = whichsig(s); /* ...no, a brick */
if (!i) {
! if (ckWARN(WARN_SIGNAL) || strEQ(s,"ALARM"))
! warner(WARN_SIGNAL, "No such signal: SIG%s", s);
return 0;
}
SvREFCNT_dec(psig_name[i]);
***************
*** 1221,1226 ****
--- 1229,1246 ----
case '\001': /* ^A */
sv_setsv(bodytarget, sv);
break;
+ case '\002': /* ^B */
+ if ((dowarn & G_WARN_FLAG) || memEQ(SvPVX(sv), WARN_ALLstring, WARNsize))
+ compiling.cop_warnings = WARN_ALL;
+ else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize))
+ compiling.cop_warnings = WARN_NONE;
+ else {
+ if (compiling.cop_warnings != WARN_NONE && compiling.cop_warnings != WARN_ALL)
+ sv_setsv(compiling.cop_warnings, sv);
+ else
+ compiling.cop_warnings = newSVsv(sv) ;
+ }
+ break;
case '\004': /* ^D */
debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
DEBUG_x(dump_all());
***************
*** 1273,1279 ****
#endif
break;
case '\027': /* ^W */
! dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
break;
case '.':
if (localizing) {
--- 1293,1300 ----
#endif
break;
case '\027': /* ^W */
! i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
! dowarn = (dowarn & G_WARN_FLAG) | (i ? G_WARN_ON : G_WARN_OFF) ;
break;
case '.':
if (localizing) {
***************
*** 1552,1559 ****
cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
if (!cv || !CvROOT(cv)) {
! if (dowarn)
! warn("SIG%s handler \"%s\" not defined.\n",
sig_name[sig], GvENAME(gv) );
return;
}
--- 1573,1580 ----
cv = sv_2cv(psig_ptr[sig],&st,&gv,TRUE);
if (!cv || !CvROOT(cv)) {
! if (ckWARN(WARN_SIGNAL))
! warner(WARN_SIGNAL, "SIG%s handler \"%s\" not defined.\n",
sig_name[sig], GvENAME(gv) );
return;
}
*** op.c.orig Fri Feb 21 23:04:46 1997
--- op.c Thu Feb 27 11:39:23 1997
***************
*** 106,114 ****
if (type != OP_AELEM && type != OP_HELEM) {
sprintf(tokenbuf, "Can't use subscript on %s", op_desc[type]);
yyerror(tokenbuf);
! if (type == OP_ENTERSUB || type == OP_RV2HV || type == OP_PADHV)
warn("(Did you mean $ or @ instead of %c?)\n",
! type == OP_ENTERSUB ? '&' : '%');
}
}
--- 106,114 ----
if (type != OP_AELEM && type != OP_HELEM) {
sprintf(tokenbuf, "Can't use subscript on %s", op_desc[type]);
yyerror(tokenbuf);
! if (type == OP_RV2HV || type == OP_ENTERSUB)
warn("(Did you mean $ or @ instead of %c?)\n",
! type == OP_RV2HV ? '%' : '&');
}
}
***************
*** 225,232 ****
if (CvANON(bcv))
CvCLONE_on(bcv);
else {
! if (dowarn && !CvUNIQUE(cv))
! warn(
"Variable \"%s\" may be unavailable",
name);
break;
--- 225,232 ----
if (CvANON(bcv))
CvCLONE_on(bcv);
else {
! if (ckWARN(WARN_CLOSURE) && !CvUNIQUE(cv))
! warner(WARN_CLOSURE,
"Variable \"%s\" may be unavailable",
name);
break;
***************
*** 235,242 ****
}
}
else if (!CvUNIQUE(compcv)) {
! if (dowarn && !CvUNIQUE(cv))
! warn("Variable \"%s\" will not stay shared", name);
}
}
av_store(comppad, newoff, SvREFCNT_inc(oldsv));
--- 235,243 ----
}
}
else if (!CvUNIQUE(compcv)) {
! if (ckWARN(WARN_CLOSURE) && !CvUNIQUE(cv))
! warner(WARN_CLOSURE,
! "Variable \"%s\" will not stay shared", name);
}
}
av_store(comppad, newoff, SvREFCNT_inc(oldsv));
***************
*** 488,493 ****
--- 489,496 ----
case OP_DBSTATE:
Safefree(cCOP->cop_label);
SvREFCNT_dec(cCOP->cop_filegv);
+ if (cCOP->cop_warnings != WARN_NONE && cCOP->cop_warnings != WARN_ALL)
+ SvREFCNT_dec(cCOP->cop_warnings);
break;
case OP_CONST:
SvREFCNT_dec(cSVOP->op_sv);
***************
*** 574,586 ****
scalarboolean(op)
OP *op;
{
! if (dowarn &&
op->op_type == OP_SASSIGN && cBINOP->op_first->op_type == OP_CONST) {
line_t oldline = curcop->cop_line;
if (copline != NOLINE)
curcop->cop_line = copline;
! warn("Found = in conditional, should be ==");
curcop->cop_line = oldline;
}
return scalar(op);
--- 577,589 ----
scalarboolean(op)
OP *op;
{
! if (ckWARN(WARN_SYNTAX) &&
op->op_type == OP_SASSIGN && cBINOP->op_first->op_type == OP_CONST) {
line_t oldline = curcop->cop_line;
if (copline != NOLINE)
curcop->cop_line = copline;
! warner(WARN_SYNTAX, "Found = in conditional, should be ==");
curcop->cop_line = oldline;
}
return scalar(op);
***************
*** 758,764 ****
case OP_CONST:
sv = cSVOP->op_sv;
! if (dowarn) {
useless = "a constant";
if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = 0;
--- 761,767 ----
case OP_CONST:
sv = cSVOP->op_sv;
! if (ckWARN(WARN_VOID)) {
useless = "a constant";
if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = 0;
***************
*** 821,828 ****
op->op_private |= OPpLEAVE_VOID;
break;
}
! if (useless && dowarn)
! warn("Useless use of %s in void context", useless);
return op;
}
--- 824,831 ----
op->op_private |= OPpLEAVE_VOID;
break;
}
! if (useless && ckWARN(WARN_VOID))
! warner(WARN_VOID, "Useless use of %s in void context", useless);
return op;
}
***************
*** 949,968 ****
switch (op->op_type) {
case OP_CONST:
! if (!(op->op_private & (OPpCONST_ARYBASE)))
goto nomod;
! if (eval_start && eval_start->op_type == OP_CONST) {
! compiling.cop_arybase = (I32)SvIV(((SVOP*)eval_start)->op_sv);
! eval_start = 0;
! }
! else if (!type) {
! SAVEI32(compiling.cop_arybase);
! compiling.cop_arybase = 0;
}
- else if (type == OP_REFGEN)
- goto nomod;
- else
- croak("That use of $[ is unsupported");
break;
case OP_STUB:
if (op->op_flags & OPf_PARENS)
--- 952,973 ----
switch (op->op_type) {
case OP_CONST:
! if (!(op->op_private & (OPpCONST_ARYBASE|OPpCONST_WARNING)))
goto nomod;
! if (op->op_private & OPpCONST_ARYBASE) {
! if (eval_start && eval_start->op_type == OP_CONST) {
! compiling.cop_arybase = (I32)SvIV(((SVOP*)eval_start)->op_sv);
! eval_start = 0;
! }
! else if (!type) {
! SAVEI32(compiling.cop_arybase);
! compiling.cop_arybase = 0;
! }
! else if (type == OP_REFGEN)
! goto nomod;
! else
! croak("That use of $[ is unsupported");
}
break;
case OP_STUB:
if (op->op_flags & OPf_PARENS)
***************
*** 1340,1345 ****
--- 1345,1355 ----
pad_reset_pending = FALSE;
SAVEI32(hints);
hints &= ~HINT_BLOCK_SCOPE;
+ SAVEPPTR(compiling.cop_warnings);
+ if (compiling.cop_warnings != WARN_ALL && compiling.cop_warnings != WARN_NONE) {
+ compiling.cop_warnings = newSVsv(compiling.cop_warnings) ;
+ SAVEFREESV(compiling.cop_warnings) ;
+ }
return retval;
}
***************
*** 1402,1412 ****
list(o);
else {
scalar(o);
! if (dowarn && bufptr > oldbufptr && bufptr[-1] == ',') {
char *s;
for (s = bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ;
if (*s == ';' || *s == '=')
! warn("Parens missing around \"%s\" list", lex ? "my" : "local");
}
}
in_my = FALSE;
--- 1412,1423 ----
list(o);
else {
scalar(o);
! if (ckWARN(WARN_PARENTHESIS) && bufptr > oldbufptr && bufptr[-1] == ',') {
char *s;
for (s = bufptr; *s && (isALNUM(*s) || strchr("@$%, ",*s)); s++) ;
if (*s == ';' || *s == '=')
! warner(WARN_PARENTHESIS, "Parens missing around \"%s\" list",
! lex ? "my" : "local");
}
}
in_my = FALSE;
***************
*** 2388,2393 ****
--- 2399,2408 ----
}
cop->cop_seq = seq;
cop->cop_arybase = curcop->cop_arybase;
+ if (curcop->cop_warnings == WARN_NONE || curcop->cop_warnings == WARN_ALL)
+ cop->cop_warnings = curcop->cop_warnings ;
+ else
+ cop->cop_warnings = newSVsv(curcop->cop_warnings) ;
if (copline == NOLINE)
cop->cop_line = curcop->cop_line;
***************
*** 2463,2470 ****
}
}
if (first->op_type == OP_CONST) {
! if (dowarn && (first->op_private & OPpCONST_BARE))
! warn("Probable precedence problem on %s", op_desc[type]);
if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
op_free(first);
return other;
--- 2478,2486 ----
}
}
if (first->op_type == OP_CONST) {
! if (ckWARN(WARN_PRECEDENCE) && (first->op_private & OPpCONST_BARE))
! warner(WARN_PRECEDENCE, "Probable precedence problem on %s",
! op_desc[type]);
if ((type == OP_AND) == (SvTRUE(((SVOP*)first)->op_sv))) {
op_free(first);
return other;
***************
*** 2480,2486 ****
else
scalar(other);
}
! else if (dowarn && (first->op_flags & OPf_KIDS)) {
OP *k1 = ((UNOP*)first)->op_first;
OP *k2 = k1->op_sibling;
OPCODE warnop = 0;
--- 2496,2502 ----
else
scalar(other);
}
! else if (ckWARN(WARN_UNSAFE) && (first->op_flags & OPf_KIDS)) {
OP *k1 = ((UNOP*)first)->op_first;
OP *k2 = k1->op_sibling;
OPCODE warnop = 0;
***************
*** 2501,2507 ****
if (warnop) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
! warn("Value of %s construct can be \"0\"; test with defined()",
op_desc[warnop]);
curcop->cop_line = oldline;
}
--- 2517,2524 ----
if (warnop) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
! warner(WARN_UNSAFE,
! "Value of %s construct can be \"0\"; test with defined()",
op_desc[warnop]);
curcop->cop_line = oldline;
}
***************
*** 3083,3093 ****
SAVEFREESV(compcv);
goto done;
}
! if (const_sv || dowarn) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
! warn(const_sv ? "Constant subroutine %s redefined"
! : "Subroutine %s redefined",name);
curcop->cop_line = oldline;
}
SvREFCNT_dec(cv);
--- 3100,3111 ----
SAVEFREESV(compcv);
goto done;
}
! if (const_sv || ckWARN(WARN_REDEFINE)) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
! warner(WARN_REDEFINE,
! const_sv ? "Constant subroutine %s redefined"
! : "Subroutine %s redefined",name);
curcop->cop_line = oldline;
}
SvREFCNT_dec(cv);
***************
*** 3252,3261 ****
}
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
! if (dowarn) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
! warn("Subroutine %s redefined",name);
curcop->cop_line = oldline;
}
SvREFCNT_dec(cv);
--- 3270,3279 ----
}
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
! if (ckWARN(WARN_REDEFINE)) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
! warner(WARN_REDEFINE, "Subroutine %s redefined",name);
curcop->cop_line = oldline;
}
SvREFCNT_dec(cv);
***************
*** 3322,3332 ****
gv = gv_fetchpv(name,TRUE, SVt_PVFM);
GvMULTI_on(gv);
if (cv = GvFORM(gv)) {
! if (dowarn) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
! warn("Format %s redefined",name);
curcop->cop_line = oldline;
}
SvREFCNT_dec(cv);
--- 3340,3350 ----
gv = gv_fetchpv(name,TRUE, SVt_PVFM);
GvMULTI_on(gv);
if (cv = GvFORM(gv)) {
! if (ckWARN(WARN_REDEFINE)) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
! warner(WARN_REDEFINE, "Format %s redefined",name);
curcop->cop_line = oldline;
}
SvREFCNT_dec(cv);
***************
*** 3811,3818 ****
char *name = SvPVx(((SVOP*)kid)->op_sv, na);
OP *newop = newAVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVAV) ));
! if (dowarn)
! warn("Array @%s missing the @ in argument %ld of %s()",
name, (long)numargs, op_desc[type]);
op_free(kid);
kid = newop;
--- 3829,3837 ----
char *name = SvPVx(((SVOP*)kid)->op_sv, na);
OP *newop = newAVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVAV) ));
! if (ckWARN(WARN_SYNTAX))
! warner(WARN_SYNTAX,
! "Array @%s missing the @ in argument %ld of %s()",
name, (long)numargs, op_desc[type]);
op_free(kid);
kid = newop;
***************
*** 3829,3836 ****
char *name = SvPVx(((SVOP*)kid)->op_sv, na);
OP *newop = newHVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVHV) ));
! if (dowarn)
! warn("Hash %%%s missing the %% in argument %ld of %s()",
name, (long)numargs, op_desc[type]);
op_free(kid);
kid = newop;
--- 3848,3856 ----
char *name = SvPVx(((SVOP*)kid)->op_sv, na);
OP *newop = newHVREF(newGVOP(OP_GV, 0,
gv_fetchpv(name, TRUE, SVt_PVHV) ));
! if (ckWARN(WARN_SYNTAX))
! warner(WARN_SYNTAX,
! "Hash %%%s missing the %% in argument %ld of %s()",
name, (long)numargs, op_desc[type]);
op_free(kid);
kid = newop;
***************
*** 4551,4564 ****
case OP_EXEC:
o->op_seq = op_seqmax++;
! if (dowarn && o->op_next && o->op_next->op_type == OP_NEXTSTATE) {
if (o->op_next->op_sibling &&
o->op_next->op_sibling->op_type != OP_DIE) {
line_t oldline = curcop->cop_line;
curcop->cop_line = ((COP*)o->op_next)->cop_line;
! warn("Statement unlikely to be reached");
! warn("(Maybe you meant system() when you said exec()?)\n");
curcop->cop_line = oldline;
}
}
--- 4571,4585 ----
case OP_EXEC:
o->op_seq = op_seqmax++;
! if (ckWARN(WARN_SYNTAX) && o->op_next && o->op_next->op_type == OP_NEXTSTATE) {
if (o->op_next->op_sibling &&
o->op_next->op_sibling->op_type != OP_DIE) {
line_t oldline = curcop->cop_line;
curcop->cop_line = ((COP*)o->op_next)->cop_line;
! warner(WARN_SYNTAX, "Statement unlikely to be reached");
! warner(WARN_SYNTAX,
! "(Maybe you meant system() when you said exec()?)\n");
curcop->cop_line = oldline;
}
}
*** op.h.orig Thu Dec 19 10:59:06 1996
--- op.h Thu Feb 27 11:31:34 1997
***************
*** 95,100 ****
--- 95,101 ----
#define OPpCONST_ENTERED 16 /* Has been entered as symbol. */
#define OPpCONST_ARYBASE 32 /* Was a $[ translated to constant. */
#define OPpCONST_BARE 64 /* Was a bare word (filehandle?). */
+ #define OPpCONST_WARNING 128 /* Was a $^W translated to constant. */
/* Private for OP_FLIP/FLOP */
#define OPpFLIP_LINENUM 64 /* Range arg potentially a line num. */
*** perl.c.orig Fri Feb 21 23:04:49 1997
--- perl.c Thu Feb 27 11:31:35 1997
***************
*** 496,501 ****
--- 496,502 ----
main_cv = Nullcv;
time(&basetime);
+ dowarn = FALSE ;
switch (Sigsetjmp(top_env,1)) {
case 1:
***************
*** 545,550 ****
--- 546,552 ----
case 'u':
case 'U':
case 'v':
+ case 'W':
case 'w':
if (s = moreswitches(s))
goto reswitch;
***************
*** 761,767 ****
if (do_undump)
my_unexec();
! if (dowarn)
gv_check(defstash);
LEAVE;
--- 763,769 ----
if (do_undump)
my_unexec();
! if (ckWARN(WARN_ONCE))
gv_check(defstash);
LEAVE;
***************
*** 1426,1432 ****
GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
exit(0);
case 'w':
! dowarn = TRUE;
s++;
return s;
case '*':
--- 1428,1439 ----
GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
exit(0);
case 'w':
! dowarn |= G_WARN_ON;
! s++;
! return s;
! case 'W':
! dowarn |= G_WARN_FLAG|G_WARN_ON;
! compiling.cop_warnings = WARN_ALL ;
s++;
return s;
case '*':
*** perl.h.orig Tue Feb 18 08:43:26 1997
--- perl.h Thu Feb 27 11:34:45 1997
***************
*** 990,995 ****
--- 990,996 ----
#include "hv.h"
#include "mg.h"
#include "scope.h"
+ #include "warning.h"
/* work around some libPW problems */
#ifdef DOINIT
*** pp.c.orig Tue Feb 25 08:48:13 1997
--- pp.c Thu Feb 27 11:31:37 1997
***************
*** 1517,1524 ****
if (pos < 0)
pos += curlen + arybase;
if (pos < 0 || pos > curlen) {
! if (dowarn || lvalue)
! warn("substr outside of string");
RETPUSHUNDEF;
}
else {
--- 1517,1524 ----
if (pos < 0)
pos += curlen + arybase;
if (pos < 0 || pos > curlen) {
! if (lvalue || ckWARN(WARN_SUBSTR))
! warner(WARN_SUBSTR, "substr outside of string");
RETPUSHUNDEF;
}
else {
***************
*** 1538,1545 ****
if (!SvGMAGICAL(sv)) {
if (SvROK(sv)) {
SvPV_force(sv,na);
! if (dowarn)
! warn("Attempt to use reference as lvalue in substr");
}
if (SvOK(sv)) /* is it defined ? */
(void)SvPOK_only(sv);
--- 1538,1546 ----
if (!SvGMAGICAL(sv)) {
if (SvROK(sv)) {
SvPV_force(sv,na);
! if (ckWARN(WARN_SUBSTR))
! warner(WARN_SUBSTR,
! "Attempt to use reference as lvalue in substr");
}
if (SvOK(sv)) /* is it defined ? */
(void)SvPOK_only(sv);
*** pp_ctl.c.orig Fri Feb 21 23:04:54 1997
--- pp_ctl.c Thu Feb 27 11:41:18 1997
***************
*** 249,256 ****
sv = *++MARK;
else {
sv = &sv_no;
! if (dowarn)
! warn("Not enough format arguments");
}
break;
--- 249,256 ----
sv = *++MARK;
else {
sv = &sv_no;
! if (ckWARN(WARN_SYNTAX))
! warner(WARN_SYNTAX, "Not enough format arguments");
}
break;
***************
*** 774,793 ****
cx = &cxstack[i];
switch (cx->cx_type) {
case CXt_SUBST:
! if (dowarn)
! warn("Exiting substitution via %s", op_name[op->op_type]);
break;
case CXt_SUB:
! if (dowarn)
! warn("Exiting subroutine via %s", op_name[op->op_type]);
break;
case CXt_EVAL:
! if (dowarn)
! warn("Exiting eval via %s", op_name[op->op_type]);
break;
case CXt_NULL:
! if (dowarn)
! warn("Exiting pseudo-block via %s", op_name[op->op_type]);
return -1;
case CXt_LOOP:
if (!cx->blk_loop.label ||
--- 774,797 ----
cx = &cxstack[i];
switch (cx->cx_type) {
case CXt_SUBST:
! if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Exiting substitution via %s",
! op_name[op->op_type]);
break;
case CXt_SUB:
! if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Exiting subroutine via %s",
! op_name[op->op_type]);
break;
case CXt_EVAL:
! if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Exiting eval via %s",
! op_name[op->op_type]);
break;
case CXt_NULL:
! if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
! op_name[op->op_type]);
return -1;
case CXt_LOOP:
if (!cx->blk_loop.label ||
***************
*** 867,886 ****
cx = &cxstack[i];
switch (cx->cx_type) {
case CXt_SUBST:
! if (dowarn)
! warn("Exiting substitution via %s", op_name[op->op_type]);
break;
case CXt_SUB:
! if (dowarn)
! warn("Exiting subroutine via %s", op_name[op->op_type]);
break;
case CXt_EVAL:
! if (dowarn)
! warn("Exiting eval via %s", op_name[op->op_type]);
break;
case CXt_NULL:
! if (dowarn)
! warn("Exiting pseudo-block via %s", op_name[op->op_type]);
return -1;
case CXt_LOOP:
DEBUG_l( deb("(Found loop #%d)\n", i));
--- 871,894 ----
cx = &cxstack[i];
switch (cx->cx_type) {
case CXt_SUBST:
! if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Exiting substitution via %s",
! op_name[op->op_type]);
break;
case CXt_SUB:
! if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Exiting subroutine via %s",
! op_name[op->op_type]);
break;
case CXt_EVAL:
! if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Exiting eval via %s",
! op_name[op->op_type]);
break;
case CXt_NULL:
! if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
! op_name[op->op_type]);
return -1;
case CXt_LOOP:
DEBUG_l( deb("(Found loop #%d)\n", i));
***************
*** 1658,1664 ****
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
! if (CvDEPTH(cv) == 100 && dowarn)
sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILL(padlist)) {
AV *newpad = newAV();
--- 1666,1672 ----
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
! if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILL(padlist)) {
AV *newpad = newAV();
***************
*** 2167,2172 ****
--- 2175,2182 ----
SAVEFREEPV(name);
SAVEI32(hints);
hints = 0;
+ SAVEPPTR(compiling.cop_warnings);
+ compiling.cop_warnings = ((dowarn & G_WARN_FLAG) ? WARN_ALL : WARN_NONE) ;
/* switch to eval mode */
***************
*** 2218,2223 ****
--- 2228,2238 ----
SAVEDELETE(defstash, safestr, strlen(safestr));
SAVEI32(hints);
hints = op->op_targ;
+ SAVEPPTR(compiling.cop_warnings);
+ if (compiling.cop_warnings != WARN_ALL && compiling.cop_warnings != WARN_NONE){
+ compiling.cop_warnings = newSVsv(compiling.cop_warnings) ;
+ SAVEFREESV(compiling.cop_warnings) ;
+ }
push_return(op->op_next);
PUSHBLOCK(cx, CXt_EVAL, SP);
*** pp_hot.c.orig Fri Feb 21 23:04:55 1997
--- pp_hot.c Thu Feb 27 11:31:39 1997
***************
*** 344,366 ****
RETURN;
}
if (!(io = GvIO(gv))) {
! if (dowarn) {
SV* sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
! warn("Filehandle %s never opened", SvPV(sv,na));
}
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
! if (dowarn) {
SV* sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
! warn("Filehandle %s opened only for input", SvPV(sv,na));
! else
! warn("print on closed filehandle %s", SvPV(sv,na));
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
--- 344,368 ----
RETURN;
}
if (!(io = GvIO(gv))) {
! if (ckWARN(WARN_UNOPENED)) {
SV* sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
! warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,na));
}
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
! if (ckWARN2(WARN_CLOSED, WARN_IO)) {
SV* sv = sv_newmortal();
gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
! warner(WARN_IO, "Filehandle %s opened only for input",
! SvPV(sv,na));
! else if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "print on closed filehandle %s",
! SvPV(sv,na));
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
***************
*** 1123,1130 ****
SP--;
}
if (!fp) {
! if (dowarn && io && !(IoFLAGS(io) & IOf_START))
! warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
if (GIMME == G_SCALAR) {
(void)SvOK_off(TARG);
PUSHTARG;
--- 1125,1133 ----
SP--;
}
if (!fp) {
! if (io && ckWARN(WARN_CLOSED) && !(IoFLAGS(io) & IOf_START))
! warner(WARN_CLOSED, "Read on closed filehandle <%s>",
! GvENAME(last_in_gv));
if (GIMME == G_SCALAR) {
(void)SvOK_off(TARG);
PUSHTARG;
***************
*** 1868,1874 ****
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
! if (CvDEPTH(cv) == 100 && dowarn
&& !(perldb && cv == GvCV(DBsub)))
sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILL(padlist)) {
--- 1871,1877 ----
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
! if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
&& !(perldb && cv == GvCV(DBsub)))
sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILL(padlist)) {
***************
*** 1955,1965 ****
CV* cv;
{
if (CvANON(cv))
! warn("Deep recursion on anonymous subroutine");
else {
SV* tmpstr = sv_newmortal();
gv_efullname3(tmpstr, CvGV(cv), Nullch);
! warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr));
}
}
--- 1958,1969 ----
CV* cv;
{
if (CvANON(cv))
! warner(WARN_RECURSION, "Deep recursion on anonymous subroutine");
else {
SV* tmpstr = sv_newmortal();
gv_efullname3(tmpstr, CvGV(cv), Nullch);
! warner(WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
! SvPVX(tmpstr));
}
}
*** pp_sys.c.orig Fri Feb 21 23:04:55 1997
--- pp_sys.c Thu Feb 27 11:31:40 1997
***************
*** 517,523 ****
sv = POPs;
! if (dowarn) {
MAGIC * mg ;
if (SvMAGICAL(sv)) {
if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
--- 517,523 ----
sv = POPs;
! if (ckWARN(WARN_UNTIE)) {
MAGIC * mg ;
if (SvMAGICAL(sv)) {
if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
***************
*** 526,533 ****
mg = mg_find(sv, 'q') ;
if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
! warn("untie attempted while %lu inner references still exist",
! (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
}
}
--- 526,534 ----
mg = mg_find(sv, 'q') ;
if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
! warner(WARN_UNTIE,
! "untie attempted while %lu inner references still exist",
! (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
}
}
***************
*** 993,1010 ****
fp = IoOFP(io);
if (!fp) {
! if (dowarn) {
if (IoIFP(io))
! warn("Filehandle only opened for input");
! else
! warn("Write on closed filehandle");
}
PUSHs(&sv_no);
}
else {
if ((IoLINES_LEFT(io) -= FmLINES(formtarget)) < 0) {
! if (dowarn)
! warn("page overflow");
}
if (!PerlIO_write(ofp, SvPVX(formtarget), SvCUR(formtarget)) ||
PerlIO_error(fp))
--- 994,1011 ----
fp = IoOFP(io);
if (!fp) {
! if (ckWARN2(WARN_CLOSED,WARN_IO)) {
if (IoIFP(io))
! warner(WARN_IO, "Filehandle only opened for input");
! else if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "Write on closed filehandle");
}
PUSHs(&sv_no);
}
else {
if ((IoLINES_LEFT(io) -= FmLINES(formtarget)) < 0) {
! if (ckWARN(WARN_IO))
! warner(WARN_IO, "page overflow");
}
if (!PerlIO_write(ofp, SvPVX(formtarget), SvCUR(formtarget)) ||
PerlIO_error(fp))
***************
*** 1036,1055 ****
else
gv = defoutgv;
if (!(io = GvIO(gv))) {
! if (dowarn) {
gv_fullname3(sv, gv, Nullch);
! warn("Filehandle %s never opened", SvPV(sv,na));
}
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
! if (dowarn) {
gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
! warn("Filehandle %s opened only for input", SvPV(sv,na));
! else
! warn("printf on closed filehandle %s", SvPV(sv,na));
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
--- 1037,1058 ----
else
gv = defoutgv;
if (!(io = GvIO(gv))) {
! if (ckWARN(WARN_UNOPENED)) {
gv_fullname3(sv, gv, Nullch);
! warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,na));
}
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
! if (ckWARN2(WARN_CLOSED,WARN_IO)) {
gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
! warner(WARN_IO, "Filehandle %s opened only for input",
! SvPV(sv,na));
! else if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "printf on closed filehandle %s",
! SvPV(sv,na));
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
***************
*** 1233,1243 ****
io = GvIO(gv);
if (!io || !IoIFP(io)) {
length = -1;
! if (dowarn) {
if (op->op_type == OP_SYSWRITE)
! warn("Syswrite on closed filehandle");
else
! warn("Send on closed socket");
}
}
else if (op->op_type == OP_SYSWRITE) {
--- 1236,1246 ----
io = GvIO(gv);
if (!io || !IoIFP(io)) {
length = -1;
! if (ckWARN(WARN_CLOSED)) {
if (op->op_type == OP_SYSWRITE)
! warner(WARN_CLOSED, "Syswrite on closed filehandle");
else
! warner(WARN_CLOSED, "Send on closed socket");
}
}
else if (op->op_type == OP_SYSWRITE) {
***************
*** 1605,1612 ****
RETPUSHUNDEF;
nuts:
! if (dowarn)
! warn("bind() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
--- 1608,1615 ----
RETPUSHUNDEF;
nuts:
! if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "bind() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
***************
*** 1635,1642 ****
RETPUSHUNDEF;
nuts:
! if (dowarn)
! warn("connect() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
--- 1638,1645 ----
RETPUSHUNDEF;
nuts:
! if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "connect() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
***************
*** 1661,1668 ****
RETPUSHUNDEF;
nuts:
! if (dowarn)
! warn("listen() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
--- 1664,1671 ----
RETPUSHUNDEF;
nuts:
! if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "listen() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
***************
*** 1715,1722 ****
RETURN;
nuts:
! if (dowarn)
! warn("accept() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
badexit:
--- 1718,1725 ----
RETURN;
nuts:
! if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "accept() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
badexit:
***************
*** 1742,1749 ****
RETURN;
nuts:
! if (dowarn)
! warn("shutdown() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
--- 1745,1752 ----
RETURN;
nuts:
! if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "shutdown() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
***************
*** 1818,1825 ****
RETURN;
nuts:
! if (dowarn)
! warn("[gs]etsockopt() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
--- 1821,1828 ----
RETURN;
nuts:
! if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "[gs]etsockopt() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
***************
*** 1880,1887 ****
RETURN;
nuts:
! if (dowarn)
! warn("get{sock, peer}name() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
--- 1883,1890 ----
RETURN;
nuts:
! if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "get{sock, peer}name() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
***************
*** 1937,1944 ****
#endif
laststatval = Stat(SvPV(statname, na), &statcache);
if (laststatval < 0) {
! if (dowarn && strchr(SvPV(statname, na), '\n'))
! warn(warn_nl, "stat");
max = 0;
}
}
--- 1940,1947 ----
#endif
laststatval = Stat(SvPV(statname, na), &statcache);
if (laststatval < 0) {
! if (ckWARN(WARN_NEWLINE) && strchr(SvPV(statname, na), '\n'))
! warner(WARN_NEWLINE, warn_nl, "stat");
max = 0;
}
}
***************
*** 2340,2347 ****
len = 512;
}
else {
! if (dowarn)
! warn("Test on unopened file <%s>",
GvENAME(cGVOP->op_gv));
SETERRNO(EBADF,RMS$_IFI);
RETPUSHUNDEF;
--- 2343,2350 ----
len = 512;
}
else {
! if (ckWARN(WARN_UNOPENED))
! warner(WARN_UNOPENED, "Test on unopened file <%s>",
GvENAME(cGVOP->op_gv));
SETERRNO(EBADF,RMS$_IFI);
RETPUSHUNDEF;
***************
*** 2359,2366 ****
i = open(SvPV(sv, na), 0);
#endif
if (i < 0) {
! if (dowarn && strchr(SvPV(sv, na), '\n'))
! warn(warn_nl, "open");
RETPUSHUNDEF;
}
laststatval = Fstat(i, &statcache);
--- 2362,2369 ----
i = open(SvPV(sv, na), 0);
#endif
if (i < 0) {
! if (ckWARN(WARN_NEWLINE) && strchr(SvPV(sv, na), '\n'))
! warner(WARN_NEWLINE, warn_nl, "open");
RETPUSHUNDEF;
}
laststatval = Fstat(i, &statcache);
*** proto.h.orig Tue Feb 4 08:55:19 1997
--- proto.h Thu Feb 27 11:31:40 1997
***************
*** 501,506 ****
--- 501,507 ----
void vivify_itervar _((SV* sv));
I32 wait4pid _((int pid, int* statusp, int flags));
void warn _((const char* pat,...)) __attribute__((format(printf,1,2)));
+ void warner _((U32 err, const char* pat,...)) __attribute__((format(printf,1,2)));
void watch _((char **addr));
I32 whichsig _((char* sig));
int yyerror _((char* s));
*** regcomp.c.orig Tue Feb 18 08:43:33 1997
--- regcomp.c Thu Feb 27 11:31:41 1997
***************
*** 719,726 ****
goto do_curly;
}
nest_check:
! if (dowarn && regcode != ®dummy && !(flags&HASWIDTH) && max > 10000) {
! warn("%.*s matches null string many times",
regparse - origparse, origparse);
}
--- 719,726 ----
goto do_curly;
}
nest_check:
! if (ckWARN(WARN_UNSAFE) && regcode != ®dummy && !(flags&HASWIDTH) && max > 10000) {
! warner(WARN_UNSAFE, "%.*s matches null string many times",
regparse - origparse, origparse);
}
*** sv.c.orig Tue Feb 18 08:43:33 1997
--- sv.c Thu Feb 27 11:31:42 1997
***************
*** 1237,1246 ****
*d = '\0';
if (op)
! warn("Argument \"%s\" isn't numeric in %s", tmpbuf,
op_name[op->op_type]);
else
! warn("Argument \"%s\" isn't numeric", tmpbuf);
}
IV
--- 1237,1246 ----
*d = '\0';
if (op)
! warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
op_name[op->op_type]);
else
! warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
}
IV
***************
*** 1282,1289 ****
}
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
! if (dowarn)
! warn(warn_uninit);
return 0;
}
}
--- 1282,1289 ----
}
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
! if (ckWARN(WARN_UNINITIALIZED))
! warner(WARN_UNINITIALIZED, warn_uninit);
return 0;
}
}
***************
*** 1310,1317 ****
SvIVX(sv) = asIV(sv);
}
else {
! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
! warn(warn_uninit);
return 0;
}
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
--- 1310,1317 ----
SvIVX(sv) = asIV(sv);
}
else {
! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP))
! warner(WARN_UNINITIALIZED, warn_uninit);
return 0;
}
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
***************
*** 1351,1358 ****
}
if (SvPOKp(sv) && SvLEN(sv))
return asUV(sv);
! if (dowarn)
! warn(warn_uninit);
return 0;
}
}
--- 1351,1358 ----
}
if (SvPOKp(sv) && SvLEN(sv))
return asUV(sv);
! if (ckWARN(WARN_UNINITIALIZED))
! warner(WARN_UNINITIALIZED, warn_uninit);
return 0;
}
}
***************
*** 1376,1383 ****
SvUVX(sv) = asUV(sv);
}
else {
! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
! warn(warn_uninit);
return 0;
}
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
--- 1376,1383 ----
SvUVX(sv) = asUV(sv);
}
else {
! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP))
! warner(WARN_UNINITIALIZED, warn_uninit);
return 0;
}
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
***************
*** 1396,1402 ****
if (SvNOKp(sv))
return SvNVX(sv);
if (SvPOKp(sv) && SvLEN(sv)) {
! if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
--- 1396,1402 ----
if (SvNOKp(sv))
return SvNVX(sv);
if (SvPOKp(sv) && SvLEN(sv)) {
! if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
***************
*** 1418,1432 ****
}
if (SvREADONLY(sv)) {
if (SvPOKp(sv) && SvLEN(sv)) {
! if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
}
if (SvIOKp(sv))
return (double)SvIVX(sv);
! if (dowarn)
! warn(warn_uninit);
return 0.0;
}
}
--- 1418,1432 ----
}
if (SvREADONLY(sv)) {
if (SvPOKp(sv) && SvLEN(sv)) {
! if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
}
if (SvIOKp(sv))
return (double)SvIVX(sv);
! if (ckWARN(WARN_UNINITIALIZED))
! warner(WARN_UNINITIALIZED, warn_uninit);
return 0.0;
}
}
***************
*** 1447,1460 ****
SvNVX(sv) = (double)SvIVX(sv);
}
else if (SvPOKp(sv) && SvLEN(sv)) {
! if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SET_NUMERIC_STANDARD();
SvNVX(sv) = atof(SvPVX(sv));
}
else {
! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
! warn(warn_uninit);
return 0.0;
}
SvNOK_on(sv);
--- 1447,1460 ----
SvNVX(sv) = (double)SvIVX(sv);
}
else if (SvPOKp(sv) && SvLEN(sv)) {
! if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SET_NUMERIC_STANDARD();
SvNVX(sv) = atof(SvPVX(sv));
}
else {
! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP))
! warner(WARN_UNINITIALIZED, warn_uninit);
return 0.0;
}
SvNOK_on(sv);
***************
*** 1473,1479 ****
if (numtype == 1)
return atol(SvPVX(sv));
! if (!numtype && dowarn)
not_a_number(sv);
SET_NUMERIC_STANDARD();
d = atof(SvPVX(sv));
--- 1473,1479 ----
if (numtype == 1)
return atol(SvPVX(sv));
! if (!numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
SET_NUMERIC_STANDARD();
d = atof(SvPVX(sv));
***************
*** 1491,1497 ****
if (numtype == 1)
return atol(SvPVX(sv));
! if (!numtype && dowarn)
not_a_number(sv);
SET_NUMERIC_STANDARD();
return U_V(atof(SvPVX(sv)));
--- 1491,1497 ----
if (numtype == 1)
return atol(SvPVX(sv));
! if (!numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
SET_NUMERIC_STANDARD();
return U_V(atof(SvPVX(sv)));
***************
*** 1659,1666 ****
(void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
goto tokensave;
}
! if (dowarn)
! warn(warn_uninit);
*lp = 0;
return "";
}
--- 1659,1666 ----
(void)sprintf(tokenbuf,"%ld",(long)SvIVX(sv));
goto tokensave;
}
! if (ckWARN(WARN_UNINITIALIZED))
! warner(WARN_UNINITIALIZED, warn_uninit);
*lp = 0;
return "";
}
***************
*** 1704,1711 ****
while (*s) s++;
}
else {
! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
! warn(warn_uninit);
*lp = 0;
return "";
}
--- 1704,1711 ----
while (*s) s++;
}
else {
! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP))
! warner(WARN_UNINITIALIZED, warn_uninit);
*lp = 0;
return "";
}
***************
*** 1973,1982 ****
CV* cv = GvCV(dstr);
if (cv) {
dref = (SV*)cv;
! if (dowarn && sref != dref &&
!GvCVGEN((GV*)dstr) &&
(CvROOT(cv) || CvXSUB(cv)) )
! warn("Subroutine %s redefined",
GvENAME((GV*)dstr));
}
}
--- 1973,1983 ----
CV* cv = GvCV(dstr);
if (cv) {
dref = (SV*)cv;
! if (ckWARN(WARN_REDEFINE) && sref != dref &&
!GvCVGEN((GV*)dstr) &&
(CvROOT(cv) || CvXSUB(cv)) )
! warner(WARN_REDEFINE,
! "Subroutine %s redefined",
GvENAME((GV*)dstr));
}
}
*** t/op/tie.t.orig Tue Nov 19 14:45:04 1996
--- t/op/tie.t Thu Feb 27 11:31:43 1997
***************
*** 77,84 ****
########
# strict behaviour, without any extra references
! #use warning 'untie';
! local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
--- 77,84 ----
########
# strict behaviour, without any extra references
! use warning 'untie';
! #local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
***************
*** 86,93 ****
########
# strict behaviour, with 1 extra references generating an error
! #use warning 'untie';
! local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
untie %h;
--- 86,93 ----
########
# strict behaviour, with 1 extra references generating an error
! use warning 'untie';
! #local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
untie %h;
***************
*** 96,103 ****
########
# strict behaviour, with 1 extra references via tied generating an error
! #use warning 'untie';
! local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
--- 96,103 ----
########
# strict behaviour, with 1 extra references via tied generating an error
! use warning 'untie';
! #local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
***************
*** 107,114 ****
########
# strict behaviour, with 1 extra references which are destroyed
! #use warning 'untie';
! local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$a = 0 ;
--- 107,114 ----
########
# strict behaviour, with 1 extra references which are destroyed
! use warning 'untie';
! #local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$a = 0 ;
***************
*** 117,124 ****
########
# strict behaviour, with extra 1 references via tied which are destroyed
! #use warning 'untie';
! local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
--- 117,124 ----
########
# strict behaviour, with extra 1 references via tied which are destroyed
! use warning 'untie';
! #local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
$a = tied %h;
***************
*** 128,135 ****
########
# strict error behaviour, with 2 extra references
! #use warning 'untie';
! local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$b = tied %h ;
--- 128,135 ----
########
# strict error behaviour, with 2 extra references
! use warning 'untie';
! #local $^W = 1 ;
use Tie::Hash ;
$a = tie %h, Tie::StdHash;
$b = tied %h ;
***************
*** 139,152 ****
########
# strict behaviour, check scope of strictness.
! #no warning 'untie';
! local $^W = 0 ;
use Tie::Hash ;
$A = tie %H, Tie::StdHash;
$C = $B = tied %H ;
{
! #use warning 'untie';
! local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
--- 139,152 ----
########
# strict behaviour, check scope of strictness.
! no warning 'untie';
! #local $^W = 0 ;
use Tie::Hash ;
$A = tie %H, Tie::StdHash;
$C = $B = tied %H ;
{
! use warning 'untie';
! #local $^W = 1 ;
use Tie::Hash ;
tie %h, Tie::StdHash;
untie %h;
*** t/pragma/warn-1global.orig Sat Jan 4 09:46:21 1997
--- t/pragma/warn-1global Thu Feb 27 11:31:44 1997
***************
*** 110,131 ****
########
$^W = 1;
! eval "my $b ; chop $b ;" ;
EXPECT
! Use of uninitialized value at - line 3.
! Use of uninitialized value at - line 3.
########
! eval "$^W = 1;" ;
my $b ; chop $b ;
EXPECT
!
########
eval {$^W = 1;} ;
my $b ; chop $b ;
EXPECT
! Use of uninitialized value at - line 3.
########
{
--- 110,133 ----
########
$^W = 1;
! eval 'my $b ; chop $b ;' ;
! print $@ ;
EXPECT
! Use of uninitialized value at (eval 1) line 1.
########
! eval '$^W = 1;' ;
! print $@ ;
my $b ; chop $b ;
EXPECT
! Use of uninitialized value at - line 4.
########
eval {$^W = 1;} ;
+ print $@ ;
my $b ; chop $b ;
EXPECT
! Use of uninitialized value at - line 4.
########
{
***************
*** 144,146 ****
--- 146,180 ----
my $c ; chop $c ;
EXPECT
Use of uninitialized value at - line 5.
+ ########
+
+ $^W = 1 + 2 ;
+ EXPECT
+
+ ########
+
+ $^W = $a ;
+ EXPECT
+
+ ########
+
+ sub fred {}
+ $^W = fred() ;
+ EXPECT
+
+ ########
+
+ sub fred { my $b ; chop $b ;}
+ { local $^W = 0 ;
+ fred() ;
+ }
+ EXPECT
+
+ ########
+
+ sub fred { my $b ; chop $b ;}
+ { local $^W = 1 ;
+ fred() ;
+ }
+ EXPECT
+ Use of uninitialized value at - line 2.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-2use Thu Feb 27 11:31:44 1997
***************
*** 0 ****
--- 1,291 ----
+ Check lexical warning functionality
+
+ TODO
+ check that the hierarchy works.
+
+ __END__
+
+ # check illegal category is caught
+ use warning 'blah' ;
+ EXPECT
+ unknown warning category 'blah' at - line 3
+ BEGIN failed--compilation aborted at - line 3.
+ ########
+
+ # Check compile time scope of pragma
+ use warning 'deprecated' ;
+ {
+ no warning ;
+ 1 if $a EQ $b ;
+ }
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 8.
+ ########
+
+ # Check compile time scope of pragma
+ no warning;
+ {
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+ }
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 6.
+ ########
+
+ # Check runtime scope of pragma
+ use warning 'uninitialized' ;
+ {
+ no warning ;
+ my $b ; chop $b ;
+ }
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 8.
+ ########
+
+ # Check runtime scope of pragma
+ no warning ;
+ {
+ use warning 'uninitialized' ;
+ my $b ; chop $b ;
+ }
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 6.
+ ########
+
+ # Check runtime scope of pragma
+ no warning ;
+ {
+ use warning 'uninitialized' ;
+ $a = sub { my $b ; chop $b ; }
+ }
+ &$a ;
+ EXPECT
+ Use of uninitialized value at - line 6.
+ ########
+
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 3.
+ ########
+
+ --FILE-- abc
+ 1 if $a EQ $b ;
+ 1;
+ --FILE--
+ use warning 'deprecated' ;
+ require "./abc";
+ EXPECT
+
+ ########
+
+ --FILE-- abc
+ use warning 'deprecated' ;
+ 1;
+ --FILE--
+ require "./abc";
+ 1 if $a EQ $b ;
+ EXPECT
+
+ ########
+
+ --FILE-- abc
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+ 1;
+ --FILE--
+ use warning 'uninitialized' ;
+ require "./abc";
+ my $a ; chop $a ;
+ EXPECT
+ Use of EQ is deprecated at ./abc line 2.
+ Use of uninitialized value at - line 3.
+ ########
+
+ --FILE-- abc.pm
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+ 1;
+ --FILE--
+ use warning 'uninitialized' ;
+ use abc;
+ my $a ; chop $a ;
+ EXPECT
+ Use of EQ is deprecated at abc.pm line 2.
+ Use of uninitialized value at - line 3.
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval {
+ my $b ; chop $b ;
+ }; print STDERR $@ ;
+ my $b ; chop $b ;
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval {
+ use warning 'uninitialized' ;
+ my $b ; chop $b ;
+ }; print STDERR $@ ;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 6.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'uninitialized' ;
+ eval {
+ my $b ; chop $b ;
+ }; print STDERR $@ ;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 5.
+ Use of uninitialized value at - line 7.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'uninitialized' ;
+ eval {
+ no warning ;
+ my $b ; chop $b ;
+ }; print STDERR $@ ;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 8.
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval {
+ 1 if $a EQ $b ;
+ }; print STDERR $@ ;
+ 1 if $a EQ $b ;
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval {
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+ }; print STDERR $@ ;
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 6.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'deprecated' ;
+ eval {
+ 1 if $a EQ $b ;
+ }; print STDERR $@ ;
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 5.
+ Use of EQ is deprecated at - line 7.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'deprecated' ;
+ eval {
+ no warning ;
+ 1 if $a EQ $b ;
+ }; print STDERR $@ ;
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 8.
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval '
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval q[
+ use warning 'uninitialized' ;
+ my $b ; chop $b ;
+ ]; print STDERR $@;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at (eval 1) line 3.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'uninitialized' ;
+ eval '
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at (eval 1) line 2.
+ Use of uninitialized value at - line 7.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'uninitialized' ;
+ eval '
+ no warning ;
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 8.
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval '
+ 1 if $a EQ $b ;
+ '; print STDERR $@ ;
+ 1 if $a EQ $b ;
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval q[
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+ ]; print STDERR $@;
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at (eval 1) line 3.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'deprecated' ;
+ eval '
+ 1 if $a EQ $b ;
+ '; print STDERR $@;
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 7.
+ Use of EQ is deprecated at (eval 1) line 2.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'deprecated' ;
+ eval '
+ no warning ;
+ 1 if $a EQ $b ;
+ '; print STDERR $@;
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 8.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-3both Thu Feb 27 11:31:44 1997
***************
*** 0 ****
--- 1,66 ----
+ Check interaction of $^W and lexical
+
+ __END__
+
+ # Check interaction of $^W and use warning
+ sub fred {
+ use warning ;
+ my $b ;
+ chop $b ;
+ }
+ { local $^W = 0 ;
+ fred() ;
+ }
+
+ EXPECT
+ Use of uninitialized value at - line 6.
+ ########
+
+ # Check interaction of $^W and use warning
+ sub fred {
+ no warning ;
+ my $b ;
+ chop $b ;
+ }
+ { local $^W = 1 ;
+ fred() ;
+ }
+
+ EXPECT
+ Use of uninitialized value at - line 6.
+ ########
+
+ # Check interaction of $^W and use warning
+ use warning ;
+ $^W = 1 ;
+ my $b ;
+ chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 6.
+ ########
+
+ # Check interaction of $^W and use warning
+ $^W = 1 ;
+ use warning ;
+ my $b ;
+ chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 6.
+ ########
+
+ # Check interaction of $^W and use warning
+ $^W = 1 ;
+ no warning ;
+ my $b ;
+ chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 6.
+ ########
+
+ # Check interaction of $^W and use warning
+ no warning ;
+ $^W = 1 ;
+ my $b ;
+ chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 6.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-4lint Thu Feb 27 11:31:45 1997
***************
*** 0 ****
--- 1,41 ----
+ Check lint
+
+ TODO
+ check that -W will override both $^W and no warning.
+ check that any required/used files also have warnings enabled.
+
+ __END__
+ -W
+ # lint: check compile time $^W is zapped
+ BEGIN { $^W = 0 ;}
+ $a = $b = 1 ;
+ $a = 1 if $a EQ $b ;
+ close STDIN ; print STDIN "abc" ;
+ EXPECT
+ Use of EQ is deprecated at - line 5.
+ print on closed filehandle main::STDIN at - line 6.
+ ########
+ -W
+ # lint: check runtime $^W is zapped
+ $^W = 0 ;
+ close STDIN ; print STDIN "abc" ;
+ EXPECT
+ print on closed filehandle main::STDIN at - line 4.
+ ########
+ -W
+ # lint: check runtime $^W is zapped
+ {
+ $^W = 0 ;
+ close STDIN ; print STDIN "abc" ;
+ }
+ EXPECT
+ print on closed filehandle main::STDIN at - line 5.
+ ########
+ -W
+ # lint: check combination of -w and -W
+ {
+ $^W = 0 ;
+ close STDIN ; print STDIN "abc" ;
+ }
+ EXPECT
+ print on closed filehandle main::STDIN at - line 5.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-doio Thu Feb 27 11:31:45 1997
***************
*** 0 ****
--- 1,89 ----
+ doio.c AOK
+
+ Can't do bidirectional pipe
+ open(F, "| true |");
+
+ warn(warn_nl, "open");
+ open(F, "true\ncd")
+
+ Close on unopened file <%s>
+ $a = "fred";close($a)
+
+ tell() on unopened file
+ $a = "fred";$a = tell($a)
+
+ seek() on unopened file
+ $a = "fred";$a = seek($a,1,1)
+
+ warn(warn_uninit);
+ print $a ;
+
+ Stat on unopened file <%s>
+ close STDIN ; -x STDIN ;
+
+ warn(warn_nl, "stat");
+ stat "ab\ncd"
+
+ warn(warn_nl, "lstat");
+ lstat "ab\ncd"
+
+ Can't exec \"%s\": %s
+
+ Can't exec \"%s\": %s
+
+
+ __END__
+ # doio.c
+ use warning 'io' ;
+ open(F, "|true|")
+ EXPECT
+ Can't do bidirectional pipe at - line 3.
+ ########
+ # doio.c
+ use warning 'io' ;
+ open(F, "<true\ncd")
+ EXPECT
+ Unsuccessful open on filename containing newline at - line 3.
+ ########
+ # doio.c
+ use warning 'io' ;
+ close STDIN ;
+ tell(STDIN);
+ $a = seek(STDIN,1,1);
+ -x STDIN ;
+ EXPECT
+ tell() on unopened file at - line 4.
+ seek() on unopened file at - line 5.
+ Stat on unopened file <STDIN> at - line 6.
+ ########
+ # doio.c
+ use warning 'uninitialized' ;
+ print $a ;
+ EXPECT
+ Use of uninitialized value at - line 3.
+ ########
+ # doio.c
+ use warning 'io' ;
+
+ EXPECT
+
+ ########
+ # doio.c
+ use warning 'io' ;
+ stat "ab\ncd";
+ lstat "ab\ncd";
+ EXPECT
+ Unsuccessful stat on filename containing newline at - line 3.
+ Unsuccessful stat on filename containing newline at - line 4.
+ ########
+ # doio.c
+ use warning 'io' ;
+ exec "lskdjfalksdjfdjfkls" ;
+ EXPECT
+ Can't exec "lskdjfalksdjfdjfkls": No such file or directory at - line 3.
+ ########
+ # doio.c
+ use warning 'io' ;
+ exec "lskdjfalksdjfdjfkls", "abc" ;
+ EXPECT
+ Can't exec "lskdjfalksdjfdjfkls": No such file or directory at - line 3.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-gv Thu Feb 27 11:31:45 1997
***************
*** 0 ****
--- 1,28 ----
+ gv.c AOK
+
+ Can't locate package %s for @%s::ISA
+ @ISA = qw(Fred); joe()
+
+
+ Use of $# is deprecated
+ Use of $* is deprecated
+
+ $a = ${"#"} ;
+ $a = ${"*"} ;
+
+
+ __END__
+ # gv.c
+ use warning 'misc' ;
+ @ISA = qw(Fred); joe()
+ EXPECT
+ Can't locate package Fred for @main::ISA at - line 3.
+ Undefined subroutine &main::joe called at - line 3.
+ ########
+ # gv.c
+ use warning 'deprecated' ;
+ $a = ${"#"};
+ $a = ${"*"};
+ EXPECT
+ Use of $# is deprecated at - line 3.
+ Use of $* is deprecated at - line 4.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-mg Thu Feb 27 11:31:46 1997
***************
*** 0 ****
--- 1,21 ----
+ mg.c AOK
+
+ No such signal: SIG%s
+ $SIG{FRED} = sub {}
+
+ SIG%s handler \"%s\" not defined.
+ $SIG{"INT"} = "ok3"; kill "INT",$$;
+
+
+ __END__
+ # mg.c
+ use warning 'signal' ;
+ $SIG{FRED} = sub {};
+ EXPECT
+ No such signal: SIGFRED at - line 3.
+ ########
+ # mg.c
+ use warning 'signal' ;
+ $SIG{"INT"} = "fred"; kill "INT",$$;
+ EXPECT
+ SIGINT handler "fred" not defined.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-op Thu Feb 27 11:31:46 1997
***************
*** 0 ****
--- 1,481 ----
+ op.c
+
+ Variable "%s" may be unavailable
+ sub x {
+ my $x;
+ sub y {
+ $x
+ }
+ }
+
+ Variable "%s" will not stay shared
+ sub x {
+ my $x;
+ sub y {
+ sub { $x }
+ }
+ }
+
+ Found = in conditional, should be ==
+ 1 if $a = 1 ;
+
+ Use of implicit split to @_ is deprecated
+ split ;
+
+ Use of implicit split to @_ is deprecated
+ $a = split ;
+
+ Useless use of time in void context
+ Useless use of a variable in void context
+ Useless use of a constant in void context
+ time ;
+ $a ;
+ "abc"
+
+
+ Parens missing around "my" list at -e line 1.
+ my $a, $b = (1,2);
+
+ Parens missing around "local" list at -e line 1.
+ local $a, $b = (1,2);
+
+ Probable precedence problem on logical or at -e line 1.
+ use warning 'syntax'; my $x = print(ABC || 1);
+
+ Value of %s may be \"0\"; use \"defined\"
+ $x = 1 if $x = <FH> ;
+ $x = 1 while $x = <FH> ;
+
+ Subroutine fred redefined at -e line 1.
+ sub fred{1;} sub fred{1;}
+
+ Constant subroutine %s redefined
+ sub fred() {1;} sub fred() {1;}
+
+ Format FRED redefined at /tmp/x line 5.
+ format FRED =
+ .
+ format FRED =
+ .
+
+ Array @%s missing the @ in argument %d of %s()
+ push fred ;
+
+ Hash %%%s missing the %% in argument %d of %s()
+ keys joe ;
+
+ Statement unlikely to be reached
+ (Maybe you meant system() when you said exec()?
+ exec "true" ; my $a
+
+
+ __END__
+ # op.c
+ use warning 'unsafe' ;
+ sub x {
+ my $x;
+ sub y {
+ $x
+ }
+ }
+ EXPECT
+ Variable "$x" will not stay shared at - line 7.
+ ########
+ # op.c
+ use warning 'unsafe' ;
+ sub x {
+ my $x;
+ sub y {
+ sub { $x }
+ }
+ }
+ EXPECT
+ Variable "$x" may be unavailable at - line 6.
+ ########
+ # op.c
+ use warning 'syntax' ;
+ 1 if $a = 1 ;
+ EXPECT
+ Found = in conditional, should be == at - line 3.
+ ########
+ # op.c
+ use warning 'deprecated' ;
+ split ;
+ EXPECT
+ Use of implicit split to @_ is deprecated at - line 3.
+ ########
+ # op.c
+ use warning 'deprecated' ;
+ $a = split ;
+ EXPECT
+ Use of implicit split to @_ is deprecated at - line 3.
+ ########
+ # op.c
+ use warning 'void' ; close STDIN ;
+ 1 x 3 ; # OP_REPEAT
+ # OP_GVSV
+ wantarray ; # OP_WANTARRAY
+ # OP_GV
+ # OP_PADSV
+ # OP_PADAV
+ # OP_PADHV
+ # OP_PADANY
+ # OP_AV2ARYLEN
+ ref ; # OP_REF
+ \@a ; # OP_REFGEN
+ \$a ; # OP_SREFGEN
+ defined $a ; # OP_DEFINED
+ hex $a ; # OP_HEX
+ oct $a ; # OP_OCT
+ length $a ; # OP_LENGTH
+ substr $a,1 ; # OP_SUBSTR
+ vec $a,1,2 ; # OP_VEC
+ index $a,1,2 ; # OP_INDEX
+ rindex $a,1,2 ; # OP_RINDEX
+ sprintf $a ; # OP_SPRINTF
+ $a[0] ; # OP_AELEM
+ # OP_AELEMFAST
+ @a[0] ; # OP_ASLICE
+ #values %a ; # OP_VALUES
+ #keys %a ; # OP_KEYS
+ $a{0} ; # OP_HELEM
+ @a{0} ; # OP_HSLICE
+ unpack $a, "" ; # OP_UNPACK
+ pack $a,"" ; # OP_PACK
+ join "" ; # OP_JOIN
+ (@a)[0,1] ; # OP_LSLICE
+ # OP_ANONLIST
+ # OP_ANONHASH
+ sort(1,2) ; # OP_SORT
+ reverse(1,2) ; # OP_REVERSE
+ # OP_RANGE
+ # OP_FLIP
+ (1 ..2) ; # OP_FLOP
+ caller ; # OP_CALLER
+ fileno STDIN ; # OP_FILENO
+ eof STDIN ; # OP_EOF
+ tell STDIN ; # OP_TELL
+ readlink 1; # OP_READLINK
+ time ; # OP_TIME
+ localtime ; # OP_LOCALTIME
+ gmtime ; # OP_GMTIME
+ getgrnam 1; # OP_GGRNAM
+ getgrgid 1 ; # OP_GGRGID
+ getpwnam 1; # OP_GPWNAM
+ getpwuid 1; # OP_GPWUID
+ EXPECT
+ Useless use of repeat in void context at - line 3.
+ Useless use of wantarray in void context at - line 5.
+ Useless use of reference-type operator in void context at - line 12.
+ Useless use of reference constructor in void context at - line 13.
+ Useless use of scalar ref constructor in void context at - line 14.
+ Useless use of defined operator in void context at - line 15.
+ Useless use of hex in void context at - line 16.
+ Useless use of oct in void context at - line 17.
+ Useless use of length in void context at - line 18.
+ Useless use of substr in void context at - line 19.
+ Useless use of vec in void context at - line 20.
+ Useless use of index in void context at - line 21.
+ Useless use of rindex in void context at - line 22.
+ Useless use of sprintf in void context at - line 23.
+ Useless use of array element in void context at - line 24.
+ Useless use of array slice in void context at - line 26.
+ Useless use of hash elem in void context at - line 29.
+ Useless use of hash slice in void context at - line 30.
+ Useless use of unpack in void context at - line 31.
+ Useless use of pack in void context at - line 32.
+ Useless use of join in void context at - line 33.
+ Useless use of list slice in void context at - line 34.
+ Useless use of sort in void context at - line 37.
+ Useless use of reverse in void context at - line 38.
+ Useless use of range (or flop) in void context at - line 41.
+ Useless use of caller in void context at - line 42.
+ Useless use of fileno in void context at - line 43.
+ Useless use of eof in void context at - line 44.
+ Useless use of tell in void context at - line 45.
+ Useless use of readlink in void context at - line 46.
+ Useless use of time in void context at - line 47.
+ Useless use of localtime in void context at - line 48.
+ Useless use of gmtime in void context at - line 49.
+ Useless use of getgrnam in void context at - line 50.
+ Useless use of getgrgid in void context at - line 51.
+ Useless use of getpwnam in void context at - line 52.
+ Useless use of getpwuid in void context at - line 53.
+ ########
+ # op.c
+ use warning 'void' ;
+ use Config ;
+ BEGIN {
+ if ( ! $Config{d_telldir}) {
+ print <<EOM ;
+ SKIPPED
+ # telldir not present
+ EOM
+ exit
+ }
+ }
+ telldir 1 ; # OP_TELLDIR
+ EXPECT
+ Useless use of telldir in void context at - line 13.
+ ########
+ # op.c
+ use warning 'void' ;
+ use Config ;
+ BEGIN {
+ if ( ! $Config{d_getppid}) {
+ print <<EOM ;
+ SKIPPED
+ # getppid not present
+ EOM
+ exit
+ }
+ }
+ getppid ; # OP_GETPPID
+ EXPECT
+ Useless use of getppid in void context at - line 13.
+ ########
+ # op.c
+ use warning 'void' ;
+ use Config ;
+ BEGIN {
+ if ( ! $Config{d_getpgrp}) {
+ print <<EOM ;
+ SKIPPED
+ # getpgrp not present
+ EOM
+ exit
+ }
+ }
+ getpgrp ; # OP_GETPGRP
+ EXPECT
+ Useless use of getpgrp in void context at - line 13.
+ ########
+ # op.c
+ use warning 'void' ;
+ use Config ;
+ BEGIN {
+ if ( ! $Config{d_times}) {
+ print <<EOM ;
+ SKIPPED
+ # times not present
+ EOM
+ exit
+ }
+ }
+ times ; # OP_TMS
+ EXPECT
+ Useless use of times in void context at - line 13.
+ ########
+ # op.c
+ use warning 'void' ;
+ use Config ;
+ BEGIN {
+ if ( ! $Config{d_getprior}) {
+ print <<EOM ;
+ SKIPPED
+ # getpriority not present
+ EOM
+ exit
+ }
+ }
+ getpriority 1,2; # OP_GETPRIORITY
+ EXPECT
+ Useless use of getpriority in void context at - line 13.
+ ########
+ # op.c
+ use warning 'void' ;
+ use Config ;
+ BEGIN {
+ if ( ! $Config{d_getlogin}) {
+ print <<EOM ;
+ SKIPPED
+ # getlogin not present
+ EOM
+ exit
+ }
+ }
+ getlogin ; # OP_GETLOGIN
+ EXPECT
+ Useless use of getlogin in void context at - line 13.
+ ########
+ # op.c
+ use warning 'void' ;
+ use Config ; BEGIN {
+ if ( ! $Config{d_socket}) {
+ print <<EOM ;
+ SKIPPED
+ # getsockname not present
+ # getpeername not present
+ # gethostbyname not present
+ # gethostbyaddr not present
+ # gethostent not present
+ # getnetbyname not present
+ # getnetbyaddr not present
+ # getnetent not present
+ # getprotobyname not present
+ # getprotobynumber not present
+ # getprotoent not present
+ # getservbyname not present
+ # getservbyport not present
+ # getservent not present
+ EOM
+ exit
+ } }
+ getsockname STDIN ; # OP_GETSOCKNAME
+ getpeername STDIN ; # OP_GETPEERNAME
+ gethostbyname 1 ; # OP_GHBYNAME
+ gethostbyaddr 1,2; # OP_GHBYADDR
+ gethostent ; # OP_GHOSTENT
+ getnetbyname 1 ; # OP_GNBYNAME
+ getnetbyaddr 1,2 ; # OP_GNBYADDR
+ getnetent ; # OP_GNETENT
+ getprotobyname 1; # OP_GPBYNAME
+ getprotobynumber 1; # OP_GPBYNUMBER
+ getprotoent ; # OP_GPROTOENT
+ getservbyname 1,2; # OP_GSBYNAME
+ getservbyport 1,2; # OP_GSBYPORT
+ getservent ; # OP_GSERVENT
+ EXPECT
+ Useless use of getsockname in void context at - line 24.
+ Useless use of getpeername in void context at - line 25.
+ Useless use of gethostbyname in void context at - line 26.
+ Useless use of gethostbyaddr in void context at - line 27.
+ Useless use of gethostent in void context at - line 28.
+ Useless use of getnetbyname in void context at - line 29.
+ Useless use of getnetbyaddr in void context at - line 30.
+ Useless use of getnetent in void context at - line 31.
+ Useless use of getprotobyname in void context at - line 32.
+ Useless use of getprotobynumber in void context at - line 33.
+ Useless use of getprotoent in void context at - line 34.
+ Useless use of getservbyname in void context at - line 35.
+ Useless use of getservbyport in void context at - line 36.
+ Useless use of getservent in void context at - line 37.
+ ########
+ # op.c
+ use warning 'void' ;
+ *a ; # OP_RV2GV
+ $a ; # OP_RV2SV
+ @a ; # OP_RV2AV
+ %a ; # OP_RV2HV
+ EXPECT
+ Useless use of a variable in void context at - line 3.
+ Useless use of a variable in void context at - line 4.
+ Useless use of a variable in void context at - line 5.
+ Useless use of a variable in void context at - line 6.
+ ########
+ # op.c
+ use warning 'void' ;
+ "abc"; # OP_CONST
+ 7 ; # OP_CONST
+ EXPECT
+ Useless use of a constant in void context at - line 3.
+ Useless use of a constant in void context at - line 4.
+ ########
+ # op.c
+ use warning 'syntax' ;
+ my $a, $b = (1,2);
+ EXPECT
+ Parens missing around "my" list at - line 3.
+ ########
+ # op.c
+ use warning 'syntax' ;
+ local $a, $b = (1,2);
+ EXPECT
+ Parens missing around "local" list at - line 3.
+ ########
+ # op.c
+ use warning 'syntax' ;
+ print (ABC || 1) ;
+ EXPECT
+ Probable precedence problem on logical or at - line 3.
+ ########
+ --FILE-- abc
+
+ --FILE--
+ # op.c
+ use warning 'unsafe' ;
+ open FH, "<abc" ;
+ $x = 1 if $x = <FH> ;
+ EXPECT
+ Value of <HANDLE> construct can be "0"; test with defined() at - line 4.
+ ########
+ --FILE-- abc
+
+ --FILE--
+ # op.c
+ use warning 'unsafe' ;
+ open FH, "<abc" ;
+ $x = 1 while $x = <FH> ;
+ EXPECT
+ Value of <HANDLE> construct can be "0"; test with defined() at - line 4.
+ ########
+ # op.c
+ use warning 'unsafe' ;
+ opendir FH, "." ;
+ $x = 1 if $x = readdir FH ;
+ closedir FH ;
+ EXPECT
+ Value of readdir construct can be "0"; test with defined() at - line 4.
+ ########
+ # op.c
+ use warning 'unsafe' ;
+ $x = 1 if $x = <*> ;
+ EXPECT
+ Value of glob construct can be "0"; test with defined() at - line 3.
+ ########
+ # op.c
+ use warning 'unsafe' ;
+ $x = 1 while $x = <*> and 0 ;
+ EXPECT
+ Value of glob construct can be "0"; test with defined() at - line 3.
+ ########
+ # op.c
+ use warning 'unsafe' ;
+ opendir FH, "." ;
+ $x = 1 while $x = readdir FH and 0 ;
+ closedir FH ;
+ EXPECT
+ Value of readdir construct can be "0"; test with defined() at - line 4.
+ ########
+ # op.c
+ use warning 'redefine' ;
+ sub fred {}
+ sub fred {}
+ EXPECT
+ Subroutine fred redefined at - line 4.
+ ########
+ # op.c
+ use warning 'redefine' ;
+ sub fred () { 1 }
+ sub fred () { 1 }
+ EXPECT
+ Constant subroutine fred redefined at - line 4.
+ ########
+ # op.c
+ use warning 'redefine' ;
+ format FRED =
+ .
+ format FRED =
+ .
+ EXPECT
+ Format FRED redefined at - line 5.
+ ########
+ # op.c
+ use warning 'syntax' ;
+ push FRED;
+ EXPECT
+ Array @FRED missing the @ in argument 1 of push() at - line 3.
+ ########
+ # op.c
+ use warning 'syntax' ;
+ @a = keys FRED ;
+ EXPECT
+ Hash %FRED missing the % in argument 1 of keys() at - line 3.
+ ########
+ # op.c
+ use warning 'syntax' ;
+ exec "true" ;
+ my $a
+ EXPECT
+ Statement unlikely to be reached at - line 4.
+ (Maybe you meant system() when you said exec()?)
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-perl Thu Feb 27 11:31:47 1997
***************
*** 0 ****
--- 1,12 ----
+ perl.c AOK
+
+ gv_check(defstash)
+ Name \"%s::%s\" used only once: possible typo
+
+
+ __END__
+ # perl.c
+ use warning 'once' ;
+ $x = 3 ;
+ EXPECT
+ Name "main::x" used only once: possible typo at - line 3.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-perly Thu Feb 27 11:31:47 1997
***************
*** 0 ****
--- 1,25 ----
+ perly.y AOK
+
+ dep() => deprecate("\"do\" to call subroutines")
+ Use of "do" to call subroutines is deprecated
+
+ sub fred {} do fred()
+ sub fred {} do fred(1)
+ sub fred {} $a = "fred" ; do $a()
+ sub fred {} $a = "fred" ; do $a(1)
+
+
+ __END__
+ # perly.y
+ use warning 'deprecated' ;
+ sub fred {}
+ do fred() ;
+ do fred(1) ;
+ $a = "fred" ;
+ do $a() ;
+ do $a(1) ;
+ EXPECT
+ Use of "do" to call subroutines is deprecated at - line 4.
+ Use of "do" to call subroutines is deprecated at - line 5.
+ Use of "do" to call subroutines is deprecated at - line 7.
+ Use of "do" to call subroutines is deprecated at - line 8.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-pp Thu Feb 27 11:31:47 1997
***************
*** 0 ****
--- 1,24 ----
+ pp.c AOK
+
+ substr outside of string
+ $a = "ab" ; $a = substr($a, 4,5)
+
+ Attempt to use reference as lvalue in substr
+ $a = "ab" ; $b = \$a ; substr($b, 1,1) = $b
+
+
+ __END__
+ # pp.c
+ use warning 'substr' ;
+ $a = "ab" ;
+ $a = substr($a, 4,5)
+ EXPECT
+ substr outside of string at - line 4.
+ ########
+ # pp.c
+ use warning 'substr' ;
+ $a = "ab" ;
+ $b = \$a ;
+ substr($b, 1,1) = "ab" ;
+ EXPECT
+ Attempt to use reference as lvalue in substr at - line 5.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-pp_ctl Thu Feb 27 11:31:48 1997
***************
*** 0 ****
--- 1,145 ----
+ pp_ctl.c AOK
+
+ Not enough format arguments
+ format STDOUT =
+ @<<< @<<<
+ $a
+ .
+ write;
+
+
+ Exiting substitution via %s
+ $_ = "abc" ;
+ while ($i ++ == 0)
+ {
+ s/ab/last/e ;
+ }
+
+ Exiting subroutine via %s
+ sub fred { last }
+ { fred() }
+
+ Exiting eval via %s
+ { eval "last" }
+
+ Exiting pseudo-block via %s
+ @a = (1,2) ; @b = sort { last } @a ;
+
+ Exiting substitution via %s
+ $_ = "abc" ;
+ last fred:
+ while ($i ++ == 0)
+ {
+ s/ab/last fred/e ;
+ }
+
+
+ Exiting subroutine via %s
+ sub fred { last joe }
+ joe: { fred() }
+
+ Exiting eval via %s
+ fred: { eval "last fred" }
+
+ Exiting pseudo-block via %s
+ @a = (1,2) ; fred: @b = sort { last fred } @a ;
+
+
+ Deep recursion on subroutine \"%s\"
+ sub fred
+ {
+ goto &fred() if $a++ < 200
+ }
+
+ goto &fred()
+
+
+ __END__
+ # pp_ctl.c
+ use warning 'syntax' ;
+ format STDOUT =
+ @<<< @<<<
+ 1
+ .
+ write;
+ EXPECT
+ Not enough format arguments at - line 5.
+ 1
+ ########
+ # pp_ctl.c
+ use warning 'unsafe' ;
+ $_ = "abc" ;
+
+ while ($i ++ == 0)
+ {
+ s/ab/last/e ;
+ }
+ EXPECT
+ Exiting substitution via last at - line 7.
+ ########
+ # pp_ctl.c
+ use warning 'unsafe' ;
+ sub fred { last }
+ { fred() }
+ EXPECT
+ Exiting subroutine via last at - line 3.
+ ########
+ # pp_ctl.c
+ use warning 'unsafe' ;
+ { eval "last" }
+ print STDERR $@ ;
+ EXPECT
+ Exiting eval via last at (eval 1) line 1.
+ ########
+ # pp_ctl.c
+ use warning 'unsafe' ;
+ @a = (1,2) ;
+ @b = sort { last } @a ;
+ EXPECT
+ Exiting pseudo-block via last at - line 4.
+ Can't "last" outside a block at - line 4.
+ ########
+ # pp_ctl.c
+ use warning 'unsafe' ;
+ $_ = "abc" ;
+ fred:
+ while ($i ++ == 0)
+ {
+ s/ab/last fred/e ;
+ }
+ EXPECT
+ Exiting substitution via last at - line 7.
+ ########
+ # pp_ctl.c
+ use warning 'unsafe' ;
+ sub fred { last joe }
+ joe: { fred() }
+ EXPECT
+ Exiting subroutine via last at - line 3.
+ ########
+ # pp_ctl.c
+ use warning 'unsafe' ;
+ joe: { eval "last joe" }
+ print STDERR $@ ;
+ EXPECT
+ Exiting eval via last at (eval 1) line 2.
+ ########
+ # pp_ctl.c
+ use warning 'unsafe' ;
+ @a = (1,2) ;
+ fred: @b = sort { last fred } @a ;
+ EXPECT
+ Exiting pseudo-block via last at - line 4.
+ Label not found for "last fred" at - line 4.
+ ########
+ # pp_ctl.c
+ use warning 'recursion' ;
+ BEGIN { warn "PREFIX\n" ;}
+ sub fred
+ {
+ goto &fred() if $a++ < 200
+ }
+
+ goto &fred()
+ EXPECT
+ Deep recursion on subroutine "main::fred" at - line 6.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-pp_hot Thu Feb 27 11:31:48 1997
***************
*** 0 ****
--- 1,69 ----
+ pp_hot.c AOK
+
+ Filehandle %s never opened
+ $f = $a = "abc" ; print $f $a
+
+ Filehandle %s opened only for input
+ print STDIN "abc" ;
+
+
+ print on closed filehandle %s
+ close STDIN ; print STDIN "abc" ;
+
+ Read on closed filehandle <%s>
+ close STDIN ; $a = <STDIN>;
+
+ Deep recursion on subroutine \"%s\"
+ sub fred { fred() if $a++ < 200} fred()
+
+ Deep recursion on anonymous subroutine
+ $a = sub { &$a if $a++ < 200} &$a
+
+ __END__
+ # pp_hot.c
+ use warning 'unopened' ;
+ $f = $a = "abc" ;
+ print $f $a
+ EXPECT
+ Filehandle main::abc never opened at - line 4.
+ ########
+ # pp_hot.c
+ use warning 'io' ;
+ print STDIN "anc";
+ EXPECT
+ Filehandle main::STDIN opened only for input at - line 3.
+ ########
+ # pp_hot.c
+ use warning 'closed' ;
+ close STDIN ;
+ print STDIN "anc";
+ EXPECT
+ print on closed filehandle main::STDIN at - line 4.
+ ########
+ # pp_hot.c
+ use warning 'closed' ;
+ close STDIN ; $a = <STDIN> ;
+ EXPECT
+ Read on closed filehandle <STDIN> at - line 3.
+ ########
+ # pp_hot.c
+ use warning 'recursion' ;
+ sub fred
+ {
+ fred() if $a++ < 200
+ }
+
+ fred()
+ EXPECT
+ Deep recursion on subroutine "main::fred" at - line 5.
+ ########
+ # pp_hot.c
+ use warning 'recursion' ;
+ $b = sub
+ {
+ &$b if $a++ < 200
+ } ;
+
+ &$b ;
+ EXPECT
+ Deep recursion on anonymous subroutine at - line 5.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-pp_sys Thu Feb 27 11:31:49 1997
***************
*** 0 ****
--- 1,208 ----
+ pp_sys.c AOK
+
+ untie attempted while %d inner references still exist
+ sub TIESCALAR { bless [] } ; tie $a, 'main'; untie $a ;
+
+ Filehandle only opened for input
+ format STDIN =
+ .
+ write STDIN;
+
+ Write on closed filehandle
+ format STDIN =
+ .
+ close STDIN;
+ write STDIN ;
+
+ page overflow
+
+ Filehandle %s never opened
+ $a = "abc"; printf $a "fred"
+
+ Filehandle %s opened only for input
+ $a = "abc";
+ printf $a "fred"
+
+ printf on closed filehandle %s
+ close STDIN ;
+ printf STDIN "fred"
+
+ Syswrite on closed filehandle
+ close STDIN;
+ syswrite STDIN, "fred", 1;
+
+ Send on closed socket
+ close STDIN;
+ send STDIN, "fred", 1
+
+ bind() on closed fd
+ close STDIN;
+ bind STDIN, "fred" ;
+
+
+ connect() on closed fd
+ close STDIN;
+ connect STDIN, "fred" ;
+
+ listen() on closed fd
+ close STDIN;
+ listen STDIN, 2;
+
+ accept() on closed fd
+ close STDIN;
+ accept STDIN, "fred" ;
+
+ shutdown() on closed fd
+ close STDIN;
+ shutdown STDIN, 0;
+
+ [gs]etsockopt() on closed fd
+ close STDIN;
+ setsockopt STDIN, 1,2,3;
+ getsockopt STDIN, 1,2;
+
+ get{sock, peer}name() on closed fd
+ close STDIN;
+ getsockname STDIN;
+ getpeername STDIN;
+
+ warn(warn_nl, "stat");
+
+ Test on unopened file <%s>
+ close STDIN ; -T STDIN ;
+
+ warn(warn_nl, "open");
+ -T "abc\ndef" ;
+
+
+
+ __END__
+ # pp_sys.c
+ use warning 'untie' ;
+ sub TIESCALAR { bless [] } ;
+ $b = tie $a, 'main';
+ untie $a ;
+ EXPECT
+ untie attempted while 1 inner references still exist at - line 5.
+ ########
+ # pp_sys.c
+ use warning 'io' ;
+ format STDIN =
+ .
+ write STDIN;
+ EXPECT
+ Filehandle only opened for input at - line 5.
+ ########
+ # pp_sys.c
+ use warning 'closed' ;
+ format STDIN =
+ .
+ close STDIN;
+ write STDIN;
+ EXPECT
+ Write on closed filehandle at - line 6.
+ ########
+ # pp_sys.c
+ use warning 'io' ;
+ format STDOUT_TOP =
+ abc
+ .
+ format STDOUT =
+ def
+ ghi
+ .
+ $= = 1 ;
+ $- =1 ;
+ open STDOUT, ">/dev/null" ;
+ write ;
+ EXPECT
+ page overflow at - line 13.
+ ########
+ # pp_sys.c
+ use warning 'unopened' ;
+ $a = "abc";
+ printf $a "fred"
+ EXPECT
+ Filehandle main::abc never opened at - line 4.
+ ########
+ # pp_sys.c
+ use warning 'closed' ;
+ close STDIN ;
+ printf STDIN "fred"
+ EXPECT
+ printf on closed filehandle main::STDIN at - line 4.
+ ########
+ # pp_sys.c
+ use warning 'io' ;
+ printf STDIN "fred"
+ EXPECT
+ Filehandle main::STDIN opened only for input at - line 3.
+ ########
+ # pp_sys.c
+ use warning 'closed' ;
+ close STDIN;
+ syswrite STDIN, "fred", 1;
+ EXPECT
+ Syswrite on closed filehandle at - line 4.
+ ########
+ # pp_sys.c
+ use warning 'io' ;
+ use Config;
+ BEGIN {
+ if ( $^O ne 'VMS' and ! $Config{d_socket}) {
+ print <<EOM ;
+ SKIPPED
+ # send not present
+ # bind not present
+ # connect not present
+ # accept not present
+ # shutdown not present
+ # setsockopt not present
+ # getsockopt not present
+ # getsockname not present
+ # getpeername not present
+ EOM
+ exit ;
+ }
+ }
+ close STDIN;
+ send STDIN, "fred", 1;
+ bind STDIN, "fred" ;
+ connect STDIN, "fred" ;
+ listen STDIN, 2;
+ accept STDIN, "fred" ;
+ shutdown STDIN, 0;
+ setsockopt STDIN, 1,2,3;
+ getsockopt STDIN, 1,2;
+ getsockname STDIN;
+ getpeername STDIN;
+ EXPECT
+ Send on closed socket at - line 22.
+ bind() on closed fd at - line 23.
+ connect() on closed fd at - line 24.
+ listen() on closed fd at - line 25.
+ accept() on closed fd at - line 26.
+ shutdown() on closed fd at - line 27.
+ [gs]etsockopt() on closed fd at - line 28.
+ [gs]etsockopt() on closed fd at - line 29.
+ get{sock, peer}name() on closed fd at - line 30.
+ get{sock, peer}name() on closed fd at - line 31.
+ ########
+ # pp_sys.c
+ use warning 'newline' ;
+ stat "abc\ndef";
+ EXPECT
+ Unsuccessful stat on filename containing newline at - line 3.
+ ########
+ # pp_sys.c
+ use warning 'unopened' ;
+ close STDIN ;
+ -T STDIN ;
+ EXPECT
+ Test on unopened file <STDIN> at - line 4.
+ ########
+ # pp_sys.c
+ use warning 'newline' ;
+ -T "abc\ndef" ;
+ EXPECT
+ Unsuccessful open on filename containing newline at - line 3.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-regcomp Thu Feb 27 11:31:49 1997
***************
*** 0 ****
--- 1,13 ----
+ regcomp.c AOK
+
+ %.*s matches null string many times
+
+ $a = "ABC123" ; $a =~ /(C*)*/'
+
+ __END__
+ # regcomp.c
+ use warning 'unsafe' ;
+ my $a = "ABC123" ;
+ $a =~ /(C*)*/ ;
+ EXPECT
+ (C*)* matches null string many times at - line 4.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-sv Thu Feb 27 11:31:49 1997
***************
*** 0 ****
--- 1,125 ----
+ sv.c AOK
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ not_a_number(sv);
+
+ not_a_number(sv);
+
+ warn(warn_uninit);
+
+ not_a_number(sv);
+
+ warn(warn_uninit);
+
+ not_a_number(sv);
+
+ not_a_number(sv);
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ Subroutine %s redefined
+
+
+ __END__
+ # sv.c
+ use integer ;
+ use warning 'uninitialized' ;
+ $x = 1 + $a[0] ; # a
+ EXPECT
+ Use of uninitialized value at - line 4.
+ ########
+ # sv.c
+ use integer ;
+ use warning 'uninitialized' ;
+ my $x *= 2 ; #b
+ EXPECT
+ Use of uninitialized value at - line 4.
+ ########
+ # sv.c
+ use warning 'uninitialized' ;
+ my $Y = 1 ;
+ my $x = 1 | $a[$Y]
+ EXPECT
+ Use of uninitialized value at - line 4.
+ ########
+ # sv.c
+ use warning 'uninitialized' ;
+ my $x *= 1 ; # d
+ EXPECT
+ Use of uninitialized value at - line 3.
+ ########
+ # sv.c
+ use warning 'uninitialized' ;
+ $x = 1 + $a[0] ; # e
+ EXPECT
+ Use of uninitialized value at - line 3.
+ ########
+ # sv.c
+ use warning 'uninitialized' ;
+ $x = $y + 1 ; # f
+ EXPECT
+ Use of uninitialized value at - line 3.
+ ########
+ # sv.c
+ use warning 'uninitialized' ;
+ $x = chop undef ; # g
+ EXPECT
+ Use of uninitialized value at - line 3.
+ ########
+ # sv.c
+ use warning 'uninitialized' ;
+ $x = chop $y ; # h
+ EXPECT
+ Use of uninitialized value at - line 3.
+ ########
+ # sv.c
+ use warning 'numeric' ;
+ sub TIESCALAR{bless[]} ;
+ sub FETCH {"def"} ;
+ tie $a,"main" ;
+ my $b = 1 + $a
+ EXPECT
+ Argument "def" isn't numeric in add at - line 6.
+ ########
+ # sv.c
+ use warning 'numeric' ;
+ my $x = 1 + "def" ;
+ EXPECT
+ Argument "def" isn't numeric in add at - line 3.
+ ########
+ # sv.c
+ use warning 'numeric' ;
+ my $a = "def" ;
+ my $x = 1 + $a ;
+ EXPECT
+ Argument "def" isn't numeric in add at - line 4.
+ ########
+ # sv.c
+ use warning 'numeric' ; use integer ;
+ my $a = "def" ;
+ my $x = 1 + $a ;
+ EXPECT
+ Argument "def" isn't numeric in i_add at - line 4.
+ ########
+ # sv.c
+ use warning 'numeric' ;
+ my $x = 1 & "def" ;
+ EXPECT
+ Argument "def" isn't numeric in bit_and at - line 3.
+ ########
+ # sv.c
+ use warning 'redefine' ;
+ sub fred {}
+ sub joe {}
+ *fred = \&joe ;
+ EXPECT
+ Subroutine fred redefined at - line 5.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-taint Thu Feb 27 11:31:50 1997
***************
*** 0 ****
--- 1,25 ----
+ taint.c TODO
+
+ Insecure %s%s while running setuid
+ Insecure %s%s while running setgid
+ Insecure %s%s while running with -T switch
+
+
+ Insecure directory in %s%s while running setuid
+ Insecure directory in %s%s while running setgid
+ Insecure directory in %s%s while running with -T switch
+
+
+
+ __END__
+ # taint.c
+ use warning 'misc' ;
+
+ EXPECT
+
+ ########
+ # taint.c
+ use warning 'misc' ;
+
+ EXPECT
+
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-toke Thu Feb 27 11:31:50 1997
***************
*** 0 ****
--- 1,308 ----
+ toke.c AOK
+
+ 1 if $a EQ $b ;
+ 1 if $a NE $b ;
+ 1 if $a LT $b ;
+ 1 if $a GT $b ;
+ 1 if $a GE $b ;
+ 1 if $a LE $b ;
+ $a = <<;
+ Use of comma-less variable list is deprecated
+ (called 3 times via depcom)
+
+ \1 better written as $1
+ use warning 'syntax' ;
+ s/(abc)/\1/;
+
+ Ambiguous use of -%c => resolved to \"-%c\" =>"
+ -a => 2;
+
+ Ambiguous use of {%s} resolved to {\"%s\"}
+ $a = $a{time} ;
+ sub fred {} $a = $a{fred} ;
+
+ warn(warn_nosemi)
+ Semicolon seems to be missing
+ $a = 1
+ &time ;
+
+
+ Reversed %c= operator
+ my $a =+ 2 ;
+ $a =- 2 ;
+ $a =* 2 ;
+ $a =% 2 ;
+ $a =& 2 ;
+ $a =. 2 ;
+ $a =^ 2 ;
+ $a =| 2 ;
+ $a =< 2 ;
+ $a =/ 2 ;
+
+ Multidimensional syntax %.*s not supported
+ my $a = $a[1,2] ;
+
+ You need to quote \"%s\""
+ sub fred {} ; $SIG{TERM} = fred;
+
+ Scalar value %.*s better written as $%.*s"
+ @a[3] = 2;
+ @a{3} = 2;
+
+ Can't use \\%c to mean $%c in expression
+ $_ = "ab" ; s/(ab)/\1/e;
+
+ Ambiguous use of %s => resolved to \"%s\" =>
+ $a = { print => 1};
+ sub fred{} $a = { fred => 1};
+
+
+ Unquoted string "abc" may clash with future reserved word at - line 3.
+ warn(warn_reserved
+ $a = abc;
+
+ chmod: mode argument is missing initial 0
+ chmod 3;
+
+ Possible attempt to separate words with commas
+ @a = qw(a, b, c) ;
+
+ Possible attempt to put comments in qw() list
+ @a = qw(a b # c) ;
+
+ umask: argument is missing initial 0
+ umask 3;
+
+ %s (...) interpreted as function
+ print ("")
+ printf ("")
+ sort ("")
+
+ Ambiguous use of %c{%s%s} resolved to %c%s%s
+ $a = ${time[2]}
+ $a = ${time{2}}
+
+
+ Ambiguous use of %c{%s} resolved to %c%s
+ $a = ${time}
+ sub fred {} $a = ${fred}
+
+ Misplaced _ in number
+ $a = 1_2;
+ $a = 1_2345_6;
+
+
+
+ __END__
+ # toke.c
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+ 1 if $a NE $b ;
+ 1 if $a GT $b ;
+ 1 if $a LT $b ;
+ 1 if $a GE $b ;
+ 1 if $a LE $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 3.
+ Use of NE is deprecated at - line 4.
+ Use of GT is deprecated at - line 5.
+ Use of LT is deprecated at - line 6.
+ Use of GE is deprecated at - line 7.
+ Use of LE is deprecated at - line 8.
+ ########
+ # toke.c
+ use warning 'deprecated' ;
+ format STDOUT =
+ @<<< @||| @>>> @>>>
+ $a $b "abc" 'def'
+ .
+ ($a, $b) = (1,2,3);
+ write;
+ EXPECT
+ Use of comma-less variable list is deprecated at - line 5.
+ Use of comma-less variable list is deprecated at - line 5.
+ Use of comma-less variable list is deprecated at - line 5.
+ 1 2 abc def
+ ########
+ # toke.c
+ use warning 'deprecated' ;
+ $a = <<;
+
+ EXPECT
+ Use of bare << to mean <<"" is deprecated at - line 3.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ s/(abc)/\1/;
+ EXPECT
+ \1 better written as $1 at - line 3.
+ ########
+ # toke.c
+ use warning 'ambiguous' ;
+ $a = $a{time} ;
+ sub fred {} $a = $a{fred} ;
+ EXPECT
+ Ambiguous use of {time} resolved to {"time"} at - line 3.
+ Ambiguous use of {fred} resolved to {"fred"} at - line 4.
+ ########
+ # toke.c
+ use warning 'ambiguous' ;
+ -a => 2;
+ EXPECT
+ Ambiguous use of -a => resolved to "-a" => at - line 3.
+ ########
+ # toke.c
+ use warning 'semicolon' ;
+ $a = 1
+ &time ;
+ EXPECT
+ Semicolon seems to be missing at - line 3.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ my $a =+ 2 ;
+ $a =- 2 ;
+ $a =* 2 ;
+ $a =% 2 ;
+ $a =& 2 ;
+ $a =. 2 ;
+ $a =^ 2 ;
+ $a =| 2 ;
+ $a =< 2 ;
+ $a =/ 2 ;
+ EXPECT
+ Reversed += operator at - line 3.
+ Reversed -= operator at - line 4.
+ Reversed *= operator at - line 5.
+ Reversed %= operator at - line 6.
+ Reversed &= operator at - line 7.
+ Reversed .= operator at - line 8.
+ syntax error at - line 8, near "=."
+ Reversed ^= operator at - line 9.
+ syntax error at - line 9, near "=^"
+ Reversed |= operator at - line 10.
+ syntax error at - line 10, near "=|"
+ Reversed <= operator at - line 11.
+ Unterminated <> operator at - line 11.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ my $a = $a[1,2] ;
+ EXPECT
+ Multidimensional syntax $a[1,2] not supported at - line 3.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ sub fred {} ; $SIG{TERM} = fred;
+ EXPECT
+ You need to quote "fred" at - line 3.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ @a[3] = 2;
+ @a{3} = 2;
+ EXPECT
+ Scalar value @a[3] better written as $a[3] at - line 3.
+ Scalar value @a{3} better written as $a{3} at - line 4.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ $_ = "ab" ;
+ s/(ab)/\1/e;
+ EXPECT
+ Can't use \1 to mean $1 in expression at - line 4.
+ ########
+ # toke.c
+ use warning 'reserved' ;
+ $a = abc;
+ EXPECT
+ Unquoted string "abc" may clash with future reserved word at - line 3.
+ ########
+ # toke.c
+ use warning 'ambiguous' ;
+ sub fred {}
+ $a = { fred => 1};
+ EXPECT
+ Ambiguous use of fred => resolved to "fred" => at - line 4.
+ ########
+ # toke.c
+ use warning 'ambiguous' ;
+ $a = { print => 1};
+ EXPECT
+ Ambiguous use of print => resolved to "print" => at - line 3.
+ ########
+ # toke.c
+ use warning 'octal' ;
+ chmod 3;
+ EXPECT
+ chmod: mode argument is missing initial 0 at - line 3, at end of line
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ @a = qw(a, b, c) ;
+ EXPECT
+ Possible attempt to separate words with commas at - line 3.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ @a = qw(a b #) ;
+ EXPECT
+ Possible attempt to put comments in qw() list at - line 3.
+ ########
+ # toke.c
+ use warning 'octal' ;
+ umask 3;
+ EXPECT
+ umask: argument is missing initial 0 at - line 3, at end of line
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ print ("")
+ EXPECT
+ print (...) interpreted as function at - line 3.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ printf ("")
+ EXPECT
+ printf (...) interpreted as function at - line 3.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ sort ("")
+ EXPECT
+ sort (...) interpreted as function at - line 3.
+ ########
+ # toke.c
+ use warning 'ambiguous' ;
+ $a = ${time[2]};
+ EXPECT
+ Ambiguous use of ${time[...]} resolved to $time[...] at - line 3.
+ ########
+ # toke.c
+ use warning 'ambiguous' ;
+ $a = ${time{2}};
+ EXPECT
+ Ambiguous use of ${time{...}} resolved to $time{...} at - line 3.
+ ########
+ # toke.c
+ use warning 'ambiguous' ;
+ $a = ${time} ;
+ EXPECT
+ Ambiguous use of ${time} resolved to $time at - line 3.
+ ########
+ # toke.c
+ use warning 'ambiguous' ;
+ sub fred {}
+ $a = ${fred} ;
+ EXPECT
+ Ambiguous use of ${fred} resolved to $fred at - line 4.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ $a = 1_2;
+ $a = 1_2345_6;
+ EXPECT
+ Misplaced _ in number at - line 3.
+ Misplaced _ in number at - line 4.
+ Misplaced _ in number at - line 4.
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-universal Thu Feb 27 11:31:51 1997
***************
*** 0 ****
--- 1,11 ----
+ universal.c
+
+ Can't locate package %s for @%s::ISA
+
+
+ __END__
+ # universal.c
+ use warning 'misc' ;
+
+ EXPECT
+
*** /dev/null Thu Feb 27 12:04:47 1997
--- t/pragma/warn-util Thu Feb 27 11:31:51 1997
***************
*** 0 ****
--- 1,12 ----
+ util.c AOK
+
+ Illegal octal digit ignored
+ my $a = oct "029" ;
+
+
+ __END__
+ # util.c
+ use warning 'octal' ;
+ my $a = oct "029" ;
+ EXPECT
+ Illegal octal digit ignored at - line 3.
*** t/pragma/warning.t.orig Thu Jan 16 08:54:13 1997
--- t/pragma/warning.t Thu Feb 27 11:31:51 1997
***************
*** 15,22 ****
END { if ($tmpfile) { 1 while unlink $tmpfile} }
my @prgs = () ;
! foreach (sort glob("pragma/warn-*")) {
open F, "<$_" or die "Cannot open $_: $!\n" ;
while (<F>) {
--- 15,30 ----
END { if ($tmpfile) { 1 while unlink $tmpfile} }
my @prgs = () ;
+ my @w_files = () ;
! if (@ARGV)
! { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./pragma/warn-#; $_ } @ARGV }
! else
! { @w_files = sort glob("pragma/warn-*") }
!
! foreach (@w_files) {
!
! next if /\.orig$/ ;
open F, "<$_" or die "Cannot open $_: $!\n" ;
while (<F>) {
*** taint.c.orig Mon Dec 23 20:16:40 1996
--- taint.c Thu Feb 27 11:31:52 1997
***************
*** 25,32 ****
ug = " while running with -T switch";
if (!unsafe)
croak(f, s, ug);
! else if (dowarn)
! warn(f, s, ug);
}
}
--- 25,32 ----
ug = " while running with -T switch";
if (!unsafe)
croak(f, s, ug);
! else if (ckWARN(WARN_TAINT))
! warner(WARN_TAINT, f, s, ug);
}
}
*** toke.c.orig Tue Feb 18 08:43:34 1997
--- toke.c Thu Feb 27 11:31:53 1997
***************
*** 209,216 ****
deprecate(s)
char *s;
{
! if (dowarn)
! warn("Use of %s is deprecated", s);
}
static void
--- 209,216 ----
deprecate(s)
char *s;
{
! if (ckWARN(WARN_DEPRECATED))
! warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
}
static void
***************
*** 800,807 ****
if (lex_inwhat == OP_SUBST && !lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
{
! if (dowarn)
! warn("\\%c better written as $%c", *s, *s);
*--s = '$';
break;
}
--- 800,807 ----
if (lex_inwhat == OP_SUBST && !lex_inpat &&
isDIGIT(*s) && *s != '0' && !isDIGIT(s[1]))
{
! if (ckWARN(WARN_SYNTAX))
! warner(WARN_SYNTAX, "\\%c better written as $%c", *s, *s);
*--s = '$';
break;
}
***************
*** 1731,1738 ****
s++;
if (strnEQ(s,"=>",2)) {
! if (dowarn)
! warn("Ambiguous use of -%c => resolved to \"-%c\" =>",
(int)tmp, (int)tmp);
s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
OPERATOR('-'); /* unary minus */
--- 1731,1739 ----
s++;
if (strnEQ(s,"=>",2)) {
! if (ckWARN(WARN_AMBIGUOUS))
! warner(WARN_AMBIGUOUS,
! "Ambiguous use of -%c => resolved to \"-%c\" =>",
(int)tmp, (int)tmp);
s = force_word(bufptr,WORD,FALSE,FALSE,FALSE);
OPERATOR('-'); /* unary minus */
***************
*** 1935,1945 ****
d++;
if (*d == '}') {
char minus = (tokenbuf[0] == '-');
! if (dowarn &&
(keyword(tokenbuf + 1, len) ||
(minus && len == 1 && isALPHA(tokenbuf[1])) ||
perl_get_cv(tokenbuf + 1, FALSE) ))
! warn("Ambiguous use of {%s} resolved to {\"%s\"}",
tokenbuf + !minus, tokenbuf + !minus);
s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
if (minus)
--- 1936,1947 ----
d++;
if (*d == '}') {
char minus = (tokenbuf[0] == '-');
! if (ckWARN(WARN_AMBIGUOUS) &&
(keyword(tokenbuf + 1, len) ||
(minus && len == 1 && isALPHA(tokenbuf[1])) ||
perl_get_cv(tokenbuf + 1, FALSE) ))
! warner(WARN_AMBIGUOUS,
! "Ambiguous use of {%s} resolved to {\"%s\"}",
tokenbuf + !minus, tokenbuf + !minus);
s = force_word(s + minus, WORD, FALSE, TRUE, FALSE);
if (minus)
***************
*** 2027,2035 ****
AOPERATOR(ANDAND);
s--;
if (expect == XOPERATOR) {
! if (dowarn && isALPHA(*s) && bufptr == linestart) {
curcop->cop_line--;
! warn(warn_nosemi);
curcop->cop_line++;
}
BAop(OP_BIT_AND);
--- 2029,2037 ----
AOPERATOR(ANDAND);
s--;
if (expect == XOPERATOR) {
! if (ckWARN(WARN_SEMICOLON) && isALPHA(*s) && bufptr == linestart) {
curcop->cop_line--;
! warner(WARN_SEMICOLON, warn_nosemi);
curcop->cop_line++;
}
BAop(OP_BIT_AND);
***************
*** 2061,2068 ****
OPERATOR(',');
if (tmp == '~')
PMop(OP_MATCH);
! if (dowarn && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
! warn("Reversed %c= operator",(int)tmp);
s--;
if (expect == XSTATE && isALPHA(tmp) &&
(s == linestart+1 || s[-2] == '\n') )
--- 2063,2070 ----
OPERATOR(',');
if (tmp == '~')
PMop(OP_MATCH);
! if (ckWARN(WARN_SYNTAX) && tmp && isSPACE(*s) && strchr("+-*/%.^&|<",tmp))
! warner(WARN_SYNTAX, "Reversed %c= operator",(int)tmp);
s--;
if (expect == XSTATE && isALPHA(tmp) &&
(s == linestart+1 || s[-2] == '\n') )
***************
*** 2183,2188 ****
--- 2185,2200 ----
TERM(THING);
}
+ #if 0
+ /* ... and neither is this one */
+ if (tokenbuf[1] == '\027' && !tokenbuf[2]) { /* $^W */
+ yylval.opval = newSVOP(OP_CONST, 0,
+ newSViv((IV)compiling.cop_warnings));
+ yylval.opval->op_private = OPpCONST_WARNING;
+ TERM(THING);
+ }
+ #endif
+
d = s;
if (lex_state == LEX_NORMAL)
s = skipspace(s);
***************
*** 2191,2197 ****
char *t;
if (*s == '[') {
tokenbuf[0] = '@';
! if (dowarn) {
for(t = s + 1;
isSPACE(*t) || isALNUM(*t) || *t == '$';
t++) ;
--- 2203,2209 ----
char *t;
if (*s == '[') {
tokenbuf[0] = '@';
! if (ckWARN(WARN_SYNTAX)) {
for(t = s + 1;
isSPACE(*t) || isALNUM(*t) || *t == '$';
t++) ;
***************
*** 2199,2212 ****
bufptr = skipspace(bufptr);
while (t < bufend && *t != ']')
t++;
! warn("Multidimensional syntax %.*s not supported",
(t - bufptr) + 1, bufptr);
}
}
}
else if (*s == '{') {
tokenbuf[0] = '%';
! if (dowarn && strEQ(tokenbuf+1, "SIG") &&
(t = strchr(s, '}')) && (t = strchr(t, '=')))
{
char tmpbuf[1024];
--- 2211,2225 ----
bufptr = skipspace(bufptr);
while (t < bufend && *t != ']')
t++;
! warner(WARN_SYNTAX,
! "Multidimensional syntax %.*s not supported",
(t - bufptr) + 1, bufptr);
}
}
}
else if (*s == '{') {
tokenbuf[0] = '%';
! if (ckWARN(WARN_SYNTAX) && strEQ(tokenbuf+1, "SIG") &&
(t = strchr(s, '}')) && (t = strchr(t, '=')))
{
char tmpbuf[1024];
***************
*** 2215,2221 ****
if (isIDFIRST(*t)) {
t = scan_word(t, tmpbuf, TRUE, &len);
if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
! warn("You need to quote \"%s\"", tmpbuf);
}
}
}
--- 2228,2235 ----
if (isIDFIRST(*t)) {
t = scan_word(t, tmpbuf, TRUE, &len);
if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
! warner(WARN_SYNTAX,
! "You need to quote \"%s\"", tmpbuf);
}
}
}
***************
*** 2259,2265 ****
tokenbuf[0] = '%';
/* Warn about @ where they meant $. */
! if (dowarn) {
if (*s == '[' || *s == '{') {
char *t = s + 1;
while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
--- 2273,2279 ----
tokenbuf[0] = '%';
/* Warn about @ where they meant $. */
! if (ckWARN(WARN_SYNTAX)) {
if (*s == '[' || *s == '{') {
char *t = s + 1;
while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
***************
*** 2267,2273 ****
if (*t == '}' || *t == ']') {
t++;
bufptr = skipspace(bufptr);
! warn("Scalar value %.*s better written as $%.*s",
t-bufptr, bufptr, t-bufptr-1, bufptr+1);
}
}
--- 2281,2288 ----
if (*t == '}' || *t == ']') {
t++;
bufptr = skipspace(bufptr);
! warner(WARN_SYNTAX,
! "Scalar value %.*s better written as $%.*s",
t-bufptr, bufptr, t-bufptr-1, bufptr+1);
}
}
***************
*** 2369,2376 ****
case '\\':
s++;
! if (dowarn && lex_inwhat && isDIGIT(*s))
! warn("Can't use \\%c to mean $%c in expression", *s, *s);
if (expect == XOPERATOR)
no_op("Backslash",s);
OPERATOR(REFGEN);
--- 2384,2392 ----
case '\\':
s++;
! if (ckWARN(WARN_SYNTAX) && lex_inwhat && isDIGIT(*s))
! warner(WARN_SYNTAX,"Can't use \\%c to mean $%c in expression",
! *s, *s);
if (expect == XOPERATOR)
no_op("Backslash",s);
OPERATOR(REFGEN);
***************
*** 2443,2450 ****
/* Is this a word before a => operator? */
if (strnEQ(d,"=>",2)) {
CLINE;
! if (dowarn && (tmp || perl_get_cv(tokenbuf, FALSE)))
! warn("Ambiguous use of %s => resolved to \"%s\" =>",
tokenbuf, tokenbuf);
yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
yylval.opval->op_private = OPpCONST_BARE;
--- 2459,2467 ----
/* Is this a word before a => operator? */
if (strnEQ(d,"=>",2)) {
CLINE;
! if (ckWARN(WARN_AMBIGUOUS) && (tmp || perl_get_cv(tokenbuf, FALSE)))
! warner(WARN_AMBIGUOUS,
! "Ambiguous use of %s => resolved to \"%s\" =>",
tokenbuf, tokenbuf);
yylval.opval = (OP*)newSVOP(OP_CONST, 0, newSVpv(tokenbuf,0));
yylval.opval->op_private = OPpCONST_BARE;
***************
*** 2483,2489 ****
if (expect == XOPERATOR) {
if (bufptr == linestart) {
curcop->cop_line--;
! warn(warn_nosemi);
curcop->cop_line++;
}
else
--- 2500,2506 ----
if (expect == XOPERATOR) {
if (bufptr == linestart) {
curcop->cop_line--;
! warner(WARN_SEMICOLON, warn_nosemi);
curcop->cop_line++;
}
else
***************
*** 2622,2632 ****
/* Call it a bare word */
bareword:
! if (dowarn) {
if (lastchar != '-') {
for (d = tokenbuf; *d && isLOWER(*d); d++) ;
if (!*d)
! warn(warn_reserved, tokenbuf);
}
}
if (lastchar && strchr("*%&", lastchar)) {
--- 2639,2649 ----
/* Call it a bare word */
bareword:
! if (ckWARN(WARN_RESERVED)) {
if (lastchar != '-') {
for (d = tokenbuf; *d && isLOWER(*d); d++) ;
if (!*d)
! warner(WARN_RESERVED, warn_reserved, tokenbuf);
}
}
if (lastchar && strchr("*%&", lastchar)) {
***************
*** 2759,2765 ****
LOP(OP_CRYPT,XTERM);
case KEY_chmod:
! if (dowarn) {
for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
if (*d != '0' && isDIGIT(*d))
yywarn("chmod: mode argument is missing initial 0");
--- 2776,2782 ----
LOP(OP_CRYPT,XTERM);
case KEY_chmod:
! if (ckWARN(WARN_OCTAL)) {
for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
if (*d != '0' && isDIGIT(*d))
yywarn("chmod: mode argument is missing initial 0");
***************
*** 3165,3179 ****
s = scan_str(s);
if (!s)
missingterm((char*)0);
! if (dowarn && SvLEN(lex_stuff)) {
d = SvPV_force(lex_stuff, len);
for (; len; --len, ++d) {
if (*d == ',') {
! warn("Possible attempt to separate words with commas");
break;
}
if (*d == '#') {
! warn("Possible attempt to put comments in qw() list");
break;
}
}
--- 3182,3198 ----
s = scan_str(s);
if (!s)
missingterm((char*)0);
! if (ckWARN(WARN_SYNTAX) && SvLEN(lex_stuff)) {
d = SvPV_force(lex_stuff, len);
for (; len; --len, ++d) {
if (*d == ',') {
! warner(WARN_SYNTAX,
! "Possible attempt to separate words with commas");
break;
}
if (*d == '#') {
! warner(WARN_SYNTAX,
! "Possible attempt to put comments in qw() list");
break;
}
}
***************
*** 3529,3535 ****
LOP(OP_UTIME,XTERM);
case KEY_umask:
! if (dowarn) {
for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
if (*d != '0' && isDIGIT(*d))
yywarn("umask: argument is missing initial 0");
--- 3548,3554 ----
LOP(OP_UTIME,XTERM);
case KEY_umask:
! if (ckWARN(WARN_OCTAL)) {
for (d = s; d < bufend && (isSPACE(*d) || *d == '('); d++) ;
if (*d != '0' && isDIGIT(*d))
yywarn("umask: argument is missing initial 0");
***************
*** 4222,4228 ****
{
char *w;
! if (dowarn && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
int level = 1;
for (w = s+2; *w && level; w++) {
if (*w == '(')
--- 4241,4247 ----
{
char *w;
! if (ckWARN(WARN_SYNTAX) && *s == ' ' && s[1] == '(') { /* XXX gotta be a better way */
int level = 1;
for (w = s+2; *w && level; w++) {
if (*w == '(')
***************
*** 4233,4239 ****
if (*w)
for (; *w && isSPACE(*w); w++) ;
if (!*w || !strchr(";|})]oa!=", *w)) /* an advisory hack only... */
! warn("%s (...) interpreted as function",name);
}
while (s < bufend && isSPACE(*s))
s++;
--- 4252,4258 ----
if (*w)
for (; *w && isSPACE(*w); w++) ;
if (!*w || !strchr(";|})]oa!=", *w)) /* an advisory hack only... */
! warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
}
while (s < bufend && isSPACE(*s))
s++;
***************
*** 4364,4372 ****
*d = '\0';
while (s < send && (*s == ' ' || *s == '\t')) s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
! if (dowarn && keyword(dest, d - dest)) {
char *brack = *s == '[' ? "[...]" : "{...}";
! warn("Ambiguous use of %c{%s%s} resolved to %c%s%s",
funny, dest, brack, funny, dest, brack);
}
lex_fakebrack = lex_brackets+1;
--- 4383,4392 ----
*d = '\0';
while (s < send && (*s == ' ' || *s == '\t')) s++;
if ((*s == '[' || (*s == '{' && strNE(dest, "sub")))) {
! if (ckWARN(WARN_AMBIGUOUS) && keyword(dest, d - dest)) {
char *brack = *s == '[' ? "[...]" : "{...}";
! warner(WARN_AMBIGUOUS,
! "Ambiguous use of %c{%s%s} resolved to %c%s%s",
funny, dest, brack, funny, dest, brack);
}
lex_fakebrack = lex_brackets+1;
***************
*** 4381,4389 ****
lex_state = LEX_INTERPEND;
if (funny == '#')
funny = '@';
! if (dowarn &&
(keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
! warn("Ambiguous use of %c{%s} resolved to %c%s",
funny, dest, funny, dest);
}
else {
--- 4401,4410 ----
lex_state = LEX_INTERPEND;
if (funny == '#')
funny = '@';
! if (ckWARN(WARN_AMBIGUOUS) &&
(keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
! warner(WARN_AMBIGUOUS,
! "Ambiguous use of %c{%s} resolved to %c%s",
funny, dest, funny, dest);
}
else {
***************
*** 4946,4960 ****
floatit = FALSE;
while (isDIGIT(*s) || *s == '_') {
if (*s == '_') {
! if (dowarn && lastub && s - lastub != 3)
! warn("Misplaced _ in number");
lastub = ++s;
}
else
*d++ = *s++;
}
! if (dowarn && lastub && s - lastub != 3)
! warn("Misplaced _ in number");
if (*s == '.' && s[1] != '.') {
floatit = TRUE;
*d++ = *s++;
--- 4967,4981 ----
floatit = FALSE;
while (isDIGIT(*s) || *s == '_') {
if (*s == '_') {
! if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
! warner(WARN_SYNTAX, "Misplaced _ in number");
lastub = ++s;
}
else
*d++ = *s++;
}
! if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
! warner(WARN_SYNTAX, "Misplaced _ in number");
if (*s == '.' && s[1] != '.') {
floatit = TRUE;
*d++ = *s++;
*** universal.c.orig Tue Feb 18 08:43:35 1997
--- universal.c Thu Feb 27 11:31:54 1997
***************
*** 57,64 ****
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
! if (dowarn)
! warn("Can't locate package %s for @%s::ISA",
SvPVX(sv), HvNAME(stash));
continue;
}
--- 57,65 ----
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
! if (ckWARN(WARN_MISC))
! warner(WARN_SYNTAX,
! "Can't locate package %s for @%s::ISA",
SvPVX(sv), HvNAME(stash));
continue;
}
*** util.c.orig Tue Feb 4 08:55:21 1997
--- util.c Thu Feb 27 11:31:55 1997
***************
*** 1213,1241 ****
return restartop;
}
#ifdef I_STDARG
! void
! croak(const char* pat, ...)
#else
/*VARARGS0*/
! void
! croak(pat, va_alist)
char *pat;
! va_dcl
#endif
{
! va_list args;
char *message;
HV *stash;
GV *gv;
CV *cv;
! #ifdef I_STDARG
! va_start(args, pat);
! #else
! va_start(args);
! #endif
! message = mess(pat, &args);
va_end(args);
if (diehook) {
/* sv_2cv might call croak() */
--- 1213,1240 ----
return restartop;
}
+ static void
#ifdef I_STDARG
! do_croak(const char *pat, va_list *args)
#else
/*VARARGS0*/
! do_croak(pat, args)
char *pat;
! va_list *args;
#endif
{
! /* va_list args; */
char *message;
HV *stash;
GV *gv;
CV *cv;
! /* #ifdef I_STDARG */
! /* va_start(args, pat); */
! /* #else */
! /* va_start(args); */
! /* #endif */
! message = mess(pat, args);
va_end(args);
if (diehook) {
/* sv_2cv might call croak() */
***************
*** 1273,1298 ****
void
#ifdef I_STDARG
! warn(const char* pat,...)
#else
/*VARARGS0*/
! warn(pat,va_alist)
! const char *pat;
va_dcl
#endif
{
! va_list args;
! char *message;
! HV *stash;
! GV *gv;
! CV *cv;
#ifdef I_STDARG
va_start(args, pat);
#else
va_start(args);
#endif
! message = mess(pat, &args);
va_end(args);
if (warnhook) {
--- 1272,1318 ----
void
#ifdef I_STDARG
! croak(const char *pat,...)
#else
/*VARARGS0*/
! croak(pat, va_alist)
! char *pat;
va_dcl
#endif
{
! va_list args;
#ifdef I_STDARG
va_start(args, pat);
#else
va_start(args);
#endif
! do_croak(pat, &args);
! va_end(args);
! }
!
! static void
! #ifdef I_STDARG
! do_warn(const char *pat, va_list *args)
! #else
! /*VARARGS0*/
! do_warn(pat,args)
! const char *pat;
! va_list *args;
! #endif
! {
! /* va_list args; */
! char *message;
! HV *stash;
! GV *gv;
! CV *cv;
!
! /* #ifdef I_STDARG */
! /* va_start(args, pat); */
! /* #else */
! /* va_start(args); */
! /* #endif */
! message = mess(pat, args);
va_end(args);
if (warnhook) {
***************
*** 1328,1333 ****
--- 1348,1400 ----
(void)PerlIO_flush(PerlIO_stderr());
}
+ void
+ #ifdef I_STDARG
+ warn(const char* pat,...)
+ #else
+ /*VARARGS0*/
+ warn(pat,va_alist)
+ const char *pat;
+ va_dcl
+ #endif
+ {
+ va_list args;
+
+ #ifdef I_STDARG
+ va_start(args, pat);
+ #else
+ va_start(args);
+ #endif
+ do_warn(pat, &args);
+ va_end(args);
+ }
+
+ void
+ #ifdef I_STDARG
+ warner(U32 err, const char* pat,...)
+ #else
+ /*VARARGS0*/
+ warner(err,pat,va_alist)
+ U32 err;
+ const char *pat;
+ va_dcl
+ #endif
+ {
+ va_list args;
+
+ #ifdef I_STDARG
+ va_start(args, pat);
+ #else
+ va_start(args);
+ #endif
+
+ if (ckDEAD(err))
+ do_croak(pat, &args) ;
+ else
+ do_warn(pat, &args) ;
+ va_end(args);
+ }
+
#ifndef VMS /* VMS' my_setenv() is in VMS.c */
void
my_setenv(nam,val)
***************
*** 2184,2191 ****
retval = n | (*s++ - '0');
len--;
}
! if (dowarn && len && (*s == '8' || *s == '9'))
! warn("Illegal octal digit ignored");
*retlen = s - start;
return retval;
}
--- 2251,2258 ----
retval = n | (*s++ - '0');
len--;
}
! if (len && (*s == '8' || *s == '9') && ckWARN(WARN_OCTAL))
! warner(WARN_OCTAL, "Illegal octal digit ignored");
*retlen = s - start;
return retval;
}
*** /dev/null Thu Feb 27 12:04:47 1997
--- warning.h Thu Feb 27 11:52:03 1997
***************
*** 0 ****
--- 1,67 ----
+ /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by warning.pl
+ Any changes made here will be lost!
+ */
+
+
+ #define Off(x) ((x) / 8)
+ #define Bit(x) (1 << ((x) % 8))
+ #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
+
+ #define G_WARN_OFF 0
+ #define G_WARN_ON 1
+ #define G_WARN_FLAG 2 /* -W flag */
+
+ #define ckDEAD(x) \
+ (curcop->cop_warnings != WARN_ALL && \
+ curcop->cop_warnings != WARN_NONE && \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x+1))
+
+ #define ckWARN(x) \
+ ( (curcop->cop_warnings && \
+ (curcop->cop_warnings == WARN_ALL || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x) ) ) \
+ || (curcop->cop_warnings == WARN_NONE && dowarn) )
+
+ #define ckWARN2(x,y) \
+ ( (curcop->cop_warnings && \
+ (curcop->cop_warnings == WARN_ALL || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x) || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*y) ) ) \
+ || (curcop->cop_warnings == WARN_NONE && dowarn) )
+
+ #define WARN_NONE NULL
+ #define WARN_ALL (&sv_yes)
+
+ #define WARN_REDEFINE 0
+ #define WARN_VOID 1
+ #define WARN_UNSAFE 2
+ #define WARN_TAINT 3
+ #define WARN_SUBSTR 4
+ #define WARN_CLOSURE 5
+ #define WARN_UNTIE 6
+ #define WARN_SIGNAL 7
+ #define WARN_NUMERIC 8
+ #define WARN_ONCE 9
+ #define WARN_SYNTAX 10
+ #define WARN_RESERVED 11
+ #define WARN_DEPRECATED 12
+ #define WARN_SEMICOLON 13
+ #define WARN_OCTAL 14
+ #define WARN_AMBIGUOUS 15
+ #define WARN_PARENTHESIS 16
+ #define WARN_PRECEDENCE 17
+ #define WARN_IO 18
+ #define WARN_NEWLINE 19
+ #define WARN_CLOSED 20
+ #define WARN_EXEC 21
+ #define WARN_UNOPENED 22
+ #define WARN_PIPE 23
+ #define WARN_UNINITIALIZED 24
+ #define WARN_RECURSION 25
+ #define WARN_MISC 26
+
+ #define WARNsize 7
+ #define WARN_ALLstring "\125\125\125\125\125\125\125"
+ #define WARN_NONEstring "\0\0\0\0\0\0\0"
+
*** /dev/null Thu Feb 27 12:04:47 1997
--- warning.pl Thu Feb 27 11:52:50 1997
***************
*** 0 ****
--- 1,290 ----
+ #!/usr/bin/perl
+
+ $tree = {
+ 'unsafe' => { 'untie' => 1,
+ 'substr' => 1,
+ 'taint' => 1,
+ 'signal' => 1,
+ 'closure' => 1,
+ } ,
+ 'io' => { 'pipe' => 1,
+ 'unopened' => 1,
+ 'closed' => 1,
+ 'newline' => 1,
+ 'exec' => 1,
+ #'wr in in file'=> 1,
+ },
+ 'syntax' => { 'ambiguous' => 1,
+ 'semicolon' => 1,
+ 'precedence' => 1,
+ 'reserved' => 1,
+ 'octal' => 1,
+ 'parenthesis' => 1,
+ 'deprecated' => 1,
+ },
+ 'void' => 1,
+ 'recursion' => 1,
+ 'redefine' => 1,
+ 'numeric' => 1,
+ 'uninitialized'=> 1,
+ 'once' => 1,
+ 'misc' => 1,
+ } ;
+
+
+ ###########################################################################
+ sub tab {
+ local($l, $t) = @_;
+ $t .= "\t" x ($l - (length($t) + 1) / 8);
+ $t;
+ }
+
+ ###########################################################################
+
+ sub walk
+ {
+ my $tre = shift ;
+ my @list = () ;
+ my ($k, $v) ;
+
+ while (($k, $v) = each %$tre) {
+
+ die "duplicate key $k\n" if defined $list{$k} ;
+ $Value{$index} = uc $k ;
+ push @{ $list{$k} }, $index ++ ;
+ if (ref $v)
+ { push (@{ $list{$k} }, walk ($v)) }
+ push @list, @{ $list{$k} } ;
+ }
+
+ return @list ;
+
+ }
+
+ ###########################################################################
+
+ sub mkRange
+ {
+ my @a = @_ ;
+ my @out = @a ;
+ my $i ;
+
+
+ for ($i = 1 ; $i < @a; ++ $i) {
+ $out[$i] = ".."
+ if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
+ }
+
+ my $out = join(",",@out);
+
+ $out =~ s/,(\.\.,)+/../g ;
+ return $out;
+ }
+
+ ###########################################################################
+
+ sub mkHex
+ {
+ my ($max, @a) = @_ ;
+ my $mask = "\x00" x $max ;
+ my $string = "" ;
+
+ foreach (@a) {
+ vec($mask, $_, 1) = 1 ;
+ }
+
+ #$string = unpack("H$max", $mask) ;
+ #$string =~ s/(..)/\x$1/g;
+ foreach (unpack("C*", $mask)) {
+ $string .= '\x' . sprintf("%2.2x", $_) ;
+ }
+ return $string ;
+ }
+
+ ###########################################################################
+
+
+ #unlink "warning.h";
+ #unlink "lib/warning.pm";
+ open(WARN, ">warning.h") || die "Can't create warning.h: $!\n";
+ open(PM, ">lib/warning.pm") || die "Can't create lib/warning.pm: $!\n";
+
+ print WARN <<'EOM' ;
+ /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by warning.pl
+ Any changes made here will be lost!
+ */
+
+
+ #define Off(x) ((x) / 8)
+ #define Bit(x) (1 << ((x) % 8))
+ #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
+
+ #define G_WARN_OFF 0
+ #define G_WARN_ON 1
+ #define G_WARN_FLAG 2 /* -W flag */
+
+ #define ckDEAD(x) \
+ (curcop->cop_warnings != WARN_ALL && \
+ curcop->cop_warnings != WARN_NONE && \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x+1))
+
+ #define ckWARN(x) \
+ ( (curcop->cop_warnings && \
+ (curcop->cop_warnings == WARN_ALL || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x) ) ) \
+ || (curcop->cop_warnings == WARN_NONE && dowarn) )
+
+ #define ckWARN2(x,y) \
+ ( (curcop->cop_warnings && \
+ (curcop->cop_warnings == WARN_ALL || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x) || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*y) ) ) \
+ || (curcop->cop_warnings == WARN_NONE && dowarn) )
+
+ #define WARN_NONE NULL
+ #define WARN_ALL (&sv_yes)
+
+ EOM
+
+
+ $index = 0 ;
+ @{ $list{"all"} } = walk ($tree) ;
+
+ $index *= 2 ;
+ $warn_size = int($index / 8) + ($index % 8 != 0) ;
+
+ foreach $k (sort { $a <=> $b } keys %Value) {
+ print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
+ }
+ print WARN "\n" ;
+
+ print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
+ #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
+ print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
+ print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
+
+ print WARN <<'EOM';
+
+ EOM
+
+ close WARN ;
+
+ while (<DATA>) {
+ 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 (<DATA>) {
+ print PM $_ ;
+ }
+
+ close PM ;
+
+ __END__
+
+ # This file was created by warning.pl
+ # Any changes made here will be lost.
+ #
+
+ package warning;
+
+ =head1 NAME
+
+ warning - Perl pragma to control
+
+ =head1 SYNOPSIS
+
+ use warning;
+
+ use warning "all";
+ use warning "deprecated";
+
+ use warning;
+ no warning "unsafe";
+
+ =head1 DESCRIPTION
+
+ If no import list is supplied, all possible restrictions are assumed.
+ (This is the safest mode to operate in, but is sometimes too strict for
+ casual programming.) Currently, there are three possible things to be
+ strict about:
+
+ =over 6
+
+ =item C<warning deprecated>
+
+ This generates a runtime error if you use deprecated
+
+ use warning 'deprecated';
+
+ =back
+
+ See L<perlmod/Pragmatic Modules>.
+
+
+ =cut
+
+ use Carp ;
+
+
+ KEYWORDS
+
+ sub bits {
+ my $mask ;
+ my $catmask ;
+ my $fatal = 0 ;
+ foreach my $word (@_) {
+ if ($word eq 'FATAL')
+ { $fatal = 1 }
+ elsif ($catmask = $Bits{$word}) {
+ $mask |= $catmask ;
+ $mask |= $DeadBits{$word} if $fatal ;
+ }
+ else
+ { croak "unknown warning category '$word'" }
+ }
+
+ return $mask ;
+ }
+
+ sub import {
+ shift;
+ $^B |= bits(@_ ? @_ : 'all') ;
+ }
+
+ sub unimport {
+ shift;
+ $^B &= ~ bits(@_ ? @_ : 'all') ;
+ }
+
+
+ 1;
*** /dev/null Thu Feb 27 12:04:47 1997
--- warning.pl Thu Feb 27 11:52:50 1997
***************
*** 0 ****
--- 1,290 ----
+ #!/usr/bin/perl
+
+ $tree = {
+ 'unsafe' => { 'untie' => 1,
+ 'substr' => 1,
+ 'taint' => 1,
+ 'signal' => 1,
+ 'closure' => 1,
+ } ,
+ 'io' => { 'pipe' => 1,
+ 'unopened' => 1,
+ 'closed' => 1,
+ 'newline' => 1,
+ 'exec' => 1,
+ #'wr in in file'=> 1,
+ },
+ 'syntax' => { 'ambiguous' => 1,
+ 'semicolon' => 1,
+ 'precedence' => 1,
+ 'reserved' => 1,
+ 'octal' => 1,
+ 'parenthesis' => 1,
+ 'deprecated' => 1,
+ },
+ 'void' => 1,
+ 'recursion' => 1,
+ 'redefine' => 1,
+ 'numeric' => 1,
+ 'uninitialized'=> 1,
+ 'once' => 1,
+ 'misc' => 1,
+ } ;
+
+
+ ###########################################################################
+ sub tab {
+ local($l, $t) = @_;
+ $t .= "\t" x ($l - (length($t) + 1) / 8);
+ $t;
+ }
+
+ ###########################################################################
+
+ sub walk
+ {
+ my $tre = shift ;
+ my @list = () ;
+ my ($k, $v) ;
+
+ while (($k, $v) = each %$tre) {
+
+ die "duplicate key $k\n" if defined $list{$k} ;
+ $Value{$index} = uc $k ;
+ push @{ $list{$k} }, $index ++ ;
+ if (ref $v)
+ { push (@{ $list{$k} }, walk ($v)) }
+ push @list, @{ $list{$k} } ;
+ }
+
+ return @list ;
+
+ }
+
+ ###########################################################################
+
+ sub mkRange
+ {
+ my @a = @_ ;
+ my @out = @a ;
+ my $i ;
+
+
+ for ($i = 1 ; $i < @a; ++ $i) {
+ $out[$i] = ".."
+ if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
+ }
+
+ my $out = join(",",@out);
+
+ $out =~ s/,(\.\.,)+/../g ;
+ return $out;
+ }
+
+ ###########################################################################
+
+ sub mkHex
+ {
+ my ($max, @a) = @_ ;
+ my $mask = "\x00" x $max ;
+ my $string = "" ;
+
+ foreach (@a) {
+ vec($mask, $_, 1) = 1 ;
+ }
+
+ #$string = unpack("H$max", $mask) ;
+ #$string =~ s/(..)/\x$1/g;
+ foreach (unpack("C*", $mask)) {
+ $string .= '\x' . sprintf("%2.2x", $_) ;
+ }
+ return $string ;
+ }
+
+ ###########################################################################
+
+
+ #unlink "warning.h";
+ #unlink "lib/warning.pm";
+ open(WARN, ">warning.h") || die "Can't create warning.h: $!\n";
+ open(PM, ">lib/warning.pm") || die "Can't create lib/warning.pm: $!\n";
+
+ print WARN <<'EOM' ;
+ /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by warning.pl
+ Any changes made here will be lost!
+ */
+
+
+ #define Off(x) ((x) / 8)
+ #define Bit(x) (1 << ((x) % 8))
+ #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
+
+ #define G_WARN_OFF 0
+ #define G_WARN_ON 1
+ #define G_WARN_FLAG 2 /* -W flag */
+
+ #define ckDEAD(x) \
+ (curcop->cop_warnings != WARN_ALL && \
+ curcop->cop_warnings != WARN_NONE && \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x+1))
+
+ #define ckWARN(x) \
+ ( (curcop->cop_warnings && \
+ (curcop->cop_warnings == WARN_ALL || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x) ) ) \
+ || (curcop->cop_warnings == WARN_NONE && dowarn) )
+
+ #define ckWARN2(x,y) \
+ ( (curcop->cop_warnings && \
+ (curcop->cop_warnings == WARN_ALL || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x) || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*y) ) ) \
+ || (curcop->cop_warnings == WARN_NONE && dowarn) )
+
+ #define WARN_NONE NULL
+ #define WARN_ALL (&sv_yes)
+
+ EOM
+
+
+ $index = 0 ;
+ @{ $list{"all"} } = walk ($tree) ;
+
+ $index *= 2 ;
+ $warn_size = int($index / 8) + ($index % 8 != 0) ;
+
+ foreach $k (sort { $a <=> $b } keys %Value) {
+ print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
+ }
+ print WARN "\n" ;
+
+ print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
+ #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
+ print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
+ print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
+
+ print WARN <<'EOM';
+
+ EOM
+
+ close WARN ;
+
+ while (<DATA>) {
+ 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 (<DATA>) {
+ print PM $_ ;
+ }
+
+ close PM ;
+
+ __END__
+
+ # This file was created by warning.pl
+ # Any changes made here will be lost.
+ #
+
+ package warning;
+
+ =head1 NAME
+
+ warning - Perl pragma to control
+
+ =head1 SYNOPSIS
+
+ use warning;
+
+ use warning "all";
+ use warning "deprecated";
+
+ use warning;
+ no warning "unsafe";
+
+ =head1 DESCRIPTION
+
+ If no import list is supplied, all possible restrictions are assumed.
+ (This is the safest mode to operate in, but is sometimes too strict for
+ casual programming.) Currently, there are three possible things to be
+ strict about:
+
+ =over 6
+
+ =item C<warning deprecated>
+
+ This generates a runtime error if you use deprecated
+
+ use warning 'deprecated';
+
+ =back
+
+ See L<perlmod/Pragmatic Modules>.
+
+
+ =cut
+
+ use Carp ;
+
+
+ KEYWORDS
+
+ sub bits {
+ my $mask ;
+ my $catmask ;
+ my $fatal = 0 ;
+ foreach my $word (@_) {
+ if ($word eq 'FATAL')
+ { $fatal = 1 }
+ elsif ($catmask = $Bits{$word}) {
+ $mask |= $catmask ;
+ $mask |= $DeadBits{$word} if $fatal ;
+ }
+ else
+ { croak "unknown warning category '$word'" }
+ }
+
+ return $mask ;
+ }
+
+ sub import {
+ shift;
+ $^B |= bits(@_ ? @_ : 'all') ;
+ }
+
+ sub unimport {
+ shift;
+ $^B &= ~ bits(@_ ? @_ : 'all') ;
+ }
+
+
+ 1;