File Coverage

blib/lib/Plack/App/URLMux.pm

Criterion	Covered	Total	%
statement	224	239	93.7
branch	82	100	82.0
condition	18	25	72.0
subroutine	32	34	94.1
pod	3	5	60.0
total	359	403	89.0

package Plack::App::URLMux;

use strict;
use v5.22;
use experimental qw(signatures postderef);
our $VERSION = '0.08';

use parent qw(Plack::Component);
use Carp qw(croak);

use constant MAX_FINE        => 65535; # if URL will contains url-path segments more than this number - increment it :)

# map[] structure constants
use constant _keys           => 0; # hash of url-path segments => map[]
use constant _level          => 1; # level of map tree
use constant _quant          => 2; # rule for quantifier at branch, this value sensitive for _named array
use constant _app            => 3; # reference to app on this leaf, undefined if does not mounted any
use constant _named          => 4; # reference to map[], if url-path has named parameter then mapping searching in it
use constant _names          => 5; # array of [parameter, index], if app has parameters in the url format
use constant _params         => 6; # array of pairs name=>value of input parameters specified at map
use constant _quants         => 7; # array of quantifiers of each url-path segments for mounted app

# _quant array constants
use constant _quant_n        => 0; # start range quanifier
use constant _quant_m        => 1; # end range qunatifier, -1 unknown maximum as possible
use constant _quant_r        => 2; # rest of posible search path, -1 unknown, unusefull, FIXME delete this
use constant _quant_h        => 3; # greedy/lazy flag for search path and gather subpathes for parameter, 0 lazy, 1 greedy

# _params array constants
use constant _param_name     => 0;
use constant _param_index    => 1;

# matched array constants
use constant _match_map      => 0;
use constant _match_length   => 1;
use constant _match_fine     => 2;
use constant _match_matching => 3;

# matching array constants
use constant _matching_index => 0;
use constant _matching_fine  => 1;

sub mount { shift->map(@_) }

