File Coverage

blib/lib/Mojo/Path/Role/Relative.pm

Criterion	Covered	Total	%
statement	29	29	100.0
branch	10	12	83.3
condition	1	4	25.0
subroutine	5	5	100.0
pod	3	3	100.0
total	48	53	90.5

package Mojo::Path::Role::Relative;
use Mojo::Base -role;
use Mojo::File;

our $VERSION = '0.01';

# https://github.com/mojolicious/mojo/issues/573

requires qw{clone leading_slash new parts to_string trailing_slash};

sub is_subpath_of {
    my ($self, $base) = @_;
    $base = $self->new($base) unless ref($base);
    return 0 if @$base > @$self;

    my $sp = [@{$self}];
    my $bp = $base->parts;

    for (my $i = 0; $i < @$bp; ++$i) {
        $i = @$bp && next if $bp->[$i] ne $sp->[0];
        shift @$sp;
    }

    return !!(@$self != @$sp);
}

sub to_rel {
    my ($self, $base) = @_;
    my $x = Mojo::File->new("$self");
    return $self->new($x->to_rel("$base")->to_string);
}

sub to_subpath_of {
    my ($self, $base) = @_;
    my $clone = $self->clone;
    return $clone unless $self->is_subpath_of($base);
    $base = $self->new($base) unless ref($base);

    my $bp = $base->parts;

    for (my $i = 0; $i < @$bp; ++$i) {
        $i = @$bp && next if ($bp->[$i] ne $clone->parts->[0]);
        shift @{$clone->{parts}};
    }

    return $clone->leading_slash(0);
}

1;


=encoding utf8

=begin html





=end html

=head1 NAME

Mojo::Path::Role::Relative - Relative operations on a Mojo::Path

=head1 SYNOPSIS

  $path = Mojo::Path->with_roles('+Relative')->new('/foo/bar/baz/data.json');
  $base = Mojo::Path->new('/foo/bar');
  # 1
  $path->is_subpath_of($base);
  # "baz/data.json"
  $path->to_subpath_of($base);
  # "baz/data.json"
  $path->to_rel($base);

=head1 DESCRIPTION

L was deprecated sometime ago. A suggestion was made to move
the functionality to L. This is an implementation of that suggestion
as a L.

=head1 METHODS

This role adds the following methods to L when composed.

=head2 is_subpath_of

=head2 to_rel

=head2 to_subpath_of



=head1 AUTHOR

kiwiroy - Roy Storey

=head1 LICENSE

This library is free software and may be distributed under the same terms as
perl itself.

=cut