line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Terse::Controller; |
2
|
1
|
|
|
1
|
|
71484
|
use strict; |
|
1
|
|
|
|
|
12
|
|
|
1
|
|
|
|
|
29
|
|
3
|
1
|
|
|
1
|
|
5
|
use warnings; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
38
|
|
4
|
1
|
|
|
1
|
|
6
|
no warnings 'reserved'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
39
|
|
5
|
1
|
|
|
1
|
|
547
|
use attributes (); |
|
1
|
|
|
|
|
1279
|
|
|
1
|
|
|
|
|
28
|
|
6
|
1
|
|
|
1
|
|
6
|
use base 'Terse'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
577
|
|
7
|
1
|
|
|
1
|
|
9
|
use B 'svref_2object'; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
106
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
our %HTTP; |
10
|
1
|
|
|
1
|
|
4
|
BEGIN { %HTTP = map { $_ => 1 } qw/get post put delete connect head options trace patch/; } |
|
9
|
|
|
|
|
930
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
sub new { |
13
|
1
|
|
|
1
|
1
|
105
|
my ($pkg, @args) = @_; |
14
|
1
|
|
|
|
|
9
|
my $self = $pkg->SUPER::new( |
15
|
|
|
|
|
|
|
app => 0, |
16
|
|
|
|
|
|
|
restrict_path => '/', |
17
|
|
|
|
|
|
|
@args |
18
|
|
|
|
|
|
|
); |
19
|
1
|
|
|
|
|
4
|
(my $namespace = $pkg) =~ s/^.*Controller:://; |
20
|
1
|
|
|
|
|
3
|
$namespace =~ s/\:\:/\//g; |
21
|
1
|
|
|
|
|
9
|
$self->namespace = lc( $namespace ); |
22
|
1
|
|
|
|
|
5
|
$self->default_req = [split "/", $self->namespace]->[-1]; |
23
|
1
|
50
|
|
|
|
20
|
$self->build_controller($self->app_config) if ($self->can('build_controller')); |
24
|
1
|
|
|
|
|
5
|
return $self; |
25
|
|
|
|
|
|
|
} |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
sub preprocess_req { |
28
|
0
|
|
|
0
|
0
|
0
|
my ($self, $req, $t) = @_; |
29
|
0
|
0
|
|
|
|
0
|
if (!$req) { |
30
|
0
|
|
|
|
|
0
|
my $alias = $Terse::Controller::dispatcher{ref $self}{_alias}; |
31
|
0
|
|
|
|
|
0
|
my $path = $t->request->uri->path; |
32
|
0
|
|
|
|
|
0
|
for my $candidate (keys %{$alias}) { |
|
0
|
|
|
|
|
0
|
|
33
|
0
|
|
|
|
|
0
|
my @captured = $path =~ m/^$candidate$/; |
34
|
0
|
0
|
|
|
|
0
|
if (scalar @captured) { |
35
|
0
|
|
|
|
|
0
|
$t->captured = \@captured; |
36
|
0
|
|
|
|
|
0
|
$req = $alias->{$candidate}->{req}; |
37
|
|
|
|
|
|
|
} |
38
|
|
|
|
|
|
|
} |
39
|
|
|
|
|
|
|
} |
40
|
0
|
|
|
|
|
0
|
return $req; |
41
|
|
|
|
|
|
|
} |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
sub build_terse { |
44
|
0
|
|
|
0
|
0
|
0
|
my ($self, $t) = @_; |
45
|
0
|
0
|
|
|
|
0
|
if ($self->models) { |
46
|
0
|
|
0
|
|
|
0
|
$t->models ||= {}; |
47
|
|
|
|
|
|
|
$t->{model} = sub { |
48
|
0
|
|
|
0
|
|
0
|
my ($t, $model) = @_; |
49
|
0
|
0
|
|
|
|
0
|
$t->raiseError("invalid model: ${model}", 400) unless $self->models->{$model}; |
50
|
0
|
|
0
|
|
|
0
|
return $t->models->{$model} ||= $self->models->{$model}->connect($t); |
51
|
0
|
|
|
|
|
0
|
}; |
52
|
|
|
|
|
|
|
} |
53
|
0
|
0
|
|
|
|
0
|
if ($self->controllers) { |
54
|
|
|
|
|
|
|
$t->{controller} = sub { |
55
|
0
|
|
|
0
|
|
0
|
my ($t, $controller) = @_; |
56
|
0
|
0
|
|
|
|
0
|
return $self->controllers->{$controller} if $self->controllers->{$controller}; |
57
|
|
|
|
|
|
|
return $self->controllers->{$self->controllers->{_alias}->{$controller}->{namespace}} |
58
|
0
|
0
|
|
|
|
0
|
if $self->controllers->{_alias}->{$controller}; |
59
|
0
|
|
|
|
|
0
|
for my $key (keys %{$self->controllers->{_alias}}) { |
|
0
|
|
|
|
|
0
|
|
60
|
0
|
|
|
|
|
0
|
my @captured = $controller =~ m/^$key$/; |
61
|
0
|
0
|
|
|
|
0
|
if (scalar @captured) { |
62
|
0
|
|
|
|
|
0
|
$controller = $self->controllers->{$self->controllers->{_alias}->{$key}->{namespace}}; |
63
|
0
|
|
|
|
|
0
|
$t->captured = \@captured; |
64
|
0
|
|
|
|
|
0
|
return $controller; |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
} |
67
|
0
|
|
|
|
|
0
|
return; |
68
|
0
|
|
|
|
|
0
|
}; |
69
|
|
|
|
|
|
|
} |
70
|
0
|
0
|
|
|
|
0
|
if ($self->views) { |
71
|
|
|
|
|
|
|
$t->{view} = sub { |
72
|
0
|
|
|
0
|
|
0
|
my ($t, $view) = @_; |
73
|
0
|
0
|
|
|
|
0
|
$t->raiseError("invalid view: ${view}", 400) unless $self->views->{$view}; |
74
|
0
|
|
|
|
|
0
|
return $self->views->{$view}; |
75
|
0
|
|
|
|
|
0
|
}; |
76
|
|
|
|
|
|
|
} |
77
|
0
|
0
|
|
|
|
0
|
if ($self->plugins) { |
78
|
0
|
|
0
|
|
|
0
|
$t->plugins ||= {}; |
79
|
|
|
|
|
|
|
$t->{plugin} = sub { |
80
|
0
|
|
|
0
|
|
0
|
my ($t, $plugin) = @_; |
81
|
0
|
0
|
|
|
|
0
|
$t->raiseError("invalid plugin: ${plugin}", 400) unless $self->plugins->{$plugin}; |
82
|
|
|
|
|
|
|
return $t->plugins->{$plugin} ||= ($self->plugins->{$plugin}->can('connect') |
83
|
|
|
|
|
|
|
? $self->plugins->{$plugin}->connect($t) |
84
|
0
|
0
|
0
|
|
|
0
|
: $self->plugins->{$plugin}); |
85
|
0
|
|
|
|
|
0
|
}; |
86
|
|
|
|
|
|
|
} |
87
|
0
|
|
|
|
|
0
|
return $t; |
88
|
|
|
|
|
|
|
} |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
sub MODIFY_CODE_ATTRIBUTES { |
91
|
7
|
|
|
7
|
|
1457
|
my ($package, $coderef, @attributes, @disallowed) = @_; |
92
|
1
|
|
|
1
|
|
8
|
no warnings qw(reserved); |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
2043
|
|
93
|
7
|
|
|
|
|
40
|
my $name = svref_2object($coderef)->GV->NAME; |
94
|
7
|
|
|
|
|
33
|
my %attr = PARSE_ATTRIBUTES($name, @attributes); |
95
|
7
|
|
|
|
|
13
|
push @{ $Terse::Controller::dispatcher{$package}{$attr{req}} }, \%attr; |
|
7
|
|
|
|
|
30
|
|
96
|
7
|
100
|
|
|
|
18
|
if ($attr{path}) { |
97
|
2
|
|
|
|
|
4
|
(my $namespace = $package) =~ s/^.*Controller:://; |
98
|
2
|
|
|
|
|
3
|
$namespace =~ s/\:\:/\//g; |
99
|
|
|
|
|
|
|
$Terse::Controller::dispatcher{$package}{_alias}{$attr{path}} = { |
100
|
|
|
|
|
|
|
namespace => lc( $namespace ), |
101
|
|
|
|
|
|
|
req => $attr{req} |
102
|
2
|
|
|
|
|
15
|
}; |
103
|
|
|
|
|
|
|
} |
104
|
7
|
|
|
|
|
21
|
return (); |
105
|
|
|
|
|
|
|
} |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
sub FETCH_CODE_ATTRIBUTES { |
108
|
0
|
|
|
0
|
|
0
|
my ($class, $coderef) = @_; |
109
|
0
|
|
|
|
|
0
|
my $cv = svref_2object($coderef); |
110
|
0
|
|
|
|
|
0
|
return @{$Terse::Controller::dispatcher{$class}{ $cv->GV->NAME }}; |
|
0
|
|
|
|
|
0
|
|
111
|
|
|
|
|
|
|
} |
112
|
|
|
|
|
|
|
|
113
|
|
|
|
|
|
|
sub PARSE_ATTRIBUTES { |
114
|
7
|
|
|
7
|
0
|
15
|
my ($sub, @attributes) = @_; |
115
|
7
|
|
|
|
|
19
|
my %attr = ( |
116
|
|
|
|
|
|
|
req => $sub, |
117
|
|
|
|
|
|
|
callback => $sub |
118
|
|
|
|
|
|
|
); |
119
|
7
|
|
|
|
|
15
|
for my $attribute (@attributes) { |
120
|
13
|
100
|
|
|
|
71
|
if ($attribute =~ m/^\s*params\((.*)\)\s*$/) { |
|
|
100
|
|
|
|
|
|
121
|
1
|
|
|
|
|
85
|
$attr{params} = { eval $1 }; |
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
elsif ($attribute =~ m/^\s*([^\s\(]+)\s*\(([\s\'\"]*?)(.*)([\s\'\"]*?)\)/) { |
124
|
7
|
|
|
|
|
20
|
my $k = lc($1); |
125
|
7
|
|
|
|
|
35
|
$attr{$k} = $3; |
126
|
7
|
100
|
100
|
|
|
41
|
if ($HTTP{$k} || $k =~ m/^(any|websocket|deleayed)$/i) { |
127
|
3
|
|
|
|
|
7
|
$attr{req} = $attr{$k}; |
128
|
|
|
|
|
|
|
} |
129
|
|
|
|
|
|
|
} |
130
|
|
|
|
|
|
|
else { |
131
|
5
|
|
|
|
|
12
|
$attr{lc($attribute)} = 1; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
} |
134
|
7
|
100
|
66
|
|
|
26
|
$attr{any} = 1 if ($attr{websocket} && scalar keys %attr < 4); |
135
|
7
|
|
|
|
|
40
|
return %attr; |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
sub delayed_response_handle { |
139
|
0
|
|
|
0
|
0
|
|
my ($self, $t, $response, $sid, $ct, $status) = @_; |
140
|
|
|
|
|
|
|
$t->{_delayed_response} = sub { |
141
|
0
|
|
|
0
|
|
|
my $responder = shift; |
142
|
0
|
|
0
|
|
|
|
my $view = $t->view($t->response_view || $self->response_view); |
143
|
0
|
|
0
|
|
|
|
my $res = $t->_build_response($sid, |
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
144
|
|
|
|
|
|
|
$t->content_type || $view && $view->content_type || $ct, |
145
|
|
|
|
|
|
|
$t->response->status_code ||= $status ||= 200 |
146
|
|
|
|
|
|
|
); |
147
|
0
|
|
|
|
|
|
$res = [splice @{$res->finalize}, 0, 2]; |
|
0
|
|
|
|
|
|
|
148
|
0
|
|
|
|
|
|
my $writer = $responder->($res); |
149
|
0
|
|
|
|
|
|
$response = eval { $response->($writer); }; |
|
0
|
|
|
|
|
|
|
150
|
0
|
0
|
0
|
|
|
|
if ($@ || $t->response->error) { |
|
|
0
|
|
|
|
|
|
151
|
0
|
|
0
|
|
|
|
$res->[0] = $t->response->status_code || 500; |
152
|
|
|
|
|
|
|
$t->raiseError($@) if #@; |
153
|
0
|
0
|
|
|
|
|
push @{$res}, [$t->response->serialize]; |
|
0
|
|
|
|
|
|
|
154
|
0
|
|
|
|
|
|
return $responder->($res); |
155
|
|
|
|
|
|
|
} |
156
|
|
|
|
|
|
|
elsif ($response) { |
157
|
0
|
|
0
|
|
|
|
$view = $t->view($t->response_view || $self->response_view); |
158
|
0
|
0
|
|
|
|
|
if ($view) { |
159
|
0
|
|
|
|
|
|
my (undef, $render) = $view->render($t, $response); |
160
|
0
|
0
|
|
|
|
|
if ($t->response->error) { |
161
|
0
|
|
0
|
|
|
|
$res->[0] = $t->response->status_code || 500; |
162
|
0
|
0
|
|
|
|
|
push @{$res}, [$t->response->no_response ? () : $t->response->serialize]; |
|
0
|
|
|
|
|
|
|
163
|
0
|
|
|
|
|
|
return $responder->($res); |
164
|
|
|
|
|
|
|
} |
165
|
0
|
|
|
|
|
|
$response = $render; |
166
|
|
|
|
|
|
|
} else { |
167
|
0
|
|
|
|
|
|
$response = $response->serialize; |
168
|
|
|
|
|
|
|
} |
169
|
0
|
|
|
|
|
|
$writer->write($response); |
170
|
|
|
|
|
|
|
} |
171
|
0
|
|
|
|
|
|
$writer->close; |
172
|
0
|
|
|
|
|
|
}; |
173
|
0
|
|
|
|
|
|
return $t; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
|
177
|
|
|
|
|
|
|
sub response_handle { |
178
|
0
|
|
|
0
|
0
|
|
my ($self, $t, $response_body, $sid, $ct, $status) = @_; |
179
|
0
|
|
0
|
|
|
|
$ct ||= 'application/json'; |
180
|
0
|
|
|
|
|
|
my $res = $t->{_delayed_response}; |
181
|
0
|
0
|
|
|
|
|
return $res if ($res); |
182
|
0
|
0
|
0
|
|
|
|
my ($content_type, $body) = $self->views && $self->views->{$t->response_view || $self->response_view} |
|
|
|
0
|
|
|
|
|
183
|
|
|
|
|
|
|
? $t->view($t->response_view || $self->response_view)->render($t, $response_body) |
184
|
|
|
|
|
|
|
: ($ct, $response_body->serialize()); |
185
|
0
|
|
0
|
|
|
|
$res = $t->_build_response($sid, $content_type, $response_body->status_code ||= $status ||= 200); |
|
|
|
0
|
|
|
|
|
186
|
0
|
|
|
|
|
|
$res->body($body); |
187
|
0
|
|
|
|
|
|
return $res->finalize; |
188
|
|
|
|
|
|
|
} |
189
|
|
|
|
|
|
|
|
190
|
|
|
|
|
|
|
sub dispatch { |
191
|
0
|
|
|
0
|
0
|
|
my ($self, $req, $t, @params) = @_; |
192
|
0
|
|
0
|
|
|
|
my $package = ref $self || $self; |
193
|
0
|
|
|
|
|
|
my $dispatch = $Terse::Controller::dispatcher{$package}; |
194
|
0
|
0
|
|
|
|
|
my @dispatcher = @{ $dispatch->{$req} || [] }; |
|
0
|
|
|
|
|
|
|
195
|
0
|
|
|
|
|
|
my $in; |
196
|
|
|
|
|
|
|
$in = sub { |
197
|
0
|
|
|
0
|
|
|
my @ISA = eval "\@$_[0]::ISA"; |
198
|
0
|
|
|
|
|
|
for (@ISA) { |
199
|
0
|
|
|
|
|
|
$in->($_); |
200
|
0
|
|
|
|
|
|
$dispatch = $Terse::Controller::dispatcher{$_}; |
201
|
0
|
0
|
0
|
|
|
|
next unless $dispatch && $dispatch->{$req}; |
202
|
0
|
|
|
|
|
|
unshift @dispatcher, @{ $dispatch->{$req} }; |
|
0
|
|
|
|
|
|
|
203
|
|
|
|
|
|
|
} |
204
|
0
|
|
|
|
|
|
}; |
205
|
0
|
|
|
|
|
|
$in->($package); |
206
|
0
|
0
|
|
|
|
|
if (!scalar @dispatcher) { |
207
|
0
|
|
|
|
|
|
$t->logError('Invalid dispatch request', 400); |
208
|
0
|
|
|
|
|
|
return; |
209
|
|
|
|
|
|
|
} |
210
|
0
|
|
|
|
|
|
$dispatch = undef; |
211
|
0
|
|
|
|
|
|
my $path = $t->request->uri->path; |
212
|
0
|
0
|
|
|
|
|
my $caps = scalar @{ $t->captured || [] }; |
|
0
|
|
|
|
|
|
|
213
|
|
|
|
|
|
|
|
214
|
0
|
|
|
|
|
|
DISPATCH: for my $candidate (reverse @dispatcher) { |
215
|
0
|
0
|
0
|
|
|
|
next DISPATCH unless ($candidate->{lc($t->request->method)} || $candidate->{any}); |
216
|
0
|
0
|
0
|
|
|
|
next DISPATCH unless (!$candidate->{captured} || $caps == $candidate->{captured}); |
217
|
0
|
0
|
|
|
|
|
if ($candidate->{params}) { |
218
|
0
|
|
|
|
|
|
for my $param (keys %{$candidate->{params}}) { |
|
0
|
|
|
|
|
|
|
219
|
0
|
0
|
|
|
|
|
next DISPATCH if (!$t->params->{$param}); |
220
|
|
|
|
|
|
|
next DISPATCH unless $self->_partial_match( |
221
|
|
|
|
|
|
|
$t->params->{$param}, |
222
|
0
|
0
|
|
|
|
|
$candidate->{params}->{$param} |
223
|
|
|
|
|
|
|
); |
224
|
|
|
|
|
|
|
} |
225
|
|
|
|
|
|
|
} |
226
|
0
|
0
|
0
|
|
|
|
$t->request->uri->path =~ m/$candidate->{path}/ or next if $candidate->{path}; |
227
|
0
|
|
|
|
|
|
$dispatch = $candidate; |
228
|
0
|
|
|
|
|
|
last; |
229
|
|
|
|
|
|
|
} |
230
|
0
|
0
|
|
|
|
|
$dispatch = $self->dispatch_hook($dispatch) if $self->can('dispatch_hook'); |
231
|
0
|
|
|
|
|
|
my $callback = $dispatch->{callback}; |
232
|
0
|
0
|
|
|
|
|
if (!$callback) { |
233
|
0
|
|
|
|
|
|
$t->logError('No callback found to dispatch the request', 400); |
234
|
0
|
|
|
|
|
|
return; |
235
|
|
|
|
|
|
|
} |
236
|
0
|
|
|
|
|
|
$t->response_namespace = $self->namespace; |
237
|
0
|
0
|
|
|
|
|
$t->response_handler = $callback if $callback !~ m/auth/; |
238
|
0
|
0
|
|
|
|
|
$t->response_view = $dispatch->{view} if $dispatch->{view}; |
239
|
0
|
0
|
|
|
|
|
$t->content_type($dispatch->{content_type}) if $dispatch->{content_type}; |
240
|
0
|
0
|
|
|
|
|
if ($dispatch->{delayed}) { |
|
|
0
|
|
|
|
|
|
241
|
0
|
|
|
0
|
|
|
return $t->delayed_response(sub { $self->$callback($t, @params); $t->response; }); |
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
242
|
|
|
|
|
|
|
} elsif ($dispatch->{websocket}) { |
243
|
0
|
|
0
|
|
|
|
$self->websockets ||= {}; |
244
|
0
|
|
|
|
|
|
$self->websockets->{$t->sid->value} = $t->websocket($self->$callback($t, @params), close_delete => 1); |
245
|
0
|
|
|
|
|
|
return $t; |
246
|
|
|
|
|
|
|
} |
247
|
0
|
|
|
|
|
|
return $self->$callback($t, @params); |
248
|
|
|
|
|
|
|
} |
249
|
|
|
|
|
|
|
|
250
|
|
|
|
|
|
|
sub _partial_match { |
251
|
0
|
|
|
0
|
|
|
my ($self, $param, $spec) = @_; |
252
|
0
|
0
|
0
|
|
|
|
return 0 if !$param && $spec; |
253
|
0
|
|
|
|
|
|
my ($ref, $match) = (ref $spec, 1); |
254
|
0
|
0
|
|
|
|
|
if (!$ref) { |
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
255
|
0
|
0
|
|
|
|
|
$match = ref $param ? 0 : $param =~ m/^$spec$/; |
256
|
|
|
|
|
|
|
} elsif ($ref eq 'ARRAY') { |
257
|
0
|
|
|
|
|
|
for (my $i = 0; $i < scalar @{$spec}; $i++) { |
|
0
|
|
|
|
|
|
|
258
|
0
|
|
|
|
|
|
$match = $self->_partial_match($param->[$i], $spec->[$i]); |
259
|
0
|
0
|
|
|
|
|
last if (!$match); |
260
|
|
|
|
|
|
|
} |
261
|
|
|
|
|
|
|
} elsif ($ref eq 'HASH') { |
262
|
0
|
|
|
|
|
|
for my $key ( keys %{$spec} ) { |
|
0
|
|
|
|
|
|
|
263
|
0
|
|
|
|
|
|
$match = $self->_partial_match($param->{$key}, $spec->{$key}); |
264
|
0
|
0
|
|
|
|
|
last if (!$match); |
265
|
|
|
|
|
|
|
} |
266
|
|
|
|
|
|
|
} |
267
|
0
|
|
|
|
|
|
return $match; |
268
|
|
|
|
|
|
|
} |
269
|
|
|
|
|
|
|
|
270
|
|
|
|
|
|
|
1; |
271
|
|
|
|
|
|
|
|
272
|
|
|
|
|
|
|
__END__; |