File Coverage

lib/Devel/SharedLibs.pm

Criterion	Covered	Total	%
statement	17	18	94.4
branch	1	2	50.0
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	23	25	92.0

########################################################################
# housekeeping
########################################################################

package Devel::SharedLibs;
use v5.22;

use IO::File;

use List::MoreUtils qw( uniq );

########################################################################
# package variables
########################################################################

our $VERSION = 'v0.3.2';
$VERSION    = eval "$VERSION";

sub import
{
    state $usable_ldd
    = do
    {
$DB::single = 1;

        # Aside: Need to check whether ldd on BSD, etc, supports
        # long option for version.

        my $result  = qx{ ldd --version 2>&1 };

        my $success = ! $?
        or warn <<"END";
# Non-zeo exit: ldd --version ($result)
# SharedLibs unable to generate output.
END

        $success
    };

    # all this does it localize $path for the END closure.
    # kwikhak for the moment until I find out if there is
    # any decent way to deal with ldd on BSD.

    my ( undef, $path ) = @_;

    END
    {
$DB::single = 1;

        $ENV{ DEVEL_SHAREDLIBS_PRINT }
        or return;

        $path   ||= $ENV{ DEVEL_SHAREDLIBS_PATH }
        or say "# False path & DEVEL_SHAREDLIBS_PATH: output to stdout.";

        # avoid stale output.
        # if ldd is not usable then this leaves nothing behind.

        my $continue    = $usable_ldd;

        if( $path && -e $path )
        {
            say "# Remove stale: '$path'";

            unlink $path
            or do
            {
                warn <<"END";
# Failed unlink: '$path', no SharedLibs output.
# SharedLibs unable to generate output.
END

                $continue   = ''
            };
        }

        if( $continue )
        {
            use autodie qw( open close );

            local $,    = "\n";
            local $\    = "\n";

            my $fh
            = $path
            ? IO::File->new( $path, 'w' )
            : *STDOUT{ IO }
            ;

            # sort isn't necessary for uniqueness but helps
            # by giving a stable output.

            print $fh
            "# ldd '$^X', '$0'" =>
            sort { $a cmp $b }
            uniq
            map
            {
                # the literal '=>' dodges linux-vdso & friends,
                # which lack a path and also the
                # "not a dynamic executable" messages from
                # most of the contents.

                my ( $lib ) = m{ => \s+ (\S+) }x;

                $lib || ()
            }
            map
            {
                split "\n" => qx(ldd $_ 2>/dev/null )
            }
            (
                $^X,
                values %INC
            );

            close $fh;

            say STDERR "SharedLibs output: '$path'";
        }
        else
        {
            say STDERR "SharedLibs unable to generate output."
        }
    }
}

# keep require happy
1
__END__