9bc82ce 11 years ago
1 contributor
276 lines | 5.777kb
package Mojo::Path;
use Mojo::Base -base;
use overload
  'bool'   => sub {1},
  '""'     => sub { shift->to_string },
  fallback => 1;

use Mojo::Util qw(decode encode url_escape url_unescape);

has charset => 'UTF-8';
has [qw(leading_slash trailing_slash)];
has parts => sub { [] };

sub new { shift->SUPER::new->parse(@_) }

sub canonicalize {
  my $self = shift;

  my @parts;
  for my $part (@{$self->parts}) {

    # ".."
    if ($part eq '..') {
      unless (@parts && $parts[-1] ne '..') { push @parts, '..' }
      else                                  { pop @parts }
      next;
    }

    # "."
    next if grep { $_ eq $part } '.', '';

    push @parts, $part;
  }
  $self->trailing_slash(undef) unless @parts;

  return $self->parts(\@parts);
}

sub clone {
  my $self  = shift;
  my $clone = Mojo::Path->new;
  $clone->leading_slash($self->leading_slash);
  $clone->trailing_slash($self->trailing_slash);
  return $clone->charset($self->charset)->parts([@{$self->parts}]);
}

sub contains {
  my ($self, $path) = @_;

  my $parts = $self->new($path)->parts;
  for my $part (@{$self->parts}) {
    return 1 unless defined(my $try = shift @$parts);
    return undef unless $part eq $try;
  }

  return !@$parts;
}

sub merge {
  my ($self, $path) = @_;

  # Replace
  return $self->parse($path) if $path =~ m!^/!;

  # Merge
  pop @{$self->parts} unless $self->trailing_slash;
  $path = $self->new($path);
  push @{$self->parts}, @{$path->parts};
  return $self->trailing_slash($path->trailing_slash);
}

sub parse {
  my ($self, $path) = @_;

  $path = url_unescape defined $path ? $path : '';
  my $charset = $self->charset;
  $path = do { my $tmp = decode($charset, $path); defined $tmp ? $tmp : $path } if $charset;
  $self->leading_slash($path =~ s!^/!!  ? 1 : undef);
  $self->trailing_slash($path =~ s!/$!! ? 1 : undef);

  return $self->parts([split '/', $path, -1]);
}

sub to_abs_string { $_[0]->leading_slash ? "$_[0]" : "/$_[0]" }

sub to_dir {
  my $clone = shift->clone;
  pop @{$clone->parts} unless $clone->trailing_slash;
  return $clone->trailing_slash(@{$clone->parts} ? 1 : 0);
}

sub to_route {
  my $self = shift;
  return '/' . join('/', @{$self->parts}) . ($self->trailing_slash ? '/' : '');
}

sub to_string {
  my $self = shift;

  my @parts   = @{$self->parts};
  my $charset = $self->charset;
  @parts = map { encode $charset, $_ } @parts if $charset;
  my $path = join '/',
    map { url_escape $_, '^A-Za-z0-9\-._~!$&\'()*+,;=:@' } @parts;
  $path = "/$path" if $self->leading_slash;
  $path = "$path/" if $self->trailing_slash;

  return $path;
}

1;

=encoding utf8

=head1 NAME

Mojo::Path - Path

=head1 SYNOPSIS

  use Mojo::Path;

  my $path = Mojo::Path->new('/foo%2Fbar%3B/baz.html');
  shift @{$path->parts};
  say "$path";

=head1 DESCRIPTION

L<Mojo::Path> is a container for URL paths.

=head1 ATTRIBUTES

L<Mojo::Path> implements the following attributes.

=head2 charset

  my $charset = $path->charset;
  $path       = $path->charset('UTF-8');

Charset used for encoding and decoding, defaults to C<UTF-8>.

  # Disable encoding and decoding
  $path->charset(undef);

=head2 leading_slash

  my $leading_slash = $path->leading_slash;
  $path             = $path->leading_slash(1);

Path has a leading slash.

=head2 parts

  my $parts = $path->parts;
  $path     = $path->parts([qw(foo bar baz)]);

The path parts.

  # Part with slash
  push @{$path->parts}, 'foo/bar';

=head2 trailing_slash

  my $trailing_slash = $path->trailing_slash;
  $path              = $path->trailing_slash(1);

Path has a trailing slash.

=head1 METHODS

L<Mojo::Path> inherits all methods from L<Mojo::Base> and implements the
following new ones.

=head2 new

  my $path = Mojo::Path->new;
  my $path = Mojo::Path->new('/foo%2Fbar%3B/baz.html');

Construct a new L<Mojo::Path> object.

=head2 canonicalize

  $path = $path->canonicalize;

Canonicalize path.

  # "/foo/baz"
  Mojo::Path->new('/foo/bar/../baz')->canonicalize;

=head2 clone

  my $clone = $path->clone;

Clone path.

=head2 contains

  my $success = $path->contains('/i/♥/mojolicious');

Check if path contains given prefix.

  # True
  Mojo::Path->new('/foo/bar')->contains('/');
  Mojo::Path->new('/foo/bar')->contains('/foo');
  Mojo::Path->new('/foo/bar')->contains('/foo/bar');

  # False
  Mojo::Path->new('/foo/bar')->contains('/f');
  Mojo::Path->new('/foo/bar')->contains('/bar');
  Mojo::Path->new('/foo/bar')->contains('/whatever');

=head2 merge

  $path = $path->merge('/foo/bar');
  $path = $path->merge('foo/bar');
  $path = $path->merge(Mojo::Path->new('foo/bar'));

Merge paths.

  # "/baz/yada"
  Mojo::Path->new('/foo/bar')->merge('/baz/yada');

  # "/foo/baz/yada"
  Mojo::Path->new('/foo/bar')->merge('baz/yada');

  # "/foo/bar/baz/yada"
  Mojo::Path->new('/foo/bar/')->merge('baz/yada');

=head2 parse

  $path = $path->parse('/foo%2Fbar%3B/baz.html');

Parse path. Note that C<%2F> will be treated as C</> for security reasons.

=head2 to_abs_string

  my $string = $path->to_abs_string;

Turn path into an absolute string.

  # "/i/%E2%99%A5/mojolicious"
  Mojo::Path->new('i/%E2%99%A5/mojolicious')->to_abs_string;

=head2 to_dir

  my $dir = $route->to_dir;

Clone path and remove everything after the right-most slash.

  # "/i/%E2%99%A5/"
  Mojo::Path->new('i/%E2%99%A5/mojolicious')->to_dir->to_abs_string;

=head2 to_route

  my $route = $path->to_route;

Turn path into a route.

  # "/i/♥/mojolicious"
  Mojo::Path->new('i/%E2%99%A5/mojolicious')->to_route;

=head2 to_string

  my $string = $path->to_string;
  my $string = "$path";

Turn path into a string.

  # "i/%E2%99%A5/mojolicious"
  Mojo::Path->new('i/%E2%99%A5/mojolicious')->to_string;

=head1 SEE ALSO

L<Mojolicious>, L<Mojolicious::Guides>, L<http://mojolicio.us>.

=cut