From: Robert 'phaylon' Sedlacek <r.sedlacek@shadowcat.co.uk>
Date: Mon, 7 May 2012 18:37:12 +0000 (+0000)
Subject: LibDirs::Perl probe for discovering perl local::lib like directories
X-Git-Tag: v0.001_001~129
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f356dcb072ecd204064205cbab2dafde49bcb90a;p=scpubgit%2FSystem-Introspector.git

LibDirs::Perl probe for discovering perl local::lib like directories
---

diff --git a/lib/System/Introspector/LibDirs/Perl.pm b/lib/System/Introspector/LibDirs/Perl.pm
new file mode 100644
index 0000000..a8f7d21
--- /dev/null
+++ b/lib/System/Introspector/LibDirs/Perl.pm
@@ -0,0 +1,65 @@
+package System::Introspector::LibDirs::Perl;
+use Moo;
+use Module::Metadata;
+use Digest::SHA;
+
+has root => (
+    is      => 'ro',
+    default => sub { '/' },
+);
+
+sub gather {
+    my ($self) = @_;
+    my $pipe = $self->_open_locate_libdirs_pipe;
+    my %libdir;
+    while (defined( my $line = <$pipe> )) {
+        chomp $line;
+        $libdir{ $line } = $self->_gather_libdir_info($line);
+    }
+    return \%libdir;
+}
+
+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);
+        push @{ $module{ $metadata->name } //= [] }, {
+            file        => $line,
+            version     => $metadata->version,
+            size        => scalar(-s $line),
+            sha256_hex  => $sha->hexdigest,
+        };
+    }
+    return \%module;
+}
+
+sub _open_locate_pm_pipe {
+    my ($self, $libdir) = @_;
+    my $command = sprintf
+        q{find %s -name '*.pm'},
+        $libdir;
+    open my $pipe, '-|', $command
+        or die "Unable to open pipe to '$command': $!\n";
+    return $pipe;
+}
+
+sub _open_locate_libdirs_pipe {
+    my ($self) = @_;
+    my $root = $self->root;
+    $root .= '/'
+        unless $root =~ m{/$};
+    my $command = sprintf
+        q{locate --regex '^%s.*lib/perl5$'},
+        $root;
+    open my $pipe, '-|', $command
+        or die "Unable to open pipe to '$command': $!\n";
+    return $pipe;
+}
+
+1;