File Coverage

blib/lib/FindBin/Parents.pm

Criterion	Covered	Total	%
statement	34	34	100.0
branch	4	6	66.6
condition	4	6	66.6
subroutine	8	8	100.0
pod	0	2	0.0
total	50	56	89.2

########################################################################
# housekeeping
########################################################################
package FindBin::Parents  v0.1.0;
use v5.40;
use parent qw( Exporter );

use Carp            qw( croak   );
use List::Util      qw( reduce  );
use Storable        qw( dclone  );

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

########################################################################
# package variables and sanity checks
########################################################################

our @EXPORT_OK
= qw
(
    dir_paths
    clear_parent_cache
);

my %path2dirz   = ();

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

########################################################################
# exported
########################################################################

# avoid issues with repeated use on different paths.

sub clear_parent_cache()
{
    %path2dirz  = ();
}

sub dir_paths( $path, $assume_dir = 1 )
{
    $path
    or croak 'Bogus dir_paths: false path argument.';

    my $dirz
    = $path2dirz{ $path . $; . $assume_dir }
    ||= do
    {
        # treat non-existant paths as dir's, mainly for testing.

        my $is_dir  = $assume_dir || -d $path;

        my ( $vol, $dir ) = splitpath $path, $is_dir;

        # ditch the starting directory.

        my @dirz    = splitdir rel2abs canonpath $dir;

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

        my $tmp
        = $dirz[0]
        ? ''
        : shift @dirz
        ;

        [
            reverse
            map
            {
                catpath $vol => $_, ''
            }
            map
            {
                $tmp    = catdir $tmp, $_
            }
            ( '' => @dirz )
        ]
    };

    wantarray
    ?   @$dirz
    : [ @$dirz ]
}

1
__END__