File Coverage

blib/lib/FindBin/libs.pm

Criterion	Covered	Total	%
statement	45	50	90.0
branch	17	28	60.7
condition	3	5	60.0
subroutine	9	9	100.0
pod			n/a
total	74	92	80.4

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

package FindBin::libs   v4.0.4;
use v5.40;

use File::Basename;

use Carp        qw( croak                   );
use List::Util  qw( uniq first              );
use Symbol      qw( qualify qualify_to_ref  );

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

use FindBin::Bin        qw( $Bin        );
use FindBin::Parents    qw( dir_paths   );

########################################################################
# 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 => q{,usr} # dir's to skip looking for ./lib
);

# saves passing this between import and $handle_args.

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

########################################################################
# utility subs
########################################################################

# 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 $append_subdir
= sub( $path, @subz )
{
    my ( $vol, $dir )   = splitpath $path, 1;

    catpath
    (
        $vol
      , catdir( $dir => @subz )
      , ''
    )
};

my $find_libs
= sub
{
    my $base    = basename ( shift // $argz{ base } );
    my $subdir  = $argz{ subdir } // '';
    my $subonly = defined $argz{ subonly } || defined $argz{ scalar };
    my @found   = ();
    my $ignorz  = $argz{ ignore };

    say STDERR "\nSearching $Bin for '$base' ($subdir)..."
    if $verbose;

    my @search
    = do
    {
        my @dirz    = dir_paths $Bin, 1;

        say STDERR join "\n\t" => 'Parent Dirs:', @dirz
        if $verbose;;

        my ( $vol ) = splitpath $dirz[0];
        my %skipz
        = map
        {
            (
                catpath( $vol => $_, '' ) => 1
            )
        }
        $ignorz->@*;

        my @subz
        = grep
        {
            ! exists $skipz{ $_ }
        }
        map
        {
            $_->$append_subdir( $base )
        }
        @dirz;

        say STDERR join "\n\t" => 'Search Subs:', @subz
        if $verbose;;

        if( $subdir )
        {
            map
            {
                my $sub = $_->$append_subdir( $subdir );

                $subonly
                ? $sub
                : [ $sub => $_ ]
            }
            @subz
        }
        else
        {
            $subonly    = 1;
            @subz
        }
    };

    if( $argz{ scalar } )
    {
        # return at most one item.

        first
        {
            -e
        }
        @search
    }
    elsif( $subonly )
    {
        # grab all the extant items on the list.

        grep
        {
            -e
        }
        @search
    }
    else
    {
        # if the subdir exists then return it and the subdir.

        map
        {
            -e $_->[0]
            ? $_->@*
            : ()
        }
        @search
    }
};

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 )
    }
    @_;

    # exporting a subdir as a scalar requires stopping at
    # the subdir, ignoring its parent.

    $argz{ subonly }
    ||= $argz{ export } && $argz{ subdir } && $argz{ scalar };

    # 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;
    }

    # 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'";

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

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

    $verbose = defined $argz{ verbose };
};

########################################################################
# interface
########################################################################

sub import
{
    &$handle_args;

    my @libz
    = map
    {
        # HAK ALERT: the regex does nothing for security,
        # just dodges -T.
        #
        # undef happens when nothing matches and the list
        # returned is empty. this just leaves @libz empty.

        defined
        ? m{ (.+) }xs
        : ()
    }
    $find_libs->();

    say join "\n\t" => 'Found Libs:', @libz
    if $verbose;

    my $caller = caller;

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

        say 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 }
            ? say STDERR "\nExporting: \$$dest"
            : say STDERR "\nExporting: \@$dest"
            ;
        }

        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, '';

            say STDERR "\nUpdated PERL5LIB:\t$ENV{ PERL5LIB }"
            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__