From: Tyler Riddle <t.riddle@shadowcat.co.uk>
Date: Wed, 26 Sep 2012 15:27:44 +0000 (-0700)
Subject: rewrote libdirs probe to have less data
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=cd06edb64be9e6aa8e9e0ac116219ce56d63e872;p=scpubgit%2FSystem-Introspector.git

rewrote libdirs probe to have less data
---

diff --git a/lib/System/Introspector/Probe/LibDirs/Perl.pm b/lib/System/Introspector/Probe/LibDirs/Perl.pm
index d197b11..5229e86 100644
--- a/lib/System/Introspector/Probe/LibDirs/Perl.pm
+++ b/lib/System/Introspector/Probe/LibDirs/Perl.pm
@@ -1,14 +1,17 @@
 package System::Introspector::Probe::LibDirs::Perl;
+
 use Moo;
 use Module::Metadata;
 use Digest::SHA;
+use ExtUtils::Installed; 
 
 use System::Introspector::Util qw(
     handle_from_command
     transform_exceptions
+    output_from_file
 );
 
-use System::Introspector::Logger qw( :log );
+use System::Introspector::Logger qw( :log :dlog );
 
 with 'System::Introspector::Role::Probe';
 
@@ -36,35 +39,61 @@ sub gather {
 
 sub _gather_libdir_info {
     my ($self, $libdir) = @_;
-    my %module;
-    my $pipe = $self->_open_locate_pm_pipe($libdir);
-    while (defined( my $line = <$pipe> )) {
-        chomp $line;
-        my $metadata = Module::Metadata->new_from_file($line);
-        next unless $metadata->name;
-        my $sha = Digest::SHA->new(256);
-        $sha->addfile($line);
-        my $version = $metadata->version;
-        push @{ $module{ $metadata->name } //= [] }, {
-            file        => $line,
-            version     => (
-                defined($version)
-                ? sprintf('%s', $version)
-                : undef
-            ),
-            size        => scalar(-s $line),
-            sha256_hex  => $sha->hexdigest,
-        };
-    }
-    return \%module;
+    my %modules;
+    
+    log_debug { "Gathering Perl libdir info for '$libdir'" };
+
+    my $installed = ExtUtils::Installed->new(inc_override => [ $libdir ]);
+    
+    foreach my $module ($installed->modules) {
+        my $packlist = $installed->packlist($module)->packlist_file;
+        
+        Dlog_trace { "Packlist file for '$module' in '$libdir' is '$_'" } $packlist;
+                
+        if (-f $packlist) {
+            $modules{$module} = [ $installed->files($module, 'all') ];           
+        } else {
+            $modules{$module} = undef; 
+        }
+    } 
+    
+    return \%modules; 
+
+#    my $pipe = $self->_open_locate_pm_pipe($libdir);
+#    while (defined( my $line = <$pipe> )) {
+#        chomp $line;
+#        my $metadata = Module::Metadata->new_from_file($line);
+#        next unless $metadata->name;
+#        my $sha = Digest::SHA->new(256);
+#        $sha->addfile($line);
+#        my $version = $metadata->version;
+#        push @{ $module{ $metadata->name } //= [] }, {
+#            file        => $line,
+#            version     => (
+#                defined($version)
+#                ? sprintf('%s', $version)
+#                : undef
+#            ),
+#            size        => scalar(-s $line),
+#            sha256_hex  => $sha->hexdigest,
+#        };
+#    }
+#    return \%module;
 }
 
-sub _open_locate_pm_pipe {
-    my ($self, $libdir) = @_;
-    log_debug { "Executing 'find' to search for Perl module files in '$libdir'" };
-    return handle_from_command
-        sprintf q{find %s -name '*.pm'}, $libdir;
-}
+#sub _open_locate_pm_pipe {
+#    my ($self, $libdir) = @_;
+#    log_debug { "Executing 'find' to search for Perl module files in '$libdir'" };
+#    return handle_from_command
+#        sprintf q{find %s -name '*.pm'}, $libdir;
+#}
+#
+#sub _open_locate_packlist_pipe {
+#    my ($self, $libdir) = @_;
+#    log_debug { "Executing 'find' to search for Perl module packlist files in '$libdir'" };
+#    return handle_from_command
+#        sprintf q{find %s -name '.packlist'}, $libdir;
+#}
 
 sub _open_locate_libdirs_pipe {
     my ($self) = @_;
@@ -73,7 +102,9 @@ sub _open_locate_libdirs_pipe {
         unless $root =~ m{/$};
     log_debug { "Executing 'locate' to identify Perl 5 library directories" };
     return handle_from_command sprintf
+        #lib/perl5 for Local::Lib? - lib/perl for others
         q{locate --regex '^%s.*lib/perl5$'}, $root;
+#        q{locate --regex '^%s.*lib/perl$'}, $root;
 }
 
 1;