File Coverage

blib/lib/FindBin/libs.pm

Criterion	Covered	Total	%
statement	46	58	79.3
branch	12	26	46.1
condition	2	5	40.0
subroutine	10	10	100.0
pod			n/a
total	70	99	70.7

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

package FindBin::libs   v2.12.01;
use v5.14;
use strict;

use FindBin;

use File::Basename;

use Carp    qw( croak                   );
use Symbol  qw( qualify qualify_to_ref  );

use File::Spec::Functions
qw
(
    &splitpath
    &splitdir
    &catpath
    &catdir
);

BEGIN
{
    # however... there have been complaints of
    # places where abs_path does not work.
    #
    # if abs_path fails on the working directory
    # then replace it with rel2abs and live with
    # possibly slower, redundant directories.
    #
    # the abs_path '//' hack allows for testing
    # broken abs_path on primitive systems that
    # cannot handle the rooted system being linked
    # back to itself.

    use Cwd qw( &abs_path &cwd );

    if
    (
        # abs_path has a fixed bug dealing with infinite
        # recursion. if upping the version of Cwd does
        # not fix this then the only other test I can
        # think of is ( -e '/.' && -e '/..' && -e '/../.' )

        eval
        {
            abs_path '//';
            abs_path cwd
        }
    )
    {
        # abs_path seems clean on this platform.
    }
    else
    {
        # abs_path seems to be having problems,
        # fix is to stub it out.
        #
        # undef avoids nastygram.

        my $ref = qualify_to_ref 'abs_path', __PACKAGE__;

        my $sub = File::Spec::Functions->can( 'rel2abs' );

        undef &{ $ref };

        *$ref = $sub
    };
}

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

my %defaultz =
(
    base    => 'lib',
    use     => undef,
    blib    => undef,   # prefer ./blib at the first level

    subdir  => '',      # add this subdir also if found.
    subonly => undef,   # leave out lib's, use only subdir.
    export  => undef,   # push variable into caller's space.
    append  => undef,   # push onto existing array (vs. overwrite)
    verbose => undef,   # boolean: print inputs, results.
    debug   => undef,   # boolean: set internal breakpoints.

    print   => 1,       # display the results

    p5lib   => undef,   # prefix PERL5LIB with the results

    ignore => '/,/usr', # dir's to skip looking for ./lib
);

# only new directories are used, ignore pre-loads
# this with unwanted values.

my %found = ();

# saves passing this between import and $handle_args.

my %argz    = ();
my $verbose = '';
my $empty   = q{};

########################################################################
# subroutines
########################################################################

# HAK ALERT: $Bin is an absolute path, there are cases
# where splitdir does not add the leading '' onto the
# directory path for it on VMS. Fix is to unshift a leading
# '' into @dirpath where the leading entry is true.

my $find_libs
= sub
{
    my $base    = basename ( shift || $argz{ base } );

    my $subdir  = $argz{ subdir } || '';

    my $subonly = defined $argz{ subonly };

    # for some reason, RH Enterprise V/4 has a
    # trailing '/'; I havn't seen another copy of
    # FindBin that does this. fix is quick enough:
    # strip the trailing '/'.
    #
    # using a regex to extract the value untaints it
    # (not useful for anything much, just helps the
    # poor slobs stuck in taint mode).
    #
    # after that splitpath can grab the directory
    # portion for future use.

    my ( $Bin ) = ( $argz{ Bin } =~ m{^ (.+) }xs );

    print STDERR "\nSearching $Bin for '$base'...\n"
    if $verbose;

    my( $vol, $dir ) = splitpath $Bin, 1;

    my @dirpath = splitdir $dir;

    # fix for File::Spec::VMS missing the leading empty
    # string on a split. this can be removed once File::Spec
    # is fixed.

    unshift @dirpath, '' if $dirpath[ 0 ];

    my @libz    = ();

    PATH:
    for( 1 .. @dirpath )
    {
        # note that catpath is extraneous on *NIX; the
        # volume only means something on DOS- & VMS-based
        # filesystems, and adding an empty basename on
        # *nix is unnecessary.
        #
        # HAK ALERT: the poor slobs stuck on windog have an
        # abs_path that croaks on missing directories. have
        # to eval the check for subdir's.

        my $abs
        = eval
        {
            abs_path
            catpath $vol, ( catdir @dirpath, $base ), $empty
        }
        || '';

        my $sub
        = $subdir
        ? eval { abs_path ( catpath '', $abs, $subdir ) } || ''
        : ''
        ;

        my @search = $subonly ? ( $sub ) : ( $abs, $sub );

        for my $dir ( @search )
        {
            if( $dir && -d $dir && ! exists $found{ $dir } )
            {
                $found{ $dir } = ();

                push @libz, $dir;

                last if $argz{ scalar };
            }
        }

        pop @dirpath
    }

    # caller gets back the existing lib paths
    # (including volume) walking up the path
    # from $FindBin::Bin -> root.
    #
    # no libs found is empty list or undef for
    # scalar.
    #
    # passing it back as a list isn't all that
    # painful for a few paths.

    wantarray ? @libz : \@libz
};

