File Coverage

blib/lib/Terse/Controller.pm
Criterion Covered Total %
statement 53 200 26.5
branch 11 102 10.7
condition 5 69 7.2
subroutine 11 25 44.0
pod 1 7 14.2
total 81 403 20.1


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__;