#!/usr/bin/perl

# recursively find NEEDED (in the ELF sense) shared libraries 
# for a given share library or for all installed Perl "glue" libraries

use strict;
use warnings;

use File::Spec;
use File::Find;
use File::Basename;

package DLL
{
    use strict;
    use warnings;
    use Capture::Tiny qw(:all);

    our ($show_system_libs, $show_perl_libs);   # default: don't show

    my @dll_path = File::Spec->path;            # Windows
    # my @dll_path = qw(/lib /lib/x86_64-linux-gnu /usr/lib /usr/lib/x86_64-linux-gnu);
    # + $ENV{LD_LIBRARY_PATH} if set
    #                                           Linux (Debian multi-arch)
    # maybe use "gcc -print-search-dirs" (pathnames may need canonicalization)
    #   install: /usr/lib/gcc/x86_64-linux-gnu/4.9/
    #   programs: =/usr/lib/gcc/x86_64-linux-gnu/4.9/:/usr/lib/gcc/x86_64-linux-gnu/4.9/:/usr/lib/gcc/x86_64-linux-gnu/:/usr/lib/gcc/x86_64-linux-gnu/4.9/:/usr/lib/gcc/x86_64-linux-gnu/:/usr/lib/gcc/x86_64-linux-gnu/4.9/../../../../x86_64-linux-gnu/bin/x86_64-linux-gnu/4.9/:/usr/lib/gcc/x86_64-linux-gnu/4.9/../../../../x86_64-linux-gnu/bin/x86_64-linux-gnu/:/usr/lib/gcc/x86_64-linux-gnu/4.9/../../../../x86_64-linux-gnu/bin/
    #   libraries: =/usr/lib/gcc/x86_64-linux-gnu/4.9/:/usr/lib/gcc/x86_64-linux-gnu/4.9/../../../../x86_64-linux-gnu/lib/x86_64-linux-gnu/4.9/:/usr/lib/gcc/x86_64-linux-gnu/4.9/../../../../x86_64-linux-gnu/lib/x86_64-linux-gnu/:/usr/lib/gcc/x86_64-linux-gnu/4.9/../../../../x86_64-linux-gnu/lib/../lib/:/usr/lib/gcc/x86_64-linux-gnu/4.9/../../../x86_64-linux-gnu/4.9/:/usr/lib/gcc/x86_64-linux-gnu/4.9/../../../x86_64-linux-gnu/:/usr/lib/gcc/x86_64-linux-gnu/4.9/../../../../lib/:/lib/x86_64-linux-gnu/4.9/:/lib/x86_64-linux-gnu/:/lib/../lib/:/usr/lib/x86_64-linux-gnu/4.9/:/usr/lib/x86_64-linux-gnu/:/usr/lib/../lib/:/usr/lib/gcc/x86_64-linux-gnu/4.9/../../../../x86_64-linux-gnu/lib/:/usr/lib/gcc/x86_64-linux-gnu/4.9/../../../:/lib/:/usr/lib/

    require Tie::CPHash;
    tie my %cache, "Tie::CPHash";

    sub name    { shift->{name} }
    sub path    { shift->{path} }


    sub find                            # class method
    {
        my ($class, $name) = @_;
        unless ($cache{$name})
        {
            my $found;
            foreach (@dll_path)
            {
                my $path = File::Spec->catfile($_, $name);
                $found = $path, last if -e $path;
            }

            $cache{$name} = bless {
                name    => $name,
                path    => $found,
            }, $class;
        }
        return $cache{$name};
    }

    sub needed
    {
        my ($self, $path) = @_;
        if (ref $self)
        {
            return @{ $self->{needed} } if $self->{needed};
            $path = $self->{path};
            die "can't find DLL $self->{name}" unless defined $path;
        }
        else
        {
            die __PACKAGE__."->needed: argument PATH missing" unless defined $path;
        }

        my ($out, $err, $exit) = capture { system(qw( objdump -ax ), $path) };
        die qq["objdump -ax $path" failed: $err] unless $exit == 0;

        my @needed = map { __PACKAGE__->find($_) } 
                         $out =~ /^\s*DLL Name:\s*(\S+)/gm;     # Windows
        #                $out =~ /^\s*NEEDED\s+(\S+)/gm;        # Linux
        $self->{needed} = \@needed if ref $self;
        return @needed;
    }


    sub depends
    {
        my ($self, $path) = @_;
        if (ref $self)
        {
            $path = $self->{path};
            die "can't find DLL $self->{name}" unless defined $path;
        }
        else
        {
            die __PACKAGE__."->depends argument PATH missing" unless defined $path;
        }

        tie my %seen, "Tie::CPHash";
        $seen{$self->name} = $self if ref $self;
        _depends(\%seen, $self->needed($path));
        return values %seen;
    }

    sub _depends
    {
        my ($seen, @needed) = @_;

        foreach (@needed)
        {
            next if $seen->{$_->name};
            if (defined $_->path)
            {
                next if $_->is_system_lib && !$show_system_libs;
                next if $_->is_perl_lib   && !$show_perl_libs;
            }

            $seen->{$_->name} = $_;
            _depends($seen, $_->needed) if defined $_->path;
        }
    }

    sub canon_path
    {
        my ($self) = @_;
        return unless defined $_->path;

        return $_->{canon_path} ||= _canon_path($_->path);
    }

    sub _canon_path
    {
        my ($path, $no_file) = @_;

        my ($vol, $dirs, $file) = File::Spec->splitpath($path, $no_file);
        $dirs =~ s{[/\\]$}{};
        my $foo = join("/", $vol, File::Spec->splitdir($dirs), $file);
        return lc $foo;
    }

    my $system_root = _canon_path($ENV{SystemRoot}, 1);

    sub is_system_lib
    {
        my ($self) = @_;
        my $canon_path = $_->canon_path or return;
        return length $canon_path > length $system_root
               && substr($canon_path, 0, length $system_root) eq $system_root;
    }

    tie my %perl_libs, "Tie::CPHash";
    {
        local $show_system_libs = 0;
        local $show_perl_libs = 1;
        $perl_libs{$_->name} = $_ foreach __PACKAGE__->depends($^X);
    };        

    sub is_perl_lib     { $perl_libs{shift->name} ? 1 : 0 }
}


