This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
porting/diag.t: Allow nested =item's
[perl5.git] / t / porting / diag.t
diff --git a/t/porting/diag.t b/t/porting/diag.t
index 00a317d..b892dfa 100644 (file)
--- a/t/porting/diag.t
+++ b/t/porting/diag.t
@@ -7,8 +7,14 @@ use TestInit qw(T); # T is chdir to the top level
 
 use warnings;
 use strict;
 
 use warnings;
 use strict;
+use Config;
+
+require './t/test.pl';
+
+if ( $Config{usecrosscompile} ) {
+  skip_all( "Not all files are available during cross-compilation" );
+}
 
 
-require 't/test.pl';
 plan('no_plan');
 
 # --make-exceptions-list outputs the list of strings that don't have
 plan('no_plan');
 
 # --make-exceptions-list outputs the list of strings that don't have
@@ -20,7 +26,7 @@ plan('no_plan');
 my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list'
   and shift;
 
 my $make_exceptions_list = ($ARGV[0]||'') eq '--make-exceptions-list'
   and shift;
 
-require 'regen/embed_lib.pl';
+require './regen/embed_lib.pl';
 
 # Look for functions that look like they could be diagnostic ones.
 my @functions;
 
 # Look for functions that look like they could be diagnostic ones.
 my @functions;
@@ -33,6 +39,7 @@ foreach (@{(setup_embed())[0]}) {
   push @functions, 'Perl_' . $_->[2] if $_->[0] =~ /p/;
   push @functions, 'S_' . $_->[2] if $_->[0] =~ /s/;
 };
   push @functions, 'Perl_' . $_->[2] if $_->[0] =~ /p/;
   push @functions, 'S_' . $_->[2] if $_->[0] =~ /s/;
 };
+push @functions, 'Perl_mess';
 
 my $regcomp_fail_re = '\b(?:(?:Simple_)?v)?FAIL[2-4]?(?:utf8f)?\b';
 my $regcomp_re =
 
 my $regcomp_fail_re = '\b(?:(?:Simple_)?v)?FAIL[2-4]?(?:utf8f)?\b';
 my $regcomp_re =
@@ -42,7 +49,7 @@ my $source_msg_re =
    "(?<routine>\\bDIE\\b|$function_re)";
 my $text_re = '"(?<text>(?:\\\\"|[^"]|"\s*[A-Z_]+\s*")*)"';
 my $source_msg_call_re = qr/$source_msg_re(?:_nocontext)? \s*
    "(?<routine>\\bDIE\\b|$function_re)";
 my $text_re = '"(?<text>(?:\\\\"|[^"]|"\s*[A-Z_]+\s*")*)"';
 my $source_msg_call_re = qr/$source_msg_re(?:_nocontext)? \s*
