[PATCH] fortify Pod::Simple::Search against non-case-preserving filesystems

[Craig A. Berry]

The current implementation of Pod::Simple::Search assumes that
case-preserved package and pod names can be constructed from filenames,
which is not always true, at least not on VMS, where the patch knocks
out about a dozen test failures in blead.

The basic approach is to root around in the file for C<=head1 NAME> and
use the first word after it to correct the case of the pod name
constructed from the filename. This is only done for names that are not
already in mixed case. The approach fails (does no additional harm but
also no good) when the internal name does not match the filename, but
that seems to me an error that shouldn't really be catered to. The test
pod squaa::Wowo had such an error and the patch includes a fix for it.

The patch also has a couple of minor VMS-specific adjustments. I'll
apply it to blead if there are no objections in the next day or so. If
it could make its way into the next CPAN version of Pod::Simple as well,
I'd appreciate it.


--- lib/Pod/Simple/Search.pm;-0 Wed Dec  7 06:09:21 2005
+++ lib/Pod/Simple/Search.pm    Mon Dec 26 22:23:56 2005
@@ -67,14 +67,7 @@ sub survey {
       $try = File::Spec->catfile( $cwd ,$try);
     }
     # simplify path
-    # on VMS canonpath will vmsify:[the.path], but File::Find::find
-    # wants /unixy/paths
-    #     (Is that irrelevent now htat we don't use File::Find? -- SMB)
-    if( $^O eq 'VMS' ) {
-      $try = VMS::Filespec::unixify($try);
-    } else {
-      $try =  File::Spec->canonpath($try);
-    }
+    $try =  File::Spec->canonpath($try);
 
     my $start_in;
     my $modname_prefix;
@@ -243,9 +236,11 @@ sub _path2modname {
   # * remove e.g. "i586-linux" (from 'archname')
   # * remove e.g. 5.00503
   # * remove pod/ if followed by perl*.pod (e.g. in pod/perlfunc.pod)
+  # * dig into the file for case-preserved name if not already mixed case
 
   my @m = @$modname_bits;
   my $x;
+  my $verbose = $self->verbose;
 
   # Shaving off leading naughty-bits
   while(@m
@@ -258,6 +253,36 @@ sub _path2modname {
 
   my $name = join '::', @m, $shortname;
   $self->_simplify_base($name);
+
+  if ($name eq lc($name) || $name eq uc($name)) {
+      open PODFILE, "<$file" or die "_path2modname: Can't open $file: $!";
+      my $in_pod = 0;
+      my $in_name = 0;
+      while (<PODFILE>) {
+        chomp;
+        $in_pod = 1 if m/^=\w/;
+        $in_pod = 0 if m/^=cut/;
+        next unless $in_pod;         # skip non-pod text
+        next if m/^\s*\z/;           # and blank lines
+        next if ($in_pod && m/^X</); # and commands
+        if ($in_name) {
+          if( m/(\w+::)?(\w+)/) {
+            # substitute case-preserved version of name
+            my $podname = $2;
+            my $prefix = $1;
+            $verbose and print "Attempting case restore of '$name' from 
'$prefix$podname'\n";
+            unless ($name =~ s/$prefix$podname/$prefix$podname/i) {
+              $verbose and print "Attempting case restore of '$name' from 
'$podname'\n";
+              $name =~ s/$podname/$podname/i;
+            }
+            last;
+          }
+        }
+        $in_name = 1 if m/^=head1 NAME/;
+    }
+    close PODFILE;
+  }
+
   return $name;
 }
 
@@ -308,6 +333,7 @@ sub _recurse_dir {
         $callback->(          $i_full, $i, 0, $modname_bits );
 
       } elsif(-d _) {
+        $i =~ s/\.DIR\z//i if $^O eq 'VMS';
         $_ = $i;
         my $rv = $callback->( $i_full, $i, 1, $modname_bits ) || '';
 
--- lib/Pod/Simple/t/other_test_lib/squaa/Wowo.pod;-0   Tue Dec 13 13:37:05 2005
+++ lib/Pod/Simple/t/other_test_lib/squaa/Wowo.pod      Mon Dec 26 22:40:47 2005
@@ -1,7 +1,7 @@
 
 =head1 NAME
 
-squaa::Glunk -- blorpoesu
+squaa::Wowo -- blorpoesu
 
 =head1 DESCRIPTION