perlbug-followup at perl
Nov 21, 2009, 5:57 PM
Post #1 of 1
(122 views)
Permalink
|
|
[perl #70718] feature patch - add new warnings category to disable prototype parsing warnings when illegal characters are found
|
|
# New Ticket Created by Matt S Trout
# Please include the string: [perl #70718]
# in the subject line of all future correspondence about this issue.
# <URL: http://rt.perl.org/rt3/Ticket/Display.html?id=70718 >
This is a bug report for perl from mst [at] shadowcat,
generated with the help of perlbug 1.35 running under perl v5.8.7.
-----------------------------------------------------------------
[Please enter your report here]
Web::Simple (which I'll be releasing later tonight) and modules like
signatures.pm give special/additional meaning to subroutine prototypes,
which means that characters may be found therein that are not normally
valid. The warnings for this are currently part of the top-level 'syntax'
category so the closest we can get to disabling the specific warnings we
want is to disable 'syntax' with 'no warnings' and then re-enable all of
its subcategories.
The included patch adds a new category, 'illegalproto', after the common
"Illegal character in prototype" warning. It also disables the warning
produced when characters are found after an @ in case you have an unusual
prototype that -looks- like a normal perl prototype.
I would argue the category name is correct even though it disables as second
warning as well as the name corresponds to the most common type of warning
encountered when using prototype extension modules, and therefore should be
more findable by the user.
diff --git a/lib/warnings.pm b/lib/warnings.pm
index 6049437..ad16726 100644
--- a/lib/warnings.pm
+++ b/lib/warnings.pm
@@ -192,10 +192,11 @@ our %Offsets = (
# Warnings Categories added in Perl 5.011
'imprecision' => 92,
+ 'illegalproto' => 94,
);
our %Bits = (
- 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
+ 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
@@ -206,6 +207,7 @@ our %Bits = (
'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+ 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [47]
'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
@@ -233,7 +235,7 @@ our %Bits = (
'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
- 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
+ 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x40", # [28..38,47]
'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
@@ -245,7 +247,7 @@ our %Bits = (
);
our %DeadBits = (
- 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
+ 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
@@ -256,6 +258,7 @@ our %DeadBits = (
'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
+ 'illegalproto' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [47]
'imprecision' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
@@ -283,7 +286,7 @@ our %DeadBits = (
'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
- 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
+ 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x80", # [28..38,47]
'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
@@ -295,7 +298,7 @@ our %DeadBits = (
);
$NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
-$LAST_BIT = 94 ;
+$LAST_BIT = 96 ;
$BYTES = 12 ;
$All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
diff --git a/pod/perllexwarn.pod b/pod/perllexwarn.pod
index 1eb8b30..45a7f5f 100644
--- a/pod/perllexwarn.pod
+++ b/pod/perllexwarn.pod
@@ -278,6 +278,8 @@ The current hierarchy is:
| |
| +- digit
| |
+ | +- illegalproto
+ | |
| +- parenthesis
| |
| +- precedence
diff --git a/t/op/protowarn.t b/t/op/protowarn.t
new file mode 100755
index 0000000..53e0118
--- /dev/null
+++ b/t/op/protowarn.t
@@ -0,0 +1,110 @@
+#!./perl
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = qw(. ../lib);
+}
+
+use strict;
+use warnings;
+
+BEGIN {
+ require 'test.pl';
+ plan( tests => 6 );
+}
+
+use vars qw{ @warnings $sub $warn };
+
+BEGIN {
+ $warn = 'Illegal character in prototype';
+}
+
+sub one_warning_ok {
+ cmp_ok(scalar(@warnings), '==', 1, 'One warning');
+ cmp_ok(substr($warnings[0],0,length($warn)),'eq',$warn,'warning message');
+ @warnings = ();
+}
+
+sub no_warnings_ok {
+ cmp_ok(scalar(@warnings), '==', 0, 'No warnings');
+ @warnings = ();
+}
+
+BEGIN {
+ $SIG{'__WARN__'} = sub { push @warnings, @_ };
+ $| = 1;
+}
+
+BEGIN { @warnings = () }
+
+$sub = sub (x) { };
+
+BEGIN {
+ one_warning_ok;
+}
+
+{
+ no warnings 'syntax';
+ $sub = sub (x) { };
+}
+
+BEGIN {
+ no_warnings_ok;
+}
+
+{
+ no warnings 'illegalproto';
+ $sub = sub (x) { };
+}
+
+BEGIN {
+ no_warnings_ok;
+}
+
+{
+ no warnings 'syntax';
+ use warnings 'illegalproto';
+ $sub = sub (x) { };
+}
+
+BEGIN {
+ one_warning_ok;
+}
+
+BEGIN {
+ $warn = q{Prototype after '@' for};
+}
+
+$sub = sub (@$) { };
+
+BEGIN {
+ one_warning_ok;
+}
+
+{
+ no warnings 'syntax';
+ $sub = sub (@$) { };
+}
+
+BEGIN {
+ no_warnings_ok;
+}
+
+{
+ no warnings 'illegalproto';
+ $sub = sub (@$) { };
+}
+
+BEGIN {
+ no_warnings_ok;
+}
+
+{
+ no warnings 'syntax';
+ use warnings 'illegalproto';
+ $sub = sub (@$) { };
+}
+
+BEGIN {
+ one_warning_ok;
+}
diff --git a/toke.c b/toke.c
index a4e9471..d9d4dec 100644
--- a/toke.c
+++ b/toke.c
@@ -7346,7 +7346,7 @@ Perl_yylex(pTHX)
bool must_be_last = FALSE;
bool underscore = FALSE;
bool seen_underscore = FALSE;
- const bool warnsyntax = ckWARN(WARN_SYNTAX);
+ const bool warnillegalproto = ckWARN(WARN_ILLEGALPROTO);
s = scan_str(s,!!PL_madskills,FALSE);
if (!s)
@@ -7358,7 +7358,7 @@ Perl_yylex(pTHX)
if (!isSPACE(*p)) {
d[tmp++] = *p;
- if (warnsyntax) {
+ if (warnillegalproto) {
if (must_be_last)
proto_after_greedy_proto = TRUE;
if (!strchr("$@%*;[]&\\_", *p)) {
@@ -7391,11 +7391,11 @@ Perl_yylex(pTHX)
}
d[tmp] = '\0';
if (proto_after_greedy_proto)
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
"Prototype after '%c' for %"SVf" : %s",
greedy_proto, SVfARG(PL_subname), d);
if (bad_proto)
- Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
+ Perl_warner(aTHX_ packWARN(WARN_ILLEGALPROTO),
"Illegal character %sin prototype for %"SVf" : %s",
seen_underscore ? "after '_' " : "",
SVfARG(PL_subname), d);
diff --git a/warnings.h b/warnings.h
index 56b3079..3ed9ecf 100644
--- a/warnings.h
+++ b/warnings.h
@@ -79,6 +79,7 @@
/* Warnings Categories added in Perl 5.011 */
#define WARN_IMPRECISION 46
+#define WARN_ILLEGALPROTO 47
#define WARNsize 12
#define WARN_ALLstring "\125\125\125\125\125\125\125\125\125\125\125\125"
diff --git a/warnings.pl b/warnings.pl
index dabc97d..2fec9e7 100644
--- a/warnings.pl
+++ b/warnings.pl
@@ -46,6 +46,7 @@ my $tree = {
'printf' => [ 5.008, DEFAULT_OFF],
'prototype' => [ 5.008, DEFAULT_OFF],
'qw' => [ 5.008, DEFAULT_OFF],
+ 'illegalproto' => [ 5.011, DEFAULT_OFF],
}],
'severe' => [ 5.008, {
'inplace' => [ 5.008, DEFAULT_ON],
[Please do not change anything below this line]
-----------------------------------------------------------------
---
Flags:
category=core
severity=wishlist
---
Site configuration information for perl v5.8.7:
Configured by Debian Project at Fri Dec 5 01:21:24 UTC 2008.
Summary of my perl5 (revision 5 version 8 subversion 7) configuration:
Platform:
osname=linux, osvers=2.6.24-16-server, archname=i486-linux-gnu-thread-multi
uname='linux vernadsky 2.6.24-16-server #1 smp thu apr 10 13:58:00 utc 2008 i686 gnulinux '
config_args='-Dusethreads -Duselargefiles -Dccflags=-DDEBIAN -Dcccdlflags=-fPIC -Darchname=i486-linux-gnu -Dprefix=/usr -Dprivlib=/usr/share/perl/5.8 -Darchlib=/usr/lib/perl/5.8 -Dvendorprefix=/usr -Dvendorlib=/usr/share/perl5 -Dvendorarch=/usr/lib/perl5 -Dsiteprefix=/usr/local -Dsitelib=/usr/local/share/perl/5.8.7 -Dsitearch=/usr/local/lib/perl/5.8.7 -Dman1dir=/usr/share/man/man1 -Dman3dir=/usr/share/man/man3 -Dsiteman1dir=/usr/local/man/man1 -Dsiteman3dir=/usr/local/man/man3 -Dman1ext=1 -Dman3ext=3perl -Dpager=/usr/bin/sensible-pager -Uafs -Ud_csh -Uusesfio -Uusenm -Duseshrplib -Dlibperl=libperl.so.5.8.7 -Dd_dosuid -des'
hint=recommended, useposix=true, d_sigaction=define
usethreads=define use5005threads=undef useithreads=define usemultiplicity=define
useperlio=define d_sfio=undef uselargefiles=define usesocks=undef
use64bitint=undef use64bitall=undef uselongdouble=undef
usemymalloc=n, bincompat5005=undef
Compiler:
cc='cc', ccflags ='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -DDEBIAN -fno-strict-aliasing -pipe -I/usr/local/include -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64',
optimize='-O2',
cppflags='-D_REENTRANT -D_GNU_SOURCE -DTHREADS_HAVE_PIDS -DDEBIAN -fno-strict-aliasing -pipe -I/usr/local/include'
ccversion='', gccversion='4.0.3 (Ubuntu 4.0.3-1ubuntu5)', gccosandvers=''
intsize=4, longsize=4, ptrsize=4, doublesize=8, byteorder=1234
d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
alignbytes=4, prototype=define
Linker and Libraries:
ld='cc', ldflags =' -L/usr/local/lib'
libpth=/usr/local/lib /lib /usr/lib
libs=-lgdbm -lgdbm_compat -ldb -ldl -lm -lpthread -lc -lcrypt
perllibs=-ldl -lm -lpthread -lc -lcrypt
libc=/lib/libc-2.3.6.so, so=so, useshrplib=true, libperl=libperl.so.5.8.7
gnulibc_version='2.3.6'
Dynamic Linking:
dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-Wl,-E'
cccdlflags='-fPIC', lddlflags='-shared -L/usr/local/lib'
Locally applied patches:
SPRINTF0 - fixes for sprintf formatting issues - CVE-2005-3962
---
@INC for perl v5.8.7:
/home/matthewt/site/perl/share/perl/5.8
/home/matthewt/site/perl/share/perl/5.8.7
/home/matthewt/site/perl/lib/perl5/i486-linux-gnu-thread-multi
/home/matthewt/site/perl/lib/perl5
/home/matthewt/site/perl/lib/perl/5.8.7
/home/matthewt/site/perl/lib/perl/5.8
/etc/perl
/usr/local/lib/perl/5.8.7
/usr/local/share/perl/5.8.7
/usr/lib/perl5
/usr/share/perl5
/usr/lib/perl/5.8
/usr/share/perl/5.8
/usr/local/lib/site_perl
.
---
Environment for perl v5.8.7:
HOME=/home/matthewt
LANG=en_GB.UTF-8
LANGUAGE=en_GB:en
LD_LIBRARY_PATH (unset)
LOGDIR (unset)
PATH=/home/matthewt/bin:/usr/local/bin:/usr/bin:/bin:/usr/local/sbin:/sbin:/usr/sbin:/home/matthewt/site/perl/bin
PERL5LIB=/home/matthewt/site/perl/share/perl/5.8:/home/matthewt/site/perl/share/perl/5.8.7:/home/matthewt/site/perl/lib/perl5:/home/matthewt/site/perl/lib/perl/5.8.7:/home/matthewt/site/perl/lib/perl/5.8
PERL_BADLANG (unset)
SHELL=/bin/sh
|
