line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
14
|
|
|
14
|
|
2932890
|
use strict; |
|
14
|
|
|
|
|
26
|
|
|
14
|
|
|
|
|
561
|
|
2
|
14
|
|
|
14
|
|
72
|
use warnings; |
|
14
|
|
|
|
|
20
|
|
|
14
|
|
|
|
|
548
|
|
3
|
|
|
|
|
|
|
|
4
|
|
|
|
|
|
|
package Dancer::Plugin::CRUD; |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
# ABSTRACT: A plugin for writing RESTful apps with Dancer |
7
|
|
|
|
|
|
|
|
8
|
14
|
|
|
14
|
|
60
|
use Carp 'croak'; |
|
14
|
|
|
|
|
21
|
|
|
14
|
|
|
|
|
797
|
|
9
|
14
|
|
|
14
|
|
641
|
use Dancer ':syntax'; |
|
14
|
|
|
|
|
186700
|
|
|
14
|
|
|
|
|
71
|
|
10
|
14
|
|
|
14
|
|
11538
|
use Dancer::Plugin; |
|
14
|
|
|
|
|
16992
|
|
|
14
|
|
|
|
|
1050
|
|
11
|
14
|
|
|
14
|
|
91
|
use Sub::Name; |
|
14
|
|
|
|
|
19
|
|
|
14
|
|
|
|
|
544
|
|
12
|
14
|
|
|
14
|
|
6632
|
use Text::Pluralize; |
|
14
|
|
|
|
|
6933
|
|
|
14
|
|
|
|
|
697
|
|
13
|
14
|
|
|
14
|
|
7017
|
use Validate::Tiny (); |
|
14
|
|
|
|
|
48901
|
|
|
14
|
|
|
|
|
33843
|
|
14
|
|
|
|
|
|
|
|
15
|
|
|
|
|
|
|
our $VERSION = '1.031'; # VERSION |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
our $SUFFIX = '_id'; |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
my $content_types = { |
20
|
|
|
|
|
|
|
json => 'application/json', |
21
|
|
|
|
|
|
|
yml => 'text/x-yaml', |
22
|
|
|
|
|
|
|
xml => 'application/xml', |
23
|
|
|
|
|
|
|
dump => 'text/x-perl', |
24
|
|
|
|
|
|
|
jsonp => 'text/javascript', |
25
|
|
|
|
|
|
|
}; |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
my %triggers_map = ( |
28
|
|
|
|
|
|
|
get => \&get, |
29
|
|
|
|
|
|
|
index => \&get, |
30
|
|
|
|
|
|
|
read => \&get, |
31
|
|
|
|
|
|
|
|
32
|
|
|
|
|
|
|
post => \&post, |
33
|
|
|
|
|
|
|
create => \&post, |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
put => \&put, |
36
|
|
|
|
|
|
|
update => \&put, |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
del => \&del, |
39
|
|
|
|
|
|
|
delete => \&del, |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
patch => \&patch, |
42
|
|
|
|
|
|
|
); |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
my %alt_syntax = ( |
45
|
|
|
|
|
|
|
get => 'read', |
46
|
|
|
|
|
|
|
post => 'create', |
47
|
|
|
|
|
|
|
put => 'update', |
48
|
|
|
|
|
|
|
del => 'delete', |
49
|
|
|
|
|
|
|
); |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
my %http_codes = ( |
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
# 1xx |
54
|
|
|
|
|
|
|
100 => 'Continue', |
55
|
|
|
|
|
|
|
101 => 'Switching Protocols', |
56
|
|
|
|
|
|
|
102 => 'Processing', |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
# 2xx |
59
|
|
|
|
|
|
|
200 => 'OK', |
60
|
|
|
|
|
|
|
201 => 'Created', |
61
|
|
|
|
|
|
|
202 => 'Accepted', |
62
|
|
|
|
|
|
|
203 => 'Non-Authoritative Information', |
63
|
|
|
|
|
|
|
204 => 'No Content', |
64
|
|
|
|
|
|
|
205 => 'Reset Content', |
65
|
|
|
|
|
|
|
206 => 'Partial Content', |
66
|
|
|
|
|
|
|
207 => 'Multi-Status', |
67
|
|
|
|
|
|
|
210 => 'Content Different', |
68
|
|
|
|
|
|
|
|
69
|
|
|
|
|
|
|
# 3xx |
70
|
|
|
|
|
|
|
300 => 'Multiple Choices', |
71
|
|
|
|
|
|
|
301 => 'Moved Permanently', |
72
|
|
|
|
|
|
|
302 => 'Found', |
73
|
|
|
|
|
|
|
303 => 'See Other', |
74
|
|
|
|
|
|
|
304 => 'Not Modified', |
75
|
|
|
|
|
|
|
305 => 'Use Proxy', |
76
|
|
|
|
|
|
|
307 => 'Temporary Redirect', |
77
|
|
|
|
|
|
|
310 => 'Too many Redirect', |
78
|
|
|
|
|
|
|
|
79
|
|
|
|
|
|
|
# 4xx |
80
|
|
|
|
|
|
|
400 => 'Bad Request', |
81
|
|
|
|
|
|
|
401 => 'Unauthorized', |
82
|
|
|
|
|
|
|
402 => 'Payment Required', |
83
|
|
|
|
|
|
|
403 => 'Forbidden', |
84
|
|
|
|
|
|
|
404 => 'Not Found', |
85
|
|
|
|
|
|
|
405 => 'Method Not Allowed', |
86
|
|
|
|
|
|
|
406 => 'Not Acceptable', |
87
|
|
|
|
|
|
|
407 => 'Proxy Authentication Required', |
88
|
|
|
|
|
|
|
408 => 'Request Time-out', |
89
|
|
|
|
|
|
|
409 => 'Conflict', |
90
|
|
|
|
|
|
|
410 => 'Gone', |
91
|
|
|
|
|
|
|
411 => 'Length Required', |
92
|
|
|
|
|
|
|
412 => 'Precondition Failed', |
93
|
|
|
|
|
|
|
413 => 'Request Entity Too Large', |
94
|
|
|
|
|
|
|
414 => 'Request-URI Too Long', |
95
|
|
|
|
|
|
|
415 => 'Unsupported Media Type', |
96
|
|
|
|
|
|
|
416 => 'Requested range unsatisfiable', |
97
|
|
|
|
|
|
|
417 => 'Expectation failed', |
98
|
|
|
|
|
|
|
418 => 'Teapot', |
99
|
|
|
|
|
|
|
422 => 'Unprocessable entity', |
100
|
|
|
|
|
|
|
423 => 'Locked', |
101
|
|
|
|
|
|
|
424 => 'Method failure', |
102
|
|
|
|
|
|
|
425 => 'Unordered Collection', |
103
|
|
|
|
|
|
|
426 => 'Upgrade Required', |
104
|
|
|
|
|
|
|
449 => 'Retry With', |
105
|
|
|
|
|
|
|
450 => 'Parental Controls', |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
# 5xx |
108
|
|
|
|
|
|
|
500 => 'Internal Server Error', |
109
|
|
|
|
|
|
|
501 => 'Not Implemented', |
110
|
|
|
|
|
|
|
502 => 'Bad Gateway', |
111
|
|
|
|
|
|
|
503 => 'Service Unavailable', |
112
|
|
|
|
|
|
|
504 => 'Gateway Time-out', |
113
|
|
|
|
|
|
|
505 => 'HTTP Version not supported', |
114
|
|
|
|
|
|
|
507 => 'Insufficient storage', |
115
|
|
|
|
|
|
|
509 => 'Bandwidth Limit Exceeded', |
116
|
|
|
|
|
|
|
); |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
our $default_serializer; |
119
|
|
|
|
|
|
|
my $stack = []; |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
sub _generate_sub { |
122
|
40
|
|
|
40
|
|
42
|
my %options = %{ shift() }; |
|
40
|
|
|
|
|
152
|
|
123
|
|
|
|
|
|
|
|
124
|
40
|
|
|
|
|
106
|
my $resname = $options{stack}->[-1]->{resname}; |
125
|
|
|
|
|
|
|
|
126
|
20
|
|
|
|
|
46
|
my $rules = [ |
127
|
55
|
|
|
|
|
132
|
map { $_->{validation_rules}->{generic} } |
128
|
40
|
|
|
|
|
46
|
grep { exists $_->{validation_rules} } reverse @{ $options{stack} } |
|
40
|
|
|
|
|
71
|
|
129
|
|
|
|
|
|
|
]; |
130
|
|
|
|
|
|
|
|
131
|
40
|
100
|
|
|
|
85
|
if ( @$rules > 0 ) { |
132
|
12
|
100
|
|
|
|
45
|
push @$rules, |
133
|
|
|
|
|
|
|
$options{stack}->[-1]->{validation_rules}->{ $options{action} } |
134
|
|
|
|
|
|
|
if exists $options{stack}->[-1]->{validation_rules} |
135
|
|
|
|
|
|
|
->{ $options{action} }; |
136
|
|
|
|
|
|
|
|
137
|
8
|
|
|
|
|
27
|
$rules = { |
138
|
|
|
|
|
|
|
fields => [ |
139
|
8
|
|
|
|
|
9
|
map { ( @{ $_->{fields} } ) } |
|
28
|
|
|
|
|
49
|
|
140
|
23
|
|
|
|
|
76
|
grep { exists $_->{fields} } @$rules |
141
|
|
|
|
|
|
|
], |
142
|
|
|
|
|
|
|
checks => [ |
143
|
23
|
|
|
|
|
16
|
map { ( @{ $_->{checks} } ) } |
|
28
|
|
|
|
|
46
|
|
144
|
0
|
|
|
|
|
0
|
grep { exists $_->{checks} } @$rules |
145
|
|
|
|
|
|
|
], |
146
|
|
|
|
|
|
|
filters => [ |
147
|
0
|
|
|
|
|
0
|
map { ( @{ $_->{filters} } ) } |
|
28
|
|
|
|
|
65
|
|
148
|
12
|
|
|
|
|
30
|
grep { exists $_->{filters} } @$rules |
149
|
|
|
|
|
|
|
], |
150
|
|
|
|
|
|
|
}; |
151
|
|
|
|
|
|
|
} |
152
|
|
|
|
|
|
|
else { |
153
|
28
|
|
|
|
|
52
|
$rules = undef; |
154
|
|
|
|
|
|
|
} |
155
|
|
|
|
|
|
|
|
156
|
55
|
|
|
|
|
215
|
my $chain = [ |
157
|
|
|
|
|
|
|
map { |
158
|
40
|
|
|
|
|
65
|
{ |
159
|
|
|
|
|
|
|
fn => $_->{chain}, |
160
|
|
|
|
|
|
|
fnid => $_->{chain_id}, |
161
|
|
|
|
|
|
|
name => $_->{resname} |
162
|
|
|
|
|
|
|
} |
163
|
40
|
|
|
|
|
53
|
} @{ $options{stack} } |
164
|
|
|
|
|
|
|
]; |
165
|
|
|
|
|
|
|
|
166
|
43
|
100
|
100
|
|
|
114
|
my @idfields = map { $_->{resname} . $SUFFIX } |
|
55
|
|
|
|
|
332
|
|
167
|
|
|
|
|
|
|
grep { |
168
|
40
|
|
|
|
|
65
|
( ( $options{action} =~ m'^(index|create)$' ) |
169
|
|
|
|
|
|
|
and ( $_->{resname} eq $resname ) ) |
170
|
|
|
|
|
|
|
? 0 |
171
|
|
|
|
|
|
|
: 1 |
172
|
40
|
|
|
|
|
47
|
} @{ $options{stack} }; |
173
|
|
|
|
|
|
|
|
174
|
40
|
|
|
|
|
94
|
my $subname = join( '_', $resname, $options{action} ); |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
return subname( |
177
|
|
|
|
|
|
|
$subname, |
178
|
|
|
|
|
|
|
sub { |
179
|
64
|
100
|
|
64
|
|
202975
|
if ( defined $rules ) { |
180
|
24
|
|
|
|
|
77
|
my $input = { |
181
|
24
|
|
|
|
|
4340
|
%{ params('query') }, |
182
|
24
|
100
|
|
|
|
451
|
%{ params('body') }, |
183
|
24
|
|
|
|
|
35
|
%{ captures() || {} } |
184
|
|
|
|
|
|
|
}; |
185
|
24
|
|
|
|
|
210
|
my $result = Validate::Tiny->new( |
186
|
|
|
|
|
|
|
$input, |
187
|
|
|
|
|
|
|
{ |
188
|
24
|
|
|
|
|
422
|
%$rules, fields => [ @idfields, @{ $rules->{fields} } ] |
189
|
|
|
|
|
|
|
} |
190
|
|
|
|
|
|
|
); |
191
|
24
|
100
|
|
|
|
3955
|
unless ( $result->success ) { |
192
|
6
|
|
|
|
|
129
|
status(400); |
193
|
6
|
|
|
|
|
189
|
return { error => $result->error }; |
194
|
|
|
|
|
|
|
} |
195
|
18
|
|
|
|
|
349
|
var validate => $result; |
196
|
|
|
|
|
|
|
} |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
{ |
199
|
58
|
|
|
|
|
245
|
my @chain = @$chain; |
|
58
|
|
|
|
|
153
|
|
200
|
|
|
|
|
|
|
|
201
|
|
|
|
|
|
|
#unless ($options{action} ~~ [qw[ read update delete patch ]]) { |
202
|
|
|
|
|
|
|
# pop @chain; |
203
|
|
|
|
|
|
|
#} |
204
|
58
|
100
|
|
|
|
65
|
my %cap = %{ captures() || {} }; |
|
58
|
|
|
|
|
177
|
|
205
|
58
|
|
|
|
|
7997
|
foreach my $ci (@chain) { |
206
|
234
|
|
|
|
|
493
|
my ( $name, $fn, $fnid ) = |
207
|
78
|
|
|
|
|
225
|
map { $ci->{$_} } qw(name fn fnid); |
208
|
78
|
100
|
100
|
|
|
664
|
if ( exists $cap{ $name . $SUFFIX } |
|
|
100
|
|
|
|
|
|
209
|
|
|
|
|
|
|
and ref $fnid eq 'CODE' ) |
210
|
|
|
|
|
|
|
{ |
211
|
14
|
|
|
|
|
55
|
$fnid->( $cap{ $name . $SUFFIX } ); |
212
|
|
|
|
|
|
|
} |
213
|
|
|
|
|
|
|
elsif ( ref $fn eq 'CODE' ) { |
214
|
4
|
|
|
|
|
10
|
$fn->(); |
215
|
|
|
|
|
|
|
} |
216
|
|
|
|
|
|
|
} |
217
|
|
|
|
|
|
|
} |
218
|
|
|
|
|
|
|
|
219
|
0
|
|
|
|
|
0
|
my @ret = |
220
|
58
|
|
|
|
|
265
|
$options{coderef}->( map { $_->{resname} } @{ $options{stack} } ); |
|
58
|
|
|
|
|
304
|
|
221
|
|
|
|
|
|
|
|
222
|
58
|
100
|
66
|
|
|
3049
|
if ( @ret |
|
|
100
|
100
|
|
|
|
|
|
|
|
66
|
|
|
|
|
223
|
|
|
|
|
|
|
and defined $ret[0] |
224
|
|
|
|
|
|
|
and ref $ret[0] eq '' |
225
|
|
|
|
|
|
|
and $ret[0] =~ m{^\d{3}$} ) |
226
|
|
|
|
|
|
|
{ |
227
|
|
|
|
|
|
|
# return ($http_status_code, ...) |
228
|
1
|
50
|
|
|
|
4
|
if ( $ret[0] >= 400 ) { |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
# return ($http_error_code, $error_message) |
231
|
1
|
|
|
|
|
4
|
status( $ret[0] ); |
232
|
1
|
|
|
|
|
23
|
return { error => $ret[1] }; |
233
|
|
|
|
|
|
|
} |
234
|
|
|
|
|
|
|
else { |
235
|
|
|
|
|
|
|
# return ($http_success_code, $payload) |
236
|
0
|
|
|
|
|
0
|
status( $ret[0] ); |
237
|
0
|
|
|
|
|
0
|
return $ret[1]; |
238
|
|
|
|
|
|
|
} |
239
|
|
|
|
|
|
|
} |
240
|
|
|
|
|
|
|
elsif ( status eq '200' ) { |
241
|
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
# http status wasn't changed yet |
243
|
55
|
100
|
|
|
|
1035
|
if ( $options{action} eq 'create' ) { status(201) } |
|
10
|
100
|
|
|
|
30
|
|
|
|
100
|
|
|
|
|
|
244
|
7
|
|
|
|
|
27
|
elsif ( $options{action} eq 'update' ) { status(202) } |
245
|
7
|
|
|
|
|
21
|
elsif ( $options{action} eq 'delete' ) { status(202) } |
246
|
|
|
|
|
|
|
} |
247
|
|
|
|
|
|
|
|
248
|
|
|
|
|
|
|
# return payload |
249
|
57
|
50
|
|
|
|
869
|
return ( wantarray ? @ret : $ret[0] ); |
250
|
|
|
|
|
|
|
} |
251
|
40
|
|
|
|
|
509
|
); |
252
|
|
|
|
|
|
|
} |
253
|
|
|
|
|
|
|
|
254
|
|
|
|
|
|
|
sub _prefix { |
255
|
7
|
|
|
7
|
|
12
|
my ( $prefix, $cb ) = @_; |
256
|
|
|
|
|
|
|
|
257
|
7
|
|
|
|
|
35
|
my $app = Dancer::App->current; |
258
|
|
|
|
|
|
|
|
259
|
7
|
50
|
|
|
|
696
|
my $app_prefix = defined $app->app_prefix ? $app->app_prefix : ""; |
260
|
7
|
|
|
|
|
75
|
my $previous = Dancer::App->current->prefix; |
261
|
|
|
|
|
|
|
|
262
|
7
|
50
|
|
|
|
71
|
if ( $app->on_lexical_prefix ) { |
263
|
0
|
0
|
|
|
|
0
|
if ( ref $previous eq 'Regexp' ) { |
264
|
0
|
|
|
|
|
0
|
$app->prefix(qr/${previous}${prefix}/); |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
else { |
267
|
0
|
|
|
|
|
0
|
my $previous_ = quotemeta($previous); |
268
|
0
|
|
|
|
|
0
|
$app->prefix(qr/${previous_}${prefix}/); |
269
|
|
|
|
|
|
|
} |
270
|
|
|
|
|
|
|
} |
271
|
|
|
|
|
|
|
else { |
272
|
7
|
50
|
|
|
|
45
|
if ( ref $app_prefix eq 'Regexp' ) { |
273
|
0
|
|
|
|
|
0
|
$app->prefix(qr/${app_prefix}${prefix}/); |
274
|
|
|
|
|
|
|
} |
275
|
|
|
|
|
|
|
else { |
276
|
7
|
|
|
|
|
22
|
my $app_prefix_ = quotemeta($app_prefix); |
277
|
7
|
|
|
|
|
199
|
$app->prefix(qr/${app_prefix_}${prefix}/); |
278
|
|
|
|
|
|
|
} |
279
|
|
|
|
|
|
|
} |
280
|
|
|
|
|
|
|
|
281
|
7
|
50
|
|
|
|
61
|
if ( ref($cb) eq 'CODE' ) { |
282
|
7
|
|
|
|
|
33
|
$app->incr_lexical_prefix; |
283
|
7
|
|
|
|
|
71
|
eval { $cb->() }; |
|
7
|
|
|
|
|
26
|
|
284
|
7
|
|
|
|
|
1140
|
my $e = $@; |
285
|
7
|
|
|
|
|
28
|
$app->dec_lexical_prefix; |
286
|
7
|
|
|
|
|
81
|
$app->prefix($previous); |
287
|
7
|
50
|
|
|
|
43
|
die $e if $e; |
288
|
|
|
|
|
|
|
} |
289
|
|
|
|
|
|
|
} |
290
|
|
|
|
|
|
|
|
291
|
|
|
|
|
|
|
register prepare_serializer_for_format => sub () { |
292
|
0
|
|
|
0
|
|
0
|
my $conf = plugin_setting; |
293
|
0
|
|
|
|
|
0
|
my $serializers = { |
294
|
|
|
|
|
|
|
'json' => 'JSON', |
295
|
|
|
|
|
|
|
'jsonp' => 'JSONP', |
296
|
|
|
|
|
|
|
'yml' => 'YAML', |
297
|
|
|
|
|
|
|
'xml' => 'XML', |
298
|
|
|
|
|
|
|
'dump' => 'Dumper', |
299
|
0
|
0
|
|
|
|
0
|
( exists $conf->{serializers} ? %{ $conf->{serializers} } : () ) |
300
|
|
|
|
|
|
|
}; |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
hook( |
303
|
|
|
|
|
|
|
before => sub { |
304
|
|
|
|
|
|
|
|
305
|
|
|
|
|
|
|
# remember what was there before |
306
|
0
|
|
0
|
0
|
|
0
|
$default_serializer ||= setting('serializer'); |
307
|
|
|
|
|
|
|
|
308
|
0
|
0
|
|
|
|
0
|
my $format = defined captures() ? captures->{format} : undef; |
309
|
0
|
0
|
0
|
|
|
0
|
$format ||= param('format') or return; |
310
|
|
|
|
|
|
|
|
311
|
0
|
0
|
|
|
|
0
|
my $serializer = $serializers->{$format} |
312
|
|
|
|
|
|
|
or return halt( |
313
|
|
|
|
|
|
|
Dancer::Error->new( |
314
|
|
|
|
|
|
|
code => 404, |
315
|
|
|
|
|
|
|
title => "unsupported format requested", |
316
|
|
|
|
|
|
|
message => "unsupported format requested: " . $format |
317
|
|
|
|
|
|
|
)->render |
318
|
|
|
|
|
|
|
); |
319
|
|
|
|
|
|
|
|
320
|
0
|
|
|
|
|
0
|
set( serializer => $serializer ); |
321
|
|
|
|
|
|
|
|
322
|
|
|
|
|
|
|
# check if we were supposed to deserialize the request |
323
|
0
|
|
|
|
|
0
|
Dancer::Serializer->process_request( Dancer::SharedData->request ); |
324
|
|
|
|
|
|
|
|
325
|
0
|
|
0
|
|
|
0
|
content_type( $content_types->{$format} |
326
|
|
|
|
|
|
|
|| setting('content_type') ); |
327
|
|
|
|
|
|
|
} |
328
|
0
|
|
|
|
|
0
|
); |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
hook( |
331
|
|
|
|
|
|
|
after => sub { |
332
|
|
|
|
|
|
|
|
333
|
|
|
|
|
|
|
# put it back the way it was |
334
|
0
|
|
|
0
|
|
0
|
set( serializer => $default_serializer ); |
335
|
|
|
|
|
|
|
} |
336
|
0
|
|
|
|
|
0
|
); |
337
|
|
|
|
|
|
|
}; |
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
register( |
340
|
|
|
|
|
|
|
resource => sub ($%) { |
341
|
13
|
|
|
13
|
|
4786
|
my $resource = my $resource1 = my $resource2 = shift; |
342
|
13
|
|
|
|
|
79
|
my %triggers = @_; |
343
|
|
|
|
|
|
|
|
344
|
|
|
|
|
|
|
{ |
345
|
13
|
|
|
|
|
22
|
my $c = quotemeta '()|{}'; |
|
13
|
|
|
|
|
31
|
|
346
|
13
|
100
|
|
|
|
244
|
if ( $resource =~ m{[$c]} ) { |
347
|
4
|
|
|
|
|
29
|
$resource1 = pluralize( $resource1, 1 ); |
348
|
4
|
|
|
|
|
207
|
$resource2 = pluralize( $resource2, 2 ); |
349
|
|
|
|
|
|
|
} |
350
|
|
|
|
|
|
|
} |
351
|
|
|
|
|
|
|
|
352
|
13
|
|
|
|
|
124
|
my %options; |
353
|
13
|
|
|
|
|
36
|
push @$stack => \%options; |
354
|
|
|
|
|
|
|
|
355
|
13
|
|
|
|
|
37
|
$options{resname} = $resource1; |
356
|
|
|
|
|
|
|
|
357
|
13
|
|
|
|
|
23
|
my $altsyntax = 0; |
358
|
13
|
100
|
|
|
|
42
|
if ( exists $triggers{altsyntax} ) { |
359
|
1
|
|
|
|
|
4
|
$altsyntax = delete $triggers{altsyntax}; |
360
|
|
|
|
|
|
|
} |
361
|
|
|
|
|
|
|
|
362
|
13
|
|
|
|
|
66
|
my $idregex = qr{[^\/\.\:\?]+}; |
363
|
|
|
|
|
|
|
|
364
|
13
|
50
|
|
|
|
71
|
if ( exists $triggers{idregex} ) { |
365
|
0
|
|
|
|
|
0
|
$idregex = delete $triggers{idregex}; |
366
|
|
|
|
|
|
|
} |
367
|
|
|
|
|
|
|
|
368
|
13
|
|
|
|
|
194
|
$options{prefix} = qr{/\Q$resource2\E}; |
369
|
13
|
|
|
|
|
414
|
$options{prefix_id} = |
370
|
|
|
|
|
|
|
qr{/\Q$resource1\E/(?<$resource1$SUFFIX>$idregex)}; |
371
|
|
|
|
|
|
|
|
372
|
13
|
100
|
|
|
|
56
|
if ( exists $triggers{validation} ) { |
373
|
3
|
|
|
|
|
57
|
$options{validation_rules} = delete $triggers{validation}; |
374
|
|
|
|
|
|
|
} |
375
|
|
|
|
|
|
|
|
376
|
13
|
100
|
|
|
|
123
|
if ( exists $triggers{chain} ) { |
377
|
2
|
|
|
|
|
4
|
$options{chain} = delete $triggers{chain}; |
378
|
|
|
|
|
|
|
} |
379
|
|
|
|
|
|
|
|
380
|
13
|
100
|
|
|
|
58
|
if ( exists $triggers{"chain$SUFFIX"} ) { |
381
|
2
|
|
|
|
|
4
|
$options{chain_id} = delete $triggers{"chain$SUFFIX"}; |
382
|
|
|
|
|
|
|
} |
383
|
|
|
|
|
|
|
|
384
|
13
|
100
|
|
|
|
55
|
if ( exists $triggers{ 'prefix' . $SUFFIX } ) { |
385
|
6
|
|
|
|
|
18
|
my $subref = delete $triggers{ 'prefix' . $SUFFIX }; |
386
|
6
|
|
|
|
|
15
|
$options{prefixed_with_id} = 1; |
387
|
6
|
50
|
|
|
|
38
|
my @prefixes = |
388
|
6
|
|
|
|
|
24
|
map { $_->{prefixed_with_id} ? $_->{prefix_id} : $_->{prefix} } |
389
|
6
|
|
|
|
|
16
|
grep { exists $_->{prefix} } @$stack; |
390
|
6
|
|
|
|
|
10
|
local $" = ''; |
391
|
6
|
|
|
|
|
45
|
_prefix( qr{@prefixes}, $subref ); |
392
|
6
|
|
|
|
|
26
|
delete $options{prefixed_with_id}; |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
|
395
|
13
|
100
|
|
|
|
48
|
if ( exists $triggers{prefix} ) { |
396
|
1
|
|
|
|
|
2
|
my $subref = delete $triggers{'prefix'}; |
397
|
1
|
|
|
|
|
2
|
$options{prefixed_with_id} = 0; |
398
|
1
|
50
|
|
|
|
5
|
my @prefixes = |
399
|
1
|
|
|
|
|
3
|
map { $_->{prefixed_with_id} ? $_->{prefix_id} : $_->{prefix} } |
400
|
1
|
|
|
|
|
2
|
grep { exists $_->{prefix} } @$stack; |
401
|
1
|
|
|
|
|
1
|
local $" = ''; |
402
|
1
|
|
|
|
|
5
|
_prefix( qr{@prefixes}, $subref ); |
403
|
1
|
|
|
|
|
5
|
delete $options{prefixed_with_id}; |
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
|
406
|
13
|
|
|
|
|
18
|
my %routes; |
407
|
|
|
|
|
|
|
|
408
|
13
|
|
|
|
|
39
|
foreach my $action (qw(index create read delete update patch)) { |
409
|
78
|
100
|
|
|
|
8428
|
next unless exists $triggers{$action}; |
410
|
|
|
|
|
|
|
|
411
|
35
|
|
|
|
|
38
|
my $route; |
412
|
|
|
|
|
|
|
|
413
|
35
|
100
|
|
|
|
109
|
if ( $action eq 'index' ) { |
|
|
100
|
|
|
|
|
|
414
|
6
|
|
|
|
|
74
|
$route = qr{/\Q$resource2\E}; |
415
|
|
|
|
|
|
|
} |
416
|
|
|
|
|
|
|
elsif ( $action eq 'create' ) { |
417
|
6
|
|
|
|
|
86
|
$route = qr{/\Q$resource1\E}; |
418
|
|
|
|
|
|
|
} |
419
|
|
|
|
|
|
|
else { |
420
|
23
|
|
|
|
|
274
|
$route = qr{/\Q$resource1\E/(?<$resource1$SUFFIX>$idregex)}; |
421
|
|
|
|
|
|
|
} |
422
|
|
|
|
|
|
|
|
423
|
35
|
|
|
|
|
183
|
my $sub = _generate_sub( |
424
|
|
|
|
|
|
|
{ |
425
|
|
|
|
|
|
|
stack => $stack, |
426
|
|
|
|
|
|
|
action => $action, |
427
|
|
|
|
|
|
|
coderef => $triggers{$action}, |
428
|
|
|
|
|
|
|
} |
429
|
|
|
|
|
|
|
); |
430
|
|
|
|
|
|
|
|
431
|
35
|
|
|
|
|
112
|
$routes{$action} = []; |
432
|
|
|
|
|
|
|
|
433
|
35
|
100
|
|
|
|
75
|
if ($altsyntax) { |
434
|
5
|
|
|
|
|
6
|
push @{ $routes{$action} } => $triggers_map{get} |
|
5
|
|
|
|
|
274
|
|
435
|
|
|
|
|
|
|
->( qr{$route/\Q$action\E\.(?json|jsonp|yml|xml|dump)} |
436
|
|
|
|
|
|
|
=> $sub ); |
437
|
5
|
|
|
|
|
2017
|
push @{ $routes{$action} } => |
|
5
|
|
|
|
|
95
|
|
438
|
|
|
|
|
|
|
$triggers_map{get}->( qr{$route/\Q$action\E} => $sub ); |
439
|
|
|
|
|
|
|
} |
440
|
35
|
|
|
|
|
1627
|
push @{ $routes{$action} } => $triggers_map{$action} |
|
35
|
|
|
|
|
918
|
|
441
|
|
|
|
|
|
|
->( qr{$route\.(?json|jsonp|yml|xml|dump)} => $sub ); |
442
|
35
|
|
|
|
|
10753
|
push @{ $routes{$action} } => |
|
35
|
|
|
|
|
133
|
|
443
|
|
|
|
|
|
|
$triggers_map{$action}->( $route => $sub ); |
444
|
|
|
|
|
|
|
} |
445
|
|
|
|
|
|
|
|
446
|
13
|
|
|
|
|
462
|
pop @$stack; |
447
|
|
|
|
|
|
|
|
448
|
13
|
|
|
|
|
119
|
return %routes; |
449
|
|
|
|
|
|
|
} |
450
|
|
|
|
|
|
|
); |
451
|
|
|
|
|
|
|
|
452
|
|
|
|
|
|
|
register( |
453
|
|
|
|
|
|
|
wrap => sub($$$) { |
454
|
5
|
|
|
5
|
|
31
|
my ( $action, $route, $coderef ) = @_; |
455
|
|
|
|
|
|
|
|
456
|
5
|
50
|
|
|
|
13
|
my @route = grep { defined and length } split m{/+}, $route; |
|
5
|
|
|
|
|
25
|
|
457
|
|
|
|
|
|
|
|
458
|
5
|
50
|
|
|
|
11
|
my $parent = @$stack ? $stack->[-1] : undef; |
459
|
5
|
|
|
|
|
10
|
foreach my $route (@route) { |
460
|
5
|
|
|
|
|
12
|
push @$stack => { resname => $route }; |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
|
463
|
5
|
50
|
|
|
|
15
|
if ( defined $parent ) { |
464
|
5
|
50
|
33
|
|
|
49
|
if ( exists $parent->{validation_rules} |
|
|
|
33
|
|
|
|
|
|
|
|
33
|
|
|
|
|
465
|
|
|
|
|
|
|
and exists $parent->{validation_rules}->{wrap} |
466
|
|
|
|
|
|
|
and exists $parent->{validation_rules}->{wrap}->{$action} |
467
|
|
|
|
|
|
|
and |
468
|
|
|
|
|
|
|
exists $parent->{validation_rules}->{wrap}->{$action}->{$route} |
469
|
|
|
|
|
|
|
) |
470
|
|
|
|
|
|
|
{ |
471
|
5
|
|
|
|
|
18
|
$stack->[-1]->{validation_rules} = |
472
|
|
|
|
|
|
|
{ lc($action) => |
473
|
|
|
|
|
|
|
$parent->{validation_rules}->{wrap}->{$action}->{$route} |
474
|
|
|
|
|
|
|
}; |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
} |
477
|
|
|
|
|
|
|
|
478
|
5
|
|
|
|
|
16
|
my $sub = _generate_sub( |
479
|
|
|
|
|
|
|
{ |
480
|
|
|
|
|
|
|
action => lc($action), |
481
|
|
|
|
|
|
|
stack => $stack, |
482
|
|
|
|
|
|
|
coderef => $coderef, |
483
|
|
|
|
|
|
|
} |
484
|
|
|
|
|
|
|
); |
485
|
|
|
|
|
|
|
|
486
|
5
|
|
|
|
|
22
|
pop @$stack for @route; |
487
|
|
|
|
|
|
|
|
488
|
5
|
|
|
|
|
6
|
my @routes; |
489
|
|
|
|
|
|
|
|
490
|
5
|
|
|
|
|
189
|
push @routes => $triggers_map{ lc($action) } |
491
|
|
|
|
|
|
|
->( qr{/\Q$route\E\.(?json|jsonp|yml|xml|dump)} => $sub ); |
492
|
5
|
|
|
|
|
1378
|
push @routes => |
493
|
|
|
|
|
|
|
$triggers_map{ lc($action) }->( qr{/\Q$route\E} => $sub ); |
494
|
|
|
|
|
|
|
|
495
|
5
|
|
|
|
|
1141
|
return @routes; |
496
|
|
|
|
|
|
|
} |
497
|
|
|
|
|
|
|
); |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
register send_entity => sub { |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
# entity, status_code |
502
|
2
|
|
50
|
2
|
|
13
|
status( $_[1] || 200 ); |
503
|
2
|
|
|
|
|
53
|
$_[0]; |
504
|
|
|
|
|
|
|
}; |
505
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
for my $code ( keys %http_codes ) { |
507
|
|
|
|
|
|
|
my $helper_name = lc( $http_codes{$code} ); |
508
|
|
|
|
|
|
|
$helper_name =~ s/[^\w]+/_/gms; |
509
|
|
|
|
|
|
|
$helper_name = "status_${helper_name}"; |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
register $helper_name => sub { |
512
|
2
|
50
|
|
2
|
|
48
|
if ( $code >= 400 ) { |
513
|
2
|
|
|
|
|
11
|
send_entity( { error => $_[0] }, $code ); |
514
|
|
|
|
|
|
|
} |
515
|
|
|
|
|
|
|
else { |
516
|
0
|
|
|
|
|
|
send_entity( $_[0], $code ); |
517
|
|
|
|
|
|
|
} |
518
|
|
|
|
|
|
|
}; |
519
|
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
register_plugin; |
522
|
|
|
|
|
|
|
1; |
523
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
__END__ |