From: Tyler Riddle <t.riddle@shadowcat.co.uk>
Date: Wed, 10 Oct 2012 23:10:55 +0000 (-0700)
Subject: new libdirs-perl probe engine; updated tests for same
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=7569d93a883fa526c89ad3e25f1bbf34bcadab48;p=scpubgit%2FSystem-Introspector.git

new libdirs-perl probe engine; updated tests for same
---

diff --git a/lib/System/Introspector/Probe/LibDirs/Perl.pm b/lib/System/Introspector/Probe/LibDirs/Perl.pm
index 2f2a4ed..ad2547b 100644
--- a/lib/System/Introspector/Probe/LibDirs/Perl.pm
+++ b/lib/System/Introspector/Probe/LibDirs/Perl.pm
@@ -24,26 +24,19 @@ has enumerate_packlists => ( is => 'ro', default => sub { 1 } );
 sub gather {
     my ($self) = @_;
     log_debug { "Gathering Perl library information" }; 
-
-if (0) {
-   log_warn { "simulating hang" };
-
-    while(1) { 
-        sleep(1)
-    };
-}
-
+    
     return transform_exceptions {
         my $pipe = $self->_open_locate_libdirs_pipe;
         my %libdir;
         while (defined( my $line = <$pipe> )) {
             chomp $line;
+            
             $libdir{ $line } = transform_exceptions {
                 return { modules => $self->_gather_libdir_info($line) };
             };
         }
 
-        log_trace { "Completed gathering Perl library information" }; 
+        log_trace { "Completed gathering Perl library information" };
         return { libdirs_perl => \%libdir };
     };
 }