# return a list of installed (ie. found below some directory in @INC) glue DLLs
sub find_all_installed_glue_dlls
{
    my @dlls;

    find(sub { push @dlls, $File::Find::name if /\.dll/i; }, 
         grep { my $auto;
                !ref $_ && -d ($auto = File::Spec->catdir($_, "auto")) ? 
                    $auto : () 
              } @INC);

    return @dlls;
}


# guess the Perl module from the pathname of a glue DLL
sub guess_module_from_glue_dll
{
    my ($path) = @_;

    # module Foo::Bar::Quux typically installs its glue DLL as
    # .../auto/Foo/Bar/Quux/Quux.dll or
    # .../auto/Foo/Bar/Quux/Quux.xs.dll
    my ($vol, $dirs, $file) = File::Spec->splitpath($path);
    $dirs =~ s{[/\\]$}{};
    $dirs =~ s{^(?:.*?[/\\])?auto[/\\]}{}
        or warn(qq[DLL "$path": path doesn't contain "auto"\n]), return;
    return join("::", File::Spec->splitdir($dirs));
}


my $show_lib_path = 0;
sub show_lib
{
    my ($dll) = @_;
    if ($show_lib_path)
    {
        printf "\t%s => %s\n", $dll->name, $dll->path || "(not found)";
    }
    else
    {
        printf "\t%s\n", $dll->name;
    }
}

if (@ARGV)
{
    foreach (@ARGV)
    {
        print $_, "\n";
        show_lib($_) foreach DLL->depends($_);
    }
}
else
{
    my %mod2dll;
    my @non_mod_dlls;
    foreach (find_all_installed_glue_dlls())
    {
        my $mod = guess_module_from_glue_dll($_);
        push(@non_mod_dlls, $_), next unless $mod;
        $mod2dll{$mod} = $_;
    }

    foreach my $mod (sort keys %mod2dll)
    {
	my $dll = $mod2dll{$mod};
        my @deps = DLL->depends($dll) or next; # suppress glue DLLs w/o dependencies
        print "$mod ($dll)\n";
        show_lib($_) foreach @deps;
    }

    print "\n";
    foreach my $dll (sort @non_mod_dlls)
    {
        print "$dll\n";
        show_lib($_) foreach DLL->depends($dll);
    }
}