sub map($self, $location, $app, @input_params) {

    if ($location eq '') {
        croak "location 'not found' has already mount app"
            if exists $self->{_mapping_not_found} and defined $self->{_mapping_not_found};
        $self->{_mapping_not_found} = $app;
        return;
    }

    my $host = '*';  #any host
    if ($location =~ m/^https?:\/\/(.*?)(\/.*)/o) {
        $host     = $1;
        $location = $2;
    }

    croak "Path '$location' need to start with '/'"
        unless $location =~ m/^\//o;
    $location =~ s/^\/|\/$//go;

    my @paths = split('/', $location);

    my ($index, $params, $quants) = (0, [], []);
    my $map = $self->{_mapping}->{$host} ||= [{}, $index, [1, 0]];  # Zero mapping for URL '/'
    $index++;
    foreach my $path (@paths) {
        my $r = @paths - $index;

        if ($path =~
            /^
                \:

                ([^\:\+\*\?\{\}\,]+?)       (?# 1: name of parameter )

                (?:
                      (?:
                            (\+|\*|\?)      (?# 2: '+|*|?' quantifier )
                            (\??)           (?# 3: '?' greedy|lazy flag )
                      )
                    | (?:
                            \{
                                (\d+)       (?# 4: start range quantifier )
                                (?:
                                    (\,)    (?# 5: range delimeter )
                                    (\d+)*  (?# 6: end range quantifier )
                                )*
                            \}
                            (\??)           (?# 7: '?' greedy|lazy flag )
                      )
                )?

            $/xo
        ){
            my ($name, $quant, $n, $m, $h) = ($1, $2 || $5, $4, $6, (($3 || $7) ? 0 : 1));

            ($n, $m) = (0, -1                  ) if $quant eq '*';
            ($n, $m) = (1, -1                  ) if $quant eq '+';
            ($n, $m) = (0,  1                  ) if $quant eq '?';
            ($n, $m) = ($n, ($m ? $m : -1)     ) if $quant eq ',';
            ($n, $m) = ($n = ($n ? $n : 1), $n ) if $quant eq '';

            #check _named now named must be array but we must check
            push(@$params, [$name, $index]);
            push(@$quants, [$n, $m, $r, $h]);

            $map->[_named] ||= {};
            $map = $map->[_named]->{"$n.$m"} ||= [{}, $index, [$n, $m]];
            $index++;
            next;
        }

        if ($path =~ /^\:/o) {
            croak "url '$location' is wrong, syntax sub path '$path' is incorrent, expect :[alphanum](*|+|?|{n,m})?\??";
        }

        #FIXME check than name contain only valid chars need check RFC for that

        $map = $map->[_keys]->{$path} ||= [{}, $index, [1, 1]];
        push(@$quants, [1, 1, $r, 1]);
        $index++;
        next;

    }

    croak "/$location has already mount app"
        if defined $map->[_app];

    @$map[_app,_params,_names,_quants] = ($app, \@input_params, @$params ? $params : undef, $quants);

}

sub prepapre_app  ($self) {}

sub call ($self, $env) {
    my ($matches, $params);

    my ($http_host, $server_name, $script_name, $path_info)
        = $env->@{qw( HTTP_HOST SERVER_NAME SCRIPT_NAME PATH_INFO )};

    #FIXME possible BUG
    # is there cases when port is not the same in HTTP_HOST and SERVER_PORT?
    if ($http_host and $env->{SERVER_PORT}) {
        $http_host =~ s/:\d+$//o;
    }

    my @path = split('/', $path_info);
    shift @path; # remove zero

    my $mapping = $self->{_mapping};

    my $matched =
        _matched(
            $self->search(
                  $mapping->{$http_host} || $mapping->{$server_name} || $mapping->{'*'}
                , my $i = 0
                , \@path
                , @path + 0
                , []
            )
        );

    unless ($matched) {
        return [404, [ 'Content-Type' => 'text/plain' ], [ "Not Found" ]]
            unless $self->{_mapping_not_found};
        return $self->{_mapping_not_found}->($env);
    }

    #now we have first matched rule and match path, we need fill params if they exists

    my ($match, $matching) = $matched->@[_match_map,_match_matching];

    if (defined $match->[_names]) {
        my ($i, $j);
        $params = [
            map {
                $_->[_param_name] =>
                    (
                            (
                                    ($j = $matching->[$_->[_param_index]-1]->[_matching_index] - 1)
                                -
                                    ($i = $_->[_param_index] - 1 > 0 ? $matching->[$_->[_param_index] - 2]->[_matching_index] : 0)
                            ) >= 0
                        ?
                            [(@path[$i..$j])]
                        :
                            []
                    )
            } @{$match->[_names]}
        ];
    }

    my $index = $matching->[-1]->[_matching_index];
    #clone input params, couse they may be mutated by middlewire
    @$env{qw( plack.urlmux.params.map plack.urlmux.params.url SCRIPT_NAME PATH_INFO )}
        = (
              [@{$match->[_params]}]
            , $params || []
            , ($script_name ? $script_name : $index ? '/' : '') . join('/', (@path[0..($index-1)]))
            , ($index == @path ? @path ? '' : '/' : '/') . join('/', (@path[$index..(@path-1)]))
        );

    return $self->response_cb($match->[_app]->($env), sub {
        $env->@{qw( PATH_INFO SCRIPT_NAME )} = ($path_info, $script_name);
    });
}

sub search ($self, $map, $index, $parts, $l, $matching) {

    my $path = $parts->[$index];
    my ($_app, $_keys, $_named) = $map->@[_app,_keys,_named];

    my $matches = [];

    if (exists $_keys->{$path}) {
        if ($index < $l) {
            push(@$matches, (@{$self->search($_keys->{$path}, $index + 1, $parts, $l, [(@$matching), [$index+1, 0]])}));
        }
        else {
            if (defined $_keys->{$path}->[_app]) {
                my $match = [$_keys->{$path}, $index + 1, 0, [(@$matching), [$index+1, 0]]];
                push (@$matches, $match);
                map {$match->[_match_fine] += $_->[_matching_fine]} @{$match->[_match_matching]};
            }
        }
    }

    if (defined $_named) {
        foreach my $quant (values %{$_named}) {
            my ($n, $m) = $quant->[_quant]->@[_quant_n,_quant_m];
            my ($ln, $lm) = ($index + $n, ($m==-1 ? MAX_FINE : $index + $m));
            my $matches_ = [];
            for ($ln .. ($lm > $l ? $l : $lm)) {
                if ($_ < $l) {
                    push(@$matches_ , (@{$self->search($quant, $_, $parts, $l, [(@$matching), [$_, $lm - $ln + 1]])}));
                }
                else {
                    if (defined $quant->[_app]) {
                        my $match = [$quant, $_, 0, [(@$matching), [$_, $lm - $ln + 1]]];
                        push(@$matches_, $match);
                        map {$match->[_match_fine] += $_->[_matching_fine]} @{$match->[_match_matching]};
                    }
                }
            }
            next unless @$matches_;
            push(@$matches, _matched_greedy($matches_, $index));
        }
    }

    if (defined $_app) {
        my $match = [$map, $index, 0, [(@$matching), [$index, 0]]];
        push(@$matches, $match);
        map {$match->[_match_fine] += $_->[_matching_fine]} @{$match->[_match_matching]};
    }

    return $matches;

}

sub _matched ($matches) {

    return unless @$matches;
    return $matches->[0] if @$matches == 1;

    my $match;

    foreach (@$matches) {
        unless (defined $match) {
            $match = $_;
            next;
        }
        if ($_->[_match_length] < $match->[_match_length]) {
            next;
        }
        if ($_->[_match_length] > $match->[_match_length]) {
            $match = $_;
            next;
        }
        if ($_->[_match_fine] < $match->[_match_fine]) {
            $match = $_;
            next;
        }
    }
    return $match;
}

sub _matched_greedy ($matches, $index) {

    return unless @$matches;
    return $matches->[0] if @$matches == 1;

    my $greedy = $matches->[0]->[_match_map]->[_quants]->[$index-1]->[_quant_h];

    my $match;
    foreach (@$matches) {
        unless (defined $match) {
            $match = $_;
            next;
        }
        if ($_->[_match_length] < $match->[_match_length]) {
            next;
        }
        if ($_->[_match_length] > $match->[_match_length] ) {
            $match = $_;
            next;
        }
        if ($greedy) {
            if ($_->[_match_matching]->[$index-1]->[_matching_index] > $match->[_match_matching]->[$index-1]->[_matching_index]) {
                $match = $_;
                next;
            }
        }
        else {
            if ($_->[_match_matching]->[$index-1]->[_matching_index] < $match->[_match_matching]->[$index-1]->[_matching_index]) {
                $match = $_;
                next;
            }
        }
    }

    return $match;
}

1;

__END__