File Coverage

blib/lib/File/FindLib.pm

Criterion	Covered	Total	%
statement	56	58	96.5
branch	15	20	75.0
condition	8	12	66.6
subroutine	8	8	100.0
pod	0	2	0.0
total	87	100	87.0

package File::FindLib;
use strict;

use File::Basename          qw< dirname >;
use File::Spec::Functions   qw< rel2abs catdir splitdir >;

use vars                    qw< $VERSION >;

my $Pkg= __PACKAGE__;   # Our class name (convenient to use in messages)
BEGIN {
    $VERSION= 0.001_004;
}

return 1;   # No run-time code below; just 'sub's and maybe BEGIN blocks


sub import {
    my( $class, @args )= @_;
    if(  1 == @args  ) {
        my( $find )= @args;
        return LookUp(
            -from => ( caller )[1],
            -upto => $find,
            -add  => $find,
        );
    } else {
        die "Too many arguments to 'use $Pkg'.  Not yet supported.\n";
    }
}


sub LookUp {
    my %args=   @_;
    my $from=   rel2abs( $args{-from} );
    my $upto=   $args{-upto};
    my $add=    $args{-add};

    warn "$Pkg finds no $from; perhaps chdir()ed before 'use $Pkg'?\n"
        if  ! -e $from  &&  $^W;
    if(  -l $from  ) {
        $from= rel2abs( readlink($from), dirname($from) );
    }
    my $dir= $from;
    $dir= dirname( $dir )
        if  ! -d _;
    while(  1  ) {
        my $find= catdir( $dir, $upto );
        if(  -e $find  ) {
            my $path= catdir( $dir, $add );
            if(  -d $path  ) {
                require lib;
                lib->import( $path );
                return $path;
            }
            my $ret= require $path;
            UpdateInc( $path );
            return $ret;
        }
        my $up= dirname( $dir );
        die "$Pkg can't find $find in ancestor directory of $from.\n"
            if  $up eq $dir;
        $dir= $up;
    }
}


# Set $INC{'My/Mod.pm'} after loading 'lib/My/Mod.pm';
# so "use File::FindLib 'lib/Mod.pm'; use Mod;" doesn't load it twice.

sub UpdateInc {
    my( $path )= @_;    # Path to module file.
    my $base= $path;    # Path minus ".pm"; parts that go into package name.
    return 0            # If no .pm on end, "use Bareword" wouldn't find it.
        if  $base !~ s/[.]pm$//;
    my @parts= grep length $_, splitdir( $base );   # Potential pkg name parts.
    my @names;              # Above minus leading parts that aren't barewords.
    unshift @names, pop @parts              # Include last part until find...
        while  @parts  &&  $parts[-1] =~ /^\w+$/;   # ...a non-bareword.
 EDGE:
    for my $o ( 0 .. $#names ) {    # Strip shortest prefix that leaves a pkg.
        next            # "use Foo::123" works but "use 123::Foo" wouldn't.
            if  $names[$o] =~ /^[0-9]/;
        my $stab= \%main::;
        my @pkg= @names[ $o..$#names ];
        for my $name ( @pkg ) {         # Defined package? No autovivification.
            $stab= $stab->{$name.'::'};
            next EDGE
                if  ! $stab  ||  'GLOB' ne ref \$stab;
        }
        my $mod= join '/', @pkg;        # @INC always uses '/'; no catdir()
        $INC{"$mod.pm"} ||= $INC{$path};
        return 1;
    }
    return 0;
}


__END__