From: Karl Williamson Date: Mon, 31 May 2010 03:54:32 +0000 (-0600) Subject: PATCH: teach diag.t new warning function names X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=1b1ee2ef87e2dcc8a1699cc870aefd1b91c5f645;p=p5sagit%2Fp5-mst-13.2.git PATCH: teach diag.t new warning function names A number of function names that do warnings have been added, but diag.t hasn't kept up. This patch changes it to look for likely function names in embed.fnc, so it will automatically keep up in the future. There's no need to worry about it looking for inappropriate functions, as the syntax of messages that it looks for is so restrictive, that there won't be false positives. Instead there are still many messages it fails to catch. As a result of it's falling behind several issues have crept in. I resolved the couple I thought were clear (including one in a comment; diag.t doesn't strip comments, but mostly it doesn't matter), and added the others to the section to ignore. are --- diff --git a/pod/perldiag.pod b/pod/perldiag.pod index 8bb0f85..4d7d6ad 100644 --- a/pod/perldiag.pod +++ b/pod/perldiag.pod @@ -1711,7 +1711,7 @@ in your false range is interpreted as a literal "-". Consider quoting the "-", "\-". The <-- HERE shows in the regular expression about where the problem was discovered. See L. -=item Fatal VMS error at %s, line %d +=item Fatal VMS error (status=%d) at %s, line %d (P) An error peculiar to VMS. Something untoward happened in a VMS system service or RTL routine; Perl's exit status should provide more diff --git a/t/porting/diag.t b/t/porting/diag.t old mode 100644 new mode 100755 index 11bbca0..daec293 --- a/t/porting/diag.t +++ b/t/porting/diag.t @@ -13,16 +13,50 @@ my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list'; chdir '..' or die "Can't chdir ..: $!"; BEGIN { defined $ENV{PERL_UNICODE} and push @INC, "lib"; } -open my $diagfh, "<", "pod/perldiag.pod" - or die "Can't open pod/perldiag.pod: $!"; +my @functions; + +open my $func_fh, "<", "embed.fnc" or die "Can't open embed.fnc: $!"; + +# Look for functions in embed.fnc that look like they could be diagnostic ones. +while (<$func_fh>) { + chomp; + s/^\s+//; + while (s/\s*\\$//) { # Grab up all continuation lines, these end in \ + my $next = <$func_fh>; + $next =~ s/^\s+//; + chomp $next; + $_ .= $next; + } + next if /^:/; # Lines beginning with colon are comments. + next unless /\|/; # Lines without a vertical bar are something we can't deal + # with + my @fields = split /\s*\|\s*/; + next unless $fields[2] =~ /warn|err|(\b|_)die|croak/i; + push @functions, $fields[2]; + + # The flag p means that this function may have a 'Perl_' prefix + # The flag s means that this function may have a 'S_' prefix + push @functions, "Perl_$fields[2]", if $fields[0] =~ /p/; + push @functions, "S_$fields[2]", if $fields[0] =~ /s/; +} + +close $func_fh; + +my $function_re = join '|', @functions; +my $source_msg_re = qr/(?\bDIE\b|$function_re)/; my %entries; + +# Get the ignores that are compiled into this file while () { chomp; $entries{$_}{todo}=1; } my $cur_entry; +open my $diagfh, "<", "pod/perldiag.pod" + or die "Can't open pod/perldiag.pod: $!"; + while (<$diagfh>) { if (m/^=item (.*)/) { $cur_entry = $1; @@ -35,6 +69,7 @@ while (<$diagfh>) { } } +# Recursively descend looking for source files. my @todo = <*>; while (@todo) { my $todo = shift @todo; @@ -74,7 +109,9 @@ sub check_file { } next if /^#/; next if /^ * /; - while (m/\bDIE\b|Perl_(croak|die|warn(er)?)/ and not m/\);$/) { + + # Loop to accumulate the message text all on one line. + while (m/$source_msg_re/ and not m/\);$/) { my $nextline = <$codefh>; # Means we fell off the end of the file. Not terribly surprising; # this code tries to merge a lot of things that aren't regular C @@ -108,27 +145,28 @@ sub check_file { s/%"\s*$from/\%$specialformats{$from}"/g; } # The %"foo" thing needs to happen *before* this regex. - if (m/(?:DIE|Perl_(croak|die|warn|warner))(?:_nocontext)? \s* + if (m/$source_msg_re(?:_nocontext)? \s* \(aTHX_ \s* - (?:packWARN\d*\((.*?)\),)? \s* - "((?:\\"|[^"])*?)"/x) { - # diag($_); - # DIE is just return Perl_die - my $severity = {croak => [qw/P F/], + (?:packWARN\d*\((?.*?)\),)? \s* + "(?(?:\\"|[^"])*?)"/x) + { + # diag($_); + # DIE is just return Perl_die + my $severity = {croak => [qw/P F/], die => [qw/P F/], warn => [qw/W D S/], - }->{$1||'die'}; - my @categories; - if ($2) { - @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $2; - } - my $name; - if ($listed_as and $listed_as_line == $.) { + }->{$+{'routine'}||'die'}; + my @categories; + if ($+{'category'}) { + @categories = map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $+{'category'}; + } + my $name; + if ($listed_as and $listed_as_line == $.) { $name = $listed_as; - } else { - $name = $3; - # The form listed in perldiag ignores most sorts of fancy printf formatting, - # or makes it more perlish. + } else { + $name = $+{'text'}; + # The form listed in perldiag ignores most sorts of fancy printf + # formatting, or makes it more perlish. $name =~ s/%%/\\%/g; $name =~ s/%l[ud]/%d/g; $name =~ s/%\.(\d+|\*)s/\%s/g; @@ -155,7 +193,7 @@ sub check_file { if (exists $entries{$name}) { if ($entries{$name}{todo}) { TODO: { - no warnings 'once'; + no warnings 'once'; local $::TODO = 'in DATA'; fail("Presence of '$name' from $codefn line $."); } @@ -261,7 +299,10 @@ Goto undefined subroutine &%s Hash \%%s missing the \% in argument %d of %s() Illegal character \%03o (carriage return) Illegal character %sin prototype for %s : %s +Integer overflow in binary number Integer overflow in decimal number +Integer overflow in hexadecimal number +Integer overflow in octal number Integer overflow in version %d internal \%p might conflict with future printf extensions invalid control request: '\%03o' @@ -325,6 +366,7 @@ refcnt_inc: fd %d < 0 refcnt_inc: fd %d: %d <= 0 Reversed %c= operator Runaway prototype +%s(%.0 %s(%.0f) failed %s(%.0f) too large Scalar value %s better written as $%s diff --git a/universal.c b/universal.c index dec8505..3df8321 100644 --- a/universal.c +++ b/universal.c @@ -218,7 +218,7 @@ A specialised variant of C for emitting the usage message for xsubs works out the package name and subroutine name from C, and then calls C. Hence if C is C<&ouch::awk>, it would call C as: - Perl_croak(aTHX_ "Usage %s::%s(%s)", "ouch" "awk", "eee_yow"); + Perl_croak(aTHX_ "Usage: %s::%s(%s)", "ouch" "awk", "eee_yow"); =cut */