File Coverage

lib/Path/Resolve.pm

Criterion	Covered	Total	%
statement	163	310	52.5
branch	43	110	39.0
condition	24	99	24.2
subroutine	33	45	73.3
pod	3	4	75.0
total	266	568	46.8

package Path::Resolve;
use warnings;
use strict;
use Carp;
use Data::Dumper;

our $VERSION = '0.0.2';

my $isWindows = $^O eq 'MSWin32';

if ($isWindows) {
    eval "use base 'Path::Resolve::Win'";
    *splitPath = *Path::Resolve::Win::splitPath;
} else {
    eval "use base 'Path::Resolve::POSIX'";
    *splitPath = *Path::Resolve::POSIX::splitPath;
}

sub new {
    bless {}, __PACKAGE__;
}

sub dirname {
    my ($self,$path) = @_;
    my @result = splitPath($path);
    my $root = $result[0],
    my $dir = $result[1];
    if (!$root && !$dir) {
        #No dirname whatsoever
        return '.';
    }
    if ($dir) {
        #It has a dirname, strip trailing slash
        $dir = substr $dir,0, length($dir) - 1;
    }
    return $root . $dir;
}

sub extname {
    my ($self,$path) = @_;
    return (splitPath($path))[3];
}

sub basename {
    my ($self, $path, $ext) = @_;
    my $f = (splitPath($path))[2];
    #TODO: make this comparison case-insensitive on windows?
    if ($ext && (substr $f, -1 * length $ext) eq $ext) {
        $f = substr $f, 0, length($f) - length($ext);
    }
    return $f;
}

