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


line stmt bran cond sub pod time code
1             package Plack::App::URLMux;
2              
3 9     9   517811 use strict;
  9         79  
  9         199  
4 9     9   88 use v5.22;
  9         50  
5 9     9   4175 use experimental qw(signatures postderef);
  9         24836  
  9         39  
6             our $VERSION = '0.08';
7              
8 9     9   4394 use parent qw(Plack::Component);
  9         1871  
  9         38  
9 9     9   95496 use Carp qw(croak);
  9         17  
  9         379  
10              
11 9     9   43 use constant MAX_FINE => 65535; # if URL will contains url-path segments more than this number - increment it :)
  9         18  
  9         402  
12              
13             # map[] structure constants
14 9     9   39 use constant _keys => 0; # hash of url-path segments => map[]
  9         15  
  9         322  
15 9     9   39 use constant _level => 1; # level of map tree
  9         14  
  9         368  
16 9     9   65 use constant _quant => 2; # rule for quantifier at branch, this value sensitive for _named array
  9         22  
  9         364  
17 9     9   51 use constant _app => 3; # reference to app on this leaf, undefined if does not mounted any
  9         15  
  9         345  
18 9     9   50 use constant _named => 4; # reference to map[], if url-path has named parameter then mapping searching in it
  9         13  
  9         375  
19 9     9   40 use constant _names => 5; # array of [parameter, index], if app has parameters in the url format
  9         14  
  9         326  
20 9     9   37 use constant _params => 6; # array of pairs name=>value of input parameters specified at map
  9         15  
  9         324  
21 9     9   37 use constant _quants => 7; # array of quantifiers of each url-path segments for mounted app
  9         15  
  9         338  
22              
23             # _quant array constants
24 9     9   43 use constant _quant_n => 0; # start range quanifier
  9         15  
  9         460  
25 9     9   45 use constant _quant_m => 1; # end range qunatifier, -1 unknown maximum as possible
  9         10  
  9         360  
26 9     9   73 use constant _quant_r => 2; # rest of posible search path, -1 unknown, unusefull, FIXME delete this
  9         25  
  9         378  
27 9     9   50 use constant _quant_h => 3; # greedy/lazy flag for search path and gather subpathes for parameter, 0 lazy, 1 greedy
  9         19  
  9         364  
28              
29             # _params array constants
30 9     9   41 use constant _param_name => 0;
  9         14  
  9         343  
31 9     9   43 use constant _param_index => 1;
  9         16  
  9         369  
32              
33             # matched array constants
34 9     9   40 use constant _match_map => 0;
  9         15  
  9         389  
35 9     9   44 use constant _match_length => 1;
  9         14  
  9         514  
36 9     9   53 use constant _match_fine => 2;
  9         22  
  9         365  
37 9     9   55 use constant _match_matching => 3;
  9         13  
  9         359  
38              
39             # matching array constants
40 9     9   62 use constant _matching_index => 0;
  9         34  
  9         439  
41 9     9   50 use constant _matching_fine => 1;
  9         25  
  9         19591  