@@ -51,31 +44,83 @@ if (0) {
 sub _gather_libdir_info {
     my ($self, $libdir) = @_;
     my %modules;
+    my $packlistfh; 
     
     log_debug { "Gathering Perl libdir info for '$libdir'" };
+    
+    $packlistfh = $self->_open_find_packlist_pipe($libdir);
+    
+    while(<$packlistfh>) {
+        chomp(my $file = $_);
+        my $module_name = $self->_module_name_from_packlist_path($file, $libdir); 
+        
+        unless(defined($module_name)) {
+            log_error { "Could not figure out module information for packlist file '$file'" };
+            next; 
+        }
 
-    my $installed = ExtUtils::Installed->new(inc_override => [ $libdir ]);
-            
-    foreach my $module ($installed->modules) {
-        my $packlist = $installed->packlist($module)->packlist_file;
+        $modules{$module_name} = {}; 
         
-        Dlog_trace { "Packlist file for '$module' in '$libdir' is '$_'" } $packlist;
-                        
-        $modules{$module} = {};
+        if ($self->enumerate_packlists) {
+            my $packlist = output_from_file($file);
+            my @files = split("\n", $packlist); 
 
-if (0) {
-  log_warn { "Simulating slowness" };
-  for(1 .. 20) { sleep(1) }
+            $modules{$module_name}->{packlist} = \@files;            
+        }        
+    }
+            
+    return \%modules; 
 }
-                        
-        if ($self->enumerate_packlists && -f $packlist) {
-            $modules{$module}->{packlist} = [ $installed->files($module, 'all') ];       
-        }
-    } 
     
-    return \%modules; 
+sub _open_find_packlist_pipe {
+    my ($self, $dir) = @_;
+    log_debug { "Executing 'find' to search for Perl module packlists in '$dir'" };
+    return handle_from_command
+        sprintf q{find %s -type f -name '.packlist'}, $dir;
+}
+
+sub _module_name_from_packlist_path {
+    my ($self, $path, $root) = @_; 
+    my $module_name = $path;
+    
+    unless($module_name =~ s/^$root//) {
+        log_debug { "Regex failure with '$path': was it rooted in '$root' ?" };
+        return undef; 
+    }
+    
+    unless($module_name =~ s/\.packlist$//) {
+        log_debug { "Could not remove packlist file name from '$path'" };
+        return undef; 
+    }
+
+    $module_name =~ s,/,::,g;
+    
+    unless($module_name =~ s/^.+?auto:://) {
+        log_debug { "Did not find 'auto' prefix in packlist path for '$path'" };
+        return undef;
+    }
+    
+    $module_name =~ s/::$//;
+    
+    return $module_name;
 }
+
+sub _open_locate_libdirs_pipe {
+    my ($self) = @_;
     
+    my $root = $self->root;
+    $root .= '/'
+        unless $root =~ m{/$};
+    log_debug { "Executing 'locate' to identify Perl 5 library directories under '$root'" };
+    my $command = sprintf q{locate --regex '^%s.*lib/perl5$'}, $root;
+    return handle_from_command $command; 
+}
+
+# The following are methods for the original larger report style.
+# They are archived here so they can be reintroduced as a 
+# set of data that is collected according to attributes on this
+# this class.
+        
 #sub _enumerate_metadata {
 #    my ($self, $libdir, $module) = @_;
 #    
@@ -117,18 +162,6 @@ if (0) {
 #        sprintf q{find %s -name '.packlist'}, $libdir;
 #}
 
-sub _open_locate_libdirs_pipe {
-    my ($self) = @_;
-    my $root = $self->root;
-    $root .= '/'
-        unless $root =~ m{/$};
-    log_debug { "Executing 'locate' to identify Perl 5 library directories" };
-    return handle_from_command sprintf
-        #lib/perl5 for Local::Lib and debian installed perl? - lib/perl for others?
-        q{locate --regex '^%s.*lib/perl$'}, $root;
-#        q{locate --regex '^%s.*lib/perl5$'}, $root;
-}
-
 1;
 
 __END__
diff --git a/t/data/libdir/perl/lib/perl5/Foo.pm b/t/data/libdir/perl/lib/perl5/Foo/Bar.pm
similarity index 60%
rename from t/data/libdir/perl/lib/perl5/Foo.pm
rename to t/data/libdir/perl/lib/perl5/Foo/Bar.pm
index d781edd..6d6a139 100644
--- a/t/data/libdir/perl/lib/perl5/Foo.pm
+++ b/t/data/libdir/perl/lib/perl5/Foo/Bar.pm
@@ -1,4 +1,4 @@
-package Foo;
+package Foo::Bar;
 
 our $VERSION = 0.001;
 
diff --git a/t/data/libdir/perl/lib/perl5/Foo/Biddle.pm b/t/data/libdir/perl/lib/perl5/Foo/Biddle.pm
new file mode 100644
index 0000000..e6fa507
--- /dev/null
+++ b/t/data/libdir/perl/lib/perl5/Foo/Biddle.pm
@@ -0,0 +1,5 @@
+package Foo::Bar::Biddle;
+
+1; 
+
+
diff --git a/t/data/libdir/perl/lib/perl5/Foo/Biddle/Bloke.pm b/t/data/libdir/perl/lib/perl5/Foo/Biddle/Bloke.pm
new file mode 100644
index 0000000..fd1f63f
--- /dev/null
+++ b/t/data/libdir/perl/lib/perl5/Foo/Biddle/Bloke.pm
@@ -0,0 +1,5 @@
+package Foo::Bar::Biddle::Bloke; 
+
+1;
+
+
diff --git a/t/data/libdir/perl/lib/perl5/auto/Foo/.packlist b/t/data/libdir/perl/lib/perl5/auto/Foo/.packlist
new file mode 100644
index 0000000..5e1fd3b
--- /dev/null
+++ b/t/data/libdir/perl/lib/perl5/auto/Foo/.packlist
@@ -0,0 +1,2 @@
+t/data/libdir/perl/lib/perl5/Foo
+t/data/libdir/perl/lib/perl5/Foo/Bar.pm
diff --git a/t/data/libdir/perl/lib/perl5/auto/Foo/Biddle/.packlist b/t/data/libdir/perl/lib/perl5/auto/Foo/Biddle/.packlist
new file mode 100644
index 0000000..6eeaafd
--- /dev/null
+++ b/t/data/libdir/perl/lib/perl5/auto/Foo/Biddle/.packlist
@@ -0,0 +1,2 @@
+t/data/libdir/perl/lib/perl5/Foo/Bar/Biddle.pm
+t/data/libdir/perl/lib/perl5/Foo/Bar/Biddle/Bloke.pm
diff --git a/t/libdirs-perl.t b/t/libdirs-perl.t
index 5b669c4..e1e8f4e 100644
--- a/t/libdirs-perl.t
+++ b/t/libdirs-perl.t
@@ -18,26 +18,21 @@ no warnings 'redefine';
 my $probe = System::Introspector::Probe::LibDirs::Perl->new(
     root => $dir,
 );
-my $data = $probe->gather;
-
-my $sha = delete $data
-    ->{libdirs_perl}{"$dir/lib/perl5"}{modules}{Foo}[0]{sha256_hex};
-ok $sha, 'contains SHA fingerprint';
 
-my $size = delete $data
-    ->{libdirs_perl}{"$dir/lib/perl5"}{modules}{Foo}[0]{size};
-ok $size, 'contains file size';
+my $data = $probe->gather;
 
 is_deeply $data, {
     libdirs_perl => {
         "$dir/lib/perl5" => {
             modules => {
-                Foo => [
-                    { file => "$dir/lib/perl5/Foo.pm", version => 0.001 },
-                ],
+                Foo => {
+                    packlist => [qw( t/data/libdir/perl/lib/perl5/Foo t/data/libdir/perl/lib/perl5/Foo/Bar.pm )],
+                }, 'Foo::Biddle' => {
+                    packlist => [qw( t/data/libdir/perl/lib/perl5/Foo/Bar/Biddle.pm t/data/libdir/perl/lib/perl5/Foo/Bar/Biddle/Bloke.pm  )],
+                }
             },
         },
     },
-}, 'package found';
+}, 'Report data matches template';
 
 done_testing;