This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
diagnostics.pm; Enhance to accept nested lists
authorKarl Williamson <khw@cpan.org>
Wed, 15 Jun 2016 18:51:39 +0000 (12:51 -0600)
committerKarl Williamson <khw@cpan.org>
Fri, 17 Jun 2016 18:45:20 +0000 (12:45 -0600)
Prior to this patch, this module assumed every =item was for a
diagnostic.  Now it keeps track, and so a given diagnostic can have a
list within it.

lib/diagnostics.pm
lib/diagnostics.t

index 40c6748..731b1a0 100644 (file)
@@ -186,7 +186,7 @@ use 5.009001;
 use Carp;
 $Carp::Internal{__PACKAGE__.""}++;
 
-our $VERSION = '1.34';
+our $VERSION = '1.35';
 our $DEBUG;
 our $VERBOSE;
 our $PRETTY;
@@ -310,6 +310,7 @@ sub transmo {
 EOFUNC
 
 my %msg;
+my $over_level = 0;     # We look only at =item lines at the first =over level
 {
     print STDERR "FINISHING COMPILATION for $_\n" if $DEBUG;
     local $/ = '';
@@ -386,7 +387,7 @@ my %msg;
            push @headers, $header if defined $header;
        }
 
-       unless ( s/=item (.*?)\s*\z//s) {
+       if ( ! s/=item (.*?)\s*\z//s || $over_level != 1) {
 
            if ( s/=head1\sDESCRIPTION//) {
                $msg{$header = 'DESCRIPTION'} = '';
@@ -395,11 +396,17 @@ my %msg;
            elsif( s/^=for\s+diagnostics\s*\n(.*?)\s*\z// ) {
                $for_item = $1;
            }
-           elsif( /^=back/ ) { # Stop processing body here
-               undef $header;
-               undef $for_item;
-               $seen_body = 0;
-               next;
+           elsif( /^=over\b/ ) {
+                $over_level++;
+            }
+           elsif( /^=back\b/ ) { # Stop processing body here
+                $over_level--;
+                if ($over_level == 0) {
+                    undef $header;
+                    undef $for_item;
+                    $seen_body = 0;
+                    next;
+                }
            }
            next;
        }
index 0b35d16..6521df2 100644 (file)
@@ -4,7 +4,7 @@ BEGIN {
     chdir '..' if -d '../pod' && -d '../t';
     @INC = 'lib';
     require './t/test.pl';
-    plan(29);
+    plan(31);
 }
 
 BEGIN {
@@ -144,17 +144,30 @@ like $warning,
 {
 # Find last warning in perldiag.pod, and last items if any
     my $lw;
+    my $over_level = 0;
     my $inlast;
     my $item;
+    my $items_not_in_overs = 0;
 
     open(my $f, '<', "pod/perldiag.pod")
         or die "failed to open pod/perldiag.pod for reading: $!";
 
     while (<$f>) {
-        if ( /^=item\s+(.*)/) {
-            $lw = $1;
-        } elsif (/^=back/) {
-           $inlast = 1;
+
+        # We only look for entries (=item lines) in the first level of =overs
+
+        if ( /^=over\b/) {
+            $over_level++;
+        } elsif ( /^=item\s+(.*)/) {
+            if ($over_level < 1) {
+                $items_not_in_overs++;
+            }
+            elsif ($over_level == 1) {
+                $lw = $1;
+            }
+        } elsif (/^=back\b/) {
+           $inlast = 1 if $over_level == 1;
+            $over_level--;
         } elsif ($inlast) {
             # Skip headings
             next if /^=/;
@@ -174,6 +187,8 @@ like $warning,
     }
     close($f);
 
+    is($over_level, 0, "(sanity...) =over balanced with =back (off by $over_level)");
+    is($items_not_in_overs, 0, "(sanity...) all =item lines are within =over..=back blocks");
     ok($item, "(sanity...) found an item to check with ($item)");
     seek STDERR, 0,0;
     $warning = '';