# break out the messy part into a separate block.

my $handle_args
= sub
{
    # discard the module, rest are arguments.

    shift;

    # anything after the module are options with arguments
    # assigned via '='.

    %argz
    = map
    {
        my $use_undef
        = do
        {
            my %a   = ();
            @a{ qw( export ignore ) } = ();
            \%a
        };

        my ( $k, $v ) = split '=', $_, 2;

        exists $use_undef->{ $k }
        or $v //= 1;

        # "no" inverts the sense of the test.

        $k =~ s{^no}{}
        and $v  = ! $v;

        ( $k => $v )
    }
    @_;

    # stuff "debug=1" into your arguments and perl -d will stop here.

    $DB::single = 1 if defined $argz{ debug };

    # default if nothing is supplied is to use the result;
    # otherwise, without use supplied either of export or
    # p5lib will turn off use.

    if( exists $argz{ use } )
    {
        # nothing further to do
    }
    elsif( defined $argz{ export } || defined $argz{ p5lib } )
    {
        $argz{ use } = undef;
    }
    else
    {
        $argz{ use } = 1;
    }

    local $defaultz{ Bin }
    = exists $argz{ realbin }
    ? $FindBin::RealBin
    : $FindBin::Bin
    ;

    # now apply the defaults, then sanity check the result.
    # base is a special case since it always has to exist.
    #
    # if $argz{ export } is defined but false then it takes
    # its default from $argz{ base }.

    while( my($k,$v) = each %defaultz )
    {
        # //= doesn't work here since undef may be a
        # legit default.

        exists $argz{ $k }
        or
        $argz{ $k } = $v;
    }

    exists $argz{ base } && $argz{ base }
    or croak "Bogus FindBin::libs: missing/false base argument, should be 'base=NAME'";

    exists $argz{ export }
    and
    $argz{ export } //= $argz{ base };

    $argz{ ignore } =
    [
        grep { $_ } split /\s*,\s*/, $argz{ ignore }
    ];

    $verbose = defined $argz{ verbose };

    my $base = $argz{ base };

    # now locate the libraries.
    #
    # %found contains the abs_path results for each directory to
    # avoid double-including directories.
    #
    # note: loop short-curcuts for the (usually) list.

    %found = ();

    for( @{ $argz{ ignore } } )
    {
        if( my $dir = eval { abs_path catdir $_, $base } )
        {
            if( -d $dir )
            {
                $found{ $dir } = 1;
            }
        }
    }
};

sub import
{
    &$handle_args;

    my @libz = $find_libs->();

    # HAK ALERT: the regex does nothing for security,
    # just dodges -T. putting this down here instead
    # of inside find_libs allows people to use saner
    # untainting plans via find_libs.

    @libz   = map { m{ (.+) }xs } @libz;

    my $caller = caller;

    if( $verbose || defined $argz{ print } )
    {
        local $\ = "\n";
        local $, = "\n\t";

        print STDERR "Found */$argz{ base }:", @libz
        if $verbose;
    }

    if( $argz{ export } )
    {
        # this has to run in order to install variables that
        # the caller is expecting to exist at runtime -- even
        # if they are empty/undef at the end of it.

        my $ref     = qualify_to_ref $argz{ export }, $caller;

        if( $verbose )
        {
            my $dest    = qualify $argz{ export }, $caller;

            $argz{ scalar }
            ? print STDERR "\nExporting: \$$dest\n"
            : print STDERR "\nExporting: \@$dest\n"
            ;
        }

        if( $argz{ scalar } )
        {
            *$ref
            = @libz
            ? \$libz[0]
            : \( my $a = '' )
            ;
        }
        elsif
        (
            $argz{ append }
            and
            my $ary = *{ $ref }{ ARRAY }
        )
        {
            push @$ary, @libz;
        }
        else
        {
            *$ref = \@libz
        }
    }

    # no 'else', these are not exclusive

    if( @libz )
    {
        if( defined $argz{ p5lib } )
        {
            # stuff the lib's found at the front of $ENV{ PERL5LIB }
            # yes, virginia, substr is an lvalue -- and saner than
            # dealing with \Q and a regex on arbitrary paths.

            ( substr $ENV{ PERL5LIB }, 0, 0 ) = join ':', @libz, '';

            print STDERR "\nUpdated PERL5LIB:\t$ENV{ PERL5LIB }\n"
            if $verbose;
        }

        if( $argz{ use } )
        {
            # this obviously won't work if lib ever depends
            # on the caller's package.
            #
            # it does avoids issues with -T blowing up on the
            # old eval technique.

            require lib;

            lib->import( @libz );
        }
    }

    0
}

# keep require happy

1

__END__