X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FExtUtils%2FInstalled.pm;h=e8f9f3a180c3acd86d28199ee6555bc39a31dc00;hb=f62a57de64cd5ddde982ef9f2ab6d195e87eec01;hp=8498f35fdfc55213b1d9cb51cef2791d102509d8;hpb=f6d6199cd6711f5e8a8e6c1a57445fa6f848c822;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/lib/ExtUtils/Installed.pm b/lib/ExtUtils/Installed.pm
index 8498f35..e8f9f3a 100644
--- a/lib/ExtUtils/Installed.pm
+++ b/lib/ExtUtils/Installed.pm
@@ -1,6 +1,6 @@
 package ExtUtils::Installed;
 
-use 5.006;
+use 5.00503;
 use strict;
 use Carp qw();
 use ExtUtils::Packlist;
@@ -9,20 +9,29 @@ use Config;
 use File::Find;
 use File::Basename;
 use File::Spec;
-require VMS::Filespec if $^O eq 'VMS';
-
-our $VERSION = '0.05';
 
+my $Is_VMS = $^O eq 'VMS';
 my $DOSISH = ($^O =~ /^(MSWin\d\d|os2|dos|mint)$/);
 
+require VMS::Filespec if $Is_VMS;
+
+use vars qw($VERSION);
+$VERSION = '1.41';
+$VERSION = eval $VERSION;
+
 sub _is_prefix {
     my ($self, $path, $prefix) = @_;
     return unless defined $prefix && defined $path;
 
-    if( $^O eq 'VMS' ) {
+    if( $Is_VMS ) {
         $prefix = VMS::Filespec::unixify($prefix);
         $path   = VMS::Filespec::unixify($path);
     }
+
+    # Sloppy Unix path normalization.
+    $prefix =~ s{/+}{/}g;
+    $path   =~ s{/+}{/}g;
+
     return 1 if substr($path, 0, length($prefix)) eq $prefix;
 
     if ($DOSISH) {
@@ -33,7 +42,7 @@ sub _is_prefix {
     return(0);
 }
 
-sub _is_doc { 
+sub _is_doc {
     my ($self, $path) = @_;
     my $man1dir = $Config{man1direxp};
     my $man3dir = $Config{man3direxp};
@@ -42,7 +51,7 @@ sub _is_doc {
            ($man3dir && $self->_is_prefix($path, $man3dir))
            ? 1 : 0)
 }
- 
+
 sub _is_type {
     my ($self, $path, $type) = @_;
     return 1 if $type eq "all";
@@ -77,7 +86,7 @@ sub new {
     my $sitearch = $Config{sitearchexp};
 
     # File::Find does not know how to deal with VMS filepaths.
-    if( $^O eq 'VMS' ) {
+    if( $Is_VMS ) {
         $archlib  = VMS::Filespec::unixify($archlib);
         $sitearch = VMS::Filespec::unixify($sitearch);
     }
@@ -95,7 +104,7 @@ sub new {
     # Read the module packlists
     my $sub = sub {
         # Only process module .packlists
-        return if ($_) ne ".packlist" || $File::Find::dir eq $archlib;
+        return if $_ ne ".packlist" || $File::Find::dir eq $archlib;
 
         # Hack of the leading bits of the paths & convert to a module name
         my $module = $File::Find::name;
@@ -109,7 +118,9 @@ sub new {
         $self->{$module}{version} = '';
         foreach my $dir (@INC) {
             my $p = File::Spec->catfile($dir, $modfile);
-            if (-f $p) {
+            if (-r $p) {
+                $module = _module_name($p, $module) if $Is_VMS;
+
                 require ExtUtils::MM;
                 $self->{$module}{version} = MM->parse_version($p);
                 last;
@@ -117,7 +128,7 @@ sub new {
         }
 
         # Read the .packlist
-        $self->{$module}{packlist} = 
+        $self->{$module}{packlist} =
           ExtUtils::Packlist->new($File::Find::name);
     };
 
@@ -127,9 +138,41 @@ sub new {
     return(bless($self, $class));
 }
 
+# VMS's non-case preserving file-system means the package name can't
+# be reconstructed from the filename.
+sub _module_name {
+    my($file, $orig_module) = @_;
+
+    my $module = '';
+    if (open PACKFH, $file) {
+        while (<PACKFH>) {
+            if (/package\s+(\S+)\s*;/) {
+                my $pack = $1;
+                # Make a sanity check, that lower case $module
+                # is identical to lowercase $pack before
+                # accepting it
+                if (lc($pack) eq lc($orig_module)) {
+                    $module = $pack;
+                    last;
+                }
+            }
+        }
+        close PACKFH;
+    }
+
+    print STDERR "Couldn't figure out the package name for $file\n"
+      unless $module;
+
+    return $module;
+}
+
+
+
 sub modules {
     my ($self) = @_;
-    return sort keys %$self;
+
+    # Bug/feature of sort in scalar context requires this.
+    return wantarray ? sort keys %$self : keys %$self;
 }
 
 sub files {
@@ -144,7 +187,7 @@ sub files {
     my (@files);
     foreach my $file (keys(%{$self->{$module}{packlist}})) {
         push(@files, $file)
-          if ($self->_is_type($file, $type) && 
+          if ($self->_is_type($file, $type) &&
               $self->_is_under($file, @under));
     }
     return(@files);