From: Craig A. Berry <craigberry@mac.com>
Date: Mon, 26 Feb 2007 00:42:30 +0000 (+0000)
Subject: Module::Pluggable::Object::search_paths portability update prompted by
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8f75121c844fcb3cbdc99c82d6051e66b39f4c78;p=p5sagit%2Fp5-mst-13.2.git

Module::Pluggable::Object::search_paths portability update prompted by
VMS test failures.  Patch also submitted to CPAN RT queue at
<http://rt.cpan.org/Public/Bug/Display.html?id=13607>.

p4raw-id: //depot/perl@30400
---

diff --git a/lib/Module/Pluggable/Object.pm b/lib/Module/Pluggable/Object.pm
index 6de9ca5..b8e58ea 100644
--- a/lib/Module/Pluggable/Object.pm
+++ b/lib/Module/Pluggable/Object.pm
@@ -3,7 +3,7 @@ package Module::Pluggable::Object;
 use strict;
 use File::Find ();
 use File::Basename;
-use File::Spec::Functions qw(splitdir catdir abs2rel);
+use File::Spec::Functions qw(splitdir catdir curdir catfile abs2rel);
 use Carp qw(croak carp);
 use Devel::InnerPackage;
 use Data::Dumper;
@@ -145,17 +145,48 @@ sub search_paths {
             # untaint the file; accept .pm only
             next unless ($file) = ($file =~ /(.*$file_regex)$/); 
             # parse the file to get the name
-            my ($name, $directory) = fileparse($file, $file_regex);
+            my ($name, $directory, $suffix) = fileparse($file, $file_regex);
 
             $directory = abs2rel($directory, $sp);
+
+            # If we have a mixed-case package name, assume case has been preserved
+            # correctly.  Otherwise, root through the file to locate the case-preserved
+            # version of the package name.
+            my @pkg_dirs = ();
+            if ( $name eq lc($name) || $name eq uc($name) ) {
+                my $pkg_file = catfile($sp, $directory, "$name$suffix");
+                open PKGFILE, "<$pkg_file" or die "search_paths: Can't open $pkg_file: $!";
+                my $in_pod = 0;
+                while ( my $line = <PKGFILE> ) {
+                    $in_pod = 1 if $line =~ m/^=\w/;
+                    $in_pod = 0 if $line =~ /^=cut/;
+                    next if ($in_pod || $line =~ /^=cut/);  # skip pod text
+                    next if $line =~ /^\s*#/;               # and comments
+                    if ( $line =~ m/^\s*package\s+(.*::)?($name)\s*;/i ) {
+                        @pkg_dirs = split /::/, $1;
+                        $name = $2;
+                        last;
+                    }
+                }
+                close PKGFILE;
+            }
+
             # then create the class name in a cross platform way
             $directory =~ s/^[a-z]://i if($^O =~ /MSWin32|dos/);       # remove volume
+            my @dirs = ();
             if ($directory) {
                 ($directory) = ($directory =~ /(.*)/);
+                @dirs = grep(length($_), splitdir($directory)) 
+                    unless $directory eq curdir();
+                for my $d (reverse @dirs) {
+                    my $pkg_dir = pop @pkg_dirs; 
+                    last unless defined $pkg_dir;
+                    $d =~ s/\Q$pkg_dir\E/$pkg_dir/i;  # Correct case
+                }
             } else {
                 $directory = "";
             }
-            my $plugin = join "::", splitdir catdir($searchpath, $directory, $name);
+            my $plugin = join '::', $searchpath, @dirs, $name;
 
             next unless $plugin =~ m!(?:[a-z\d]+)[a-z\d]!i;
 
diff --git a/lib/Module/Pluggable/t/20dodgy_files.t b/lib/Module/Pluggable/t/20dodgy_files.t
index 3ad16d0..2486402 100644
--- a/lib/Module/Pluggable/t/20dodgy_files.t
+++ b/lib/Module/Pluggable/t/20dodgy_files.t
@@ -1,5 +1,12 @@
 #!perl -w
 
+BEGIN {
+    if ($^O eq 'VMS') {
+        print "1..0 # Skip: can't handle misspelled plugin names\n";
+        exit;
+    }
+}
+
 use strict;
 use FindBin;
 use lib "$FindBin::Bin/lib";