#!/usr/local/bin/perl

$VERSION = '0.01';

use warnings; use strict;

use Data::Dumper;
$Data::Dumper::Useqq = 1;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Terse = 0;
$Data::Dumper::Purity = $Data::Dumper::Deepcopy = 1;
$Data::Dumper::Deparse = 1;

use Getopt::Long;

my %opt =
  (
    'ports-data' => q{/var/db/pkg}
  , 'file-list'  => '+CONTENTS'

  , 'ports' => []
  , 'libs'  => []
  );

GetOptions
(
  'd|dir|ports-data=s' => \$opt{'ports-data'}
, 'p|ports=s@' => $opt{'ports'}
, 'l|libs=s@' => $opt{'libs'}
)
  or die;

#  Search for files for ALL the installed ports.
push @{ $opt{'ports'} } , '.' unless scalar @{ $opt{'ports'} };

push @{ $opt{'libs'} } , @ARGV if scalar @ARGV;

my $possibly_linked =
  get_files
  (
    {
      'list-maker' => [ qw{ pkg_info -L } ]
    , 'ports' => find_ports( $opt{'ports'} )
    , 'keep'  =>
        qr{ (?: /(?: s?bin | libexec ) / .+ | /perl\d+/.+?[^/]+\.so )$
+ }x
    }
  );

my $linked =
  find_libs
  (
    {
      'libs-lister' => q{ldd}
    , 'ports' => $possibly_linked
    , 'keep' => ( map qr{$_}i , join '|' , @{ $opt{'libs'} } )[0]
    }
  );

print Dumper( $linked );

exit;

sub find_libs
{
  my ( $find ) = @_;

  my %linked;
  my $parse = qr{^ \s* lib[-.,_a-zA-Z0-9]+ \s+ => \s+ .+ };

  foreach my $port ( keys %{ $find->{'ports'} } )
  {
    foreach my $file (  @{ $find->{'ports'}->{ $port } } )
    {
      #  Stringification is needed to send ldd(1) errors to /dev/null;
+ otherwise
      #  "2>/dev/null: No such file or directory" error message is pro
+duced by
      #  ldd(1).
      my $cmd =
        join ' ' , $find->{'libs-lister'} , $file , '2>/dev/null';

      open my $ph , '-|' , $cmd or die "Cannot open pipe: $!";

      my $skip = quotemeta $file;
      $skip = qr{^$skip:};

      while ( my $line = <$ph> )
      {
        next unless $line =~ m/$find->{'keep'}/;
        next if $line =~ m/$skip/;

        $line =~ s/^\s+//;
        chomp $line;
        push @{ $linked{ $port }->{ $file } } , $line
      }
    }
  }
  return { %linked };
}

sub get_files
{
  my ( $find ) = @_;

  my %files;
  foreach my $p ( @{ $find->{'ports'} } )
  {
    open my $ph , '-|' , @{ $find->{'list-maker'} } , $p
      or die "Cannot open pipe: $!";

    while ( my $file = <$ph> )
    {
      next unless $file =~ m/$find->{'keep'}/ ;

      chomp $file;
      push @{ $files{ $p } } , $file ;
    }
  }
  return { %files };
}

sub find_ports
{
  my ( $re ) = @_;

  ($re) = map qr{$_}i, join '|' , @{ $re };

  my ($dh , $close ) = open_dir( $opt{'ports-data'} );

  my @ports;
  while ( my $port = readdir $dh )
  {
    next unless $port =~ m/$re/;

    my $path = join '/' , $opt{'ports-data'} , $port;
    next
      unless -d $path
          && -f join '/' , $path , $opt{'file-list'}
        ;

    push @ports , $port;
  }

  $close->();

  chomp @ports;
  return [ sort @ports ];
}

sub open_dir
{
  my ( $dir ) = @_;
  opendir my $dh , $dir or die "Cannot open $dir: $!";
  return ( $dh , sub { closedir $dh or die "Cannot close $dir: $!"; } 
+);
}