package
    Path::Resolve::Win; {
    use Carp;
    use strict;
    use warnings;
    use Cwd();
    use Data::Dumper;

    my $splitDeviceRe =   qr/^([a-zA-Z]:|[\\\/]{2}[^\\\/]+[\\\/]+[^\\\/]+)?([\\\/])?([\s\S]*?)$/;
    my $splitTailRe   =   qr/^([\s\S]*?)((?:\.{1,2}|[^\\\/]+?|)(\.[^.\/\\]*|))(?:[\\\/]*)$/;
    my $CWD = Cwd::cwd();

    sub sep {'\\'};
    sub delimiter {';'};

    sub splitPath {
        my ($filename) = @_;
        my @result = Path::Resolve::Utils::exec($splitDeviceRe,$filename);
        my $device = ($result[1] || '') . ($result[2] || '');
        my $tail = $result[3] || '';
        #Split the tail into dir, basename and extension
        my @result2 = Path::Resolve::Utils::exec($splitTailRe,$tail);
        my $dir = $result2[1];
        my $basename = $result2[2];
        my $ext = $result2[3];
        return ($device, $dir, $basename, $ext);
    }

    sub parse {
        my ($self, $path) = @_;
        if (!$path || ref $path){
            croak("Parameter 'pathString' must be a string");
        }

        my @allParts = splitPath($path);

        if (!@allParts || scalar @allParts != 4) {
            croak("Invalid path '" . $path . "'");
        }

        return {
            root => $allParts[0],
            dir  => $allParts[0] . substr ($allParts[1], 0, -1),
            base => $allParts[2],
            ext  => $allParts[3],
            name => substr ($allParts[2], 0, length($allParts[2]) - length($allParts[3]))
        };
    }

    sub format {
        my ($self, $pathObject) = @_;
        if ( ref $pathObject ne 'HASH' ) {
            croak "Parameter 'pathObject' must be an Hash Ref";
        }

        my $root = $pathObject->{root} || '';
        if (!defined $root || ref $root) {
            croak 'pathObject->{root} must be a string or undefined';
        }

        my $dir = $pathObject->{dir};
        my $base = $pathObject->{base} || '';
        if (!$dir) {
            return $base;
        }

        my $t = substr $dir, length($dir) - 1,  2;
        if ($t eq $self->sep) {
            return $dir . $base;
        }

        return $dir . $self->sep . $base;
    }

    sub isAbsolute {
        my ($self, $path) = @_;
        my @result = Path::Resolve::Utils::exec($splitDeviceRe,$path);
        my $device = $result[1] || '';
        my $isUnc = $device && $device !~ /^.:/;
        ##UNC paths are always absolute
        return !!$result[2] || $isUnc;
    }

    sub normalizeUNCRoot {
        my $device = shift;
        $device =~ s/^[\\\/]+//;
        $device =~ s/[\\\/]+/\\/g;
        return '\\\\' . $device;
    }

    sub resolve {
        my $self = shift;
        my $resolvedDevice = '';
        my $resolvedTail = '';
        my $resolvedAbsolute = 0;
        my $isUnc;
        my @args = @_;
        for (my $i = (scalar @args) - 1; $i >= -1; $i--) {
            my $path;
            if ($i >= 0) {
                $path = $_[$i];
            } elsif (!$resolvedDevice) {
                $path = $CWD;
            } else {
                ##TODO
            }

            ## skip empty paths
            if (!$path) {
                next;
            }

            my @result = Path::Resolve::Utils::exec($splitDeviceRe,$path);
            my $device = $result[1] || '';
            $isUnc = $device && $device !~ /^.:/;
            my $isAbsolute = $self->isAbsolute($path);
            my $tail = $result[3];
            if ($device &&
                $resolvedDevice &&
                ( lc $device ne lc $resolvedDevice ) ) {
                #This path points to another device so it is not applicable
                next;
            }

            if (!$resolvedDevice) {
                $resolvedDevice = $device;
            }
            if (!$resolvedAbsolute) {
                $resolvedTail = $tail . '\\' . $resolvedTail;
                $resolvedAbsolute = $isAbsolute;
            }
            if ($resolvedDevice && $resolvedAbsolute) {
                last;
            }
        }

        #Convert slashes to backslashes when `resolvedDevice` points to an UNC
        #root. Also squash multiple slashes into a single one where appropriate.
        if ($isUnc) {
            $resolvedDevice = normalizeUNCRoot($resolvedDevice);
        }

        my @resolvedTail = grep {$_ if $_} split /[\\\/]+/, $resolvedTail;
        @resolvedTail = Path::Resolve::Utils::normalizeArray(\@resolvedTail,!$resolvedAbsolute);
        $resolvedTail = join '\\',@resolvedTail;
        my $ret = ($resolvedDevice . ($resolvedAbsolute ? '\\' : '') . $resolvedTail) || '.';
        return $ret;
    }

    sub normalize {
        my ($self, $path) = @_;
        my @result = Path::Resolve::Utils::exec($splitDeviceRe,$path);
        my $device = $result[1] || '';
        my @device = split '',$device;
        my $isUnc = @device && $device[1] ne ':';
        my $isAbsolute = !!$result[2] || $isUnc;
        my $tail = $result[3];
        my $trailingSlash = $tail =~ /[\\\/]$/;
        #If device is a drive letter, we'll normalize to lower case.
        if (@device && $device[1] eq ':') {
            $device = lc $device;
        }

        my @tail = grep {$_ if $_} split /[\\\/]+/, $tail;
        @tail = Path::Resolve::Utils::normalizeArray(\@tail,!$isAbsolute);
        $tail = join '\\', @tail;
        if (!$tail && !$isAbsolute) {
            $tail = '.';
        }
        if ($tail && $trailingSlash) {
            $tail .= '\\';
        }
        #Convert slashes to backslashes when `device` points to an UNC root.
        #Also squash multiple slashes into a single one where appropriate.
        if ($isUnc) {
            $device = normalizeUNCRoot($device);
        }

        return $device . ($isAbsolute ? '\\' : '') . $tail;
    }

    sub join {
        my $self = shift;
        my @paths = grep {$_ if $_} @_;
        my $joined = join '\\', @paths;
        if ( @paths && $paths[0] !~ /^[\\\/]{2}[^\\\/]/ ) {
            $joined =~ s/^[\\\/]{2,}/\\/;
        }
        return $self->normalize($joined);
    }

    sub _trim {
        my @arr = @_;
        my $start = 0;
        foreach my $a (@arr) {
            last if ($a ne '');
            $start++;
        }
        my $end = scalar @arr - 1;
        while ($end >= 0) {
            last if ($arr[$end] ne '');
            $end--;
        }
        return () if ($start > $end);
        return splice @arr,$start, $end - $start + 1;
    }

    sub relative {
        my ($self, $from, $to) = @_;
        $from = $self->resolve($from);
        $to = $self->resolve($to);
        #windows is not case sensitive
        my $lowerFrom = lc $from;
        my $lowerTo = lc $to;
        my @toParts = _trim(split(/\\/, $to));
        my @lowerFromParts = _trim(split(/\\/,$lowerFrom));
        my @lowerToParts = _trim(split(/\\/,$lowerTo));
        my $length = do {
            my $len = scalar @lowerFromParts;
            my $len2 = scalar @lowerToParts;
            $len < $len2 ? $len : $len2;
        };

        my $samePartsLength = $length;
        for (my $i = 0; $i < $length; $i++) {
            if ($lowerFromParts[$i] ne $lowerToParts[$i]) {
                $samePartsLength = $i;
                last;
            }
        }
        if ($samePartsLength == 0) {
            return $to;
        }

        my @outputParts = ();
        for (my $i = $samePartsLength; $i < scalar @lowerFromParts; $i++) {
            push @outputParts, ('..');
        }

        push @outputParts, ( splice(@toParts,$samePartsLength) );
        return CORE::join '\\',@outputParts;
    }
} #end Path::Resolve::Win


