# See README.warning for information of what the patch does.
#
# Apply with patch -p0 <warn.patch
exit 0
-----------------------------------------------------------------------
*** MANIFEST.orig Fri May 15 14:58:01 1998
--- MANIFEST Sat May 16 16:56:54 1998
***************
*** 551,556 ****
--- 551,557 ----
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
***************
*** 901,906 ****
--- 902,925 ----
t/pragma/strict.t See if strictures work
t/pragma/subs.t See if subroutine pseudo-importation works
t/pragma/warn-1global Tests of global warnings for warning.t
+ t/pragma/warn-2use Tests for "use warning" for warning.t
+ t/pragma/warn-doio Tests for doio.c for warning.t
+ t/pragma/warn-gv Tests for gv.c for warning.t
+ t/pragma/warn-mg Tests for mg.c for warning.t
+ t/pragma/warn-op Tests for op.c for warning.t
+ t/pragma/warn-perl Tests for perl.c for warning.t
+ t/pragma/warn-perly Tests for perly.y for warning.t
+ t/pragma/warn-pp Tests for pp.c for warning.t
+ t/pragma/warn-pp_ctl Tests for pp_ctl.c for warning.t
+ t/pragma/warn-pp_hot Tests for pp_hot.c for warning.t
+ t/pragma/warn-pp_sys Tests for pp_sys.c for warning.t
+ t/pragma/warn-regcomp Tests for regcomp.c for warning.t
+ t/pragma/warn-regexec Tests for regexec.c for warning.t
+ t/pragma/warn-sv Tests for sv.c for warning.t
+ t/pragma/warn-taint Tests for taint.c for warning.t
+ t/pragma/warn-toke Tests for toke.c for warning.t
+ t/pragma/warn-universal Tests for universal.c for warning.t
+ t/pragma/warn-util Tests for util.c for warning.t
t/pragma/warning.t See if warning controls work
taint.c Tainting code
thrdvar.h Per-thread variables
***************
*** 954,959 ****
--- 973,980 ----
vms/vms_yfix.pl convert Unix perly.[ch] to VMS perly_[ch].vms
vms/vmsish.h VMS-specific C header for Perl core
vms/writemain.pl Generate perlmain.c from miniperlmain.c+extensions
+ warning.h The warning numbers
+ warning.pl Program to write warning.h and lib/warning.pm
win32/Makefile Win32 makefile for NMAKE (Visual C++ build)
win32/TEST Win32 port
win32/autosplit.pl Win32 port
*** Makefile.SH.orig Thu May 14 16:56:17 1998
--- Makefile.SH Sat May 16 16:56:54 1998
***************
*** 200,206 ****
h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h
h3 = opcode.h patchlevel.h perl.h perly.h pp.h proto.h regcomp.h
h4 = regexp.h scope.h sv.h unixish.h util.h perlio.h thread.h
! h5 = bytecode.h byterun.h
h = $(h1) $(h2) $(h3) $(h4) $(h5)
c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c byterun.c
--- 200,206 ----
h2 = embed.h form.h gv.h handy.h hv.h keywords.h mg.h op.h
h3 = opcode.h patchlevel.h perl.h perly.h pp.h proto.h regcomp.h
h4 = regexp.h scope.h sv.h unixish.h util.h perlio.h thread.h
! h5 = bytecode.h byterun.h warning.h
h = $(h1) $(h2) $(h3) $(h4) $(h5)
c1 = $(mallocsrc) av.c scope.c op.c doop.c doio.c dump.c hv.c mg.c byterun.c
***************
*** 443,448 ****
--- 443,449 ----
# byterun.h: bytecode.pl
# byterun.c: bytecode.pl
# lib/B/Asmdata.pm: bytecode.pl
+ # warning.h lib/warning.pm: warning.pl
# The correct versions should be already supplied with the perl kit,
# in case you don't have perl available.
# To force them to run, type
***************
*** 452,457 ****
--- 453,459 ----
perl opcode.pl
perl embed.pl
perl bytecode.pl
+ perl warning.pl
# Extensions:
# Names added to $(dynamic_ext) or $(static_ext) will automatically
*** /dev/null Tue Jan 1 04:00:00 1980
--- README.warning Sat May 16 17:02:50 1998
***************
*** 0 ****
--- 1,231 ----
+ Date: 16th May 1998
+
+ This patch adds lexical warnings to Perl. It should apply over
+ 5.004_65
+
+ NOTE: This is a prototype. Do not assume that lexical warnings will
+ necessarily be anything like this implementation.
+
+ Changes
+ =======
+
+ Date: 8th April 1998
+
+ * patch now applies cleanly over 5.004_64
+
+ * added the -X switch (the inverse "lint" command)
+
+ Date: 26th Feb 1997
+
+ * By popular demand, the warnings bitmask can now be of arbitrary
+ length. The code uses an SV* to store the bitmask.
+
+ * Rationalised the warning categories a bit. This area still needs
+ a lot of work.
+
+ * Added -W switch (the "lint" command).
+
+ * Added an experimental feature to allow warnings to be excalated
+ to fatal errors.
+
+
+ The "use warning" pragma
+ ============================
+
+ The "use warning" pragma is intended to 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.
+
+ The inverse "lint" flag, -X
+ ===========================
+ Does exactly the same as the -W flag, except it disables all warnings.
+
+
+ Fatal Warnings
+ ==============
+
+ This feature is very experimental.
+
+ The presence of the word "FATAL" in the category list will escalate any
+ warnings from the category specified that are detected in the lexical
+ scope into fatal errors. In the code below, there are 3 places where a
+ deprecated warning will be detected, the middle one will produce a
+ fatal error.
+
+
+ use warning ;
+
+ $a = 1 if $a EQ $b ;
+
+ {
+ use warning qw(FATAL deprecated) ;
+ $a = 1 if $a EQ $b ;
+ }
+
+ $a = 1 if $a EQ $b ;
+
+
+ TODO
+ ====
+
+ test harness for -X (assuming it is a permanent fixture).
+
+ Unresolved Issues
+ =================
+
+ The pragma name?
+ A few possibilities:
+ warning
+ warnings
+ warn
+
+ Hierarchy of Warnings
+ The current patch has a fairly arbitrary hierarchy.
+ Ideas for a useful hierarchy would be most welcome.
+
+ A command line option to turn off all warnings?
+ -X or -q, perhaps.
+
+ Current mandatory warnings.
+ May be useful to bring them under the control of this pragma.
+
+ Severity
+ Do we want/need a severity classification?
+ pedantic
+ high/strict/precise
+ medium/default
+ low/common
+
+ Versions
+ This is a thorhy issue. Say someone writes a script using Perl
+ 5.004 and places this at the top:
+
+ use warning ;
+
+ Time passes and 5.005 comes out. It has added a few extra warnings.
+ The script prints warning messages.
+
+ A possibility is to allow the warnings that are checked to be
+ limited to those available in a given version of Perl. A possible
+ syntax could be:
+
+ use warning 5.004 ;
+
+ or
+
+ use warning 5.004 qw(void uninitialized) ;
+
+ Do we really need this amount of control?
+
+ Documentation
+ There isn't any yet.
+
+
+ perl5db.pl
+ The debugger saves and restores $^W at runtime. I haven't checked
+ whether the debugger will still work with the lexical warnings
+ patch applied.
+
+ diagnostics.pm
+ I *think* I've got diagnostics to work with the lexiacal warnings
+ patch, but there were design decisions made in diagnostics to work
+ around the limitations of $^W. Now that those limitations are gone,
+ the module should be revisited.
*** cop.h.orig Thu May 14 17:08:44 1998
--- cop.h Sat May 16 16:56:54 1998
***************
*** 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 Fri May 15 17:05:27 1998
--- doio.c Sat May 16 16:56:54 1998
***************
*** 173,180 ****
TAINT_PROPER("piped open");
if (name[strlen(name)-1] == '|') {
name[strlen(name)-1] = '\0' ;
! if (dowarn)
! warn("Can't do bidirectional pipe");
}
fp = PerlProc_popen(name,"w");
writing = 1;
--- 173,180 ----
TAINT_PROPER("piped open");
if (name[strlen(name)-1] == '|') {
name[strlen(name)-1] = '\0' ;
! if (ckWARN(WARN_PIPE))
! warner(WARN_PIPE, "Can't do bidirectional pipe");
}
fp = PerlProc_popen(name,"w");
writing = 1;
***************
*** 283,290 ****
}
}
if (!fp) {
! if (dowarn && IoTYPE(io) == '<' && strchr(name, '\n'))
! warn(warn_nl, "open");
goto say_false;
}
if (IoTYPE(io) &&
--- 283,290 ----
}
}
if (!fp) {
! if (ckWARN(WARN_NEWLINE) && IoTYPE(io) == '<' && strchr(name, '\n'))
! warner(WARN_NEWLINE, warn_nl, "open");
goto say_false;
}
if (IoTYPE(io) &&
***************
*** 584,591 ****
}
io = GvIO(gv);
if (!io) { /* never opened */
! if (dowarn && not_implicit)
! warn("Close on unopened file <%s>",GvENAME(gv));
SETERRNO(EBADF,SS$_IVCHAN);
return FALSE;
}
--- 584,591 ----
}
io = GvIO(gv);
if (!io) { /* never opened */
! if (ckWARN(WARN_UNOPENED) && not_implicit)
! warner(WARN_UNOPENED, "Close on unopened file <%s>",GvENAME(gv));
SETERRNO(EBADF,SS$_IVCHAN);
return FALSE;
}
***************
*** 681,688 ****
#endif
return PerlIO_tell(fp);
}
! if (dowarn)
! warn("tell() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
return -1L;
}
--- 681,688 ----
#endif
return PerlIO_tell(fp);
}
! if (ckWARN(WARN_UNOPENED))
! warner(WARN_UNOPENED, "tell() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
return -1L;
}
***************
*** 700,707 ****
#endif
return PerlIO_seek(fp, pos, whence) >= 0;
}
! if (dowarn)
! warn("seek() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
return FALSE;
}
--- 700,707 ----
#endif
return PerlIO_seek(fp, pos, whence) >= 0;
}
! if (ckWARN(WARN_UNOPENED))
! warner(WARN_UNOPENED, "seek() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
return FALSE;
}
***************
*** 714,721 ****
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
! if (dowarn)
! warn("sysseek() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
return -1L;
}
--- 714,721 ----
if (gv && (io = GvIO(gv)) && (fp = IoIFP(io)))
return PerlLIO_lseek(PerlIO_fileno(fp), pos, whence);
! if (ckWARN(WARN_UNOPENED))
! warner(WARN_UNOPENED, "sysseek() on unopened file");
SETERRNO(EBADF,RMS$_IFI);
return -1L;
}
***************
*** 835,842 ****
}
switch (SvTYPE(sv)) {
case SVt_NULL:
! if (dowarn)
! warn(warn_uninit);
return TRUE;
case SVt_IV:
if (SvIOK(sv)) {
--- 835,842 ----
}
switch (SvTYPE(sv)) {
case SVt_NULL:
! if (ckWARN(WARN_UNINITIALIZED))
! warner(WARN_UNINITIALIZED, warn_uninit);
return TRUE;
case SVt_IV:
if (SvIOK(sv)) {
***************
*** 876,883 ****
else {
if (tmpgv == defgv)
return laststatval;
! if (dowarn)
! warn("Stat on unopened file <%s>",
GvENAME(tmpgv));
statgv = Nullgv;
sv_setpv(statname,"");
--- 876,883 ----
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,"");
***************
*** 902,909 ****
sv_setpv(statname, s);
laststype = OP_STAT;
laststatval = PerlLIO_stat(s, &statcache);
! if (laststatval < 0 && dowarn && strchr(s, '\n'))
! warn(warn_nl, "stat");
return laststatval;
}
}
--- 902,909 ----
sv_setpv(statname, s);
laststype = OP_STAT;
laststatval = PerlLIO_stat(s, &statcache);
! if (laststatval < 0 && ckWARN(WARN_NEWLINE) && strchr(s, '\n'))
! warner(WARN_NEWLINE, warn_nl, "stat");
return laststatval;
}
}
***************
*** 933,940 ****
#else
laststatval = PerlLIO_stat(SvPV(sv, na),&statcache);
#endif
! if (laststatval < 0 && dowarn && strchr(SvPV(sv, na), '\n'))
! warn(warn_nl, "lstat");
return laststatval;
}
--- 933,940 ----
#else
laststatval = PerlLIO_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;
}
***************
*** 961,968 ****
PerlProc_execvp(tmps,Argv);
else
PerlProc_execvp(Argv[0],Argv);
! if (dowarn)
! warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
}
do_execfree();
return FALSE;
--- 961,969 ----
PerlProc_execvp(tmps,Argv);
else
PerlProc_execvp(Argv[0],Argv);
! if (ckWARN(WARN_EXEC))
! warner(WARN_EXEC, "Can't exec \"%s\": %s",
! Argv[0], Strerror(errno));
}
do_execfree();
return FALSE;
***************
*** 1064,1071 ****
do_execfree();
goto doshell;
}
! if (dowarn)
! warn("Can't exec \"%s\": %s", Argv[0], Strerror(errno));
}
do_execfree();
return FALSE;
--- 1065,1073 ----
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 Fri May 15 14:59:13 1998
--- global.sym Sat May 16 16:56:54 1998
***************
*** 1065,1070 ****
--- 1065,1071 ----
utilize
wait4pid
warn
+ warner
watch
whichsig
yydestruct
*** gv.c.orig Fri May 15 14:59:14 1998
--- gv.c Sat May 16 16:56:54 1998
***************
*** 218,225 ****
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;
}
--- 218,225 ----
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;
}
***************
*** 349,356 ****
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
! if (dowarn && !method && (GvCVGEN(gv) || GvSTASH(gv) != stash))
! warn(
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
HvNAME(stash), (int)len, name);
--- 349,357 ----
/*
* Inheriting AUTOLOAD for non-methods works ... for now.
*/
! if (ckWARN(WARN_DEPRECATED) && !method &&
! (GvCVGEN(gv) || GvSTASH(gv) != stash))
! warner(WARN_DEPRECATED,
"Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated",
HvNAME(stash), (int)len, name);
***************
*** 711,718 ****
case '#':
case '*':
! if (dowarn && len == 1 && sv_type == SVt_PV)
! warn("Use of $%s is deprecated", name);
/* FALL THROUGH */
case '[':
case '!':
--- 712,719 ----
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 '!':
***************
*** 731,736 ****
--- 732,738 ----
case '/':
case '|':
case '\001':
+ case '\002':
case '\004':
case '\005':
case '\006':
***************
*** 869,875 ****
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));
}
}
--- 871,878 ----
curcop->cop_filegv = filegv;
if (filegv && GvMULTI(filegv)) /* Filename began with slash */
continue;
! warner(WARN_ONCE,
! "Name \"%s::%s\" used only once: possible typo",
HvNAME(stash), GvNAME(gv));
}
}
*** interp.sym.orig Thu May 14 17:10:37 1998
--- interp.sym Sat May 16 16:56:54 1998
***************
*** 67,72 ****
--- 67,73 ----
laststatval
laststype
leftgv
+ lexwarn
lineary
localizing
localpatches
*** lib/diagnostics.pm.orig Tue Nov 25 14:52:48 1997
--- lib/diagnostics.pm Sat May 16 16:56:54 1998
***************
*** 274,280 ****
$transmo = <<EOFUNC;
sub transmo {
! local \$^W = 0; # recursive warnings we do NOT need!
study;
EOFUNC
--- 274,280 ----
$transmo = <<EOFUNC;
sub transmo {
! #local \$^W = 0; # recursive warnings we do NOT need!
study;
EOFUNC
***************
*** 371,377 ****
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;
--- 371,377 ----
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;
***************
*** 407,413 ****
sub disable {
shift;
! $^W = $old_w;
return unless $SIG{__WARN__} eq \&warn_trap;
$SIG{__WARN__} = $oldwarn;
$SIG{__DIE__} = $olddie;
--- 407,413 ----
sub disable {
shift;
! #$^W = $old_w;
return unless $SIG{__WARN__} eq \&warn_trap;
$SIG{__WARN__} = $oldwarn;
$SIG{__DIE__} = $olddie;
*** /dev/null Tue Jan 1 04:00:00 1980
--- lib/warning.pm Sat May 16 16:56:54 1998
***************
*** 0 ****
--- 1,169 ----
+
+ # 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\x55", # [0..31]
+ 'ambiguous' => "\x00\x00\x00\x00\x04\x00\x00\x00", # [17]
+ 'closed' => "\x00\x00\x00\x00\x00\x10\x00\x00", # [22]
+ 'closure' => "\x00\x04\x00\x00\x00\x00\x00\x00", # [5]
+ 'default' => "\x00\x00\x04\x00\x00\x00\x00\x00", # [9]
+ 'deprecated' => "\x00\x00\x00\x04\x00\x00\x00\x00", # [13]
+ 'exec' => "\x00\x00\x00\x00\x00\x40\x00\x00", # [23]
+ 'io' => "\x00\x00\x00\x00\x00\x55\x05\x00", # [20..25]
+ 'misc' => "\x00\x00\x00\x00\x00\x00\x00\x01", # [28]
+ 'newline' => "\x00\x00\x00\x00\x00\x04\x00\x00", # [21]
+ 'numeric' => "\x00\x00\x01\x00\x00\x00\x00\x00", # [8]
+ 'octal' => "\x00\x00\x00\x00\x01\x00\x00\x00", # [16]
+ 'once' => "\x00\x00\x10\x00\x00\x00\x00\x00", # [10]
+ 'parenthesis' => "\x00\x00\x00\x00\x10\x00\x00\x00", # [18]
+ 'pipe' => "\x00\x00\x00\x00\x00\x00\x04\x00", # [25]
+ 'precedence' => "\x00\x00\x00\x00\x40\x00\x00\x00", # [19]
+ 'printf' => "\x00\x00\x00\x40\x00\x00\x00\x00", # [15]
+ 'recursion' => "\x00\x00\x00\x00\x00\x00\x40\x00", # [27]
+ 'redefine' => "\x01\x00\x00\x00\x00\x00\x00\x00", # [0]
+ 'reserved' => "\x00\x00\x00\x01\x00\x00\x00\x00", # [12]
+ 'semicolon' => "\x00\x00\x00\x10\x00\x00\x00\x00", # [14]
+ 'signal' => "\x00\x40\x00\x00\x00\x00\x00\x00", # [7]
+ 'substr' => "\x00\x01\x00\x00\x00\x00\x00\x00", # [4]
+ 'syntax' => "\x00\x00\x40\x55\x55\x00\x00\x00", # [11..19]
+ 'taint' => "\x40\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x10\x00", # [26]
+ 'unopened' => "\x00\x00\x00\x00\x00\x00\x01\x00", # [24]
+ 'unsafe' => "\x50\x55\x00\x00\x00\x00\x00\x00", # [2..7]
+ 'untie' => "\x00\x10\x00\x00\x00\x00\x00\x00", # [6]
+ 'void' => "\x04\x00\x00\x00\x00\x00\x00\x00", # [1]
+ );
+
+ %DeadBits = (
+ 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..31]
+ 'ambiguous' => "\x00\x00\x00\x00\x08\x00\x00\x00", # [17]
+ 'closed' => "\x00\x00\x00\x00\x00\x20\x00\x00", # [22]
+ 'closure' => "\x00\x08\x00\x00\x00\x00\x00\x00", # [5]
+ 'default' => "\x00\x00\x08\x00\x00\x00\x00\x00", # [9]
+ 'deprecated' => "\x00\x00\x00\x08\x00\x00\x00\x00", # [13]
+ 'exec' => "\x00\x00\x00\x00\x00\x80\x00\x00", # [23]
+ 'io' => "\x00\x00\x00\x00\x00\xaa\x0a\x00", # [20..25]
+ 'misc' => "\x00\x00\x00\x00\x00\x00\x00\x02", # [28]
+ 'newline' => "\x00\x00\x00\x00\x00\x08\x00\x00", # [21]
+ 'numeric' => "\x00\x00\x02\x00\x00\x00\x00\x00", # [8]
+ 'octal' => "\x00\x00\x00\x00\x02\x00\x00\x00", # [16]
+ 'once' => "\x00\x00\x20\x00\x00\x00\x00\x00", # [10]
+ 'parenthesis' => "\x00\x00\x00\x00\x20\x00\x00\x00", # [18]
+ 'pipe' => "\x00\x00\x00\x00\x00\x00\x08\x00", # [25]
+ 'precedence' => "\x00\x00\x00\x00\x80\x00\x00\x00", # [19]
+ 'printf' => "\x00\x00\x00\x80\x00\x00\x00\x00", # [15]
+ 'recursion' => "\x00\x00\x00\x00\x00\x00\x80\x00", # [27]
+ 'redefine' => "\x02\x00\x00\x00\x00\x00\x00\x00", # [0]
+ 'reserved' => "\x00\x00\x00\x02\x00\x00\x00\x00", # [12]
+ 'semicolon' => "\x00\x00\x00\x20\x00\x00\x00\x00", # [14]
+ 'signal' => "\x00\x80\x00\x00\x00\x00\x00\x00", # [7]
+ 'substr' => "\x00\x02\x00\x00\x00\x00\x00\x00", # [4]
+ 'syntax' => "\x00\x00\x80\xaa\xaa\x00\x00\x00", # [11..19]
+ 'taint' => "\x80\x00\x00\x00\x00\x00\x00\x00", # [3]
+ 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x20\x00", # [26]
+ 'unopened' => "\x00\x00\x00\x00\x00\x00\x02\x00", # [24]
+ 'unsafe' => "\xa0\xaa\x00\x00\x00\x00\x00\x00", # [2..7]
+ 'untie' => "\x00\x20\x00\x00\x00\x00\x00\x00", # [6]
+ 'void' => "\x08\x00\x00\x00\x00\x00\x00\x00", # [1]
+ );
+
+
+ sub bits {
+ my $mask ;
+ my $catmask ;
+ my $fatal = 0 ;
+ foreach my $word (@_) {
+ if ($word eq 'FATAL')
+ { $fatal = 1 }
+ elsif ($catmask = $Bits{$word}) {
+ $mask |= $catmask ;
+ $mask |= $DeadBits{$word} if $fatal ;
+ }
+ else
+ { croak "unknown warning category '$word'" }
+ }
+
+ return $mask ;
+ }
+
+ sub import {
+ shift;
+ $^B |= bits(@_ ? @_ : 'all') ;
+ }
+
+ sub unimport {
+ shift;
+ $^B &= ~ bits(@_ ? @_ : 'all') ;
+ }
+
+
+ sub make_fatal
+ {
+ my $self = shift ;
+ my $bitmask = $self->bits(@_) ;
+ $SIG{__WARN__} =
+ sub
+ {
+ die @_ if $^B & $bitmask ;
+ warn @_
+ } ;
+ }
+
+ sub bitmask
+ {
+ return $^B ;
+ }
+
+ sub enabled
+ {
+ my $string = shift ;
+
+ return 1
+ if $bits{$string} && $^B & $bits{$string} ;
+
+ return 0 ;
+ }
+
+ 1;
*** mg.c.orig Fri May 15 14:59:39 1998
--- mg.c Sat May 16 16:56:54 1998
***************
*** 338,343 ****
--- 338,369 ----
return 0;
}
+ static char *
+ printW(sv)
+ SV * sv ;
+ {
+ #if 1
+ return "" ;
+
+ #else
+ int i ;
+ static char buffer[50] ;
+ char buf1[20] ;
+ char * p ;
+
+
+ sprintf(buffer, "Buffer %d, Length = %d - ", sv, SvCUR(sv)) ;
+ p = SvPVX(sv) ;
+ for (i = 0; i < SvCUR(sv) ; ++ i) {
+ sprintf (buf1, " %x [%x]", (p+i), *(p+i)) ;
+ strcat(buffer, buf1) ;
+ }
+
+ return buffer ;
+
+ #endif
+ }
+
int
magic_get(SV *sv, MAGIC *mg)
{
***************
*** 352,357 ****
--- 378,395 ----
case '\001': /* ^A */
sv_setsv(sv, bodytarget);
break;
+ case '\002': /* ^B */
+ /* printf("magic_get $^B: ") ; */
+ if (curcop->cop_warnings == WARN_NONE)
+ /* printf("WARN_NONE\n"), */
+ sv_setpvn(sv, WARN_NONEstring, WARNsize) ;
+ else if (curcop->cop_warnings == WARN_ALL)
+ /* printf("WARN_ALL\n"), */
+ sv_setpvn(sv, WARN_ALLstring, WARNsize) ;
+ else
+ /* printf("some %s\n", printW(curcop->cop_warnings)), */
+ sv_setsv(sv, curcop->cop_warnings);
+ break;
case '\004': /* ^D */
sv_setiv(sv, (IV)(debug & 32767));
break;
***************
*** 435,441 ****
#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 '&':
--- 473,479 ----
#endif
break;
case '\027': /* ^W */
! sv_setiv(sv, (IV)((dowarn & G_WARN_ON) == G_WARN_ON));
break;
case '1': case '2': case '3': case '4':
case '5': case '6': case '7': case '8': case '9': case '&':
***************
*** 831,838 ****
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]);
--- 869,876 ----
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]);
***************
*** 903,910 ****
HV *basestash = gv_stashsv(*svp, FALSE);
if (!basestash) {
! if (dowarn)
! warn("No such package \"%_\" in @ISA assignment", *svp);
continue;
}
gvp = (GV**)hv_fetch(basestash, FIELDS, 6, FALSE);
--- 941,949 ----
HV *basestash = gv_stashsv(*svp, FALSE);
if (!basestash) {
! if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE,
! "No such package \"%_\" in @ISA assignment", *svp);
continue;
}
gvp = (GV**)hv_fetch(basestash, FIELDS, 6, FALSE);
***************
*** 1521,1526 ****
--- 1560,1580 ----
case '\001': /* ^A */
sv_setsv(bodytarget, sv);
break;
+ case '\002': /* ^B */
+ if ( ! (dowarn & G_WARN_ALL_MASK)) {
+ if (memEQ(SvPVX(sv), WARN_ALLstring, WARNsize))
+ compiling.cop_warnings = WARN_ALL;
+ else if (memEQ(SvPVX(sv), WARN_NONEstring, WARNsize))
+ compiling.cop_warnings = WARN_NONE;
+ else {
+ if (compiling.cop_warnings != WARN_NONE &&
+ compiling.cop_warnings != WARN_ALL)
+ sv_setsv(compiling.cop_warnings, sv);
+ else
+ compiling.cop_warnings = newSVsv(sv) ;
+ }
+ }
+ break;
case '\004': /* ^D */
debug = (SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv)) | 0x80000000;
DEBUG_x(dump_all());
***************
*** 1570,1576 ****
#endif
break;
case '\027': /* ^W */
! dowarn = (bool)(SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv));
break;
case '.':
if (localizing) {
--- 1624,1633 ----
#endif
break;
case '\027': /* ^W */
! if ( ! (dowarn & G_WARN_ALL_MASK)) {
! i = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
! dowarn = (i ? G_WARN_ON : G_WARN_OFF) ;
! }
break;
case '.':
if (localizing) {
***************
*** 1960,1967 ****
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], (gv ? GvENAME(gv)
: ((cv && CvGV(cv))
? GvENAME(CvGV(cv))
--- 2017,2024 ----
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], (gv ? GvENAME(gv)
: ((cv && CvGV(cv))
? GvENAME(CvGV(cv))
*** op.c.orig Fri May 15 14:59:42 1998
--- op.c Sat May 16 16:56:55 1998
***************
*** 118,124 ****
}
croak("Can't use global %s in \"my\"",name);
}
! if (dowarn && AvFILLp(comppad_name) >= 0) {
SV **svp = AvARRAY(comppad_name);
for (off = AvFILLp(comppad_name); off > comppad_name_floor; off--) {
if ((sv = svp[off])
--- 118,124 ----
}
croak("Can't use global %s in \"my\"",name);
}
! if (ckWARN(WARN_UNSAFE) && AvFILLp(comppad_name) >= 0) {
SV **svp = AvARRAY(comppad_name);
for (off = AvFILLp(comppad_name); off > comppad_name_floor; off--) {
if ((sv = svp[off])
***************
*** 126,132 ****
&& SvIVX(sv) == 999999999 /* var is in open scope */
&& strEQ(name, SvPVX(sv)))
{
! warn("\"my\" variable %s masks earlier declaration in same scope", name);
break;
}
}
--- 126,134 ----
&& SvIVX(sv) == 999999999 /* var is in open scope */
&& strEQ(name, SvPVX(sv)))
{
! warner(WARN_UNSAFE,
! "\"my\" variable %s masks earlier declaration in same scope",
! name);
break;
}
}
***************
*** 223,230 ****
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;
***************
*** 233,240 ****
}
}
else if (!CvUNIQUE(compcv)) {
! if (dowarn && !SvFAKE(sv) && !CvUNIQUE(cv))
! warn("Variable \"%s\" will not stay shared", name);
}
}
av_store(comppad, newoff, SvREFCNT_inc(oldsv));
--- 235,244 ----
}
}
else if (!CvUNIQUE(compcv)) {
! if (ckWARN(WARN_CLOSURE) && !SvFAKE(sv)
! && !CvUNIQUE(cv))
! warner(WARN_CLOSURE,
! "Variable \"%s\" will not stay shared", name);
}
}
av_store(comppad, newoff, SvREFCNT_inc(oldsv));
***************
*** 586,591 ****
--- 590,597 ----
case OP_DBSTATE:
Safefree(cCOPo->cop_label);
SvREFCNT_dec(cCOPo->cop_filegv);
+ if (cCOPo->cop_warnings != WARN_NONE && cCOPo->cop_warnings != WARN_ALL)
+ SvREFCNT_dec(cCOPo->cop_warnings);
break;
case OP_CONST:
SvREFCNT_dec(cSVOPo->op_sv);
***************
*** 667,680 ****
static OP *
scalarboolean(OP *o)
{
! if (dowarn &&
o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
dTHR;
line_t oldline = curcop->cop_line;
if (copline != NOLINE)
curcop->cop_line = copline;
! warn("Found = in conditional, should be ==");
curcop->cop_line = oldline;
}
return scalar(o);
--- 673,686 ----
static OP *
scalarboolean(OP *o)
{
! if (ckWARN(WARN_SYNTAX) &&
o->op_type == OP_SASSIGN && cBINOPo->op_first->op_type == OP_CONST) {
dTHR;
line_t oldline = curcop->cop_line;
if (copline != NOLINE)
curcop->cop_line = copline;
! warner(WARN_SYNTAX, "Found = in conditional, should be ==");
curcop->cop_line = oldline;
}
return scalar(o);
***************
*** 857,863 ****
case OP_CONST:
sv = cSVOPo->op_sv;
! if (dowarn) {
useless = "a constant";
if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = 0;
--- 863,869 ----
case OP_CONST:
sv = cSVOPo->op_sv;
! if (ckWARN(WARN_VOID)) {
useless = "a constant";
if (SvNIOK(sv) && (SvNV(sv) == 0.0 || SvNV(sv) == 1.0))
useless = 0;
***************
*** 924,931 ****
}
break;
}
! if (useless && dowarn)
! warn("Useless use of %s in void context", useless);
return o;
}
--- 930,937 ----
}
break;
}
! if (useless && ckWARN(WARN_VOID))
! warner(WARN_VOID, "Useless use of %s in void context", useless);
return o;
}
***************
*** 1427,1444 ****
{
OP *o;
! if (dowarn &&
! (left->op_type == OP_RV2AV ||
! left->op_type == OP_RV2HV ||
! left->op_type == OP_PADAV ||
! left->op_type == OP_PADHV)) {
! char *desc = op_desc[(right->op_type == OP_SUBST ||
! right->op_type == OP_TRANS)
! ? right->op_type : OP_MATCH];
! char *sample = ((left->op_type == OP_RV2AV ||
! left->op_type == OP_PADAV)
! ? "@array" : "%hash");
! warn("Applying %s to %s will act on scalar(%s)", desc, sample, sample);
}
if (right->op_type == OP_MATCH ||
--- 1433,1452 ----
{
OP *o;
! if (ckWARN(WARN_UNSAFE) &&
! (left->op_type == OP_RV2AV ||
! left->op_type == OP_RV2HV ||
! left->op_type == OP_PADAV ||
! left->op_type == OP_PADHV)) {
! char *desc = op_desc[(right->op_type == OP_SUBST ||
! right->op_type == OP_TRANS)
! ? right->op_type : OP_MATCH];
! char *sample = ((left->op_type == OP_RV2AV ||
! left->op_type == OP_PADAV)
! ? "@array" : "%hash");
! warner(WARN_UNSAFE,
! "Applying %s to %s will act on scalar(%s)",
! desc, sample, sample);
}
if (right->op_type == OP_MATCH ||
***************
*** 1517,1522 ****
--- 1525,1536 ----
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;
}
***************
*** 1587,1597 ****
if (o->op_flags & OPf_PARENS)
list(o);
else {
! 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;
--- 1601,1612 ----
if (o->op_flags & OPf_PARENS)
list(o);
else {
! 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;
***************
*** 2564,2569 ****
--- 2579,2588 ----
}
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;
***************
*** 2644,2651 ****
}
}
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);
*firstp = Nullop;
--- 2663,2671 ----
}
}
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);
*firstp = Nullop;
***************
*** 2663,2669 ****
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;
--- 2683,2689 ----
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;
***************
*** 2686,2692 ****
if (warnop) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
! warn("Value of %s%s can be \"0\"; test with defined()",
op_desc[warnop],
((warnop == OP_READLINE || warnop == OP_GLOB)
? " construct" : "() operator"));
--- 2706,2713 ----
if (warnop) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
! warner(WARN_UNSAFE,
! "Value of %s%s can be \"0\"; test with defined()",
op_desc[warnop],
((warnop == OP_READLINE || warnop == OP_GLOB)
? " construct" : "() operator"));
***************
*** 3390,3403 ****
if (curstackinfo->si_type == SI_SORT && sortcop == CvSTART(cv))
croak("Can't redefine active sort subroutine %s", name);
const_sv = cv_const_sv(cv);
! if (const_sv || dowarn && !(CvGV(cv) && GvSTASH(CvGV(cv))
&& HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))),
"autouse"))) {
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);
--- 3411,3426 ----
if (curstackinfo->si_type == SI_SORT && sortcop == CvSTART(cv))
croak("Can't redefine active sort subroutine %s", name);
const_sv = cv_const_sv(cv);
! if (const_sv || ckWARN(WARN_REDEFINE)
! && !(CvGV(cv) && GvSTASH(CvGV(cv))
&& HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))),
"autouse"))) {
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);
***************
*** 3615,3626 ****
}
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
! if (dowarn && !(CvGV(cv) && GvSTASH(CvGV(cv))
&& HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
! warn("Subroutine %s redefined",name);
curcop->cop_line = oldline;
}
SvREFCNT_dec(cv);
--- 3638,3649 ----
}
else if (CvROOT(cv) || CvXSUB(cv) || GvASSUMECV(gv)) {
/* already defined (or promised) */
! if (ckWARN(WARN_REDEFINE) && !(CvGV(cv) && GvSTASH(CvGV(cv))
&& HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))), "autouse"))) {
line_t oldline = curcop->cop_line;
curcop->cop_line = copline;
! warner(WARN_REDEFINE, "Subroutine %s redefined",name);
curcop->cop_line = oldline;
}
SvREFCNT_dec(cv);
***************
*** 3695,3705 ****
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);
--- 3718,3728 ----
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);
***************
*** 4167,4174 ****
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;
--- 4190,4198 ----
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;
***************
*** 4185,4192 ****
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;
--- 4209,4217 ----
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;
***************
*** 4932,4938 ****
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_EXIT &&
o->op_next->op_sibling->op_type != OP_WARN &&
--- 4957,4963 ----
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_EXIT &&
o->op_next->op_sibling->op_type != OP_WARN &&
***************
*** 4940,4947 ****
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;
}
}
--- 4965,4972 ----
line_t oldline = curcop->cop_line;
curcop->cop_line = ((COP*)o->op_next)->cop_line;
! warner(WARN_SYNTAX, "Statement unlikely to be reached");
! warner(WARN_SYNTAX, "(Maybe you meant system() when you said exec()?)\n");
curcop->cop_line = oldline;
}
}
*** op.h.orig Fri May 15 14:59:43 1998
--- op.h Sat May 16 16:56:55 1998
***************
*** 119,124 ****
--- 119,125 ----
#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 May 15 16:07:56 1998
--- perl.c Sat May 16 16:56:55 1998
***************
*** 385,391 ****
minus_a = FALSE;
minus_F = FALSE;
doswitches = FALSE;
! dowarn = FALSE;
doextract = FALSE;
sawampersand = FALSE; /* must save all match strings */
sawstudy = FALSE; /* do fbm_instr on all strings */
--- 385,391 ----
minus_a = FALSE;
minus_F = FALSE;
doswitches = FALSE;
! dowarn = G_WARN_OFF ;
doextract = FALSE;
sawampersand = FALSE; /* must save all match strings */
sawstudy = FALSE; /* do fbm_instr on all strings */
***************
*** 629,634 ****
--- 629,635 ----
time(&basetime);
oldscope = scopestack_ix;
+ dowarn = G_WARN_OFF ;
JMPENV_PUSH(ret);
switch (ret) {
***************
*** 686,691 ****
--- 687,694 ----
case 'u':
case 'U':
case 'v':
+ case 'W':
+ case 'X':
case 'w':
if (s = moreswitches(s))
goto reswitch;
***************
*** 971,977 ****
if (do_undump)
my_unexec();
! if (dowarn)
gv_check(defstash);
LEAVE;
--- 974,980 ----
if (do_undump)
my_unexec();
! if (ckWARN(WARN_ONCE))
gv_check(defstash);
LEAVE;
***************
*** 1708,1714 ****
Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
PerlProc_exit(0);
case 'w':
! dowarn = TRUE;
s++;
return s;
case '*':
--- 1711,1728 ----
Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
PerlProc_exit(0);
case 'w':
! if (! (dowarn & G_WARN_ALL_MASK))
! dowarn |= G_WARN_ON;
! s++;
! return s;
! case 'W':
! dowarn = G_WARN_ALL_ON|G_WARN_ON;
! compiling.cop_warnings = WARN_ALL ;
! s++;
! return s;
! case 'X':
! dowarn = G_WARN_ALL_OFF;
! compiling.cop_warnings = WARN_NONE ;
s++;
return s;
case '*':
*** perl.h.orig Fri May 15 16:07:56 1998
--- perl.h Sat May 16 16:56:55 1998
***************
*** 1124,1129 ****
--- 1124,1130 ----
#include "hv.h"
#include "mg.h"
#include "scope.h"
+ #include "warning.h"
#include "bytecode.h"
#include "byterun.h"
*** pp.c.orig Fri May 15 15:00:31 1998
--- pp.c Sat May 16 16:56:55 1998
***************
*** 232,239 ****
if (op->op_flags & OPf_REF ||
op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "a symbol");
! if (dowarn)
! warn(warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, na);
--- 232,239 ----
if (op->op_flags & OPf_REF ||
op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "a symbol");
! if (ckWARN(WARN_UNINITIALIZED))
! warner(WARN_UNINITIALIZED, warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, na);
***************
*** 276,283 ****
if (op->op_flags & OPf_REF ||
op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "a SCALAR");
! if (dowarn)
! warn(warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, na);
--- 276,283 ----
if (op->op_flags & OPf_REF ||
op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "a SCALAR");
! if (ckWARN(WARN_UNINITIALIZED))
! warner(WARN_UNINITIALIZED, warn_uninit);
RETSETUNDEF;
}
sym = SvPV(sv, na);
***************
*** 515,522 ****
SV *ssv = POPs;
STRLEN len;
char *ptr = SvPV(ssv,len);
! if (dowarn && len == 0)
! warn("Explicit blessing to '' (assuming package main)");
stash = gv_stashpvn(ptr, len, TRUE);
}
--- 515,523 ----
SV *ssv = POPs;
STRLEN len;
char *ptr = SvPV(ssv,len);
! if (ckWARN(WARN_UNSAFE) && len == 0)
! warner(WARN_UNSAFE,
! "Explicit blessing to '' (assuming package main)");
stash = gv_stashpvn(ptr, len, TRUE);
}
***************
*** 1858,1865 ****
rem -= pos;
}
if (fail < 0) {
! if (dowarn || lvalue || repl)
! warn("substr outside of string");
RETPUSHUNDEF;
}
else {
--- 1859,1866 ----
rem -= pos;
}
if (fail < 0) {
! if (ckWARN(WARN_SUBSTR) || lvalue || repl)
! warner(WARN_SUBSTR, "substr outside of string");
RETPUSHUNDEF;
}
else {
***************
*** 1869,1876 ****
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);
--- 1870,1878 ----
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);
***************
*** 2541,2548 ****
SV *val = NEWSV(46, 0);
if (MARK < SP)
sv_setsv(val, *++MARK);
! else if (dowarn)
! warn("Odd number of elements in hash assignment");
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
--- 2543,2550 ----
SV *val = NEWSV(46, 0);
if (MARK < SP)
sv_setsv(val, *++MARK);
! else if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
(void)hv_store_ent(hv,key,val,0);
}
SP = ORIGMARK;
***************
*** 2986,2993 ****
default:
croak("Invalid type in unpack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
! if (commas++ == 0 && dowarn)
! warn("Invalid type in unpack: '%c'", (int)datumtype);
break;
case '%':
if (len == 1 && pat[-1] != '1')
--- 2988,2995 ----
default:
croak("Invalid type in unpack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
! if (commas++ == 0 && ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Invalid type in unpack: '%c'", (int)datumtype);
break;
case '%':
if (len == 1 && pat[-1] != '1')
***************
*** 3768,3775 ****
default:
croak("Invalid type in pack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
! if (commas++ == 0 && dowarn)
! warn("Invalid type in pack: '%c'", (int)datumtype);
break;
case '%':
DIE("%% may only be used in unpack");
--- 3770,3777 ----
default:
croak("Invalid type in pack: '%c'", (int)datumtype);
case ',': /* grandfather in commas but with a warning */
! if (commas++ == 0 && ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Invalid type in pack: '%c'", (int)datumtype);
break;
case '%':
DIE("%% may only be used in unpack");
***************
*** 4141,4148 ****
* of pack() (and all copies of the result) are
* gone.
*/
! if (dowarn && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
! warn("Attempt to pack pointer to temporary value");
if (SvPOK(fromstr) || SvNIOK(fromstr))
aptr = SvPV(fromstr,na);
else
--- 4143,4151 ----
* of pack() (and all copies of the result) are
* gone.
*/
! if (ckWARN(WARN_UNSAFE) && (SvTEMP(fromstr) || SvPADTMP(fromstr)))
! warner(WARN_UNSAFE,
! "Attempt to pack pointer to temporary value");
if (SvPOK(fromstr) || SvNIOK(fromstr))
aptr = SvPV(fromstr,na);
else
*** pp_ctl.c.orig Fri May 15 15:00:33 1998
--- pp_ctl.c Sat May 16 16:56:55 1998
***************
*** 331,338 ****
sv = *++MARK;
else {
sv = &sv_no;
! if (dowarn)
! warn("Not enough format arguments");
}
break;
--- 331,338 ----
sv = *++MARK;
else {
sv = &sv_no;
! if (ckWARN(WARN_SYNTAX))
! warner(WARN_SYNTAX, "Not enough format arguments");
}
break;
***************
*** 868,887 ****
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 ||
--- 868,891 ----
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 ||
***************
*** 975,994 ****
cx = &cxstack[i];
switch (cx->cx_type) {
case CXt_SUBST:
! if (dowarn)
! warn("Exiting substitution via %s", op_name[op->op_type]);
break;
case CXt_SUB:
! if (dowarn)
! warn("Exiting subroutine via %s", op_name[op->op_type]);
break;
case CXt_EVAL:
! if (dowarn)
! warn("Exiting eval via %s", op_name[op->op_type]);
break;
case CXt_NULL:
! if (dowarn)
! warn("Exiting pseudo-block via %s", op_name[op->op_type]);
return -1;
case CXt_LOOP:
DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
--- 979,1002 ----
cx = &cxstack[i];
switch (cx->cx_type) {
case CXt_SUBST:
! if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Exiting substitution via %s",
! op_name[op->op_type]);
break;
case CXt_SUB:
! if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Exiting subroutine via %s",
! op_name[op->op_type]);
break;
case CXt_EVAL:
! if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Exiting eval via %s",
! op_name[op->op_type]);
break;
case CXt_NULL:
! if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Exiting pseudo-block via %s",
! op_name[op->op_type]);
return -1;
case CXt_LOOP:
DEBUG_l( deb("(Found loop #%ld)\n", (long)i));
***************
*** 1786,1792 ****
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
! if (CvDEPTH(cv) == 100 && dowarn)
sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILLp(padlist)) {
AV *newpad = newAV();
--- 1794,1800 ----
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
! if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION))
sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILLp(padlist)) {
AV *newpad = newAV();
***************
*** 2498,2503 ****
--- 2506,2513 ----
SAVEFREEPV(name);
SAVEI32(hints);
hints = 0;
+ SAVEPPTR(compiling.cop_warnings);
+ compiling.cop_warnings = ((dowarn & G_WARN_ALL_ON) ? WARN_ALL : WARN_NONE) ;
/* switch to eval mode */
***************
*** 2558,2563 ****
--- 2568,2578 ----
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 May 15 15:00:34 1998
--- pp_hot.c Sat May 16 16:56:55 1998
***************
*** 322,344 ****
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;
--- 322,346 ----
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;
***************
*** 425,432 ****
if (op->op_flags & OPf_REF ||
op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "an ARRAY");
! if (dowarn)
! warn(warn_uninit);
if (GIMME == G_ARRAY)
RETURN;
RETPUSHUNDEF;
--- 427,434 ----
if (op->op_flags & OPf_REF ||
op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "an ARRAY");
! if (ckWARN(WARN_UNINITIALIZED))
! warner(WARN_UNINITIALIZED, warn_uninit);
if (GIMME == G_ARRAY)
RETURN;
RETPUSHUNDEF;
***************
*** 509,516 ****
if (op->op_flags & OPf_REF ||
op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "a HASH");
! if (dowarn)
! warn(warn_uninit);
if (GIMME == G_ARRAY) {
SP--;
RETURN;
--- 511,518 ----
if (op->op_flags & OPf_REF ||
op->op_private & HINT_STRICT_REFS)
DIE(no_usym, "a HASH");
! if (ckWARN(WARN_UNINITIALIZED))
! warner(WARN_UNINITIALIZED, warn_uninit);
if (GIMME == G_ARRAY) {
SP--;
RETURN;
***************
*** 645,658 ****
}
TAINT_NOT;
}
! if (relem == lastrelem && dowarn) {
if (relem == firstrelem &&
SvROK(*relem) &&
( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
! warn("Reference found where even-sized list expected");
else
! warn("Odd number of elements in hash assignment");
}
}
break;
--- 647,660 ----
}
TAINT_NOT;
}
! if (relem == lastrelem && ckWARN(WARN_UNSAFE)) {
if (relem == firstrelem &&
SvROK(*relem) &&
( SvTYPE(SvRV(*relem)) == SVt_PVAV ||
SvTYPE(SvRV(*relem)) == SVt_PVHV ) )
! warner(WARN_UNSAFE, "Reference found where even-sized list expected");
else
! warner(WARN_UNSAFE, "Odd number of elements in hash assignment");
}
}
break;
***************
*** 1168,1175 ****
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;
--- 1170,1178 ----
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;
***************
*** 2131,2137 ****
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
! if (CvDEPTH(cv) == 100 && dowarn
&& !(PERLDB_SUB && cv == GvCV(DBsub)))
sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILLp(padlist)) {
--- 2134,2140 ----
if (CvDEPTH(cv) < 2)
(void)SvREFCNT_inc(cv);
else { /* save temporaries on recursion? */
! if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
&& !(PERLDB_SUB && cv == GvCV(DBsub)))
sub_crush_depth(cv);
if (CvDEPTH(cv) > AvFILLp(padlist)) {
***************
*** 2245,2255 ****
sub_crush_depth(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));
}
}
--- 2248,2259 ----
sub_crush_depth(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 May 15 15:00:35 1998
--- pp_sys.c Sat May 16 16:56:55 1998
***************
*** 571,577 ****
SV * sv ;
sv = POPs;
! if (dowarn) {
MAGIC * mg ;
if (SvMAGICAL(sv)) {
if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
--- 571,577 ----
SV * sv ;
sv = POPs;
! if (ckWARN(WARN_UNTIE)) {
MAGIC * mg ;
if (SvMAGICAL(sv)) {
if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV)
***************
*** 580,587 ****
mg = mg_find(sv, 'q') ;
if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
! warn("untie attempted while %lu inner references still exist",
! (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
}
}
--- 580,588 ----
mg = mg_find(sv, 'q') ;
if (mg && SvREFCNT(SvRV(mg->mg_obj)) > 1)
! warner(WARN_UNTIE,
! "untie attempted while %lu inner references still exist",
! (unsigned long)SvREFCNT(SvRV(mg->mg_obj)) - 1 ) ;
}
}
***************
*** 1041,1058 ****
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))
--- 1042,1059 ----
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))
***************
*** 1107,1126 ****
sv = NEWSV(0,0);
if (!(io = GvIO(gv))) {
! if (dowarn) {
gv_fullname3(sv, gv, Nullch);
! warn("Filehandle %s never opened", SvPV(sv,na));
}
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
! if (dowarn) {
gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
! warn("Filehandle %s opened only for input", SvPV(sv,na));
! else
! warn("printf on closed filehandle %s", SvPV(sv,na));
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
--- 1108,1129 ----
sv = NEWSV(0,0);
if (!(io = GvIO(gv))) {
! if (ckWARN(WARN_UNOPENED)) {
gv_fullname3(sv, gv, Nullch);
! warner(WARN_UNOPENED, "Filehandle %s never opened", SvPV(sv,na));
}
SETERRNO(EBADF,RMS$_IFI);
goto just_say_no;
}
else if (!(fp = IoOFP(io))) {
! if (ckWARN2(WARN_CLOSED,WARN_IO)) {
gv_fullname3(sv, gv, Nullch);
if (IoIFP(io))
! warner(WARN_IO, "Filehandle %s opened only for input",
! SvPV(sv,na));
! else if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "printf on closed filehandle %s",
! SvPV(sv,na));
}
SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
goto just_say_no;
***************
*** 1349,1359 ****
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) {
--- 1352,1362 ----
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) {
***************
*** 1737,1744 ****
RETPUSHUNDEF;
nuts:
! if (dowarn)
! warn("bind() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
--- 1740,1747 ----
RETPUSHUNDEF;
nuts:
! if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "bind() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
***************
*** 1767,1774 ****
RETPUSHUNDEF;
nuts:
! if (dowarn)
! warn("connect() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
--- 1770,1777 ----
RETPUSHUNDEF;
nuts:
! if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "connect() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
***************
*** 1793,1800 ****
RETPUSHUNDEF;
nuts:
! if (dowarn)
! warn("listen() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
--- 1796,1803 ----
RETPUSHUNDEF;
nuts:
! if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "listen() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
***************
*** 1847,1854 ****
RETURN;
nuts:
! if (dowarn)
! warn("accept() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
badexit:
--- 1850,1857 ----
RETURN;
nuts:
! if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "accept() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
badexit:
***************
*** 1874,1881 ****
RETURN;
nuts:
! if (dowarn)
! warn("shutdown() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
--- 1877,1884 ----
RETURN;
nuts:
! if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "shutdown() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
RETPUSHUNDEF;
#else
***************
*** 1952,1959 ****
RETURN;
nuts:
! if (dowarn)
! warn("[gs]etsockopt() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
--- 1955,1962 ----
RETURN;
nuts:
! if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "[gs]etsockopt() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
***************
*** 2025,2032 ****
RETURN;
nuts:
! if (dowarn)
! warn("get{sock, peer}name() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
--- 2028,2035 ----
RETURN;
nuts:
! if (ckWARN(WARN_CLOSED))
! warner(WARN_CLOSED, "get{sock, peer}name() on closed fd");
SETERRNO(EBADF,SS$_IVCHAN);
nuts2:
RETPUSHUNDEF;
***************
*** 2083,2090 ****
#endif
laststatval = PerlLIO_stat(SvPV(statname, na), &statcache);
if (laststatval < 0) {
! if (dowarn && strchr(SvPV(statname, na), '\n'))
! warn(warn_nl, "stat");
max = 0;
}
}
--- 2086,2093 ----
#endif
laststatval = PerlLIO_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;
}
}
***************
*** 2488,2495 ****
len = 512;
}
else {
! if (dowarn)
! warn("Test on unopened file <%s>",
GvENAME(cGVOP->op_gv));
SETERRNO(EBADF,RMS$_IFI);
RETPUSHUNDEF;
--- 2491,2498 ----
len = 512;
}
else {
! if (ckWARN(WARN_UNOPENED))
! warner(WARN_UNOPENED, "Test on unopened file <%s>",
GvENAME(cGVOP->op_gv));
SETERRNO(EBADF,RMS$_IFI);
RETPUSHUNDEF;
***************
*** 2507,2514 ****
i = PerlLIO_open(SvPV(sv, na), 0);
#endif
if (i < 0) {
! if (dowarn && strchr(SvPV(sv, na), '\n'))
! warn(warn_nl, "open");
RETPUSHUNDEF;
}
laststatval = PerlLIO_fstat(i, &statcache);
--- 2510,2517 ----
i = PerlLIO_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 = PerlLIO_fstat(i, &statcache);
*** proto.h.orig Fri May 15 15:00:37 1998
--- proto.h Sat May 16 16:56:55 1998
***************
*** 589,594 ****
--- 589,595 ----
void vivify_ref _((SV* sv, U32 to_what));
I32 wait4pid _((int pid, int* statusp, int flags));
void warn _((const char* pat,...));
+ void warner _((U32 err, const char* pat,...));
void watch _((char** addr));
I32 whichsig _((char* sig));
int yyerror _((char* s));
*** regcomp.c.orig Fri May 15 15:00:38 1998
--- regcomp.c Sat May 16 16:56:55 1998
***************
*** 439,447 ****
? (flags & ~SCF_DO_SUBSTR) : flags);
if (!scan) /* It was not CURLYX, but CURLY. */
scan = next;
! if (dowarn && (minnext + deltanext == 0)
&& !(data->flags & (SF_HAS_PAR|SF_IN_PAR)))
! warn("Strange *+?{} on zero-length expression");
min += minnext * mincount;
is_inf |= (maxcount == REG_INFTY && (minnext + deltanext) > 0
|| deltanext == I32_MAX);
--- 439,447 ----
? (flags & ~SCF_DO_SUBSTR) : flags);
if (!scan) /* It was not CURLYX, but CURLY. */
scan = next;
! if (ckWARN(WARN_UNSAFE) && (minnext + deltanext == 0)
&& !(data->flags & (SF_HAS_PAR|SF_IN_PAR)))
! warner(WARN_UNSAFE, "Strange *+?{} on zero-length expression");
min += minnext * mincount;
is_inf |= (maxcount == REG_INFTY && (minnext + deltanext) > 0
|| deltanext == I32_MAX);
***************
*** 1459,1466 ****
goto do_curly;
}
nest_check:
! if (dowarn && !SIZE_ONLY && !(flags&HASWIDTH) && max > 10000) {
! warn("%.*s matches null string many times",
regparse - origparse, origparse);
}
--- 1459,1466 ----
goto do_curly;
}
nest_check:
! if (ckWARN(WARN_UNSAFE) && !SIZE_ONLY && !(flags&HASWIDTH) && max > 10000) {
! warner(WARN_UNSAFE, "%.*s matches null string many times",
regparse - origparse, origparse);
}
***************
*** 1886,1893 ****
* (POSIX Extended Character Classes, that is)
* The text between e.g. [: and :] would start
* at posixccs + 1 and stop at regparse - 2. */
! if (dowarn && !SIZE_ONLY)
! warn("Character class syntax [%c %c] is reserved for future extensions", posixccc, posixccc);
regparse++; /* skip over the ending ] */
}
}
--- 1886,1894 ----
* (POSIX Extended Character Classes, that is)
* The text between e.g. [: and :] would start
* at posixccs + 1 and stop at regparse - 2. */
! if (ckWARN(WARN_UNSAFE) && !SIZE_ONLY)
! warner(WARN_UNSAFE,
! "Character class syntax [%c %c] is reserved for future extensions", posixccc, posixccc);
regparse++; /* skip over the ending ] */
}
}
*** regexec.c.orig Thu May 14 17:11:58 1998
--- regexec.c Sat May 16 16:56:55 1998
***************
*** 1178,1187 ****
regcc = cc;
if (n >= cc->max) { /* Maximum greed exceeded? */
! if (dowarn && n >= REG_INFTY
&& !(reg_flags & RF_warned)) {
reg_flags |= RF_warned;
! warn("count exceeded %d", REG_INFTY - 1);
}
sayNO;
}
--- 1178,1187 ----
regcc = cc;
if (n >= cc->max) { /* Maximum greed exceeded? */
! if (ckWARN(WARN_UNSAFE) && n >= REG_INFTY
&& !(reg_flags & RF_warned)) {
reg_flags |= RF_warned;
! warner(WARN_UNSAFE, "count exceeded %d", REG_INFTY - 1);
}
sayNO;
}
***************
*** 1227,1235 ****
PerlIO_printf(Perl_debug_log, "%*s failed, try continuation...\n", REPORT_CODE_OFF+regindent*2, "")
);
}
! if (dowarn && n >= REG_INFTY && !(reg_flags & RF_warned)) {
reg_flags |= RF_warned;
! warn("count exceeded %d", REG_INFTY - 1);
}
/* Failed deeper matches of scan, so see if this one works. */
--- 1227,1235 ----
PerlIO_printf(Perl_debug_log, "%*s failed, try continuation...\n", REPORT_CODE_OFF+regindent*2, "")
);
}
! if (ckWARN(WARN_UNSAFE) && n >= REG_INFTY && !(reg_flags & RF_warned)) {
reg_flags |= RF_warned;
! warner(WARN_UNSAFE, "count exceeded %d", REG_INFTY - 1);
}
/* Failed deeper matches of scan, so see if this one works. */
*** sv.c.orig Fri May 15 15:00:39 1998
--- sv.c Sat May 16 16:56:56 1998
***************
*** 1280,1289 ****
*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
--- 1280,1289 ----
*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
***************
*** 1304,1313 ****
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
if (!SvROK(sv)) {
! if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!localizing)
! warn(warn_uninit);
}
return 0;
}
--- 1304,1313 ----
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
if (!SvROK(sv)) {
! if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!localizing)
! warner(WARN_UNINITIALIZED, warn_uninit);
}
return 0;
}
***************
*** 1330,1337 ****
}
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
! if (dowarn)
! warn(warn_uninit);
return 0;
}
}
--- 1330,1337 ----
}
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
! if (ckWARN(WARN_UNINITIALIZED))
! warner(WARN_UNINITIALIZED, warn_uninit);
return 0;
}
}
***************
*** 1359,1366 ****
}
else {
dTHR;
! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
! warn(warn_uninit);
return 0;
}
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
--- 1359,1366 ----
}
else {
dTHR;
! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP))
! warner(WARN_UNINITIALIZED, warn_uninit);
return 0;
}
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
***************
*** 1382,1391 ****
if (SvPOKp(sv) && SvLEN(sv))
return asUV(sv);
if (!SvROK(sv)) {
! if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!localizing)
! warn(warn_uninit);
}
return 0;
}
--- 1382,1391 ----
if (SvPOKp(sv) && SvLEN(sv))
return asUV(sv);
if (!SvROK(sv)) {
! if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!localizing)
! warner(WARN_UNINITIALIZED, warn_uninit);
}
return 0;
}
***************
*** 1405,1412 ****
}
if (SvPOKp(sv) && SvLEN(sv))
return asUV(sv);
! if (dowarn)
! warn(warn_uninit);
return 0;
}
}
--- 1405,1412 ----
}
if (SvPOKp(sv) && SvLEN(sv))
return asUV(sv);
! if (ckWARN(WARN_UNINITIALIZED))
! warner(WARN_UNINITIALIZED, warn_uninit);
return 0;
}
}
***************
*** 1430,1439 ****
SvUVX(sv) = asUV(sv);
}
else {
! if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!localizing)
! warn(warn_uninit);
}
return 0;
}
--- 1430,1439 ----
SvUVX(sv) = asUV(sv);
}
else {
! if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!localizing)
! warner(WARN_UNINITIALIZED, warn_uninit);
}
return 0;
}
***************
*** 1452,1458 ****
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));
--- 1452,1458 ----
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));
***************
*** 1460,1469 ****
if (SvIOKp(sv))
return (double)SvIVX(sv);
if (!SvROK(sv)) {
! if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!localizing)
! warn(warn_uninit);
}
return 0;
}
--- 1460,1469 ----
if (SvIOKp(sv))
return (double)SvIVX(sv);
if (!SvROK(sv)) {
! if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!localizing)
! warner(WARN_UNINITIALIZED, warn_uninit);
}
return 0;
}
***************
*** 1479,1493 ****
}
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;
}
}
--- 1479,1493 ----
}
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;
}
}
***************
*** 1508,1522 ****
SvNVX(sv) = (double)SvIVX(sv);
}
else if (SvPOKp(sv) && SvLEN(sv)) {
! if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SET_NUMERIC_STANDARD();
SvNVX(sv) = atof(SvPVX(sv));
}
else {
dTHR;
! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
! warn(warn_uninit);
return 0.0;
}
SvNOK_on(sv);
--- 1508,1522 ----
SvNVX(sv) = (double)SvIVX(sv);
}
else if (SvPOKp(sv) && SvLEN(sv)) {
! if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
SET_NUMERIC_STANDARD();
SvNVX(sv) = atof(SvPVX(sv));
}
else {
dTHR;
! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP))
! warner(WARN_UNINITIALIZED, warn_uninit);
return 0.0;
}
SvNOK_on(sv);
***************
*** 1534,1540 ****
if (numtype == 1)
return atol(SvPVX(sv));
! if (!numtype && dowarn)
not_a_number(sv);
SET_NUMERIC_STANDARD();
d = atof(SvPVX(sv));
--- 1534,1540 ----
if (numtype == 1)
return atol(SvPVX(sv));
! if (!numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
SET_NUMERIC_STANDARD();
d = atof(SvPVX(sv));
***************
*** 1553,1559 ****
if (numtype == 1)
return strtoul(SvPVX(sv), Null(char**), 10);
#endif
! if (!numtype && dowarn)
not_a_number(sv);
SET_NUMERIC_STANDARD();
return U_V(atof(SvPVX(sv)));
--- 1553,1559 ----
if (numtype == 1)
return strtoul(SvPVX(sv), Null(char**), 10);
#endif
! if (!numtype && ckWARN(WARN_NUMERIC))
not_a_number(sv);
SET_NUMERIC_STANDARD();
return U_V(atof(SvPVX(sv)));
***************
*** 1668,1677 ****
goto tokensave;
}
if (!SvROK(sv)) {
! if (dowarn && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!localizing)
! warn(warn_uninit);
}
*lp = 0;
return "";
--- 1668,1677 ----
goto tokensave;
}
if (!SvROK(sv)) {
! if (ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (!localizing)
! warner(WARN_UNINITIALIZED, warn_uninit);
}
*lp = 0;
return "";
***************
*** 1730,1737 ****
tsv = Nullsv;
goto tokensave;
}
! if (dowarn)
! warn(warn_uninit);
*lp = 0;
return "";
}
--- 1730,1737 ----
tsv = Nullsv;
goto tokensave;
}
! if (ckWARN(WARN_UNINITIALIZED))
! warner(WARN_UNINITIALIZED, warn_uninit);
*lp = 0;
return "";
}
***************
*** 1778,1785 ****
}
else {
dTHR;
! if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
! warn(warn_uninit);
*lp = 0;
return "";
}
--- 1778,1785 ----
}
else {
dTHR;
! if (!localizing && ckWARN(WARN_UNINITIALIZED) && !(SvFLAGS(sv) & SVs_PADTMP))
! warner(WARN_UNINITIALIZED, warn_uninit);
*lp = 0;
return "";
}
***************
*** 2081,2092 ****
if (cv_const_sv(cv))
warn("Constant subroutine %s redefined",
GvENAME((GV*)dstr));
! else if (dowarn) {
if (!(CvGV(cv) && GvSTASH(CvGV(cv))
&& HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))),
"autouse")))
! warn("Subroutine %s redefined",
GvENAME((GV*)dstr));
}
}
--- 2081,2093 ----
if (cv_const_sv(cv))
warn("Constant subroutine %s redefined",
GvENAME((GV*)dstr));
! else if (ckWARN(WARN_REDEFINE)) {
if (!(CvGV(cv) && GvSTASH(CvGV(cv))
&& HvNAME(GvSTASH(CvGV(cv)))
&& strEQ(HvNAME(GvSTASH(CvGV(cv))),
"autouse")))
! warner(WARN_REDEFINE,
! "Subroutine %s redefined",
GvENAME((GV*)dstr));
}
}
***************
*** 2213,2220 ****
}
else {
if (dtype == SVt_PVGV) {
! if (dowarn)
! warn("Undefined value assigned to typeglob");
}
else
(void)SvOK_off(dstr);
--- 2214,2221 ----
}
else {
if (dtype == SVt_PVGV) {
! if (ckWARN(WARN_UNSAFE))
! warner(WARN_UNSAFE, "Undefined value assigned to typeglob");
}
else
(void)SvOK_off(dstr);
***************
*** 4752,4758 ****
default:
unknown:
! if (!args && dowarn &&
(op->op_type == OP_PRTF || op->op_type == OP_SPRINTF)) {
SV *msg = sv_newmortal();
sv_setpvf(msg, "Invalid conversion in %s: ",
--- 4753,4759 ----
default:
unknown:
! if (!args && ckWARN(WARN_PRINTF) &&
(op->op_type == OP_PRTF || op->op_type == OP_SPRINTF)) {
SV *msg = sv_newmortal();
sv_setpvf(msg, "Invalid conversion in %s: ",
***************
*** 4762,4768 ****
c & 0xFF);
else
sv_catpv(msg, "end of string");
! warn("%_", msg); /* yes, this is reentrant */
}
/* output mangled stuff ... */
--- 4763,4769 ----
c & 0xFF);
else
sv_catpv(msg, "end of string");
! warner(WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
}
/* output mangled stuff ... */
*** t/op/tie.t.orig Tue Nov 25 14:55:47 1997
--- t/op/tie.t Sat May 16 16:56:56 1998
***************
*** 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 Thu Mar 5 18:12:13 1998
--- t/pragma/warn-1global Sat May 16 16:56:56 1998
***************
*** 1,5 ****
--- 1,6 ----
Check existing $^W functionality
+
__END__
# warnable code, warnings disabled
***************
*** 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.
########
{
--- 111,134 ----
########
$^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.
########
{
***************
*** 147,151 ****
--- 150,186 ----
########
-w
-e undef
+ EXPECT
+ Use of uninitialized value at - line 2.
+ ########
+
+ $^W = 1 + 2 ;
+ EXPECT
+
+ ########
+
+ $^W = $a ;
+ EXPECT
+
+ ########
+
+ sub fred {}
+ $^W = fred() ;
+ EXPECT
+
+ ########
+
+ sub fred { my $b ; chop $b ;}
+ { local $^W = 0 ;
+ fred() ;
+ }
+ EXPECT
+
+ ########
+
+ sub fred { my $b ; chop $b ;}
+ { local $^W = 1 ;
+ fred() ;
+ }
EXPECT
Use of uninitialized value at - line 2.
*** /dev/null Tue Jan 1 04:00:00 1980
--- t/pragma/warn-2use Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,291 ----
+ Check lexical warning functionality
+
+ TODO
+ check that the warning hierarchy works.
+
+ __END__
+
+ # check illegal category is caught
+ use warning 'blah' ;
+ EXPECT
+ unknown warning category 'blah' at - line 3
+ BEGIN failed--compilation aborted at - line 3.
+ ########
+
+ # Check compile time scope of pragma
+ use warning 'deprecated' ;
+ {
+ no warning ;
+ 1 if $a EQ $b ;
+ }
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 8.
+ ########
+
+ # Check compile time scope of pragma
+ no warning;
+ {
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+ }
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 6.
+ ########
+
+ # Check runtime scope of pragma
+ use warning 'uninitialized' ;
+ {
+ no warning ;
+ my $b ; chop $b ;
+ }
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 8.
+ ########
+
+ # Check runtime scope of pragma
+ no warning ;
+ {
+ use warning 'uninitialized' ;
+ my $b ; chop $b ;
+ }
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 6.
+ ########
+
+ # Check runtime scope of pragma
+ no warning ;
+ {
+ use warning 'uninitialized' ;
+ $a = sub { my $b ; chop $b ; }
+ }
+ &$a ;
+ EXPECT
+ Use of uninitialized value at - line 6.
+ ########
+
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 3.
+ ########
+
+ --FILE-- abc
+ 1 if $a EQ $b ;
+ 1;
+ --FILE--
+ use warning 'deprecated' ;
+ require "./abc";
+ EXPECT
+
+ ########
+
+ --FILE-- abc
+ use warning 'deprecated' ;
+ 1;
+ --FILE--
+ require "./abc";
+ 1 if $a EQ $b ;
+ EXPECT
+
+ ########
+
+ --FILE-- abc
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+ 1;
+ --FILE--
+ use warning 'uninitialized' ;
+ require "./abc";
+ my $a ; chop $a ;
+ EXPECT
+ Use of EQ is deprecated at ./abc line 2.
+ Use of uninitialized value at - line 3.
+ ########
+
+ --FILE-- abc.pm
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+ 1;
+ --FILE--
+ use warning 'uninitialized' ;
+ use abc;
+ my $a ; chop $a ;
+ EXPECT
+ Use of EQ is deprecated at abc.pm line 2.
+ Use of uninitialized value at - line 3.
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval {
+ my $b ; chop $b ;
+ }; print STDERR $@ ;
+ my $b ; chop $b ;
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval {
+ use warning 'uninitialized' ;
+ my $b ; chop $b ;
+ }; print STDERR $@ ;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 6.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'uninitialized' ;
+ eval {
+ my $b ; chop $b ;
+ }; print STDERR $@ ;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 5.
+ Use of uninitialized value at - line 7.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'uninitialized' ;
+ eval {
+ no warning ;
+ my $b ; chop $b ;
+ }; print STDERR $@ ;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 8.
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval {
+ 1 if $a EQ $b ;
+ }; print STDERR $@ ;
+ 1 if $a EQ $b ;
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval {
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+ }; print STDERR $@ ;
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 6.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'deprecated' ;
+ eval {
+ 1 if $a EQ $b ;
+ }; print STDERR $@ ;
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 5.
+ Use of EQ is deprecated at - line 7.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'deprecated' ;
+ eval {
+ no warning ;
+ 1 if $a EQ $b ;
+ }; print STDERR $@ ;
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 8.
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval '
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval q[
+ use warning 'uninitialized' ;
+ my $b ; chop $b ;
+ ]; print STDERR $@;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at (eval 1) line 3.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'uninitialized' ;
+ eval '
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at (eval 1) line 2.
+ Use of uninitialized value at - line 7.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'uninitialized' ;
+ eval '
+ no warning ;
+ my $b ; chop $b ;
+ '; print STDERR $@ ;
+ my $b ; chop $b ;
+ EXPECT
+ Use of uninitialized value at - line 8.
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval '
+ 1 if $a EQ $b ;
+ '; print STDERR $@ ;
+ 1 if $a EQ $b ;
+ EXPECT
+
+ ########
+
+ # Check scope of pragma with eval
+ no warning ;
+ eval q[
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+ ]; print STDERR $@;
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at (eval 1) line 3.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'deprecated' ;
+ eval '
+ 1 if $a EQ $b ;
+ '; print STDERR $@;
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 7.
+ Use of EQ is deprecated at (eval 1) line 2.
+ ########
+
+ # Check scope of pragma with eval
+ use warning 'deprecated' ;
+ eval '
+ no warning ;
+ 1 if $a EQ $b ;
+ '; print STDERR $@;
+ 1 if $a EQ $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 8.
*** /dev/null Tue Jan 1 04:00:00 1980
--- t/pragma/warn-3both Sat May 16 16:56:56 1998
***************
*** 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 Tue Jan 1 04:00:00 1980
--- t/pragma/warn-4lint Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,112 ----
+ Check lint
+
+ __END__
+ -W
+ # lint: check compile time $^W is zapped
+ BEGIN { $^W = 0 ;}
+ $a = $b = 1 ;
+ $a = 1 if $a EQ $b ;
+ close STDIN ; print STDIN "abc" ;
+ EXPECT
+ Use of EQ is deprecated at - line 5.
+ print on closed filehandle main::STDIN at - line 6.
+ ########
+ -W
+ # lint: check runtime $^W is zapped
+ $^W = 0 ;
+ close STDIN ; print STDIN "abc" ;
+ EXPECT
+ print on closed filehandle main::STDIN at - line 4.
+ ########
+ -W
+ # lint: check runtime $^W is zapped
+ {
+ $^W = 0 ;
+ close STDIN ; print STDIN "abc" ;
+ }
+ EXPECT
+ print on closed filehandle main::STDIN at - line 5.
+ ########
+ -W
+ # lint: check "no warning" is zapped
+ no warning ;
+ $a = $b = 1 ;
+ $a = 1 if $a EQ $b ;
+ close STDIN ; print STDIN "abc" ;
+ EXPECT
+ Use of EQ is deprecated at - line 5.
+ print on closed filehandle main::STDIN at - line 6.
+ ########
+ -W
+ # lint: check "no warning" is zapped
+ {
+ no warning ;
+ close STDIN ; print STDIN "abc" ;
+ }
+ EXPECT
+ print on closed filehandle main::STDIN at - line 5.
+ ########
+ -Ww
+ # lint: check combination of -w and -W
+ {
+ $^W = 0 ;
+ close STDIN ; print STDIN "abc" ;
+ }
+ EXPECT
+ print on closed filehandle main::STDIN at - line 5.
+ ########
+ -W
+ --FILE-- abc.pm
+ no warning 'deprecated' ;
+ my ($a, $b) = (0,0);
+ 1 if $a EQ $b ;
+ 1;
+ --FILE--
+ no warning 'uninitialized' ;
+ use abc;
+ my $a ; chop $a ;
+ EXPECT
+ Use of EQ is deprecated at abc.pm line 3.
+ Use of uninitialized value at - line 3.
+ ########
+ -W
+ --FILE-- abc
+ no warning 'deprecated' ;
+ my ($a, $b) = (0,0);
+ 1 if $a EQ $b ;
+ 1;
+ --FILE--
+ no warning 'uninitialized' ;
+ require "./abc";
+ my $a ; chop $a ;
+ EXPECT
+ Use of EQ is deprecated at ./abc line 3.
+ Use of uninitialized value at - line 3.
+ ########
+ -W
+ --FILE-- abc.pm
+ BEGIN {$^W = 0}
+ my ($a, $b) = (0,0);
+ 1 if $a EQ $b ;
+ 1;
+ --FILE--
+ $^W = 0 ;
+ use abc;
+ my $a ; chop $a ;
+ EXPECT
+ Use of EQ is deprecated at abc.pm line 3.
+ Use of uninitialized value at - line 3.
+ ########
+ -W
+ --FILE-- abc
+ BEGIN {$^W = 0}
+ my ($a, $b) = (0,0);
+ 1 if $a EQ $b ;
+ 1;
+ --FILE--
+ $^W = 0 ;
+ require "./abc";
+ my $a ; chop $a ;
+ EXPECT
+ Use of EQ is deprecated at ./abc line 3.
+ Use of uninitialized value at - line 3.
*** /dev/null Tue Jan 1 04:00:00 1980
--- t/pragma/warn-5nolint Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,96 ----
+ Check anti-lint
+
+ __END__
+ -X
+ # nolint: check compile time $^W is zapped
+ BEGIN { $^W = 1 ;}
+ $a = $b = 1 ;
+ $a = 1 if $a EQ $b ;
+ close STDIN ; print STDIN "abc" ;
+ EXPECT
+ ########
+ -X
+ # nolint: check runtime $^W is zapped
+ $^W = 1 ;
+ close STDIN ; print STDIN "abc" ;
+ EXPECT
+ ########
+ -X
+ # nolint: check runtime $^W is zapped
+ {
+ $^W = 1 ;
+ close STDIN ; print STDIN "abc" ;
+ }
+ EXPECT
+ ########
+ -X
+ # nolint: check "no warning" is zapped
+ use warning ;
+ $a = $b = 1 ;
+ $a = 1 if $a EQ $b ;
+ close STDIN ; print STDIN "abc" ;
+ EXPECT
+ ########
+ -X
+ # nolint: check "no warning" is zapped
+ {
+ use warning ;
+ close STDIN ; print STDIN "abc" ;
+ }
+ EXPECT
+ ########
+ -Xw
+ # nolint: check combination of -w and -X
+ {
+ $^W = 1 ;
+ close STDIN ; print STDIN "abc" ;
+ }
+ EXPECT
+ ########
+ -X
+ --FILE-- abc.pm
+ use warning 'deprecated' ;
+ my ($a, $b) = (0,0);
+ 1 if $a EQ $b ;
+ 1;
+ --FILE--
+ use warning 'uninitialized' ;
+ use abc;
+ my $a ; chop $a ;
+ EXPECT
+ ########
+ -X
+ --FILE-- abc
+ use warning 'deprecated' ;
+ my ($a, $b) = (0,0);
+ 1 if $a EQ $b ;
+ 1;
+ --FILE--
+ use warning 'uninitialized' ;
+ require "./abc";
+ my $a ; chop $a ;
+ EXPECT
+ ########
+ -X
+ --FILE-- abc.pm
+ BEGIN {$^W = 1}
+ my ($a, $b) = (0,0);
+ 1 if $a EQ $b ;
+ 1;
+ --FILE--
+ $^W = 1 ;
+ use abc;
+ my $a ; chop $a ;
+ EXPECT
+ ########
+ -X
+ --FILE-- abc
+ BEGIN {$^W = 1}
+ my ($a, $b) = (0,0);
+ 1 if $a EQ $b ;
+ 1;
+ --FILE--
+ $^W = 1 ;
+ require "./abc";
+ my $a ; chop $a ;
+ EXPECT
*** /dev/null Tue Jan 1 04:00:00 1980
--- t/pragma/warn-doio Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,94 ----
+ doio.c AOK
+
+ Can't do bidirectional pipe
+ open(F, "| true |");
+
+ warn(warn_nl, "open");
+ open(F, "true\ncd")
+
+ Close on unopened file <%s>
+ $a = "fred";close($a)
+
+ tell() on unopened file
+ $a = "fred";$a = tell($a)
+
+ seek() on unopened file
+ $a = "fred";$a = seek($a,1,1)
+
+ sysseek() on unopened file
+ $a = "fred";$a = seek($a,1,1)
+
+ warn(warn_uninit);
+ print $a ;
+
+ Stat on unopened file <%s>
+ close STDIN ; -x STDIN ;
+
+ warn(warn_nl, "stat");
+ stat "ab\ncd"
+
+ warn(warn_nl, "lstat");
+ lstat "ab\ncd"
+
+ Can't exec \"%s\": %s
+
+ Can't exec \"%s\": %s
+
+
+ __END__
+ # doio.c
+ use warning 'io' ;
+ open(F, "|true|")
+ EXPECT
+ Can't do bidirectional pipe at - line 3.
+ ########
+ # doio.c
+ use warning 'io' ;
+ open(F, "<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);
+ $a = sysseek(STDIN,1,1);
+ -x STDIN ;
+ EXPECT
+ tell() on unopened file at - line 4.
+ seek() on unopened file at - line 5.
+ sysseek() on unopened file at - line 6.
+ Stat on unopened file <STDIN> at - line 7.
+ ########
+ # doio.c
+ use warning 'uninitialized' ;
+ print $a ;
+ EXPECT
+ Use of uninitialized value at - line 3.
+ ########
+ # doio.c
+ use warning 'io' ;
+
+ EXPECT
+
+ ########
+ # doio.c
+ use warning 'io' ;
+ stat "ab\ncd";
+ lstat "ab\ncd";
+ EXPECT
+ Unsuccessful stat on filename containing newline at - line 3.
+ Unsuccessful stat on filename containing newline at - line 4.
+ ########
+ # doio.c
+ use warning 'io' ;
+ exec "lskdjfalksdjfdjfkls" ;
+ EXPECT
+ Can't exec "lskdjfalksdjfdjfkls": No such file or directory at - line 3.
+ ########
+ # doio.c
+ use warning 'io' ;
+ exec "lskdjfalksdjfdjfkls", "abc" ;
+ EXPECT
+ Can't exec "lskdjfalksdjfdjfkls": No such file or directory at - line 3.
*** /dev/null Tue Jan 1 04:00:00 1980
--- t/pragma/warn-gv Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,40 ----
+ gv.c AOK
+
+ Can't locate package %s for @%s::ISA
+ @ISA = qw(Fred); joe()
+
+ Use of inherited AUTOLOAD for non-method %s::%.*s() is deprecated
+ sub Other::AUTOLOAD { 1 } sub Other::fred {}
+ @ISA = qw(Other) ;
+ fred() ;
+
+ Use of $# is deprecated
+ Use of $* is deprecated
+
+ $a = ${"#"} ;
+ $a = ${"*"} ;
+
+
+ __END__
+ # gv.c
+ use warning 'misc' ;
+ @ISA = qw(Fred); joe()
+ EXPECT
+ Can't locate package Fred for @main::ISA at - line 3.
+ Undefined subroutine &main::joe called at - line 3.
+ ########
+ # gv.c
+ sub Other::AUTOLOAD { 1 } sub Other::fred {}
+ @ISA = qw(Other) ;
+ use warning 'deprecated' ;
+ fred() ;
+ EXPECT
+ Use of inherited AUTOLOAD for non-method main::fred() is deprecated at - line 5.
+ ########
+ # gv.c
+ use warning 'deprecated' ;
+ $a = ${"#"};
+ $a = ${"*"};
+ EXPECT
+ Use of $# is deprecated at - line 3.
+ Use of $* is deprecated at - line 4.
*** /dev/null Tue Jan 1 04:00:00 1980
--- t/pragma/warn-mg Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,30 ----
+ mg.c AOK
+
+ No such signal: SIG%s
+ $SIG{FRED} = sub {}
+
+ No such package "%_" in @ISA assignment
+ @ISA = 'fred' ;
+
+ 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 'unsafe' ;
+ @ISA = 'fred' ;
+ EXPECT
+ No such package "fred" in @ISA assignment at - line 3.
+ ########
+ # mg.c
+ use warning 'signal' ;
+ $SIG{"INT"} = "fred"; kill "INT",$$;
+ EXPECT
+ SIGINT handler "fred" not defined.
*** /dev/null Tue Jan 1 04:00:00 1980
--- t/pragma/warn-op Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,535 ----
+ op.c AOK
+
+ "my" variable %s masks earlier declaration in same scope
+ my $x;
+ my $x ;
+
+ Variable "%s" may be unavailable
+ sub x {
+ my $x;
+ sub y {
+ $x
+ }
+ }
+
+ Variable "%s" will not stay shared
+ sub x {
+ my $x;
+ sub y {
+ sub { $x }
+ }
+ }
+
+ Found = in conditional, should be ==
+ 1 if $a = 1 ;
+
+ Use of implicit split to @_ is deprecated
+ split ;
+
+ Use of implicit split to @_ is deprecated
+ $a = split ;
+
+ Useless use of time in void context
+ Useless use of a variable in void context
+ Useless use of a constant in void context
+ time ;
+ $a ;
+ "abc"
+
+ Applying %s to %s will act on scalar(%s)
+ my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
+ @a =~ /abc/ ;
+ @a =~ s/a/b/ ;
+ @a =~ tr/a/b/ ;
+ @$b =~ /abc/ ;
+ @$b =~ s/a/b/ ;
+ @$b =~ tr/a/b/ ;
+ %a =~ /abc/ ;
+ %a =~ s/a/b/ ;
+ %a =~ tr/a/b/ ;
+ %$c =~ /abc/ ;
+ %$c =~ s/a/b/ ;
+ %$c =~ tr/a/b/ ;
+
+
+ Parens missing around "my" list at -e line 1.
+ my $a, $b = (1,2);
+
+ Parens missing around "local" list at -e line 1.
+ local $a, $b = (1,2);
+
+ Probable precedence problem on logical or at -e line 1.
+ use warning 'syntax'; my $x = print(ABC || 1);
+
+ Value of %s may be \"0\"; use \"defined\"
+ $x = 1 if $x = <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' ;
+ my $x ;
+ my $x ;
+ EXPECT
+ "my" variable $x masks earlier declaration in same scope at - line 4.
+ ########
+ # op.c
+ use warning 'unsafe' ;
+ sub x {
+ my $x;
+ sub y {
+ $x
+ }
+ }
+ EXPECT
+ Variable "$x" will not stay shared at - line 7.
+ ########
+ # op.c
+ use warning 'unsafe' ;
+ sub x {
+ my $x;
+ sub y {
+ sub { $x }
+ }
+ }
+ EXPECT
+ Variable "$x" may be unavailable at - line 6.
+ ########
+ # op.c
+ use warning 'syntax' ;
+ 1 if $a = 1 ;
+ EXPECT
+ Found = in conditional, should be == at - line 3.
+ ########
+ # op.c
+ use warning 'deprecated' ;
+ split ;
+ EXPECT
+ Use of implicit split to @_ is deprecated at - line 3.
+ ########
+ # op.c
+ use warning 'deprecated' ;
+ $a = split ;
+ EXPECT
+ Use of implicit split to @_ is deprecated at - line 3.
+ ########
+ # op.c
+ use warning 'void' ; close STDIN ;
+ 1 x 3 ; # OP_REPEAT
+ # OP_GVSV
+ wantarray ; # OP_WANTARRAY
+ # OP_GV
+ # OP_PADSV
+ # OP_PADAV
+ # OP_PADHV
+ # OP_PADANY
+ # OP_AV2ARYLEN
+ ref ; # OP_REF
+ \@a ; # OP_REFGEN
+ \$a ; # OP_SREFGEN
+ defined $a ; # OP_DEFINED
+ hex $a ; # OP_HEX
+ oct $a ; # OP_OCT
+ length $a ; # OP_LENGTH
+ substr $a,1 ; # OP_SUBSTR
+ vec $a,1,2 ; # OP_VEC
+ index $a,1,2 ; # OP_INDEX
+ rindex $a,1,2 ; # OP_RINDEX
+ sprintf $a ; # OP_SPRINTF
+ $a[0] ; # OP_AELEM
+ # OP_AELEMFAST
+ @a[0] ; # OP_ASLICE
+ #values %a ; # OP_VALUES
+ #keys %a ; # OP_KEYS
+ $a{0} ; # OP_HELEM
+ @a{0} ; # OP_HSLICE
+ unpack "a", "a" ; # OP_UNPACK
+ pack $a,"" ; # OP_PACK
+ join "" ; # OP_JOIN
+ (@a)[0,1] ; # OP_LSLICE
+ # OP_ANONLIST
+ # OP_ANONHASH
+ sort(1,2) ; # OP_SORT
+ reverse(1,2) ; # OP_REVERSE
+ # OP_RANGE
+ # OP_FLIP
+ (1 ..2) ; # OP_FLOP
+ caller ; # OP_CALLER
+ fileno STDIN ; # OP_FILENO
+ eof STDIN ; # OP_EOF
+ tell STDIN ; # OP_TELL
+ readlink 1; # OP_READLINK
+ time ; # OP_TIME
+ localtime ; # OP_LOCALTIME
+ gmtime ; # OP_GMTIME
+ getgrnam 1; # OP_GGRNAM
+ getgrgid 1 ; # OP_GGRGID
+ getpwnam 1; # OP_GPWNAM
+ getpwuid 1; # OP_GPWUID
+ EXPECT
+ Useless use of repeat in void context at - line 3.
+ Useless use of wantarray in void context at - line 5.
+ Useless use of reference-type operator in void context at - line 12.
+ Useless use of reference constructor in void context at - line 13.
+ Useless use of scalar ref constructor in void context at - line 14.
+ Useless use of defined operator in void context at - line 15.
+ Useless use of hex in void context at - line 16.
+ Useless use of oct in void context at - line 17.
+ Useless use of length in void context at - line 18.
+ Useless use of substr in void context at - line 19.
+ Useless use of vec in void context at - line 20.
+ Useless use of index in void context at - line 21.
+ Useless use of rindex in void context at - line 22.
+ Useless use of sprintf in void context at - line 23.
+ Useless use of array element in void context at - line 24.
+ Useless use of array slice in void context at - line 26.
+ Useless use of hash elem in void context at - line 29.
+ Useless use of hash slice in void context at - line 30.
+ Useless use of unpack in void context at - line 31.
+ Useless use of pack in void context at - line 32.
+ Useless use of join in void context at - line 33.
+ Useless use of list slice in void context at - line 34.
+ Useless use of sort in void context at - line 37.
+ Useless use of reverse in void context at - line 38.
+ Useless use of range (or flop) in void context at - line 41.
+ Useless use of caller in void context at - line 42.
+ Useless use of fileno in void context at - line 43.
+ Useless use of eof in void context at - line 44.
+ Useless use of tell in void context at - line 45.
+ Useless use of readlink in void context at - line 46.
+ Useless use of time in void context at - line 47.
+ Useless use of localtime in void context at - line 48.
+ Useless use of gmtime in void context at - line 49.
+ Useless use of getgrnam in void context at - line 50.
+ Useless use of getgrgid in void context at - line 51.
+ Useless use of getpwnam in void context at - line 52.
+ Useless use of getpwuid in void context at - line 53.
+ ########
+ # op.c
+ use warning 'void' ;
+ use Config ;
+ BEGIN {
+ if ( ! $Config{d_telldir}) {
+ print <<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 'unsafe' ;
+ my $a ; my @a = () ; my %a = () ; my $b = \@a ; my $c = \%a ;
+ @a =~ /abc/ ;
+ @a =~ s/a/b/ ;
+ @a =~ tr/a/b/ ;
+ @$b =~ /abc/ ;
+ @$b =~ s/a/b/ ;
+ @$b =~ tr/a/b/ ;
+ %a =~ /abc/ ;
+ %a =~ s/a/b/ ;
+ %a =~ tr/a/b/ ;
+ %$c =~ /abc/ ;
+ %$c =~ s/a/b/ ;
+ %$c =~ tr/a/b/ ;
+ EXPECT
+ Applying pattern match to @array will act on scalar(@array) at - line 4.
+ Applying substitution to @array will act on scalar(@array) at - line 5.
+ Can't modify private array in substitution at - line 5, near "s/a/b/ ;"
+ Applying character translation to @array will act on scalar(@array) at - line 6.
+ Applying pattern match to @array will act on scalar(@array) at - line 7.
+ Applying substitution to @array will act on scalar(@array) at - line 8.
+ Applying character translation to @array will act on scalar(@array) at - line 9.
+ Applying pattern match to %hash will act on scalar(%hash) at - line 10.
+ Applying substitution to %hash will act on scalar(%hash) at - line 11.
+ Applying character translation to %hash will act on scalar(%hash) at - line 12.
+ Applying pattern match to %hash will act on scalar(%hash) at - line 13.
+ Applying substitution to %hash will act on scalar(%hash) at - line 14.
+ Applying character translation to %hash will act on scalar(%hash) at - line 15.
+ Execution of - aborted due to compilation errors.
+ ########
+ # 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.
+ ########
+ # op.c
+ use warning 'unsafe' ;
+ opendir FH, "." ;
+ $x = 1 if $x = readdir FH ;
+ closedir FH ;
+ EXPECT
+ Value of readdir() operator can be "0"; test with defined() at - line 4.
+ ########
+ # op.c
+ use warning 'unsafe' ;
+ $x = 1 if $x = <*> ;
+ EXPECT
+ Value of glob construct can be "0"; test with defined() at - line 3.
+ ########
+ # op.c
+ use warning 'unsafe' ;
+ %a = (1,2,3,4) ;
+ $x = 1 if $x = each %a ;
+ EXPECT
+ Value of each() operator can be "0"; test with defined() at - line 4.
+ ########
+ # op.c
+ use warning 'unsafe' ;
+ $x = 1 while $x = <*> and 0 ;
+ EXPECT
+ Value of glob construct can be "0"; test with defined() at - line 3.
+ ########
+ # op.c
+ use warning 'unsafe' ;
+ opendir FH, "." ;
+ $x = 1 while $x = readdir FH and 0 ;
+ closedir FH ;
+ EXPECT
+ Value of readdir() operator can be "0"; test with defined() at - line 4.
+ ########
+ # op.c
+ use warning 'redefine' ;
+ sub fred {}
+ sub fred {}
+ EXPECT
+ Subroutine fred redefined at - line 4.
+ ########
+ # op.c
+ use warning 'redefine' ;
+ sub fred () { 1 }
+ sub fred () { 1 }
+ EXPECT
+ Constant subroutine fred redefined at - line 4.
+ ########
+ # op.c
+ use warning 'redefine' ;
+ format FRED =
+ .
+ format FRED =
+ .
+ EXPECT
+ Format FRED redefined at - line 5.
+ ########
+ # op.c
+ use warning 'syntax' ;
+ push FRED;
+ EXPECT
+ Array @FRED missing the @ in argument 1 of push() at - line 3.
+ ########
+ # op.c
+ use warning 'syntax' ;
+ @a = keys FRED ;
+ EXPECT
+ Hash %FRED missing the % in argument 1 of keys() at - line 3.
+ ########
+ # op.c
+ use warning 'syntax' ;
+ exec "true" ;
+ my $a
+ EXPECT
+ Statement unlikely to be reached at - line 4.
+ (Maybe you meant system() when you said exec()?)
*** /dev/null Tue Jan 1 04:00:00 1980
--- t/pragma/warn-perl Sat May 16 16:56:56 1998
***************
*** 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 Tue Jan 1 04:00:00 1980
--- t/pragma/warn-perly Sat May 16 16:56:56 1998
***************
*** 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 Tue Jan 1 04:00:00 1980
--- t/pragma/warn-pp Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,82 ----
+ pp.c TODO
+
+ substr outside of string
+ $a = "ab" ; $a = substr($a, 4,5)
+
+ Attempt to use reference as lvalue in substr
+ $a = "ab" ; $b = \$a ; substr($b, 1,1) = $b
+
+ uninitialized in pp_rv2gv()
+ my *b = *{ undef()}
+
+ uninitialized in pp_rv2sv()
+ my $a = undef ; my $b = $$a
+
+ Odd number of elements in hash list
+ my $a = { 1,2,3 } ;
+
+ Invalid type in unpack: '%c
+ my $A = pack ("A,A", 1,2) ;
+ my @A = unpack ("A,A", "22") ;
+
+ Attempt to pack pointer to temporary value
+ pack("p", "abc") ;
+
+ Explicit blessing to '' (assuming package main)
+ bless \[], "";
+
+ __END__
+ # pp.c
+ use warning 'substr' ;
+ $a = "ab" ;
+ $a = substr($a, 4,5)
+ EXPECT
+ substr outside of string at - line 4.
+ ########
+ # pp.c
+ use warning 'substr' ;
+ $a = "ab" ;
+ $b = \$a ;
+ substr($b, 1,1) = "ab" ;
+ EXPECT
+ Attempt to use reference as lvalue in substr at - line 5.
+ ########
+ # pp.c
+ use warning 'uninitialized' ;
+ # TODO
+ EXPECT
+
+ ########
+ # pp.c
+ use warning 'unsafe' ;
+ my $a = { 1,2,3};
+ EXPECT
+ Odd number of elements in hash assignment at - line 3.
+ ########
+ # pp.c
+ use warning 'unsafe' ;
+ my @a = unpack ("A,A", "22") ;
+ my $a = pack ("A,A", 1,2) ;
+ EXPECT
+ Invalid type in unpack: ',' at - line 3.
+ Invalid type in pack: ',' at - line 4.
+ ########
+ # pp.c
+ use warning 'uninitialized' ;
+ my $a = undef ;
+ my $b = $$a
+ EXPECT
+ Use of uninitialized value at - line 4.
+ ########
+ # pp.c
+ use warning 'unsafe' ;
+ sub foo { my $a = "a"; return $a . $a++ . $a++ }
+ my $a = pack("p", &foo) ;
+ EXPECT
+ Attempt to pack pointer to temporary value at - line 4.
+ ########
+ # pp.c
+ use warning 'unsafe' ;
+ bless \[], "" ;
+ EXPECT
+ Explicit blessing to '' (assuming package main) at - line 3.
*** /dev/null Tue Jan 1 04:00:00 1980
--- t/pragma/warn-pp_ctl Sat May 16 16:56:56 1998
***************
*** 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 Tue Jan 1 04:00:00 1980
--- t/pragma/warn-pp_hot Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,107 ----
+ pp_hot.c AOK
+
+ Filehandle %s never opened
+ $f = $a = "abc" ; print $f $a
+
+ Filehandle %s opened only for input
+ print STDIN "abc" ;
+
+
+ print on closed filehandle %s
+ close STDIN ; print STDIN "abc" ;
+
+ uninitialized
+ my $a = undef ; my @b = @$a
+
+ uninitialized
+ my $a = undef ; my %b = %$a
+
+ Odd number of elements in hash list
+ %X = (1,2,3) ;
+
+ Reference found where even-sized list expected
+ $X = [ 1 ..3 ];
+
+ Read on closed filehandle <%s>
+ close STDIN ; $a = <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 'uninitialized' ;
+ my $a = undef ;
+ my @b = @$a
+ EXPECT
+ Use of uninitialized value at - line 4.
+ ########
+ # pp_hot.c
+ use warning 'uninitialized' ;
+ my $a = undef ;
+ my %b = %$a
+ EXPECT
+ Use of uninitialized value at - line 4.
+ ########
+ # pp_hot.c
+ use warning 'unsafe' ;
+ my %X ; %X = (1,2,3) ;
+ EXPECT
+ Odd number of elements in hash assignment at - line 3.
+ ########
+ # pp_hot.c
+ use warning 'unsafe' ;
+ my %X ; %X = [1 .. 3] ;
+ EXPECT
+ Reference found where even-sized list expected at - line 3.
+ ########
+ # pp_hot.c
+ use warning 'closed' ;
+ close STDIN ; $a = <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 Tue Jan 1 04:00:00 1980
--- t/pragma/warn-pp_sys Sat May 16 16:56:56 1998
***************
*** 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 Tue Jan 1 04:00:00 1980
--- t/pragma/warn-regcomp Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,41 ----
+ regcomp.c AOK
+
+ %.*s matches null string many times
+
+ $a = "ABC123" ; $a =~ /(C*)*/'
+
+ Strange *+?{} on zero-length expression
+
+ /(?=a)?/
+
+ Character class syntax [: :] is reserved for future extensions
+ /[a[:xyz:]b]/
+
+ Character class syntax [. .] is reserved for future extensions
+ Character class syntax [= =] is reserved for future extensions
+
+ __END__
+ # regcomp.c
+ use warning 'unsafe' ;
+ my $a = "ABC123" ;
+ $a =~ /(C*)*/ ;
+ EXPECT
+ (C*)* matches null string many times at - line 4.
+ ########
+ # regcomp.c
+ use warning 'unsafe' ;
+ $_ = "" ;
+ /(?=a)?/;
+ EXPECT
+ Strange *+?{} on zero-length expression at - line 4.
+ ########
+ # regcomp.c
+ use warning 'unsafe' ;
+ $_ = "" ;
+ /[a[:xyz:]b]/;
+ /[a[.xyz.]b]/;
+ /[a[=xyz=]b]/;
+ EXPECT
+ Character class syntax [: :] is reserved for future extensions at - line 4.
+ Character class syntax [. .] is reserved for future extensions at - line 5.
+ Character class syntax [= =] is reserved for future extensions at - line 6.
*** /dev/null Tue Jan 1 04:00:00 1980
--- t/pragma/warn-regexec Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,24 ----
+ regexec.c
+
+ count exceeded %d
+
+ $_ = 'a' x (2**15+1); /^()(a\1)*$/ ;
+ count exceeded %d
+
+ $_ = 'a' x (2**15+1); /^()(a\1)*?$/ ;
+
+
+ __END__
+ # regexec.c
+ use warning 'unsafe' ;
+ $_ = 'a' x (2**15+1);
+ /^()(a\1)*$/ ;
+ EXPECT
+ count exceeded 32766 at - line 4.
+ ########
+ # regexec.c
+ use warning 'unsafe' ;
+ $_ = 'a' x (2**15+1);
+ /^()(a\1)*?$/ ;
+ EXPECT
+ count exceeded 32766 at - line 4.
*** /dev/null Tue Jan 1 04:00:00 1980
--- t/pragma/warn-sv Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,203 ----
+ sv.c AOK
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ not_a_number(sv);
+
+ not_a_number(sv);
+
+ warn(warn_uninit);
+
+ not_a_number(sv);
+
+ warn(warn_uninit);
+
+ not_a_number(sv);
+
+ not_a_number(sv);
+
+ warn(warn_uninit);
+
+ warn(warn_uninit);
+
+ Subroutine %s redefined
+
+ Invalid conversion in %s:
+
+ Undefined value assigned to typeglob
+
+
+ __END__
+ # sv.c
+ use integer ;
+ use warning 'uninitialized' ;
+ $x = 1 + $a[0] ; # a
+ EXPECT
+ Use of uninitialized value at - line 4.
+ ########
+ # sv.c (sv_2iv)
+ package fred ;
+ sub TIESCALAR { my $x ; bless \$x}
+ sub FETCH { return undef }
+ sub STORE { return 1 }
+ package main ;
+ tie $A, 'fred' ;
+ use integer ;
+ use warning 'uninitialized' ;
+ $A *= 2 ;
+ EXPECT
+ Use of uninitialized value at - line 10.
+ ########
+ # sv.c
+ use integer ;
+ use warning 'uninitialized' ;
+ my $x *= 2 ; #b
+ EXPECT
+ Use of uninitialized value at - line 4.
+ ########
+ # sv.c (sv_2uv)
+ package fred ;
+ sub TIESCALAR { my $x ; bless \$x}
+ sub FETCH { return undef }
+ sub STORE { return 1 }
+ package main ;
+ tie $A, 'fred' ;
+ use warning 'uninitialized' ;
+ $B = 0 ;
+ $B |= $A ;
+ EXPECT
+ Use of uninitialized value at - line 10.
+ ########
+ # sv.c
+ use warning 'uninitialized' ;
+ my $Y = 1 ;
+ my $x = 1 | $a[$Y]
+ EXPECT
+ Use of uninitialized value at - line 4.
+ ########
+ # sv.c
+ use warning 'uninitialized' ;
+ my $x *= 1 ; # d
+ EXPECT
+ Use of uninitialized value at - line 3.
+ ########
+ # sv.c
+ use warning 'uninitialized' ;
+ $x = 1 + $a[0] ; # e
+ EXPECT
+ Use of uninitialized value at - line 3.
+ ########
+ # sv.c (sv_2nv)
+ package fred ;
+ sub TIESCALAR { my $x ; bless \$x}
+ sub FETCH { return undef }
+ sub STORE { return 1 }
+ package main ;
+ tie $A, 'fred' ;
+ use warning 'uninitialized' ;
+ $A *= 2 ;
+ EXPECT
+ Use of uninitialized value at - line 9.
+ ########
+ # sv.c
+ use warning 'uninitialized' ;
+ $x = $y + 1 ; # f
+ EXPECT
+ Use of uninitialized value at - line 3.
+ ########
+ # sv.c
+ use warning 'uninitialized' ;
+ $x = chop undef ; # g
+ EXPECT
+ Use of uninitialized value at - line 3.
+ ########
+ # sv.c
+ use warning 'uninitialized' ;
+ $x = chop $y ; # h
+ EXPECT
+ Use of uninitialized value at - line 3.
+ ########
+ # sv.c (sv_2pv)
+ package fred ;
+ sub TIESCALAR { my $x ; bless \$x}
+ sub FETCH { return undef }
+ sub STORE { return 1 }
+ package main ;
+ tie $A, 'fred' ;
+ use warning 'uninitialized' ;
+ $B = "" ;
+ $B .= $A ;
+ EXPECT
+ Use of uninitialized value at - line 10.
+ ########
+ # sv.c
+ use warning 'numeric' ;
+ sub TIESCALAR{bless[]} ;
+ sub FETCH {"def"} ;
+ tie $a,"main" ;
+ my $b = 1 + $a
+ EXPECT
+ Argument "def" isn't numeric in add at - line 6.
+ ########
+ # sv.c
+ use warning 'numeric' ;
+ my $x = 1 + "def" ;
+ EXPECT
+ Argument "def" isn't numeric in add at - line 3.
+ ########
+ # sv.c
+ use warning 'numeric' ;
+ my $a = "def" ;
+ my $x = 1 + $a ;
+ EXPECT
+ Argument "def" isn't numeric in add at - line 4.
+ ########
+ # sv.c
+ use warning 'numeric' ; use integer ;
+ my $a = "def" ;
+ my $x = 1 + $a ;
+ EXPECT
+ Argument "def" isn't numeric in i_add at - line 4.
+ ########
+ # sv.c
+ use warning 'numeric' ;
+ my $x = 1 & "def" ;
+ EXPECT
+ Argument "def" isn't numeric in bit_and at - line 3.
+ ########
+ # sv.c
+ use warning 'redefine' ;
+ sub fred {}
+ sub joe {}
+ *fred = \&joe ;
+ EXPECT
+ Subroutine fred redefined at - line 5.
+ ########
+ # sv.c
+ use warning 'printf' ;
+ open F, ">/dev/null" ;
+ printf F "%q\n" ;
+ my $a = sprintf "%q" ;
+ printf F "%" ;
+ $a = sprintf "%" ;
+ printf F "%\x02" ;
+ $a = sprintf "%\x02" ;
+ EXPECT
+ Invalid conversion in sprintf: "%q" at - line 5.
+ Invalid conversion in sprintf: end of string at - line 7.
+ Invalid conversion in sprintf: "%\002" at - line 9.
+ Invalid conversion in printf: "%q" at - line 4.
+ Invalid conversion in printf: end of string at - line 6.
+ Invalid conversion in printf: "%\002" at - line 8.
+ ########
+ # sv.c
+ use warning 'unsafe' ;
+ *a = undef ;
+ EXPECT
+ Undefined value assigned to typeglob at - line 3.
*** /dev/null Tue Jan 1 04:00:00 1980
--- t/pragma/warn-taint Sat May 16 16:56:56 1998
***************
*** 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 Tue Jan 1 04:00:00 1980
--- t/pragma/warn-toke Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,280 ----
+ toke.c AOK
+
+ we seem to have lost a few ambiguous warnings!!
+
+
+ 1 if $a EQ $b ;
+ 1 if $a NE $b ;
+ 1 if $a LT $b ;
+ 1 if $a GT $b ;
+ 1 if $a GE $b ;
+ 1 if $a LE $b ;
+ $a = <<;
+ Use of comma-less variable list is deprecated
+ (called 3 times via depcom)
+
+ \1 better written as $1
+ use warning 'syntax' ;
+ s/(abc)/\1/;
+
+ warn(warn_nosemi)
+ Semicolon seems to be missing
+ $a = 1
+ &time ;
+
+
+ Reversed %c= operator
+ my $a =+ 2 ;
+ $a =- 2 ;
+ $a =* 2 ;
+ $a =% 2 ;
+ $a =& 2 ;
+ $a =. 2 ;
+ $a =^ 2 ;
+ $a =| 2 ;
+ $a =< 2 ;
+ $a =/ 2 ;
+
+ Multidimensional syntax %.*s not supported
+ my $a = $a[1,2] ;
+
+ You need to quote \"%s\""
+ sub fred {} ; $SIG{TERM} = fred;
+
+ Scalar value %.*s better written as $%.*s"
+ @a[3] = 2;
+ @a{3} = 2;
+
+ Can't use \\%c to mean $%c in expression
+ $_ = "ab" ; s/(ab)/\1/e;
+
+ Unquoted string "abc" may clash with future reserved word at - line 3.
+ warn(warn_reserved
+ $a = abc;
+
+ chmod: mode argument is missing initial 0
+ chmod 3;
+
+ Possible attempt to separate words with commas
+ @a = qw(a, b, c) ;
+
+ Possible attempt to put comments in qw() list
+ @a = qw(a b # c) ;
+
+ umask: argument is missing initial 0
+ umask 3;
+
+ %s (...) interpreted as function
+ print ("")
+ printf ("")
+ sort ("")
+
+ Ambiguous use of %c{%s%s} resolved to %c%s%s
+ $a = ${time[2]}
+ $a = ${time{2}}
+
+
+ Ambiguous use of %c{%s} resolved to %c%s
+ $a = ${time}
+ sub fred {} $a = ${fred}
+
+ Misplaced _ in number
+ $a = 1_2;
+ $a = 1_2345_6;
+
+ Bareword \"%s\" refers to nonexistent package
+ $a = FRED:: ;
+
+
+ __END__
+ # toke.c
+ use warning 'deprecated' ;
+ 1 if $a EQ $b ;
+ 1 if $a NE $b ;
+ 1 if $a GT $b ;
+ 1 if $a LT $b ;
+ 1 if $a GE $b ;
+ 1 if $a LE $b ;
+ EXPECT
+ Use of EQ is deprecated at - line 3.
+ Use of NE is deprecated at - line 4.
+ Use of GT is deprecated at - line 5.
+ Use of LT is deprecated at - line 6.
+ Use of GE is deprecated at - line 7.
+ Use of LE is deprecated at - line 8.
+ ########
+ # toke.c
+ use warning 'deprecated' ;
+ format STDOUT =
+ @<<< @||| @>>> @>>>
+ $a $b "abc" 'def'
+ .
+ ($a, $b) = (1,2,3);
+ write;
+ EXPECT
+ Use of comma-less variable list is deprecated at - line 5.
+ Use of comma-less variable list is deprecated at - line 5.
+ Use of comma-less variable list is deprecated at - line 5.
+ 1 2 abc def
+ ########
+ # toke.c
+ use warning 'deprecated' ;
+ $a = <<;
+
+ EXPECT
+ Use of bare << to mean <<"" is deprecated at - line 3.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ s/(abc)/\1/;
+ EXPECT
+ \1 better written as $1 at - line 3.
+ ########
+ # toke.c
+ use warning 'semicolon' ;
+ $a = 1
+ &time ;
+ EXPECT
+ Semicolon seems to be missing at - line 3.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ my $a =+ 2 ;
+ $a =- 2 ;
+ $a =* 2 ;
+ $a =% 2 ;
+ $a =& 2 ;
+ $a =. 2 ;
+ $a =^ 2 ;
+ $a =| 2 ;
+ $a =< 2 ;
+ $a =/ 2 ;
+ EXPECT
+ Reversed += operator at - line 3.
+ Reversed -= operator at - line 4.
+ Reversed *= operator at - line 5.
+ Reversed %= operator at - line 6.
+ Reversed &= operator at - line 7.
+ Reversed .= operator at - line 8.
+ syntax error at - line 8, near "=."
+ Reversed ^= operator at - line 9.
+ syntax error at - line 9, near "=^"
+ Reversed |= operator at - line 10.
+ syntax error at - line 10, near "=|"
+ Reversed <= operator at - line 11.
+ Unterminated <> operator at - line 11.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ my $a = $a[1,2] ;
+ EXPECT
+ Multidimensional syntax $a[1,2] not supported at - line 3.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ sub fred {} ; $SIG{TERM} = fred;
+ EXPECT
+ You need to quote "fred" at - line 3.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ @a[3] = 2;
+ @a{3} = 2;
+ EXPECT
+ Scalar value @a[3] better written as $a[3] at - line 3.
+ Scalar value @a{3} better written as $a{3} at - line 4.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ $_ = "ab" ;
+ s/(ab)/\1/e;
+ EXPECT
+ Can't use \1 to mean $1 in expression at - line 4.
+ ########
+ # toke.c
+ use warning 'reserved' ;
+ $a = abc;
+ EXPECT
+ Unquoted string "abc" may clash with future reserved word at - line 3.
+ ########
+ # toke.c
+ use warning 'octal' ;
+ chmod 3;
+ EXPECT
+ chmod: mode argument is missing initial 0 at - line 3, at end of line
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ @a = qw(a, b, c) ;
+ EXPECT
+ Possible attempt to separate words with commas at - line 3.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ @a = qw(a b #) ;
+ EXPECT
+ Possible attempt to put comments in qw() list at - line 3.
+ ########
+ # toke.c
+ use warning 'octal' ;
+ umask 3;
+ EXPECT
+ umask: argument is missing initial 0 at - line 3, at end of line
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ print ("")
+ EXPECT
+ print (...) interpreted as function at - line 3.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ printf ("")
+ EXPECT
+ printf (...) interpreted as function at - line 3.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ sort ("")
+ EXPECT
+ sort (...) interpreted as function at - line 3.
+ ########
+ # toke.c
+ use warning 'ambiguous' ;
+ $a = ${time[2]};
+ EXPECT
+ Ambiguous use of ${time[...]} resolved to $time[...] at - line 3.
+ ########
+ # toke.c
+ use warning 'ambiguous' ;
+ $a = ${time{2}};
+ EXPECT
+ Ambiguous use of ${time{...}} resolved to $time{...} at - line 3.
+ ########
+ # toke.c
+ use warning 'ambiguous' ;
+ $a = ${time} ;
+ EXPECT
+ Ambiguous use of ${time} resolved to $time at - line 3.
+ ########
+ # toke.c
+ use warning 'ambiguous' ;
+ sub fred {}
+ $a = ${fred} ;
+ EXPECT
+ Ambiguous use of ${fred} resolved to $fred at - line 4.
+ ########
+ # toke.c
+ use warning 'syntax' ;
+ $a = 1_2;
+ $a = 1_2345_6;
+ EXPECT
+ Misplaced _ in number at - line 3.
+ Misplaced _ in number at - line 4.
+ Misplaced _ in number at - line 4.
+ ########
+ # toke.c
+ use warning 'unsafe' ;
+ $a = FRED:: ;
+ EXPECT
+ Bareword "FRED::" refers to nonexistent package at - line 3.
*** /dev/null Tue Jan 1 04:00:00 1980
--- t/pragma/warn-universal Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,11 ----
+ universal.c
+
+ Can't locate package %s for @%s::ISA
+
+
+ __END__
+ # universal.c
+ use warning 'misc' ;
+
+ EXPECT
+
*** /dev/null Tue Jan 1 04:00:00 1980
--- t/pragma/warn-util Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,21 ----
+ util.c AOK
+
+ Illegal octal digit ignored
+ my $a = oct "029" ;
+
+ Illegal hex digit ignored
+ my $a = hex "0xv9" ;
+
+
+ __END__
+ # util.c
+ use warning 'octal' ;
+ my $a = oct "029" ;
+ EXPECT
+ Illegal octal digit ignored at - line 3.
+ ########
+ # util.c
+ use warning 'unsafe' ;
+ *a = hex "0xv9" ;
+ EXPECT
+ Illegal hex digit ignored at - line 3.
*** t/pragma/warning.t.orig Tue Nov 25 14:55:51 1997
--- t/pragma/warning.t Sat May 16 16:56:56 1998
***************
*** 16,23 ****
END { if ($tmpfile) { 1 while unlink $tmpfile} }
my @prgs = () ;
! foreach (sort glob("pragma/warn-*")) {
next if /(~|\.orig)$/;
--- 16,31 ----
END { if ($tmpfile) { 1 while unlink $tmpfile} }
my @prgs = () ;
+ my @w_files = () ;
! if (@ARGV)
! { print "ARGV = [@ARGV]\n" ; @w_files = map { s#^#./pragma/warn-#; $_ } @ARGV }
! else
! { @w_files = sort glob("pragma/warn-*") }
!
! foreach (@w_files) {
!
! next if /\.orig$/ ;
next if /(~|\.orig)$/;
*** taint.c.orig Wed Dec 17 14:28:12 1997
--- taint.c Sat May 16 16:56:56 1998
***************
*** 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 Fri May 15 15:02:39 1998
--- toke.c Sat May 16 16:56:56 1998
***************
*** 211,218 ****
void
deprecate(char *s)
{
! if (dowarn)
! warn("Use of %s is deprecated", s);
}
static void
--- 211,218 ----
void
deprecate(char *s)
{
! if (ckWARN(WARN_DEPRECATED))
! warner(WARN_DEPRECATED, "Use of %s is deprecated", s);
}
static void
***************
*** 943,950 ****
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;
}
--- 943,950 ----
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;
}
***************
*** 2357,2365 ****
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);
--- 2357,2365 ----
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);
***************
*** 2391,2398 ****
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') )
--- 2391,2398 ----
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') )
***************
*** 2522,2528 ****
char *t;
if (*s == '[') {
tokenbuf[0] = '@';
! if (dowarn) {
for(t = s + 1;
isSPACE(*t) || isALNUM(*t) || *t == '$';
t++) ;
--- 2522,2528 ----
char *t;
if (*s == '[') {
tokenbuf[0] = '@';
! if (ckWARN(WARN_SYNTAX)) {
for(t = s + 1;
isSPACE(*t) || isALNUM(*t) || *t == '$';
t++) ;
***************
*** 2530,2543 ****
bufptr = skipspace(bufptr);
while (t < bufend && *t != ']')
t++;
! warn("Multidimensional syntax %.*s not supported",
(t - bufptr) + 1, bufptr);
}
}
}
else if (*s == '{') {
tokenbuf[0] = '%';
! if (dowarn && strEQ(tokenbuf+1, "SIG") &&
(t = strchr(s, '}')) && (t = strchr(t, '=')))
{
char tmpbuf[sizeof tokenbuf];
--- 2530,2544 ----
bufptr = skipspace(bufptr);
while (t < bufend && *t != ']')
t++;
! warner(WARN_SYNTAX,
! "Multidimensional syntax %.*s not supported",
(t - bufptr) + 1, bufptr);
}
}
}
else if (*s == '{') {
tokenbuf[0] = '%';
! if (ckWARN(WARN_SYNTAX) && strEQ(tokenbuf+1, "SIG") &&
(t = strchr(s, '}')) && (t = strchr(t, '=')))
{
char tmpbuf[sizeof tokenbuf];
***************
*** 2546,2552 ****
if (isIDFIRST(*t)) {
t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
! warn("You need to quote \"%s\"", tmpbuf);
}
}
}
--- 2547,2554 ----
if (isIDFIRST(*t)) {
t = scan_word(t, tmpbuf, sizeof tmpbuf, TRUE, &len);
if (*t != '(' && perl_get_cv(tmpbuf, FALSE))
! warner(WARN_SYNTAX,
! "You need to quote \"%s\"", tmpbuf);
}
}
}
***************
*** 2616,2622 ****
tokenbuf[0] = '%';
/* Warn about @ where they meant $. */
! if (dowarn) {
if (*s == '[' || *s == '{') {
char *t = s + 1;
while (*t && (isALNUM(*t) || strchr(" \t$#+-'\"", *t)))
--- 2618,2624 ----
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)))
***************
*** 2624,2630 ****
if (*t == '}' || *t == ']') {
t++;
bufptr = skipspace(bufptr);
! warn("Scalar value %.*s better written as $%.*s",
t-bufptr, bufptr, t-bufptr-1, bufptr+1);
}
}
--- 2626,2633 ----
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);
}
}
***************
*** 2730,2737 ****
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);
--- 2733,2741 ----
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);
***************
*** 2856,2862 ****
if (expect == XOPERATOR) {
if (bufptr == linestart) {
curcop->cop_line--;
! warn(warn_nosemi);
curcop->cop_line++;
}
else
--- 2860,2866 ----
if (expect == XOPERATOR) {
if (bufptr == linestart) {
curcop->cop_line--;
! warner(WARN_SEMICOLON, warn_nosemi);
curcop->cop_line++;
}
else
***************
*** 2870,2877 ****
if (len > 2 &&
tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
{
! if (dowarn && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
! warn("Bareword \"%s\" refers to nonexistent package",
tokenbuf);
len -= 2;
tokenbuf[len] = '\0';
--- 2874,2882 ----
if (len > 2 &&
tokenbuf[len - 2] == ':' && tokenbuf[len - 1] == ':')
{
! if (ckWARN(WARN_UNSAFE) && ! gv_fetchpv(tokenbuf, FALSE, SVt_PVHV))
! warner(WARN_UNSAFE,
! "Bareword \"%s\" refers to nonexistent package",
tokenbuf);
len -= 2;
tokenbuf[len] = '\0';
***************
*** 3025,3035 ****
/* Call it a bare word */
bareword:
! if (dowarn) {
if (lastchar != '-') {
for (d = tokenbuf; *d && isLOWER(*d); d++) ;
if (!*d)
! warn(warn_reserved, tokenbuf);
}
}
--- 3030,3040 ----
/* 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);
}
}
***************
*** 3170,3176 ****
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");
--- 3175,3181 ----
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");
***************
*** 3590,3604 ****
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;
}
}
--- 3595,3611 ----
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;
}
}
***************
*** 3969,3975 ****
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");
--- 3976,3982 ----
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");
***************
*** 4663,4669 ****
{
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 == '(')
--- 4670,4676 ----
{
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 == '(')
***************
*** 4674,4680 ****
if (*w)
for (; *w && isSPACE(*w); w++) ;
if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
! warn("%s (...) interpreted as function",name);
}
while (s < bufend && isSPACE(*s))
s++;
--- 4681,4687 ----
if (*w)
for (; *w && isSPACE(*w); w++) ;
if (!*w || !strchr(";|})]oaiuw!=", *w)) /* an advisory hack only... */
! warner(WARN_SYNTAX, "%s (...) interpreted as function",name);
}
while (s < bufend && isSPACE(*s))
s++;
***************
*** 4812,4820 ****
*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;
--- 4819,4828 ----
*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;
***************
*** 4829,4837 ****
lex_state = LEX_INTERPEND;
if (funny == '#')
funny = '@';
! if (dowarn && lex_state == LEX_NORMAL &&
(keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
! warn("Ambiguous use of %c{%s} resolved to %c%s",
funny, dest, funny, dest);
}
else {
--- 4837,4846 ----
lex_state = LEX_INTERPEND;
if (funny == '#')
funny = '@';
! if (ckWARN(WARN_AMBIGUOUS) && lex_state == LEX_NORMAL &&
(keyword(dest, d - dest) || perl_get_cv(dest, FALSE)))
! warner(WARN_AMBIGUOUS,
! "Ambiguous use of %c{%s} resolved to %c%s",
funny, dest, funny, dest);
}
else {
***************
*** 5588,5595 ****
if -w is on
*/
if (*s == '_') {
! if (dowarn && lastub && s - lastub != 3)
! warn("Misplaced _ in number");
lastub = ++s;
}
else {
--- 5597,5604 ----
if -w is on
*/
if (*s == '_') {
! if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
! warner(WARN_SYNTAX, "Misplaced _ in number");
lastub = ++s;
}
else {
***************
*** 5602,5609 ****
}
/* final misplaced underbar check */
! if (dowarn && lastub && s - lastub != 3)
! warn("Misplaced _ in number");
/* read a decimal portion if there is one. avoid
3..5 being interpreted as the number 3. followed
--- 5611,5618 ----
}
/* final misplaced underbar check */
! if (ckWARN(WARN_SYNTAX) && lastub && s - lastub != 3)
! warner(WARN_SYNTAX, "Misplaced _ in number");
/* read a decimal portion if there is one. avoid
3..5 being interpreted as the number 3. followed
*** universal.c.orig Tue Feb 3 13:16:56 1998
--- universal.c Sat May 16 16:56:56 1998
***************
*** 54,61 ****
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;
}
--- 54,62 ----
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 Fri May 15 15:02:41 1998
--- util.c Sat May 16 16:56:56 1998
***************
*** 1325,1336 ****
return restartop;
}
- #ifdef I_STDARG
void
croak(const char* pat, ...)
#else
/*VARARGS0*/
- void
croak(pat, va_alist)
char *pat;
va_dcl
--- 1325,1335 ----
return restartop;
}
void
+ #ifdef I_STDARG
croak(const char* pat, ...)
#else
/*VARARGS0*/
croak(pat, va_alist)
char *pat;
va_dcl
***************
*** 1390,1396 ****
void
#ifdef I_STDARG
! warn(const char* pat,...)
#else
/*VARARGS0*/
warn(pat,va_alist)
--- 1389,1395 ----
void
#ifdef I_STDARG
! warn(const char *pat,...)
#else
/*VARARGS0*/
warn(pat,va_alist)
***************
*** 1452,1457 ****
--- 1451,1555 ----
(void)PerlIO_flush(PerlIO_stderr());
}
+ void
+ #ifdef I_STDARG
+ warner(U32 err, const char* pat,...)
+ #else
+ /*VARARGS0*/
+ warner(err,pat,va_alist)
+ U32 err;
+ const char *pat;
+ va_dcl
+ #endif
+ {
+ va_list args;
+ char *message;
+ HV *stash;
+ GV *gv;
+ CV *cv;
+
+ #ifdef I_STDARG
+ va_start(args, pat);
+ #else
+ va_start(args);
+ #endif
+ message = mess(pat, &args);
+ va_end(args);
+
+ if (ckDEAD(err)) {
+ #ifdef USE_THREADS
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
+ #endif /* USE_THREADS */
+ if (diehook) {
+ /* sv_2cv might call croak() */
+ SV *olddiehook = diehook;
+ ENTER;
+ SAVESPTR(diehook);
+ diehook = Nullsv;
+ cv = sv_2cv(olddiehook, &stash, &gv, 0);
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
+ dSP;
+ SV *msg;
+
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
+
+ PUSHMARK(sp);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+
+ LEAVE;
+ }
+ }
+ if (in_eval) {
+ restartop = die_where(message);
+ JMPENV_JUMP(3);
+ }
+ PerlIO_puts(PerlIO_stderr(),message);
+ (void)PerlIO_flush(PerlIO_stderr());
+ my_failure_exit();
+
+ }
+ else {
+ if (warnhook) {
+ /* sv_2cv might call warn() */
+ dTHR;
+ SV *oldwarnhook = warnhook;
+ ENTER;
+ SAVESPTR(warnhook);
+ warnhook = Nullsv;
+ cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
+ dSP;
+ SV *msg;
+
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
+
+ PUSHMARK(sp);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+
+ LEAVE;
+ return;
+ }
+ }
+ PerlIO_puts(PerlIO_stderr(),message);
+ #ifdef LEAKTEST
+ DEBUG_L(xstat());
+ #endif
+ (void)PerlIO_flush(PerlIO_stderr());
+ }
+ }
+
#ifndef VMS /* VMS' my_setenv() is in VMS.c */
#ifndef WIN32
void
***************
*** 2377,2384 ****
retval = n | (*s++ - '0');
len--;
}
! if (dowarn && len && (*s == '8' || *s == '9'))
! warn("Illegal octal digit ignored");
*retlen = s - start;
return retval;
}
--- 2475,2482 ----
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;
}
***************
*** 2400,2407 ****
retval = n | ((tmp - hexdigit) & 15);
s++;
}
! if (dowarn && !tmp) {
! warn("Illegal hex digit ignored");
}
*retlen = s - start;
return retval;
--- 2498,2505 ----
retval = n | ((tmp - hexdigit) & 15);
s++;
}
! if (ckWARN(WARN_UNSAFE) && !tmp) {
! warner(WARN_UNSAFE, "Illegal hex digit ignored");
}
*retlen = s - start;
return retval;
*** /dev/null Tue Jan 1 04:00:00 1980
--- warning.h Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,99 ----
+ /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by warning.pl
+ Any changes made here will be lost!
+ */
+
+
+ #define Off(x) ((x) / 8)
+ #define Bit(x) (1 << ((x) % 8))
+ #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
+
+ #define G_WARN_OFF 0 /* $^W == 0 */
+ #define G_WARN_ON 1 /* $^W != 0 */
+ #define G_WARN_ALL_ON 2 /* -W flag */
+ #define G_WARN_ALL_OFF 4 /* -X flag */
+ #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
+
+ #if 1
+
+ /* Part of the logic below assumes that WARN_NONE is NULL */
+
+ #define ckDEAD(x) \
+ (curcop->cop_warnings != WARN_ALL && \
+ curcop->cop_warnings != WARN_NONE && \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x+1))
+
+ #define ckWARN(x) \
+ ( (curcop->cop_warnings && \
+ (curcop->cop_warnings == WARN_ALL || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x) ) ) \
+ || (dowarn & G_WARN_ON) )
+
+ #define ckWARN2(x,y) \
+ ( (curcop->cop_warnings && \
+ (curcop->cop_warnings == WARN_ALL || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x) || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*y) ) ) \
+ || (dowarn & G_WARN_ON) )
+
+ #else
+
+ #define ckDEAD(x) \
+ (curcop->cop_warnings != WARN_ALL && \
+ curcop->cop_warnings != WARN_NONE && \
+ SvPVX(curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) )
+
+ #define ckWARN(x) \
+ ( (dowarn & G_WARN_ON) || ( (dowarn & G_WARN_DISABLE) && \
+ curcop->cop_warnings && \
+ ( curcop->cop_warnings == WARN_ALL || \
+ SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) ) ) )
+
+ #define ckWARN2(x,y) \
+ ( (dowarn & G_WARN_ON) || ( (dowarn & G_WARN_DISABLE) && \
+ curcop->cop_warnings && \
+ ( curcop->cop_warnings == WARN_ALL || \
+ SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || \
+ SvPVX(curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) )
+
+ #endif
+
+ #define WARN_NONE NULL
+ #define WARN_ALL (&sv_yes)
+
+ #define WARN_REDEFINE 0
+ #define WARN_VOID 1
+ #define WARN_UNSAFE 2
+ #define WARN_TAINT 3
+ #define WARN_SUBSTR 4
+ #define WARN_CLOSURE 5
+ #define WARN_UNTIE 6
+ #define WARN_SIGNAL 7
+ #define WARN_NUMERIC 8
+ #define WARN_DEFAULT 9
+ #define WARN_ONCE 10
+ #define WARN_SYNTAX 11
+ #define WARN_RESERVED 12
+ #define WARN_DEPRECATED 13
+ #define WARN_SEMICOLON 14
+ #define WARN_PRINTF 15
+ #define WARN_OCTAL 16
+ #define WARN_AMBIGUOUS 17
+ #define WARN_PARENTHESIS 18
+ #define WARN_PRECEDENCE 19
+ #define WARN_IO 20
+ #define WARN_NEWLINE 21
+ #define WARN_CLOSED 22
+ #define WARN_EXEC 23
+ #define WARN_UNOPENED 24
+ #define WARN_PIPE 25
+ #define WARN_UNINITIALIZED 26
+ #define WARN_RECURSION 27
+ #define WARN_MISC 28
+
+ #define WARNsize 8
+ #define WARN_ALLstring "\125\125\125\125\125\125\125\125"
+ #define WARN_NONEstring "\0\0\0\0\0\0\0\0"
+
+ /* end of file warning.h */
+
*** /dev/null Tue Jan 1 04:00:00 1980
--- warning.pl Sat May 16 16:56:56 1998
***************
*** 0 ****
--- 1,358 ----
+ #!/usr/bin/perl
+
+ use strict ;
+
+ sub DEFAULT_ON () { 1 }
+ sub DEFAULT_OFF () { 2 }
+
+ my $tree = {
+ 'unsafe' => { 'untie' => DEFAULT_OFF,
+ 'substr' => DEFAULT_OFF,
+ 'taint' => DEFAULT_OFF,
+ 'signal' => DEFAULT_OFF,
+ 'closure' => DEFAULT_OFF,
+ } ,
+ 'io' => { 'pipe' => DEFAULT_OFF,
+ 'unopened' => DEFAULT_OFF,
+ 'closed' => DEFAULT_OFF,
+ 'newline' => DEFAULT_OFF,
+ 'exec' => DEFAULT_OFF,
+ #'wr in in file'=> DEFAULT_OFF,
+ },
+ 'syntax' => { 'ambiguous' => DEFAULT_OFF,
+ 'semicolon' => DEFAULT_OFF,
+ 'precedence' => DEFAULT_OFF,
+ 'reserved' => DEFAULT_OFF,
+ 'octal' => DEFAULT_OFF,
+ 'parenthesis' => DEFAULT_OFF,
+ 'deprecated' => DEFAULT_OFF,
+ 'printf' => DEFAULT_OFF,
+ },
+ 'void' => DEFAULT_OFF,
+ 'recursion' => DEFAULT_OFF,
+ 'redefine' => DEFAULT_OFF,
+ 'numeric' => DEFAULT_OFF,
+ 'uninitialized'=> DEFAULT_OFF,
+ 'once' => DEFAULT_OFF,
+ 'misc' => DEFAULT_OFF,
+ 'default' => DEFAULT_ON,
+ } ;
+
+
+ ###########################################################################
+ sub tab {
+ my($l, $t) = @_;
+ $t .= "\t" x ($l - (length($t) + 1) / 8);
+ $t;
+ }
+
+ ###########################################################################
+
+ my %list ;
+ my %Value ;
+ my $index = 0 ;
+
+ sub walk
+ {
+ my $tre = shift ;
+ my @list = () ;
+ my ($k, $v) ;
+
+ while (($k, $v) = each %$tre) {
+
+ die "duplicate key $k\n" if defined $list{$k} ;
+ $Value{$index} = uc $k ;
+ push @{ $list{$k} }, $index ++ ;
+ if (ref $v)
+ { push (@{ $list{$k} }, walk ($v)) }
+ push @list, @{ $list{$k} } ;
+ }
+
+ return @list ;
+
+ }
+
+ ###########################################################################
+
+ sub mkRange
+ {
+ my @a = @_ ;
+ my @out = @a ;
+ my $i ;
+
+
+ for ($i = 1 ; $i < @a; ++ $i) {
+ $out[$i] = ".."
+ if $a[$i] == $a[$i - 1] + 1 && $a[$i] + 1 == $a[$i + 1] ;
+ }
+
+ my $out = join(",",@out);
+
+ $out =~ s/,(\.\.,)+/../g ;
+ return $out;
+ }
+
+ ###########################################################################
+
+ sub mkHex
+ {
+ my ($max, @a) = @_ ;
+ my $mask = "\x00" x $max ;
+ my $string = "" ;
+
+ foreach (@a) {
+ vec($mask, $_, 1) = 1 ;
+ }
+
+ #$string = unpack("H$max", $mask) ;
+ #$string =~ s/(..)/\x$1/g;
+ foreach (unpack("C*", $mask)) {
+ $string .= '\x' . sprintf("%2.2x", $_) ;
+ }
+ return $string ;
+ }
+
+ ###########################################################################
+
+
+ #unlink "warning.h";
+ #unlink "lib/warning.pm";
+ open(WARN, ">warning.h") || die "Can't create warning.h: $!\n";
+ open(PM, ">lib/warning.pm") || die "Can't create lib/warning.pm: $!\n";
+
+ print WARN <<'EOM' ;
+ /* !!!!!!! DO NOT EDIT THIS FILE !!!!!!!
+ This file is built by warning.pl
+ Any changes made here will be lost!
+ */
+
+
+ #define Off(x) ((x) / 8)
+ #define Bit(x) (1 << ((x) % 8))
+ #define IsSet(a, x) ((a)[Off(x)] & Bit(x))
+
+ #define G_WARN_OFF 0 /* $^W == 0 */
+ #define G_WARN_ON 1 /* $^W != 0 */
+ #define G_WARN_ALL_ON 2 /* -W flag */
+ #define G_WARN_ALL_OFF 4 /* -X flag */
+ #define G_WARN_ALL_MASK (G_WARN_ALL_ON|G_WARN_ALL_OFF)
+
+ #if 1
+
+ /* Part of the logic below assumes that WARN_NONE is NULL */
+
+ #define ckDEAD(x) \
+ (curcop->cop_warnings != WARN_ALL && \
+ curcop->cop_warnings != WARN_NONE && \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x+1))
+
+ #define ckWARN(x) \
+ ( (curcop->cop_warnings && \
+ (curcop->cop_warnings == WARN_ALL || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x) ) ) \
+ || (dowarn & G_WARN_ON) )
+
+ #define ckWARN2(x,y) \
+ ( (curcop->cop_warnings && \
+ (curcop->cop_warnings == WARN_ALL || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*x) || \
+ IsSet(SvPVX(curcop->cop_warnings), 2*y) ) ) \
+ || (dowarn & G_WARN_ON) )
+
+ #else
+
+ #define ckDEAD(x) \
+ (curcop->cop_warnings != WARN_ALL && \
+ curcop->cop_warnings != WARN_NONE && \
+ SvPVX(curcop->cop_warnings)[Off(2*x+1)] & Bit(2*x+1) )
+
+ #define ckWARN(x) \
+ ( (dowarn & G_WARN_ON) || ( (dowarn & G_WARN_DISABLE) && \
+ curcop->cop_warnings && \
+ ( curcop->cop_warnings == WARN_ALL || \
+ SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) ) ) )
+
+ #define ckWARN2(x,y) \
+ ( (dowarn & G_WARN_ON) || ( (dowarn & G_WARN_DISABLE) && \
+ curcop->cop_warnings && \
+ ( curcop->cop_warnings == WARN_ALL || \
+ SvPVX(curcop->cop_warnings)[Off(2*x)] & Bit(2*x) || \
+ SvPVX(curcop->cop_warnings)[Off(2*y)] & Bit(2*y) ) ) )
+
+ #endif
+
+ #define WARN_NONE NULL
+ #define WARN_ALL (&sv_yes)
+
+ EOM
+
+
+ $index = 0 ;
+ @{ $list{"all"} } = walk ($tree) ;
+
+ $index *= 2 ;
+ my $warn_size = int($index / 8) + ($index % 8 != 0) ;
+
+ my $k ;
+ foreach $k (sort { $a <=> $b } keys %Value) {
+ print WARN tab(5, "#define WARN_$Value{$k}"), "$k\n" ;
+ }
+ print WARN "\n" ;
+
+ print WARN tab(5, '#define WARNsize'), "$warn_size\n" ;
+ #print WARN tab(5, '#define WARN_ALLstring'), '"', ('\377' x $warn_size) , "\"\n" ;
+ print WARN tab(5, '#define WARN_ALLstring'), '"', ('\125' x $warn_size) , "\"\n" ;
+ print WARN tab(5, '#define WARN_NONEstring'), '"', ('\0' x $warn_size) , "\"\n" ;
+
+ print WARN <<'EOM';
+
+ /* end of file warning.h */
+
+ EOM
+
+ close WARN ;
+
+ while (<DATA>) {
+ last if /^KEYWORDS$/ ;
+ print PM $_ ;
+ }
+
+ $list{'all'} = [ 0 .. 8 * ($warn_size/2) - 1 ] ;
+ print PM "%Bits = (\n" ;
+ foreach $k (sort keys %list) {
+
+ my $v = $list{$k} ;
+ my @list = sort { $a <=> $b } @$v ;
+
+ print PM tab(4, " '$k'"), '=> "',
+ # mkHex($warn_size, @list),
+ mkHex($warn_size, map $_ * 2 , @list),
+ '", # [', mkRange(@list), "]\n" ;
+ }
+
+ print PM " );\n\n" ;
+
+ print PM "%DeadBits = (\n" ;
+ foreach $k (sort keys %list) {
+
+ my $v = $list{$k} ;
+ my @list = sort { $a <=> $b } @$v ;
+
+ print PM tab(4, " '$k'"), '=> "',
+ # mkHex($warn_size, @list),
+ mkHex($warn_size, map $_ * 2 + 1 , @list),
+ '", # [', mkRange(@list), "]\n" ;
+ }
+
+ print PM " );\n\n" ;
+ while (<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') ;
+ }
+
+
+ sub make_fatal
+ {
+ my $self = shift ;
+ my $bitmask = $self->bits(@_) ;
+ $SIG{__WARN__} =
+ sub
+ {
+ die @_ if $^B & $bitmask ;
+ warn @_
+ } ;
+ }
+
+ sub bitmask
+ {
+ return $^B ;
+ }
+
+ sub enabled
+ {
+ my $string = shift ;
+
+ return 1
+ if $bits{$string} && $^B & $bits{$string} ;
+
+ return 0 ;
+ }
+
+ 1;