fix NAME of perl5125delta.pod

[perl5.git] / t / porting / podcheck.t

diff --git a/t/porting/podcheck.t b/t/porting/podcheck.t
index 1ea1e6b..4cea599 100644 (file)
--- a/t/porting/podcheck.t
+++ b/t/porting/podcheck.t
@@ -399,6 +399,8 @@ my $non_pods = qr/ (?: \.
                            | $lib_ext # object libraries
                            | $lib_so  # shared libraries
                            | $dl_ext  # dynamic libraries
+                           | gif      # GIF images (example files from CGI.pm)
+                           | eg       # examples from libnet
                        )
                        $
                     ) | ~$ | \ \(Autosaved\)\.txt$ # Other editor droppings
@@ -456,7 +458,8 @@ sub suppressed {
 
     sub plan {
         my %plan = @_;
-        $planned = $plan{tests};
+        $planned = $plan{tests} + 1;    # +1 for final test that files haven't
+                                        # been removed
         print "1..$planned\n";
         return;
     }
@@ -470,7 +473,7 @@ sub suppressed {
         $current_test++;
         print "not " unless $success;
         print "ok $current_test - $message\n";
-        return;
+        return $success;
     }
 
     sub skip {
@@ -1034,6 +1037,27 @@ package My::Pod::Checker {      # Extend Pod::Checker
         delete $problems{$self->get_filename};
         return;
     }
+
+    sub parse_from_file {
+        # This overrides the super class method so that if an open fails on a
+        # transitory file, it doesn't croak.  It returns 1 if it did find the
+        # file, 0 if it didn't
+
+        my $self = shift;
+        my $filename = shift;
+        # ignores 2nd param, which is output file.  Always uses undef
+
+        if (open my $in_fh, '<:bytes', $filename) {
+            $self->SUPER::parse_from_filehandle($in_fh, undef);
+            close $in_fh;
+            return 1;
+        }
+
+        # If couldn't open file, perhaps it was transitory, and hence not an error
+        return 0 unless -e $filename;
+
+        die "Can't open '$filename': $!\n";
+    }
 }
 
 package Tie_Array_to_FH {  # So printing actually goes to an array
@@ -1237,11 +1261,11 @@ sub extract_pod {   # Extracts just the pod from a file; returns undef if file
     # look at instead of being printed
     tie *ALREADY_FH, 'Tie_Array_to_FH', \@pod;
     if (open my $in_fh, '<:bytes', $filename) {
-    my $parser = Pod::Parser->new();
-    $parser->parse_from_filehandle($in_fh, *ALREADY_FH);
-    close $in_fh;
+        my $parser = Pod::Parser->new();
+        $parser->parse_from_filehandle($in_fh, *ALREADY_FH);
+        close $in_fh;
 
-    return join "", @pod
+        return join "", @pod
     }
 
     # The file should already have been opened once to get here, so if that
@@ -1254,13 +1278,15 @@ sub extract_pod {   # Extracts just the pod from a file; returns undef if file
 
 my $digest = Digest->new($digest_type);
 
+# This is used as a callback from File::Find::find(), which always constructs
+# pathnames using Unix separators
 sub is_pod_file {
     # If $_ is a pod file, add it to the lists and do other prep work.
 
     if (-d) {
         # Don't look at files in directories that are for tests, nor those
         # beginning with a dot
-        if ($_ eq 't' || $_ =~ /^\../) {
+        if (m!/t\z! || m!/\.!) {
             $File::Find::prune = 1;
         }
         return;
@@ -1270,8 +1296,9 @@ sub is_pod_file {
                                # check if 0 length
     return unless -f || -l;    # Weird file types won't be pods
 
-    if ($_ =~ /^\./           # No hidden Unix files
-        || $_ =~ $non_pods) {
+    my ($leaf) = m!([^/]+)\z!;
+    if (m!/\.!                 # No hidden Unix files
+        || $leaf =~ $non_pods) {
         note("Not considering $_") if DEBUG;
         return;
     }
@@ -1279,8 +1306,7 @@ sub is_pod_file {
     my $filename = $File::Find::name;
 
     # $filename is relative, like './path'.  Strip that initial part away.
-    # Assumes that the path separator is exactly one character.
-    $filename =~ s/^\..//;
+    $filename =~ s!^\./!! or die 'Unexpected pathname "$filename"';
 
     return if $excluded_files{canonicalize($filename)};
 
@@ -1395,7 +1421,7 @@ else { # No input files -- go find all the possibilities.
     chdir File::Spec->updir;
 
     # And look in this directory and all its subdirectories
-    find( \&is_pod_file, '.');
+    find( {wanted => \&is_pod_file, no_chdir => 1}, '.');
 
     # Add ourselves to the test
     push @files, "t/porting/podcheck.t";
@@ -1467,8 +1493,12 @@ foreach my $filename (@files) {
     # We have set the name in the checker object if there is a possibility
     # that no further parsing is necessary, but otherwise do the parsing now.
     if (! $checker->name) {
+        if (! $checker->parse_from_file($filename, undef)) {
+            $checker->set_skip("$filename is transitory");
+            next FILE;
+        }
         $parsed = 1;
-        $checker->parse_from_file($filename, undef);
+
     }
 
     if ($checker->num_errors() < 0) {   # Returns negative if not a pod
@@ -1620,8 +1650,11 @@ foreach my $filename (@files) {
         {
             $checker->node($name) if $name;
         }
-        else {
-            $checker->parse_from_file($filename, undef) if ! $parsed;
+        elsif (! $parsed) {
+            if (! $checker->parse_from_file($filename, undef)) {
+                $checker->set_skip("$filename is transitory");
+                next FILE;
+            }
         }
 
         # Go through everything in the file that could be an anchor that
@@ -1809,9 +1842,19 @@ foreach my $filename (@files) {
             note(join "", @diagnostics,
             "See end of this test output for your options on silencing this");
         }
+
+        delete $known_problems{$canonical};
     }
 }
 
+if (! ok (keys %known_problems == 0, "The known problems data base includes no references to non-existent files")) {
+    note("The following files were not found: "
+         . join ", ", keys %known_problems);
+    note("They will automatically be removed from the db the next time");
+    note("  cd t; ./perl -I../lib porting/podcheck.t --regen");
+    note("is run");
+}
+
 my $how_to = <<EOF;
    run this test script by hand, using the following formula (on
    Un*x-like machines):