From 077b44c7321d21b70dfdc26bc03d96b62d785cb8 Mon Sep 17 00:00:00 2001 From: Yves Orton Date: Mon, 5 Sep 2022 12:05:16 +0200 Subject: [PATCH] porting/diag.t - improved parsing a bit 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. --- dquote.c | 4 ++-- op.c | 22 ++++++++++++++-------- os2/os2ish.h | 3 +-- perl.h | 18 ++++++++++++++++++ t/porting/diag.t | 40 ++++++++++++++++++++++++---------------- 5 files changed, 59 insertions(+), 28 deletions(-) diff --git a/dquote.c b/dquote.c index e0c56228a98c..e2c03f64eb33 100644 --- a/dquote.c +++ b/dquote.c @@ -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"; @@ -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++] = '\\'; diff --git a/op.c b/op.c index e51c03cd9c65..9de2326488e2 100644 --- a/op.c +++ b/op.c @@ -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); diff --git a/os2/os2ish.h b/os2/os2ish.h index 0f80a4ddca00..83528feee8e8 100644 --- a/os2/os2ish.h +++ b/os2/os2ish.h @@ -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 */ @@ -1239,4 +1239,3 @@ typedef struct { PQTOPLEVEL get_sysinfo(ULONG pid, ULONG flags); #endif /* _OS2_H */ - diff --git a/perl.h b/perl.h index fa7bbd76ecb7..25f422365f17 100644 --- a/perl.h +++ b/perl.h @@ -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!) diff --git a/t/porting/diag.t b/t/porting/diag.t index 268993e1cdde..3f56e9201bf8 100644 --- a/t/porting/diag.t +++ b/t/porting/diag.t @@ -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} ) { @@ -40,6 +40,7 @@ foreach (@{(setup_embed())[0]}) { push @functions, 'S_' . $_->[2] if $_->[0] =~ /S/; }; push @functions, 'Perl_mess'; +push @functions, 'PERL_DIAG_(?\w+)'; my $regcomp_fail_re = '\b(?:(?:Simple_)?v)?FAIL[2-4]?(?:utf8f)?\b'; my $regcomp_re = @@ -286,26 +287,26 @@ sub check_file { $listed_as_line = $.+1; } elsif (m) { - $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*\((?(?:[^()]+|\([^()]+\))+\))?/ + and !$+{tail} + ) { while (not m/\);\s*$/) { my $nextline = <$codefh>; # Means we fell off the end of the file. Not terribly surprising; @@ -335,11 +336,17 @@ sub check_file { s/ (?$_<"); # 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; @@ -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. @@ -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