Skip to content

Commit

Permalink
porting/diag.t - improved parsing a bit
Browse files Browse the repository at this point in the history 
The "multiline" logic of diag.t was getting confused by define
statements that would define a symbol to call an error function but not
end in ";", this would then slurp potentially many lines errorenously,
potentially absorbing more than one message. The multi-line logic also
would undef $listed_as and lose the diag_listed_as data in some
circumstances.

Fixing those issues revealed some interesting cases. To fix one of them
I defined a new noop macro in perl.h to help: PERL_DIAG_WARN_SYNTAX(),
which helps the diag.t parser identify messages without needing to be
actually part of a specific message line. These macros are noops, they
just return their argument, but they help hint to diag.t what is going
on. Maybe in the future this can be reworked to be more generic, there
are other similar cases that are not covered.

Interestingly fixing this bug meant that at least one message that used
to be erroneously picked up was no longer identified or tested. This was
replaced with a PERL_DIAG_DIE_SYNTAX() wrapper.
  • Loading branch information
@demerphq
demerphq committed Sep 8, 2022
1 parent 60d3cb4 commit 077b44c
Show file tree
Hide file tree
Showing 5 changed files with 59 additions and 28 deletions.
4 changes: 2 additions & 2 deletions dquote.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,7 +46,7 @@ Perl_grok_bslash_c(pTHX_ const char source,
const char control = toCTRL('{');
if (isPRINT_A(control)) {
/* diag_listed_as: Use "%s" instead of "%s" */
*message = Perl_form(aTHX_ "Use \"%c\" instead of \"\\c{\"", control);
*message = Perl_form(aTHX_ PERL_DIAG_DIE_SYNTAX("Use \"%c\" instead of \"\\c{\""), control);
}
else {
*message = "Sequence \"\\c{\" invalid";
Expand All @@ -58,7 +58,7 @@ Perl_grok_bslash_c(pTHX_ const char source,
if (isPRINT_A(*result) && ckWARN(WARN_SYNTAX)) {
U8 clearer[3];
U8 i = 0;
char format[] = "\"\\c%c\" is more clearly written simply as \"%s\"";
char format[] = PERL_DIAG_WARN_SYNTAX("\"\\c%c\" is more clearly written simply as \"%s\"");

if (! isWORDCHAR(*result)) {
clearer[i++] = '\\';
Expand Down
22 changes: 14 additions & 8 deletions op.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -1877,20 +1877,26 @@ Perl_warn_elem_scalar_context(pTHX_ const OP *o, SV *name, bool is_hash, bool is

if (keypv) {
msg = is_slice ?
"Scalar value @%" SVf "%c%s%c better written as $%" SVf "%c%s%c" :
"%%%" SVf "%c%s%c in scalar context better written as $%" SVf "%c%s%c";
/* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
/* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
/* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
PERL_DIAG_WARN_SYNTAX(
"Scalar value @%" SVf "%c%s%c better written as $%" SVf "%c%s%c") :
/* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
PERL_DIAG_WARN_SYNTAX(
"%%%" SVf "%c%s%c in scalar context better written as $%" SVf "%c%s%c");

Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
SVfARG(name), lbrack, keypv, rbrack,
SVfARG(name), lbrack, keypv, rbrack);
}
else {
msg = is_slice ?
"Scalar value @%" SVf "%c%" SVf "%c better written as $%" SVf "%c%" SVf "%c" :
"%%%" SVf "%c%" SVf "%c in scalar context better written as $%" SVf "%c%" SVf "%c";
/* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
/* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
/* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
PERL_DIAG_WARN_SYNTAX(
"Scalar value @%" SVf "%c%" SVf "%c better written as $%" SVf "%c%" SVf "%c") :
/* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
PERL_DIAG_WARN_SYNTAX(
"%%%" SVf "%c%" SVf "%c in scalar context better written as $%" SVf "%c%" SVf "%c");

Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
SVfARG(name), lbrack, SVfARG(keysv), rbrack,
SVfARG(name), lbrack, SVfARG(keysv), rbrack);
Expand Down
3 changes: 1 addition & 2 deletions os2/os2ish.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -192,7 +192,7 @@ extern int rc;
# define pthread_setspecific(k,v) (*(k)=(v),0)
# define pthread_key_create(keyp,flag) \
( DosAllocThreadLocalMemory(1,(unsigned long**)keyp) \
? Perl_croak_nocontext("LocalMemory"),1 \
? Perl_croak_nocontext("Out of memory!"), 1 \
: 0 \
)
#endif /* USE_SLOW_THREAD_SPECIFIC */
Expand Down Expand Up @@ -1239,4 +1239,3 @@ typedef struct {
PQTOPLEVEL get_sysinfo(ULONG pid, ULONG flags);

#endif /* _OS2_H */

18 changes: 18 additions & 0 deletions perl.h
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8918,6 +8918,24 @@ END_EXTERN_C
/* ${^MAX_NESTED_EVAL_BEGIN_BLOCKS} */
#define PERL_VAR_MAX_NESTED_EVAL_BEGIN_BLOCKS "\015AX_NESTED_EVAL_BEGIN_BLOCKS"

/* Defines like this make it easier to do porting/diag.t. They are no-
* ops that return their argument which can be used to hint to diag.t
* that a string is actually an error message. By putting the category
* information into the macro name it considerably simplifies extended
* diag.t to support these cases. Feel free to add more.
*
* While it seems tempting to try to convert all of our diagnostics to
* this format, it would miss part of the point of diag.t in that it
* detects NEW diagnostics, which would not necessarily use these
* macros. The macros instead exist where we know we have an error
* message that isnt being picked up by diag.t because it is declared
* as a string independently of the function it is fed to, something
* diag.t can never handle right without help.
*/
#define PERL_DIAG_STR_(x) ("" x "")
#define PERL_DIAG_WARN_SYNTAX(x) PERL_DIAG_STR_(x)
#define PERL_DIAG_DIE_SYNTAX(x) PERL_DIAG_STR_(x)

/*
(KEEP THIS LAST IN perl.h!)
Expand Down
40 changes: 24 additions & 16 deletions t/porting/diag.t
View file
Original file line number Diff line number Diff line change
Expand Up @@ -8,7 +8,7 @@ use TestInit qw(T); # T is chdir to the top level
use warnings;
use strict;
use Config;

use Data::Dumper;
require './t/test.pl';

if ( $Config{usecrosscompile} ) {
Expand Down Expand Up @@ -40,6 +40,7 @@ foreach (@{(setup_embed())[0]}) {
push @functions, 'S_' . $_->[2] if $_->[0] =~ /S/;
};
push @functions, 'Perl_mess';
push @functions, 'PERL_DIAG_(?<wrapper>\w+)';

my $regcomp_fail_re = '\b(?:(?:Simple_)?v)?FAIL[2-4]?(?:utf8f)?\b';
my $regcomp_re =
Expand Down Expand Up @@ -286,26 +287,26 @@ sub check_file {
$listed_as_line = $.+1;
}
elsif (m</\*\s*diag_listed_as: (.*?)\s*\z>) {
$listed_as = $1;
my $finished;
my $new_listed_as = $1;
while (<$codefh>) {
if (m<\*/>) {
$listed_as .= $` =~ s/^\s*/ /r =~ s/\s+\z//r;
$new_listed_as .= $` =~ s/^\s*/ /r =~ s/\s+\z//r;
$listed_as_line = $.+1;
$finished = 1;
$listed_as= $new_listed_as;
last;
}
else {
$listed_as .= s/^\s*/ /r =~ s/\s+\z//r;
$new_listed_as .= s/^\s*/ /r =~ s/\s+\z//r;
}
}
if (!$finished) { $listed_as = undef }
}
next if /^#/;

my $multiline = 0;
# Loop to accumulate the message text all on one line.
if (m/(?!^)\b(?:$source_msg_re(?:_nocontext)?|$regcomp_re)\s*\(/) {
if (m/(?!^)\b(?:$source_msg_re(?:_nocontext)?|$regcomp_re)\s*\((?<tail>(?:[^()]+|\([^()]+\))+\))?/
and !$+{tail}
) {
while (not m/\);\s*$/) {
my $nextline = <$codefh>;
# Means we fell off the end of the file. Not terribly surprising;
Expand Down Expand Up @@ -335,11 +336,17 @@ sub check_file {
s/ (?<!%) % $format_modifiers ( [dioxXucsfeEgGp] ) /%$1/xg;

# The %"foo" thing needs to happen *before* this regex.
# diag($_);
#diag(">$_<");
# DIE is just return Perl_die
my ($name, $category, $routine);
my ($name, $category, $routine, $wrapper);
if (/\b$source_msg_call_re/) {
($name, $category, $routine) = ($+{'text'}, $+{'category'}, $+{'routine'});
($name, $category, $routine, $wrapper) = ($+{'text'}, $+{'category'}, $+{'routine'}, $+{'wrapper'});
if ($wrapper) {
$category = $wrapper if $wrapper=~/WARN/;
$routine = "Perl_warner" if $wrapper=~/WARN/;
$routine = "yyerror" if $wrapper=~/DIE/;
}
# diag(Dumper(\%+,{category=>$category, routine=>$routine, name=>$name}));
# Sometimes the regexp will pick up too much for the category
# e.g., WARN_UNINITIALIZED), PL_warn_uninit_sv ... up to the next )
$category && $category =~ s/\).*//s;
Expand Down Expand Up @@ -394,8 +401,9 @@ sub check_file {
join ", ",
sort map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
}
if ($listed_as and $listed_as_line == $. - $multiline) {
if ($listed_as) {
$name = $listed_as;
undef $listed_as;
} else {
# The form listed in perldiag ignores most sorts of fancy printf
# formatting, or makes it more perlish.
Expand Down Expand Up @@ -479,13 +487,13 @@ sub check_message {
my $qr = $qrs{$severity} ||= qr/$severity/;

like($entries{$key}{severity}, $qr,
$severity =~ /\[/
? "severity is one of $severity for $key"
: "severity is $severity for $key");
($severity =~ /\[/
? "severity is one of $severity"
: "severity is $severity") . "for '$name' at $codefn line $.");

is($entries{$key}{category}, $categories,
($categories ? "categories are [$categories]" : "no category")
. " for $key");
. " for '$name' at $codefn line $.");
}
} elsif ($partial) {
# noop
Expand Down

0 comments on commit 077b44c

Please sign in to comment.