-    \((?:aTHX_)? \s*
+    \( (?: \s* Perl_form \( )? (?:aTHX_)? \s*
     (?:packWARN\d*\((?<category>.*?)\),)? \s*
     $text_re /x;
 my $bad_version_re = qr{BADVERSION\([^"]*$text_re};
     (?:packWARN\d*\((?<category>.*?)\),)? \s*
     $text_re /x;
 my $bad_version_re = qr{BADVERSION\([^"]*$text_re};
@@ -69,7 +76,20 @@ my $category_re = qr/ [a-z0-9_:]+?/;    # Note: requires an initial space
 my $severity_re = qr/ . (?: \| . )* /x; # A severity is a single char, but can
                                         # be of the form 'S|P|W'
 my @same_descr;
 my $severity_re = qr/ . (?: \| . )* /x; # A severity is a single char, but can
                                         # be of the form 'S|P|W'
 my @same_descr;
+my $depth = 0;
 while (<$diagfh>) {
 while (<$diagfh>) {
+  if (m/^=over/) {
+    $depth++;
+    next;
+  }
+  if (m/^=back/) {
+    $depth--;
+    next;
+  }
+
+  # Stuff deeper than main level is ignored
+  next if $depth != 1;
+
   if (m/^=item (.*)/) {
     $cur_entry = $1;
 
   if (m/^=item (.*)/) {
     $cur_entry = $1;
 
@@ -84,6 +104,10 @@ while (<$diagfh>) {
 
     $cur_entry =~ s/\n/ /gs; # Fix multi-line headers if they have \n's
     $cur_entry =~ s/\s+\z//;
 
     $cur_entry =~ s/\n/ /gs; # Fix multi-line headers if they have \n's
     $cur_entry =~ s/\s+\z//;
+    $cur_entry =~ s/E<lt>/</g;
+    $cur_entry =~ s/E<gt>/>/g;
+    $cur_entry =~ s,E<sol>,/,g;
+    $cur_entry =~ s/[BCIFS](?:<<< (.*?) >>>|<< (.*?) >>|<(.*?)>)/$+/g;
 
     if (exists $entries{$cur_entry} &&  $entries{$cur_entry}{todo}
                                     && !$entries{$cur_entry}{cattodo}) {
 
     if (exists $entries{$cur_entry} &&  $entries{$cur_entry}{todo}
                                     && !$entries{$cur_entry}{cattodo}) {
@@ -130,6 +154,11 @@ while (<$diagfh>) {
   }
 }
 
   }
 }
 
+if ($depth != 0) {
+    diag ("Unbalance =over/=back.  Fix before proceeding; over - back = " . $depth);
+    exit(1);
+}
+
 foreach my $cur_entry ( keys %entries) {
     next if $entries{$cur_entry}{todo}; # If in this file, won't have a severity
     if (! exists $entries{$cur_entry}{severity}
 foreach my $cur_entry ( keys %entries) {
     next if $entries{$cur_entry}{todo}; # If in this file, won't have a severity
     if (! exists $entries{$cur_entry}{severity}
@@ -167,7 +196,8 @@ my %specialformats = (IVdf => 'd',
                      UTF8f=> 's',
                      SVf256=>'s',
                      SVf32=> 's',
                      UTF8f=> 's',
                      SVf256=>'s',
                      SVf32=> 's',
-                     SVf  => 's');
+                     SVf  => 's',
+                     PNf  => 's');
 my $format_modifiers = qr/ [#0\ +-]*              # optional flags
                          (?: [1-9][0-9]* | \* )? # optional field width
                          (?: \. \d* )?           # optional precision
 my $format_modifiers = qr/ [#0\ +-]*              # optional flags
                          (?: [1-9][0-9]* | \* )? # optional field width
                          (?: \. \d* )?           # optional precision
@@ -188,7 +218,7 @@ while (my $file = <$fh>) {
     $file =~ s/\s+.*//;
     next unless $file =~ /\.(?:c|cpp|h|xs|y)\z/ or $file =~ /^perly\./;
     # OS/2 extensions have never been migrated to ext/, hence the special case:
     $file =~ s/\s+.*//;
     next unless $file =~ /\.(?:c|cpp|h|xs|y)\z/ or $file =~ /^perly\./;
     # OS/2 extensions have never been migrated to ext/, hence the special case:
-    next if $file =~ m!\A(?:ext|dist|cpan|lib|t|os2/OS2|x2p)/!
+    next if $file =~ m!\A(?:ext|dist|cpan|lib|t|os2/OS2)/!
             && $file !~ m!\Aext/DynaLoader/!;
     check_file($file);
 }
             && $file !~ m!\Aext/DynaLoader/!;
     check_file($file);
 }
@@ -236,12 +266,28 @@ sub check_file {
       $listed_as = $1;
       $listed_as_line = $.+1;
     }
       $listed_as = $1;
       $listed_as_line = $.+1;
     }
+    elsif (m</\*\s*diag_listed_as: (.*?)\s*\z>) {
+      $listed_as = $1;
+      my $finished;
+      while (<$codefh>) {
+        if (m<\*/>) {
+          $listed_as .= $` =~ s/^\s*/ /r =~ s/\s+\z//r;
+          $listed_as_line = $.+1;
+          $finished = 1;
+          last;
+        }
+        else {
+          $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*\(/) {
     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*\(/) {
-      while (not m/\);$/) {
+      while (not m/\);\s*$/) {
         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
         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
@@ -277,6 +323,8 @@ sub check_file {
       # 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;
       # 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;
+      # Special-case yywarn
+      /yywarn/ and $category = 'syntax';
       if (/win32_croak_not_implemented\(/) {
         $name .= " not implemented!"
       }
       if (/win32_croak_not_implemented\(/) {
         $name .= " not implemented!"
       }
@@ -476,7 +524,6 @@ Can't fix broken locale name "%s"
 Can't get short module name from a handle
 Can't load DLL `%s', possible problematic module `%s'
 Can't locate %s:   %s
 Can't get short module name from a handle
 Can't load DLL `%s', possible problematic module `%s'
 Can't locate %s:   %s
-Can't locate object method "%s" via package "%s" (perhaps you forgot to load "%s"?)
 Can't pipe "%s": %s
 Can't set type on DOS
 Can't spawn: %s
 Can't pipe "%s": %s
 Can't set type on DOS
 Can't spawn: %s
@@ -590,6 +637,7 @@ Not array reference given to mod2fname
 Operator or semicolon missing before %c%s
 Out of memory during list extend
 panic queryaddr
 Operator or semicolon missing before %c%s
 Out of memory during list extend
 panic queryaddr
+Parse error
 PerlApp::TextQuery: no arguments, please
 POSIX syntax [%c %c] is reserved for future extensions in regex; marked by <-- HERE in m/%s/
 ptr wrong %p != %p fl=%x nl=%p e=%p for %d
 PerlApp::TextQuery: no arguments, please
 POSIX syntax [%c %c] is reserved for future extensions in regex; marked by <-- HERE in m/%s/
 ptr wrong %p != %p fl=%x nl=%p e=%p for %d
@@ -626,7 +674,6 @@ sv_2iv assumed (U_V(fabs((double)SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%f U_V
 switching effective gid is not implemented
 switching effective uid is not implemented
 System V IPC is not implemented on this machine
 switching effective gid is not implemented
 switching effective uid is not implemented
 System V IPC is not implemented on this machine
--T and -B not implemented on filehandles
 Terminating on signal SIG%s(%d)
 The crypt() function is not implemented on NetWare
 The flock() function is not implemented on NetWare
 Terminating on signal SIG%s(%d)
 The crypt() function is not implemented on NetWare
 The flock() function is not implemented on NetWare
@@ -644,7 +691,9 @@ Unexpected program mode %d when morphing back from PM
 Unrecognized character %s; marked by <-- HERE after %s<-- HERE near column %d
 Unstable directory path, current directory changed unexpectedly
 Unterminated compressed integer in unpack
 Unrecognized character %s; marked by <-- HERE after %s<-- HERE near column %d
 Unstable directory path, current directory changed unexpectedly
 Unterminated compressed integer in unpack
+Usage: %s(%s)
 Usage: %s::%s(%s)
 Usage: %s::%s(%s)
+Usage: CODE(0x%x)(%s)
 Usage: File::Copy::rmscopy(from,to[,date_flag])
 Usage: VMS::Filespec::candelete(spec)
 Usage: VMS::Filespec::fileify(spec)
 Usage: File::Copy::rmscopy(from,to[,date_flag])
 Usage: VMS::Filespec::candelete(spec)
 Usage: VMS::Filespec::fileify(spec)
@@ -656,7 +705,6 @@ Usage: VMS::Filespec::unixrealpath(spec)
 Usage: VMS::Filespec::vmsify(spec)
 Usage: VMS::Filespec::vmspath(spec)
 Usage: VMS::Filespec::vmsrealpath(spec)
 Usage: VMS::Filespec::vmsify(spec)
 Usage: VMS::Filespec::vmspath(spec)
 Usage: VMS::Filespec::vmsrealpath(spec)
-Use of inherited AUTOLOAD for non-method %s::%s() is deprecated
 utf8 "\x%X" does not map to Unicode
 Value of logical "%s" too long. Truncating to %i bytes
 waitpid: process %x is not a child of process %x
 utf8 "\x%X" does not map to Unicode
 Value of logical "%s" too long. Truncating to %i bytes
 waitpid: process %x is not a child of process %x
@@ -672,13 +720,12 @@ Wrong syntax (suid) fd script name "%s"
 'X' outside of string in unpack
 
 __CATEGORIES__
 'X' outside of string in unpack
 
 __CATEGORIES__
-Code point 0x%X is not Unicode, all \p{} matches fail; all \P{} matches succeed
-Code point 0x%X is not Unicode, may not be portable
+
+# This is a warning, but is currently followed immediately by a croak (toke.c)
 Illegal character \%o (carriage return)
 Illegal character \%o (carriage return)
+
+# Because uses WARN_MISSING as a synonym for WARN_UNINITIALIZED (sv.c)
 Missing argument in %s
 Missing argument in %s
-Unicode non-character U+%X is illegal for open interchange
-Operation "%s" returns its argument for non-Unicode code point 0x%X
-Operation "%s" returns its argument for UTF-16 surrogate U+%X
-Unicode surrogate U+%X is illegal in UTF-8
-UTF-16 surrogate U+%X
+
+# This message can be both fatal and non-
 False [] range "%s" in regex; marked by <-- HERE in m/%s/
 False [] range "%s" in regex; marked by <-- HERE in m/%s/
Unnamed repository; edit this file 'description' to name the repository.