File Coverage

blib/lib/Path/Naive.pm

Criterion	Covered	Total	%
statement	69	69	100.0
branch	46	48	95.8
condition	32	36	88.8
subroutine	13	13	100.0
pod	9	9	100.0
total	169	175	96.5

package Path::Naive;

our $AUTHORITY = 'cpan:PERLANCAR'; # AUTHORITY
our $DATE = '2020-02-12'; # DATE
our $DIST = 'Path-Naive'; # DIST
our $VERSION = '0.043'; # VERSION

use strict;
use warnings;

use Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
    abs_path
    concat_and_normalize_path
    concat_path
    normalize_and_split_path
    normalize_path
    is_abs_path
    is_rel_path
    rel_path
    split_path
);

sub abs_path {
    my ($path, $base) = @_;

    die "Please specify path (first arg)"  unless defined $path && length $path;
    die "Please specify base (second arg)" unless defined $base && length $base;
    die "base must be absolute" unless is_abs_path($base);
    concat_and_normalize_path($base, $path);
}

sub is_abs_path {
    my $path = shift;
    die "Please specify path" unless defined $path && length $path;
    $path =~ m!\A/! ? 1:0;
}

sub is_rel_path {
    my $path = shift;
    die "Please specify path" unless defined $path && length $path;
    $path =~ m!\A/! ? 0:1;
}

sub concat_path {
    die "Please specify at least two paths" unless @_ > 1;
    my $i = 0;
    my $res = $_[0];
    for (@_) {
        die "Please specify path (#$i)" unless defined && length;
        next unless $i++;
        if (m!\A/!) {
            $res = $_;
        } else {
            $res .= ($res =~ m!/\z! ? "" : "/") . $_;
        }
    }
    $res;
}

sub concat_and_normalize_path {
    normalize_path(concat_path(@_));
}

my $_split;
sub _normalize_path {
    my $path = shift;
    my @elems0 = split_path($path);
    my $is_abs = $path =~ m!\A/!;
    my @elems;
    while (@elems0) {
        my $elem = shift @elems0;
        next if $elem eq '.' && (@elems || @elems0 || $is_abs);
        do { pop @elems; next } if $elem eq '..' &&
            (@elems>1 && $elems[-1] ne '..' ||
                 @elems==1 && $elems[-1] ne '..' && $elems[-1] ne '.' && @elems0 ||
                     $is_abs);
        push @elems, $elem;
    }
    return @elems if $_split;
    ($is_abs ? "/" : "") . join("/", @elems);
}

sub normalize_path {
    $_split = 0;
    goto &_normalize_path;
}

sub normalize_and_split_path {
    $_split = 1;
    goto &_normalize_path;
}

sub rel_path {
    my ($path, $base) = @_;

    die "Please specify path (first arg)"  unless defined $path && length $path;
    die "Please specify base (second arg)" unless defined $base && length $base;
    die "path must be absolute" unless is_abs_path($path);
    die "base must be absolute" unless is_abs_path($base);
    my @elems_path = normalize_and_split_path($path);
    my @elems_base = normalize_and_split_path($base);

    my $num_common_elems = 0;
    for (0..$#elems_base) {
        last unless @elems_path > $num_common_elems;
        last unless
            $elems_path[$num_common_elems] eq $elems_base[$num_common_elems];
        $num_common_elems++;
    }
    my @elems;
    push @elems, ".." for ($num_common_elems .. $#elems_base);
    push @elems, @elems_path[$num_common_elems .. $#elems_path];
    @elems = (".") unless @elems;
    join("/", @elems);
}

sub split_path {
    my $path = shift;
    die "Please specify path" unless defined $path && length $path;
    grep {length} split qr!/+!, $path;
}

1;
# ABSTRACT: Yet another abstract, Unix-like path manipulation routines

__END__