Skip to content

Commit 077b44c

Browse files
demerphqdemerphq
committed
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.
1 parent 60d3cb4 commit 077b44c

File tree

5 files changed

+59
-28
lines changed

5 files changed

+59
-28
lines changed

‎dquote.c‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -46,7 +46,7 @@ Perl_grok_bslash_c(pTHX_ const char source,
4646
const char control = toCTRL('{');
4747
if (isPRINT_A(control)) {
4848
/* diag_listed_as: Use "%s" instead of "%s" */
49-
*message = Perl_form(aTHX_ "Use \"%c\" instead of \"\\c{\"", control);
49+
*message = Perl_form(aTHX_ PERL_DIAG_DIE_SYNTAX("Use \"%c\" instead of \"\\c{\""), control);
5050
}
5151
else {
5252
*message = "Sequence \"\\c{\" invalid";
@@ -58,7 +58,7 @@ Perl_grok_bslash_c(pTHX_ const char source,
5858
if (isPRINT_A(*result) && ckWARN(WARN_SYNTAX)) {
5959
U8 clearer[3];
6060
U8 i = 0;
61-
char format[] = "\"\\c%c\" is more clearly written simply as \"%s\"";
61+
char format[] = PERL_DIAG_WARN_SYNTAX("\"\\c%c\" is more clearly written simply as \"%s\"");
6262

6363
if (! isWORDCHAR(*result)) {
6464
clearer[i++] = '\\';

‎op.c‎

Lines changed: 14 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1877,20 +1877,26 @@ Perl_warn_elem_scalar_context(pTHX_ const OP *o, SV *name, bool is_hash, bool is
18771877

18781878
if (keypv) {
18791879
msg = is_slice ?
1880-
"Scalar value @%" SVf "%c%s%c better written as $%" SVf "%c%s%c" :
1881-
"%%%" SVf "%c%s%c in scalar context better written as $%" SVf "%c%s%c";
1882-
/* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1883-
/* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1880+
/* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1881+
PERL_DIAG_WARN_SYNTAX(
1882+
"Scalar value @%" SVf "%c%s%c better written as $%" SVf "%c%s%c") :
1883+
/* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1884+
PERL_DIAG_WARN_SYNTAX(
1885+
"%%%" SVf "%c%s%c in scalar context better written as $%" SVf "%c%s%c");
1886+
18841887
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
18851888
SVfARG(name), lbrack, keypv, rbrack,
18861889
SVfARG(name), lbrack, keypv, rbrack);
18871890
}
18881891
else {
18891892
msg = is_slice ?
1890-
"Scalar value @%" SVf "%c%" SVf "%c better written as $%" SVf "%c%" SVf "%c" :
1891-
"%%%" SVf "%c%" SVf "%c in scalar context better written as $%" SVf "%c%" SVf "%c";
1892-
/* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1893-
/* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1893+
/* diag_listed_as: Scalar value @%s[%s] better written as $%s[%s] */
1894+
PERL_DIAG_WARN_SYNTAX(
1895+
"Scalar value @%" SVf "%c%" SVf "%c better written as $%" SVf "%c%" SVf "%c") :
1896+
/* diag_listed_as: %%s[%s] in scalar context better written as $%s[%s] */
1897+
PERL_DIAG_WARN_SYNTAX(
1898+
"%%%" SVf "%c%" SVf "%c in scalar context better written as $%" SVf "%c%" SVf "%c");
1899+
18941900
Perl_warner(aTHX_ packWARN(WARN_SYNTAX), msg,
18951901
SVfARG(name), lbrack, SVfARG(keysv), rbrack,
18961902
SVfARG(name), lbrack, SVfARG(keysv), rbrack);

‎os2/os2ish.h‎

Lines changed: 1 addition & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -192,7 +192,7 @@ extern int rc;
192192
# define pthread_setspecific(k,v) (*(k)=(v),0)
193193
# define pthread_key_create(keyp,flag) \
194194
( DosAllocThreadLocalMemory(1,(unsigned long**)keyp) \
195-
? Perl_croak_nocontext("LocalMemory"),1 \
195+
? Perl_croak_nocontext("Out of memory!"), 1 \
196196
: 0 \
197197
)
198198
#endif /* USE_SLOW_THREAD_SPECIFIC */
@@ -1239,4 +1239,3 @@ typedef struct {
12391239
PQTOPLEVEL get_sysinfo(ULONG pid, ULONG flags);
12401240

12411241
#endif /* _OS2_H */
1242-

‎perl.h‎

Lines changed: 18 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -8918,6 +8918,24 @@ END_EXTERN_C
89188918
/* ${^MAX_NESTED_EVAL_BEGIN_BLOCKS} */
89198919
#define PERL_VAR_MAX_NESTED_EVAL_BEGIN_BLOCKS "\015AX_NESTED_EVAL_BEGIN_BLOCKS"
89208920

8921+
/* Defines like this make it easier to do porting/diag.t. They are no-
8922+
* ops that return their argument which can be used to hint to diag.t
8923+
* that a string is actually an error message. By putting the category
8924+
* information into the macro name it considerably simplifies extended
8925+
* diag.t to support these cases. Feel free to add more.
8926+
*
8927+
* While it seems tempting to try to convert all of our diagnostics to
8928+
* this format, it would miss part of the point of diag.t in that it
8929+
* detects NEW diagnostics, which would not necessarily use these
8930+
* macros. The macros instead exist where we know we have an error
8931+
* message that isnt being picked up by diag.t because it is declared
8932+
* as a string independently of the function it is fed to, something
8933+
* diag.t can never handle right without help.
8934+
*/
8935+
#define PERL_DIAG_STR_(x) ("" x "")
8936+
#define PERL_DIAG_WARN_SYNTAX(x) PERL_DIAG_STR_(x)
8937+
#define PERL_DIAG_DIE_SYNTAX(x) PERL_DIAG_STR_(x)
8938+
89218939
/*
89228940
89238941
(KEEP THIS LAST IN perl.h!)

‎t/porting/diag.t‎

Lines changed: 24 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -8,7 +8,7 @@ use TestInit qw(T); # T is chdir to the top level
88
use warnings;
99
use strict;
1010
use Config;
11-
11+
use Data::Dumper;
1212
require './t/test.pl';
1313

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

4445
my $regcomp_fail_re = '\b(?:(?:Simple_)?v)?FAIL[2-4]?(?:utf8f)?\b';
4546
my $regcomp_re =
@@ -286,26 +287,26 @@ sub check_file {
286287
$listed_as_line = $.+1;
287288
}
288289
elsif (m</\*\s*diag_listed_as: (.*?)\s*\z>) {
289-
$listed_as = $1;
290-
my $finished;
290+
my $new_listed_as = $1;
291291
while (<$codefh>) {
292292
if (m<\*/>) {
293-
$listed_as .= $` =~ s/^\s*/ /r =~ s/\s+\z//r;
293+
$new_listed_as .= $` =~ s/^\s*/ /r =~ s/\s+\z//r;
294294
$listed_as_line = $.+1;
295-
$finished = 1;
295+
$listed_as= $new_listed_as;
296296
last;
297297
}
298298
else {
299-
$listed_as .= s/^\s*/ /r =~ s/\s+\z//r;
299+
$new_listed_as .= s/^\s*/ /r =~ s/\s+\z//r;
300300
}
301301
}
302-
if (!$finished) { $listed_as = undef }
303302
}
304303
next if /^#/;
305304

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

337338
# The %"foo" thing needs to happen *before* this regex.
338-
# diag($_);
339+
#diag(">$_<");
339340
# DIE is just return Perl_die
340-
my ($name, $category, $routine);
341+
my ($name, $category, $routine, $wrapper);
341342
if (/\b$source_msg_call_re/) {
342-
($name, $category, $routine) = ($+{'text'}, $+{'category'}, $+{'routine'});
343+
($name, $category, $routine, $wrapper) = ($+{'text'}, $+{'category'}, $+{'routine'}, $+{'wrapper'});
344+
if ($wrapper) {
345+
$category = $wrapper if $wrapper=~/WARN/;
346+
$routine = "Perl_warner" if $wrapper=~/WARN/;
347+
$routine = "yyerror" if $wrapper=~/DIE/;
348+
}
349+
# diag(Dumper(\%+,{category=>$category, routine=>$routine, name=>$name}));
343350
# Sometimes the regexp will pick up too much for the category
344351
# e.g., WARN_UNINITIALIZED), PL_warn_uninit_sv ... up to the next )
345352
$category && $category =~ s/\).*//s;
@@ -394,8 +401,9 @@ sub check_file {
394401
join ", ",
395402
sort map {s/^WARN_//; lc $_} split /\s*[|,]\s*/, $category;
396403
}
397-
if ($listed_as and $listed_as_line == $. - $multiline) {
404+
if ($listed_as) {
398405
$name = $listed_as;
406+
undef $listed_as;
399407
} else {
400408
# The form listed in perldiag ignores most sorts of fancy printf
401409
# formatting, or makes it more perlish.
@@ -479,13 +487,13 @@ sub check_message {
479487
my $qr = $qrs{$severity} ||= qr/$severity/;
480488

481489
like($entries{$key}{severity}, $qr,
482-
$severity =~ /\[/
483-
? "severity is one of $severity for $key"
484-
: "severity is $severity for $key");
490+
($severity =~ /\[/
491+
? "severity is one of $severity"
492+
: "severity is $severity") . "for '$name' at $codefn line $.");
485493

486494
is($entries{$key}{category}, $categories,
487495
($categories ? "categories are [$categories]" : "no category")
488-
. " for $key");
496+
. " for '$name' at $codefn line $.");
489497
}
490498
} elsif ($partial) {
491499
# noop

0 commit comments

Comments
 (0)