package
    Path::Resolve::POSIX; {
    use strict;
    use warnings;
    use Carp;
    use Cwd();
    my $CWD = Cwd::cwd();

    sub sep {'/'};
    sub delimiter {':'};

    #'root' is just a slash, or nothing.
    my $splitPathRe = qr/^(\/?|)([\s\S]*?)((?:\.{1,2}|[^\/]+?|)(\.[^.\/]*|))(?:[\/]*)$/;
    sub splitPath {
        my ($filename) = @_;
        my @res = Path::Resolve::Utils::exec($splitPathRe,$filename);
        return splice @res, 1;
    }

    sub parse {
        my ($self, $path) = @_;
        if (!$path || ref $path){
            croak("Parameter 'pathString' must be a string");
        }

        my @allParts = splitPath($path);

        if (!@allParts || scalar @allParts != 4) {
            croak("Invalid path '" . $path . "'");
        }

        $allParts[1] ||= '';
        $allParts[2] ||= '';
        $allParts[3] ||= '';

        return {
            root => $allParts[0],
            dir  => $allParts[0] . substr ($allParts[1], 0, -1),
            base => $allParts[2],
            ext  => $allParts[3],
            name => substr ($allParts[2], 0, length($allParts[2]) - length($allParts[3]))
        };
    }

    sub format {
        my ($self, $pathObject) = @_;
        if ( ref $pathObject ne 'HASH' ) {
            croak "Parameter 'pathObject' must be an Hash Ref";
        }

        my $root = $pathObject->{root} || '';
        if (!defined $root || ref $root) {
            croak 'pathObject->{root} must be a string or undefined';
        }

        my $dir = $pathObject->{dir} ? $pathObject->{dir} . $self->sep : '';
        my $base = $pathObject->{base} || '';
        return $dir . $base;
    }

    sub resolve {
        my $self = shift;
        my $resolvedPath = '';
        my $resolvedAbsolute = 0;
        my @args = @_;
        for (my $i = (scalar @args) - 1; $i >= -1 && !$resolvedAbsolute; $i--) {
            my $path = ($i >= 0) ? $args[$i] : $CWD;
            #Skip empty and invalid entries
            if (!$path) {
                next;
            }
            $resolvedPath = $path . '/' . $resolvedPath;
            $resolvedAbsolute = $path =~ m/^\//;
        }

        #At this point the path should be resolved to a full absolute path, but
        #handle relative paths to be safe (might happen when process.cwd() fails)
        #Normalize the path
        my @resolved = grep { $_ if $_ } split '/', $resolvedPath;
        $resolvedPath = join '/', Path::Resolve::Utils::normalizeArray(\@resolved, !$resolvedAbsolute);
        return (($resolvedAbsolute ? '/' : '') . $resolvedPath) || '.';
    }

    sub isAbsolute {
        my ($self, $path) = @_;
        return $path =~ /^\//;
    }

    sub normalize {
        my ($self, $path) = @_;
        my $isAbsolute = $self->isAbsolute($path);
        my $trailingSlash = (substr $path, -1) eq '/';
        #Normalize the path
        my @resolved = grep { $_ if $_ } split '/', $path;
        $path = join '/', Path::Resolve::Utils::normalizeArray(\@resolved, !$isAbsolute);
        if (!$path && !$isAbsolute) {
            $path = '.';
        }
        if ($path && $trailingSlash) {
            $path .= '/';
        }
        return ($isAbsolute ? '/' : '') . $path;
    }

    sub join {
        my $self = shift;
        my @paths = @_;
        my @norm = grep {$_ if $_} @paths;
        return $self->normalize( join('/', @norm) );
    }

    sub _trim {
        my @arr = @_;
        my $start = 0;
        foreach my $a (@arr) {
            last if ($a ne '');
            $start++;
        }
        my $end = scalar @arr - 1;
        while ($end >= 0) {
            last if ($arr[$end] ne '');
            $end--;
        }
        return () if ($start > $end);
        return splice @arr,$start, $end - $start + 1;
    }

    sub relative {
        my ($self, $from, $to) = @_;
        $from = substr resolve($self,$from),1;
        $to = substr resolve($self,$to),1;
        my @fromParts = _trim( split('/',$from) );
        my @toParts = _trim( split('/',$to) );
        my $length = do {
            my $len = scalar @fromParts;
            my $len2 = scalar @toParts;
            $len < $len2 ? $len : $len2;
        };

        my $samePartsLength = $length;
        for (my $i = 0; $i < $length; $i++) {
            if ($fromParts[$i] ne $toParts[$i]) {
                $samePartsLength = $i;
                last;
            }
        }

        my @outputParts = ();
        for (my $i = $samePartsLength; $i < scalar @fromParts; $i++) {
            push @outputParts, ('..');
        }

        push @outputParts, ( splice(@toParts,$samePartsLength) );
        return CORE::join '/',@outputParts;
    }
} #end Path::Resolve::Posix

package
    Path::Resolve::Utils; {
    use strict;
    use warnings;

    #==========================================================================
    # javascript like exec function
    # we can do it the perl way but for fun I want to emulate node path module
    # the way it is :)
    #==========================================================================
    sub exec {
        my ($expr,$string) = @_;
        my @m = $string =~ $expr;
        if (@m){
            unshift @m, substr $string,$-[0],$+[0];
        }
        return @m;
    }

    sub normalizeArray {
        my ($parts, $allowAboveRoot) = @_;
        #if the path tries to go above the root, `up` ends up > 0
        my @parts = @{$parts};
        my $up = 0;
        for (my $i = (scalar @parts) - 1; $i >= 0; $i--) {
            my $last = $parts->[$i];
            if ($last eq '.') {
                splice @parts, $i, 1;
            } elsif ($last eq '..') {
                splice @parts, $i, 1;
                $up++;
            } elsif ($up) {
                splice @parts, $i, 1;
                $up--;
            }
        }

        #if the path is allowed to go above the root, restore leading ..s
        if ($allowAboveRoot) {
            while ($up--) {
                unshift @parts, ('..');
            }
        }
        return @parts;
    }
} # end Path::Resolve::Utils

1;

__END__