line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Pinwheel::Mapper; |
2
|
|
|
|
|
|
|
|
3
|
5
|
|
|
5
|
|
57664
|
use strict; |
|
5
|
|
|
|
|
8
|
|
|
5
|
|
|
|
|
185
|
|
4
|
5
|
|
|
5
|
|
28
|
use warnings; |
|
5
|
|
|
|
|
10
|
|
|
5
|
|
|
|
|
14024
|
|
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
|
7
|
|
|
|
|
|
|
sub new |
8
|
|
|
|
|
|
|
{ |
9
|
28
|
|
|
28
|
1
|
21908
|
my $class = shift; |
10
|
28
|
|
|
|
|
647
|
my $self = bless({}, $class); |
11
|
28
|
|
|
|
|
84
|
$self->reset(); |
12
|
28
|
|
|
|
|
71
|
return $self; |
13
|
|
|
|
|
|
|
} |
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
|
16
|
|
|
|
|
|
|
sub reset |
17
|
|
|
|
|
|
|
{ |
18
|
64
|
|
|
64
|
1
|
40511
|
my $self = shift; |
19
|
64
|
|
|
|
|
473
|
$self->{routes} = []; |
20
|
64
|
|
|
|
|
467
|
$self->{named} = {}; |
21
|
|
|
|
|
|
|
} |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
|
24
|
|
|
|
|
|
|
sub connect |
25
|
|
|
|
|
|
|
{ |
26
|
93
|
|
|
93
|
1
|
1103
|
my $self = shift; |
27
|
93
|
100
|
|
|
|
255
|
my $name = (scalar(@_) & 1) ? undef : shift; |
28
|
93
|
|
|
|
|
186
|
my $route = _tidy_path(shift); |
29
|
93
|
|
|
|
|
1071
|
my %options = @_; |
30
|
93
|
|
100
|
|
|
523
|
my $defaults = delete $options{'defaults'} || {}; |
31
|
93
|
|
100
|
|
|
526
|
my $requirements = delete $options{'requirements'} || {}; |
32
|
93
|
|
100
|
|
|
826
|
my $conditions = delete $options{'conditions'} || {}; |
33
|
93
|
|
|
|
|
136
|
my @matchkeys = (); |
34
|
93
|
|
|
|
|
141
|
my %target = (); |
35
|
93
|
|
|
|
|
99
|
my $regexp; |
36
|
|
|
|
|
|
|
|
37
|
93
|
100
|
|
|
|
271
|
$options{'_static'} = 1 if ($route =~ /^\w+:\/\//); |
38
|
|
|
|
|
|
|
|
39
|
93
|
|
|
|
|
413
|
while (my ($key, $value) = each(%options)) { |
40
|
53
|
100
|
|
|
|
350
|
$defaults->{$key} = $value unless $key =~ /^_/; |
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
my $subfn = sub { |
44
|
104
|
|
|
104
|
|
323
|
my ($prefix, $type, $name) = @_; |
45
|
104
|
|
|
|
|
110
|
my $pattern; |
46
|
|
|
|
|
|
|
|
47
|
104
|
|
|
|
|
202
|
push @matchkeys, $name; |
48
|
104
|
100
|
100
|
|
|
558
|
if ($name eq 'controller' || $name eq 'action') { |
|
|
100
|
|
|
|
|
|
49
|
13
|
|
|
|
|
30
|
$target{$name} = '*'; |
50
|
|
|
|
|
|
|
} elsif ($name eq 'id') { |
51
|
5
|
|
100
|
|
|
23
|
$defaults->{id} ||= undef; |
52
|
|
|
|
|
|
|
} |
53
|
104
|
100
|
|
|
|
231
|
$prefix = '\.' if ($prefix eq '.'); |
54
|
104
|
100
|
|
|
|
355
|
if ($type eq '*') { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
55
|
12
|
|
|
|
|
26
|
$pattern = $prefix . '(.*)'; |
56
|
|
|
|
|
|
|
} elsif (exists($requirements->{$name})) { |
57
|
7
|
|
|
|
|
21
|
$pattern = $prefix . '(' . $requirements->{$name} . ')'; |
58
|
|
|
|
|
|
|
} elsif ($prefix eq '\.') { |
59
|
5
|
|
|
|
|
10
|
$pattern = $prefix . '([^/.][^/]*)'; |
60
|
|
|
|
|
|
|
} else { |
61
|
80
|
|
|
|
|
149
|
$pattern = $prefix . '([^/.]+)'; |
62
|
|
|
|
|
|
|
} |
63
|
104
|
100
|
|
|
|
281
|
$pattern = "(?:$pattern)?" if exists($defaults->{$name}); |
64
|
104
|
|
|
|
|
427
|
return $pattern; |
65
|
93
|
|
|
|
|
483
|
}; |
66
|
|
|
|
|
|
|
|
67
|
93
|
|
|
|
|
149
|
$regexp = $route; |
68
|
93
|
|
|
|
|
505
|
$regexp =~ s!([/.]?)([:*])\(?([a-z][a-z0-9_]*)\)?!&$subfn($1, $2, $3)!ge; |
|
104
|
|
|
|
|
372
|
|
69
|
93
|
|
100
|
|
|
14297
|
$defaults->{'controller'} ||= 'content'; |
70
|
93
|
|
100
|
|
|
345
|
$defaults->{'action'} ||= 'index'; |
71
|
93
|
100
|
|
|
|
240
|
if (!$target{'controller'}) { |
72
|
85
|
|
|
|
|
186
|
$target{'controller'} = $defaults->{'controller'}; |
73
|
|
|
|
|
|
|
} |
74
|
93
|
100
|
|
|
|
203
|
if (!$target{'action'}) { |
75
|
88
|
|
|
|
|
163
|
$target{'action'} = $defaults->{'action'}; |
76
|
|
|
|
|
|
|
} |
77
|
|
|
|
|
|
|
|
78
|
93
|
|
|
|
|
454
|
foreach (keys %$requirements) { |
79
|
7
|
|
|
|
|
311
|
$requirements->{$_} = qr/^$requirements->{$_}$/; |
80
|
|
|
|
|
|
|
} |
81
|
93
|
100
|
100
|
|
|
398
|
if ($conditions->{method} && $conditions->{method} eq 'any') { |
82
|
1
|
|
|
|
|
3
|
$conditions->{method} = undef; |
83
|
|
|
|
|
|
|
} |
84
|
|
|
|
|
|
|
|
85
|
93
|
|
|
|
|
3614
|
my $r = { |
86
|
|
|
|
|
|
|
name => $name, |
87
|
|
|
|
|
|
|
route => $route, |
88
|
|
|
|
|
|
|
regexp => qr/^${regexp}$/, |
89
|
|
|
|
|
|
|
matchkeys => \@matchkeys, |
90
|
|
|
|
|
|
|
defaults => $defaults, |
91
|
|
|
|
|
|
|
requirements => $requirements, |
92
|
|
|
|
|
|
|
conditions => $conditions, |
93
|
|
|
|
|
|
|
target => \%target, |
94
|
|
|
|
|
|
|
options => \%options |
95
|
|
|
|
|
|
|
}; |
96
|
93
|
100
|
|
|
|
348
|
push @{$self->{routes}}, $r unless $options{'_static'}; |
|
85
|
|
|
|
|
203
|
|
97
|
93
|
100
|
|
|
|
1227
|
$self->{named}{$name} = $r if defined($name); |
98
|
|
|
|
|
|
|
} |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
101
|
|
|
|
|
|
|
sub match |
102
|
|
|
|
|
|
|
{ |
103
|
89
|
|
|
89
|
1
|
25296
|
my ($self, $path, $method) = @_; |
104
|
89
|
|
|
|
|
129
|
my ($k, $v, %params, @matches, $route); |
105
|
|
|
|
|
|
|
|
106
|
89
|
|
|
|
|
234
|
$path = _tidy_path($path); |
107
|
89
|
100
|
100
|
|
|
406
|
$method = undef if $method && $method eq 'any'; |
108
|
|
|
|
|
|
|
|
109
|
89
|
|
|
|
|
113
|
foreach $route (@{$self->{routes}}) { |
|
89
|
|
|
|
|
1267
|
|
110
|
197
|
|
|
|
|
1231
|
@matches = ($path =~ /$route->{regexp}/); |
111
|
197
|
100
|
|
|
|
621
|
next if scalar(@matches) == 0; |
112
|
77
|
100
|
100
|
|
|
236
|
if (defined($method) && defined($route->{conditions}{method})) { |
113
|
7
|
100
|
|
|
|
31
|
next if $method ne $route->{conditions}{method}; |
114
|
|
|
|
|
|
|
} |
115
|
74
|
|
|
|
|
215
|
foreach $k (@{$route->{matchkeys}}) { |
|
74
|
|
|
|
|
247
|
|
116
|
62
|
|
|
|
|
92
|
$v = shift @matches; |
117
|
62
|
100
|
|
|
|
150
|
$v =~ s/%([0-9a-fA-F]{2})/chr(hex($1))/ge if $v; |
|
2
|
|
|
|
|
11
|
|
118
|
62
|
|
|
|
|
188
|
$params{$k} = $v; |
119
|
|
|
|
|
|
|
} |
120
|
74
|
|
|
|
|
136
|
while (($k, $v) = each(%{$route->{defaults}})) { |
|
240
|
|
|
|
|
910
|
|
121
|
166
|
100
|
|
|
|
547
|
$params{$k} = $v unless defined($params{$k}); |
122
|
|
|
|
|
|
|
} |
123
|
74
|
|
|
|
|
361
|
return \%params; |
124
|
|
|
|
|
|
|
} |
125
|
15
|
|
|
|
|
65
|
return undef; |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
|
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
sub generate |
130
|
|
|
|
|
|
|
{ |
131
|
62
|
|
|
62
|
1
|
17984
|
my $self = shift; |
132
|
62
|
100
|
|
|
|
2216
|
my $name = (scalar(@_) & 1) ? shift : undef; |
133
|
62
|
|
|
|
|
227
|
my %params = @_; |
134
|
62
|
|
|
|
|
74
|
my ($base, $k, $v, $route, $url); |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
# If the controller and action are the same as the base set of parameters, |
137
|
|
|
|
|
|
|
# inherit any missing keys |
138
|
62
|
|
|
|
|
121
|
$base = delete $params{_base}; |
139
|
62
|
100
|
100
|
|
|
213
|
if (!$name && _compare_targets($base, \%params)) { |
140
|
7
|
|
|
|
|
30
|
while (($k, $v) = each(%$base)) { |
141
|
28
|
100
|
|
|
|
280
|
$params{$k} = $v unless exists($params{$k}); |
142
|
|
|
|
|
|
|
} |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
# A controller and action are always required |
146
|
62
|
|
100
|
|
|
257
|
$params{controller} ||= 'content'; |
147
|
62
|
|
100
|
|
|
223
|
$params{action} ||= 'index'; |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
# Expand any objects supplied as route parameters |
150
|
62
|
|
|
|
|
195
|
foreach (keys(%params)) { |
151
|
207
|
100
|
|
|
|
705
|
next unless ref($v = $params{$_}); |
152
|
5
|
|
|
|
|
16
|
$v = $v->route_param; |
153
|
5
|
100
|
|
|
|
30
|
if (ref $v) { |
154
|
4
|
|
|
|
|
8
|
delete $params{$_}; |
155
|
4
|
|
|
|
|
27
|
%params = (%params, %$v); |
156
|
|
|
|
|
|
|
} else { |
157
|
1
|
|
|
|
|
4
|
$params{$_} = $v; |
158
|
|
|
|
|
|
|
} |
159
|
|
|
|
|
|
|
} |
160
|
|
|
|
|
|
|
|
161
|
|
|
|
|
|
|
# Find the appropriate route |
162
|
62
|
100
|
|
|
|
320
|
if ($name) { |
163
|
|
|
|
|
|
|
# Quick: find the named route |
164
|
42
|
|
|
|
|
106
|
$route = $self->{named}{$name}; |
165
|
|
|
|
|
|
|
} else { |
166
|
|
|
|
|
|
|
# Slower: scan routes for the first valid parameter match |
167
|
20
|
|
|
|
|
27
|
foreach my $r (@{$self->{routes}}) { |
|
20
|
|
|
|
|
51
|
|
168
|
25
|
100
|
|
|
|
67
|
next unless _compare_targets($r->{target}, \%params); |
169
|
19
|
100
|
|
|
|
52
|
next unless _validate_route_params($r, \%params); |
170
|
18
|
|
|
|
|
26
|
$route = $r; |
171
|
18
|
|
|
|
|
27
|
last; |
172
|
|
|
|
|
|
|
} |
173
|
|
|
|
|
|
|
} |
174
|
62
|
100
|
|
|
|
150
|
return undef unless $route; |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
# Fill in missing parameters with the defaults from the matched route |
177
|
59
|
|
|
|
|
322
|
while (($k, $v) = each(%{$route->{defaults}})) { |
|
184
|
|
|
|
|
766
|
|
178
|
125
|
100
|
|
|
|
314
|
$params{$k} = $v unless exists($params{$k}); |
179
|
|
|
|
|
|
|
} |
180
|
|
|
|
|
|
|
|
181
|
59
|
|
|
|
|
151
|
return _insert_route_params($route, \%params); |
182
|
|
|
|
|
|
|
} |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
sub names |
186
|
|
|
|
|
|
|
{ |
187
|
1
|
|
|
1
|
1
|
5
|
return [sort keys %{$_[0]->{named}}]; |
|
1
|
|
|
|
|
14
|
|
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
sub _tidy_path |
192
|
|
|
|
|
|
|
{ |
193
|
192
|
|
|
192
|
|
6510
|
my ($path) = @_; |
194
|
|
|
|
|
|
|
# 1. Remove trailing slashes |
195
|
192
|
|
|
|
|
707
|
$path =~ s/\/+$//; |
196
|
|
|
|
|
|
|
# 2. Remove leading slashes before a / |
197
|
192
|
|
|
|
|
541
|
$path =~ s/(?
|
198
|
|
|
|
|
|
|
# 3. Ensure leading '/' unless it's a full URL |
199
|
192
|
100
|
66
|
|
|
1031
|
$path = '/' . $path if ($path !~ /^\// && $path !~ /^\w+:\/\//); |
200
|
192
|
|
|
|
|
515
|
return $path; |
201
|
|
|
|
|
|
|
} |
202
|
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
# Does this route match these params? |
204
|
|
|
|
|
|
|
# The route matches if the controller and the action match. |
205
|
|
|
|
|
|
|
# controller/action are matched as follows: it matches if it's specified in |
206
|
|
|
|
|
|
|
# the route, and the corresponding param is either missing, or the same as |
207
|
|
|
|
|
|
|
# that on the route, or "*". |
208
|
|
|
|
|
|
|
|
209
|
|
|
|
|
|
|
sub _compare_targets |
210
|
|
|
|
|
|
|
{ |
211
|
45
|
|
|
45
|
|
62
|
my ($base, $params) = @_; |
212
|
45
|
|
|
|
|
44
|
my ($key, $b, $p); |
213
|
|
|
|
|
|
|
|
214
|
45
|
|
|
|
|
78
|
foreach $key ('controller', 'action') { |
215
|
72
|
|
|
|
|
269
|
$b = $base->{$key}; |
216
|
72
|
100
|
|
|
|
185
|
return 0 unless defined($b); |
217
|
60
|
|
|
|
|
219
|
$p = $params->{$key}; |
218
|
60
|
100
|
100
|
|
|
390
|
return 0 if ($p && $p ne $b && $b ne '*'); |
|
|
|
100
|
|
|
|
|
219
|
|
|
|
|
|
|
} |
220
|
26
|
|
|
|
|
222
|
return 1; |
221
|
|
|
|
|
|
|
} |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
# Is this set of params OK for this route? |
224
|
|
|
|
|
|
|
# Tests defaults and requirements (regexp). |
225
|
|
|
|
|
|
|
|
226
|
|
|
|
|
|
|
sub _validate_route_params |
227
|
|
|
|
|
|
|
{ |
228
|
78
|
|
|
78
|
|
122
|
my ($route, $params) = @_; |
229
|
78
|
|
|
|
|
100
|
my ($key, $value, $regexp); |
230
|
78
|
|
|
|
|
123
|
my $requirements = $route->{requirements}; |
231
|
78
|
|
|
|
|
102
|
my $defaults = $route->{defaults}; |
232
|
|
|
|
|
|
|
|
233
|
78
|
|
|
|
|
99
|
foreach $key (@{$route->{matchkeys}}) { |
|
78
|
|
|
|
|
161
|
|
234
|
116
|
|
|
|
|
284
|
$value = $params->{$key}; |
235
|
116
|
100
|
100
|
|
|
293
|
return 0 unless (defined($value) || exists($defaults->{$key})); |
236
|
115
|
|
|
|
|
160
|
$regexp = $requirements->{$key}; |
237
|
115
|
100
|
100
|
|
|
800
|
return 0 if (defined($value) && $regexp && $value !~ /${regexp}/); |
|
|
|
100
|
|
|
|
|
238
|
|
|
|
|
|
|
} |
239
|
75
|
|
|
|
|
502
|
return 1; |
240
|
|
|
|
|
|
|
} |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
sub _insert_route_params |
243
|
|
|
|
|
|
|
{ |
244
|
59
|
|
|
59
|
|
85
|
my ($route, $params) = @_; |
245
|
59
|
|
|
|
|
68
|
my ($filter, $fn, $url); |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
# Run any requested filters on the parameters before inserting them |
248
|
59
|
|
100
|
|
|
267
|
$filter = $route->{options}{_filter} || []; |
249
|
59
|
100
|
|
|
|
181
|
$filter = [$filter] if (ref($filter) eq 'CODE'); |
250
|
59
|
|
|
|
|
119
|
&$_($params) foreach (@$filter); |
251
|
|
|
|
|
|
|
|
252
|
59
|
100
|
|
|
|
133
|
return unless _validate_route_params($route, $params); |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
# Insert the parameters into the URL |
255
|
57
|
|
|
|
|
105
|
$url = $route->{route}; |
256
|
57
|
|
|
|
|
170
|
$url =~ s!([/.]?)\*\(?([a-z][a-z0-9_]*)\)?!_param($1, $params->{$2}, 1)!ge; |
|
12
|
|
|
|
|
49
|
|
257
|
57
|
|
|
|
|
317
|
$url =~ s!([/.]?):\(?([a-z][a-z0-9_]*)\)?!_param($1, $params->{$2}, 0)!ge; |
|
72
|
|
|
|
|
229
|
|
258
|
|
|
|
|
|
|
|
259
|
57
|
|
|
|
|
267
|
return $url; |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
|
262
|
|
|
|
|
|
|
sub _param |
263
|
|
|
|
|
|
|
{ |
264
|
84
|
|
|
84
|
|
172
|
my ($prefix, $s, $keep_slash) = @_; |
265
|
84
|
100
|
|
|
|
180
|
return '' if !defined($s); |
266
|
81
|
|
|
|
|
152
|
$s =~ s/([^A-Za-z0-9\/_.-])/sprintf('%%%02X', ord($1))/ge; |
|
2
|
|
|
|
|
15
|
|
267
|
81
|
100
|
|
|
|
465
|
$s =~ s/\//%2F/g unless $keep_slash; |
268
|
81
|
|
|
|
|
315
|
return $prefix . $s; |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
|
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
1; |
273
|
|
|
|
|
|
|
|
274
|
|
|
|
|
|
|
__DATA__ |