File Coverage

blib/lib/URI/Normalize.pm

Criterion	Covered	Total	%
statement	42	42	100.0
branch	13	18	72.2
condition	3	6	50.0
subroutine	7	7	100.0
pod	2	2	100.0
total	67	75	89.3

package URI::Normalize;
$URI::Normalize::VERSION = '0.001';
use strict;
use warnings;

use base 'Exporter';

use URI;
use Scalar::Util qw( blessed );

our @EXPORT_OK = qw( normalize_uri remove_dot_segments );

# ABSTRACT: Normalize URIs according to RFC 3986


sub normalize_uri {
    my $uri = shift;

    die '$uri is a required parameter to normalize_uri' unless defined $uri;

    $uri = URI->new($uri) unless blessed($uri) and $uri->isa('URI');

    # Start by placing the URI in canonical form
    $uri = $uri->canonical;
    $uri = remove_dot_segments($uri);

    return $uri;
}


sub remove_dot_segments {
    my $uri = shift;

    die '$uri is a required parameter to normalize_uri' unless defined $uri;

    if (not (blessed($uri) and $uri->isa('URI'))) {
        $uri = URI->new($uri);
    }
    else {
        $uri = $uri->clone;
    }

    my $input = $uri->path;
    my $output = '';

    while (length $input > 0) {

        # A. ^./ and ^../ are deleted
        next if $input =~ s{ ^ [.][.]? / }{}x;

        # B. ^/./ and ^/.$ are deleted
        next if $input =~ s{ ^ /[.] (?: / | $ ) }{/}x;

        # C. ^/../ and ^/..$ remove last element of output and delete
        if ($input =~ s{ ^ /[.][.] (?: / | $ ) }{/}x) {
            my $segstart = rindex($output, '/');
            next unless $segstart >= 0;

            my $segend   = length($output) - $segstart;
            substr $output, $segstart, $segend, '';
            next;
        }

        # D. ^.$ and ^..$ are deleted
        next if $input =~ s{ ^ [.][.]? $ }{}x;

        # E. move ^/?[^/]* to output
        $input =~ s{ (/? [^/]*) }{}x;
        $output .= $1;
    }

    $uri->path($output);
    return $uri;
}


1;

__END__