42              
43 0     0 1 0 sub mount { shift->map(@_) }
44              
45 29     29 1 1016 sub map($self, $location, $app, @input_params) {
  29         46  
  29         47  
  29         39  
  29         42  
  29         36  
46              
47 29 100       68 if ($location eq '') {
48             croak "location 'not found' has already mount app"
49 1 50 33     31 if exists $self->{_mapping_not_found} and defined $self->{_mapping_not_found};
50 1         3 $self->{_mapping_not_found} = $app;
51 1         3 return;
52             }
53              
54 28         43 my $host = '*'; #any host
55 28 100       79 if ($location =~ m/^https?:\/\/(.*?)(\/.*)/o) {
56 5         23 $host = $1;
57 5         14 $location = $2;
58             }
59              
60 28 50       90 croak "Path '$location' need to start with '/'"
61             unless $location =~ m/^\//o;
62 28         118 $location =~ s/^\/|\/$//go;
63              
64 28         71 my @paths = split('/', $location);
65              
66 28         67 my ($index, $params, $quants) = (0, [], []);
67 28   100     358 my $map = $self->{_mapping}->{$host} ||= [{}, $index, [1, 0]]; # Zero mapping for URL '/'
68 28         47 $index++;
69 28         57 foreach my $path (@paths) {
70 30         52 my $r = @paths - $index;
71              
72 30 100       130 if ($path =~
73             /^
74             \:
75              
76             ([^\:\+\*\?\{\}\,]+?) (?# 1: name of parameter )
77              
78             (?:
79             (?:
80             (\+|\*|\?) (?# 2: '+|*|?' quantifier )
81             (\??) (?# 3: '?' greedy|lazy flag )
82             )
83             | (?:
84             \{
85             (\d+) (?# 4: start range quantifier )
86             (?:
87             (\,) (?# 5: range delimeter )
88             (\d+)* (?# 6: end range quantifier )
89             )*
90             \}
91             (\??) (?# 7: '?' greedy|lazy flag )
92             )
93             )?
94              
95             $/xo
96             ){
97 15 50 100     127 my ($name, $quant, $n, $m, $h) = ($1, $2 || $5, $4, $6, (($3 || $7) ? 0 : 1));
      33        
98              
99 15 100       36 ($n, $m) = (0, -1 ) if $quant eq '*';
100 15 100       34 ($n, $m) = (1, -1 ) if $quant eq '+';
101 15 50       29 ($n, $m) = (0, 1 ) if $quant eq '?';
102 15 100       29 ($n, $m) = ($n, ($m ? $m : -1) ) if $quant eq ',';
    100          
103 15 50       36 ($n, $m) = ($n = ($n ? $n : 1), $n ) if $quant eq '';
    100          
104              
105             #check _named now named must be array but we must check
106 15         44 push(@$params, [$name, $index]);
107 15         68 push(@$quants, [$n, $m, $r, $h]);
108              
109 15   100     55 $map->[_named] ||= {};
110 15   100     100 $map = $map->[_named]->{"$n.$m"} ||= [{}, $index, [$n, $m]];
111 15         24 $index++;
112 15         33 next;
113             }
114              
115 15 50       37 if ($path =~ /^\:/o) {
116 0         0 croak "url '$location' is wrong, syntax sub path '$path' is incorrent, expect :[alphanum](*|+|?|{n,m})?\??";
117             }
118              
119             #FIXME check than name contain only valid chars need check RFC for that
120              
121 15   100     95 $map = $map->[_keys]->{$path} ||= [{}, $index, [1, 1]];
122 15         54 push(@$quants, [1, 1, $r, 1]);
123 15         30 $index++;
124 15         26 next;
125              
126             }
127              
128 28 50       63 croak "/$location has already mount app"
129             if defined $map->[_app];
130              
131 28 100       163 @$map[_app,_params,_names,_quants] = ($app, \@input_params, @$params ? $params : undef, $quants);
132              
133             }
134              
135 0     0 0 0 sub prepapre_app ($self) {}
  0         0  
136              
137 59     59 1 191063 sub call ($self, $env) {
  59         89  
  59         67  
  59         64  
138 59         89 my ($matches, $params);
139              
140             my ($http_host, $server_name, $script_name, $path_info)
141 59         151 = $env->@{qw( HTTP_HOST SERVER_NAME SCRIPT_NAME PATH_INFO )};
142              
143             #FIXME possible BUG
144             # is there cases when port is not the same in HTTP_HOST and SERVER_PORT?
145 59 50 33     259 if ($http_host and $env->{SERVER_PORT}) {
146 59         112 $http_host =~ s/:\d+$//o;
147             }
148              
149 59         157 my @path = split('/', $path_info);
150 59         83 shift @path; # remove zero
151              
152 59         110 my $mapping = $self->{_mapping};
153              
154             my $matched =
155             _matched(
156             $self->search(
157 59   66     379 $mapping->{$http_host} || $mapping->{$server_name} || $mapping->{'*'}
158             , my $i = 0
159             , \@path
160             , @path + 0
161             , []
162             )
163             );
164              
165 59 100       144 unless ($matched) {
166             return [404, [ 'Content-Type' => 'text/plain' ], [ "Not Found" ]]
167 1 50       4 unless $self->{_mapping_not_found};
168 1         4 return $self->{_mapping_not_found}->($env);
169             }
170              
171             #now we have first matched rule and match path, we need fill params if they exists
172              
173 58         102 my ($match, $matching) = $matched->@[_match_map,_match_matching];
174              
175 58 100       109 if (defined $match->[_names]) {
176 29         32 my ($i, $j);
177             $params = [
178             map {
179 34 100       171 $_->[_param_name] =>
    100          
180             (
181             (
182             ($j = $matching->[$_->[_param_index]-1]->[_matching_index] - 1)
183             -
184             ($i = $_->[_param_index] - 1 > 0 ? $matching->[$_->[_param_index] - 2]->[_matching_index] : 0)
185             ) >= 0
186             ?
187             [(@path[$i..$j])]
188             :
189             []
190             )
191 29         31 } @{$match->[_names]}
  29         40  
192             ];
193             }
194              
195 58         95 my $index = $matching->[-1]->[_matching_index];
196             #clone input params, couse they may be mutated by middlewire
197             @$env{qw( plack.urlmux.params.map plack.urlmux.params.url SCRIPT_NAME PATH_INFO )}
198             = (
199 58 100 100     75 [@{$match->[_params]}]
  58 50       503  
    100          
    100          
200             , $params || []
201             , ($script_name ? $script_name : $index ? '/' : '') . join('/', (@path[0..($index-1)]))
202             , ($index == @path ? @path ? '' : '/' : '/') . join('/', (@path[$index..(@path-1)]))
203             );
204              
205             return $self->response_cb($match->[_app]->($env), sub {
206 58     58   3906 $env->@{qw( PATH_INFO SCRIPT_NAME )} = ($path_info, $script_name);
207 58         178 });
208             }
209              
210 202     202 0 212 sub search ($self, $map, $index, $parts, $l, $matching) {
  202         215  
  202         227  
  202         263  
  202         225  
  202         201  
  202         210  
  202         187  
211              
212 202         251 my $path = $parts->[$index];
213 202         353 my ($_app, $_keys, $_named) = $map->@[_app,_keys,_named];
214              
215 202         231 my $matches = [];
216              
217 202 100       352 if (exists $_keys->{$path}) {
218 30 50       63 if ($index < $l) {
219 30         39 push(@$matches, (@{$self->search($_keys->{$path}, $index + 1, $parts, $l, [(@$matching), [$index+1, 0]])}));
  30         148  
220             }
221             else {
222 0 0       0 if (defined $_keys->{$path}->[_app]) {
223 0         0 my $match = [$_keys->{$path}, $index + 1, 0, [(@$matching), [$index+1, 0]]];
224 0         0 push (@$matches, $match);
225 0         0 map {$match->[_match_fine] += $_->[_matching_fine]} @{$match->[_match_matching]};
  0         0  
  0         0  
226             }
227             }
228             }
229              
230 202 100       305 if (defined $_named) {
231 47         52 foreach my $quant (values %{$_named}) {
  47         93  
232 77         147 my ($n, $m) = $quant->[_quant]->@[_quant_n,_quant_m];
233 77 100       161 my ($ln, $lm) = ($index + $n, ($m==-1 ? MAX_FINE : $index + $m));
234 77         115 my $matches_ = [];
235 77 100       165 for ($ln .. ($lm > $l ? $l : $lm)) {
236 168 100       223 if ($_ < $l) {
237 113         126 push(@$matches_ , (@{$self->search($quant, $_, $parts, $l, [(@$matching), [$_, $lm - $ln + 1]])}));
  113         274  
238             }
239             else {
240 55 100       90 if (defined $quant->[_app]) {
241 39         79 my $match = [$quant, $_, 0, [(@$matching), [$_, $lm - $ln + 1]]];
242 39         64 push(@$matches_, $match);
243 39         41 map {$match->[_match_fine] += $_->[_matching_fine]} @{$match->[_match_matching]};
  60         92  
  39         63  
244             }
245             }
246             }
247 77 100       133 next unless @$matches_;
248 55         97 push(@$matches, _matched_greedy($matches_, $index));
249             }
250             }
251              
252 202 100       306 if (defined $_app) {
253 151         311 my $match = [$map, $index, 0, [(@$matching), [$index, 0]]];
254 151         197 push(@$matches, $match);
255 151         155 map {$match->[_match_fine] += $_->[_matching_fine]} @{$match->[_match_matching]};
  284         403  
  151         228  
256             }
257              
258 202         410 return $matches;
259              
260             }
261              
262 59     59   68 sub _matched ($matches) {
  59         63  
  59         65  
263              
264 59 100       124 return unless @$matches;
265 58 100       107 return $matches->[0] if @$matches == 1;
266              
267 37         43 my $match;
268              
269 37         56 foreach (@$matches) {
270 93 100       135 unless (defined $match) {
271 37         42 $match = $_;
272 37         55 next;
273             }
274 56 100       102 if ($_->[_match_length] < $match->[_match_length]) {
275 37         50 next;
276             }
277 19 100       28 if ($_->[_match_length] > $match->[_match_length]) {
278 3         4 $match = $_;
279 3         3 next;
280             }
281 16 100       36 if ($_->[_match_fine] < $match->[_match_fine]) {
282 2         3 $match = $_;
283 2         3 next;
284             }
285             }
286 37         58 return $match;
287             }
288              
289 55     55   56 sub _matched_greedy ($matches, $index) {
  55         60  
  55         55  
  55         53  
290              
291 55 50       79 return unless @$matches;
292 55 100       147 return $matches->[0] if @$matches == 1;
293              
294 35         58 my $greedy = $matches->[0]->[_match_map]->[_quants]->[$index-1]->[_quant_h];
295              
296 35         38 my $match;
297 35         48 foreach (@$matches) {
298 111 100       144 unless (defined $match) {
299 35         50 $match = $_;
300 35         44 next;
301             }
302 76 100       117 if ($_->[_match_length] < $match->[_match_length]) {
303 10         12 next;
304             }
305 66 100       94 if ($_->[_match_length] > $match->[_match_length] ) {
306 63         57 $match = $_;
307 63         74 next;
308             }
309 3 50       5 if ($greedy) {
310 3 50       8 if ($_->[_match_matching]->[$index-1]->[_matching_index] > $match->[_match_matching]->[$index-1]->[_matching_index]) {
311 0         0 $match = $_;
312 0         0 next;
313             }
314             }
315             else {
316 0 0       0 if ($_->[_match_matching]->[$index-1]->[_matching_index] < $match->[_match_matching]->[$index-1]->[_matching_index]) {
317 0         0 $match = $_;
318 0         0 next;
319             }
320             }
321             }
322              
323 35         101 return $match;
324             }
325              
326             1;
327              
328             __END__