File Coverage

blib/lib/Ado/Control.pm
Criterion Covered Total %
statement 37 58 63.7
branch 12 34 35.2
condition 3 4 75.0
subroutine 6 8 75.0
pod 7 7 100.0
total 65 111 58.5


line stmt bran cond sub pod time code
1             package Ado::Control;
2 24     24   140 use Mojo::Base 'Mojolicious::Controller';
  24         42  
  24         126  
3              
4             our $DEV_MODE = ($ENV{MOJO_MODE} || '' =~ /dev/);
5             has description => 'Ado is a framework for web projects based on Mojolicious,'
6             . ' written in the Perl programming language.';
7             has keywords => 'SSOT, CRM, ERP, CMS, Perl, SQL';
8              
9 156     156 1 153385 sub generator { return 'Ado ' . $Ado::VERSION . ' - ' . $Ado::CODENAME }
10              
11             sub config {
12 0     0 1 0 state $app = $_[0]->app;
13 0 0       0 return $app->config(ref $_[0])->{$_[1]} if $_[1]; #if key
14 0         0 return $app->config(ref $_[0]);
15             }
16              
17             sub debug;
18             if ($DEV_MODE) {
19              
20             sub debug {
21 195     195 1 8117 my ($package, $filename, $line, $subroutine) = caller(0);
22 195         582 state $log = $_[0]->app->log;
23 195         828 return $log->debug(
24             @_[1 .. $#_] #, " at $filename:$line"
25             );
26             }
27             }
28              
29             #Require a list of formats or render "415 - Unsupported Media Type"
30             #and return false.
31             sub require_formats {
32 5     5 1 15 my ($c, @formats) = @_;
33 5 100       66 unless ($c->accepts(@formats)) {
34              
35             #propose urls with the accepted formats
36 1         417 my @locations = map { $c->url_for(format => $_)->to_abs } @formats;
  2         633  
37 1         423 $c->res->headers->add('Content-Location' => $locations[0]);
38              
39 1   50     47 my $message =
40             "415 - Unsupported Media Type \""
41             . ($c->req->headers->accept // '')
42 1         30 . "\". Please try ${\ join(', ', @locations)}!";
43 1 50       761 $c->debug($c->url_for . " requires " . join(',', @formats) . ". Rendering: $message")
44             if $DEV_MODE;
45 1         39 $c->render(
46             text => $message,
47             status => 415
48             );
49 1         39 return;
50             }
51 4         1524 return 1;
52             }
53              
54             sub list_for_json {
55 4     4 1 1043 my ($c, $range, $dsc_objects, $meta) = @_;
56 4         14 my $url = $c->url_with(format => $c->stash->{format})->query('limit' => $$range[0]);
57 4         1927 my $prev = $$range[1] - $$range[0];
58 4 50       13 $prev = $prev > 0 ? $prev : 0;
59              
60             #arrayref of hashes or DSC objects?
61             my $data =
62             ref($dsc_objects->[0]) eq 'HASH'
63             ? $dsc_objects
64 4 50       15 : [map { $_->data } @$dsc_objects];
  8         78  
65             return {
66 4 50       50 json => {
    50          
    50          
67              
68             #TODO: Strive to implement linking using this reference:
69             # http://www.iana.org/assignments/link-relations/link-relations.xhtml
70             query => {offset => $$range[1], limit => $$range[0]},
71             links => [
72             { rel => 'self',
73             href => "" . $url->query([offset => $$range[1]])
74             },
75             ( @$data == $$range[0]
76             ? { rel => 'next',
77             href => "" . $url->query([offset => $$range[0] + $$range[1]])
78             }
79             : ()
80             ),
81             ( $$range[1]
82             ? { rel => 'prev',
83             href => "" . $url->query([offset => $prev])
84             }
85             : ()
86             ),
87             ],
88             data => $data,
89             ($meta ? (meta => $meta) : ())
90             },
91             };
92             } # end sub list_for_json
93              
94             #validates input parameters given a rules template
95             sub validate_input {
96 0     0 1 0 my ($c, $template) = @_;
97 0         0 my $v = $c->validation;
98 0         0 my $errors = {};
99 0         0 foreach my $param (keys %$template) {
100 0         0 my $checks = $template->{$param};
101 0 0       0 $checks || next; #false or undefined?!?
102              
103             #field
104             my $f =
105             $checks->{required}
106 0 0       0 ? $v->required($param)
107             : $v->optional($param);
108 0         0 foreach my $check (keys %$checks) {
109 0 0       0 next if $check eq 'required';
110 0 0       0 if (ref $$checks{$check} eq 'HASH') {
    0          
111 0         0 $f->$check(%{$checks->{$check}});
  0         0  
112             }
113             elsif (ref $$checks{$check} eq 'ARRAY') {
114 0         0 $f->$check(@{$checks->{$check}});
  0         0  
115             }
116 0         0 else { $f->$check($checks->{$check}) }
117             } #end foreach my $check
118 0 0       0 $errors->{$param} = $f->error($param)
119             if $f->error($param);
120              
121             } #end foreach my $param
122              
123             return {
124 0 0       0 ( !!keys %{$errors}
  0         0  
125             ? ( errors => $errors,
126             json => {
127             status => 'error',
128             code => 400,
129             message => $errors,
130             data => 'validate_input'
131             }
132             )
133             : (output => $v->output)
134             )
135             };
136             }
137              
138             sub user {
139 100     100 1 328 my ($c, $user) = @_;
140 100         204 state $delete_fields = [qw(login_password created_by changed_by disabled start_date email)];
141 100 100       446 if ($user) {
    100          
142              
143             # Remove as much as possible user data.
144 2         4 delete @{$user->data}{@$delete_fields};
  2         12  
145 2         28 $c->{user} = $user;
146 2         6 return $c;
147             }
148             elsif ($c->{user}) {
149 33         743 return $c->{user};
150             }
151              
152             # Called for the first time without a $user object.
153             # Defaults to current user or Guest.
154 65   100     331 $c->{user} = Ado::Model::Users->by_login_name($c->session->{login_name} //= 'guest');
155 65         15495 delete @{$c->{user}->data}{@$delete_fields};
  65         324  
156 65         1577 return $c->{user};
157             }
158              
159             1;
160              
161             =pod
162              
163             =encoding utf8
164              
165             =head1 NAME
166              
167             Ado::Control - The base class for all controllers!
168              
169             =head1 SYNOPSIS
170              
171             It must be inherited by all controllers. Put code here only to be shared by
172             it's subclasses or used in hooks.
173              
174             package Ado::Control::Hello;
175             use Mojo::Base 'Ado::Control';
176              
177             =head1 ATTRIBUTES
178              
179             Ado::Control inherits all attributes from L
180             and implements the following new ones.
181              
182             =head2 description
183              
184             Returns a default description used in C element of HTML pages.
185              
186             =head2 generator
187              
188             Returns the concatenated moniker, VERSION and L.
189              
190             =head2 keywords
191              
192             Returns default keywords used in C element of HTML pages.
193              
194             =head1 SUBROUTINES/METHODS
195              
196             Methods shared among subclasses and in hooks
197              
198             =head2 config
199              
200             Overwrites the default helper L
201             which is actually an alias for L. Returns configuration specific
202             to the I package only.
203              
204             #in Ado::Control::List or Ado::Control::Foo or...
205             my $myvalue = $c->config('mykey');
206             #a shortcut to
207             my $myvalue = $app->config(__PACKAGE__)->{mykey}
208             ...
209              
210             To access the application-wide configuration use
211             C<$c-Eapp-Econfig('key')>.
212              
213             =head2 debug
214              
215             A shortcut to:
216              
217             $c->app->log->debug(@_);
218              
219             =head2 list_for_json
220              
221             Prepares a structure suitable for rendering as JSON for listing an ARRAYref
222             of HASHES or L* objects, returned by L
223             and returns it. Accepts two C references and one arbitrary C
224             reference as parameters:
225              
226             my $res = $c->list_for_json([$limit, $offset], \@list_of_AMobjects_or_hashes, $meta);
227              
228             Use this method to ensure uniform and predictable representation across all
229             listing resources. Use the C<$meta> key for arbitrary metadata, specific to
230             your resource. See L for example
231             output and L for the example source.
232              
233             my @range = ($c->param('limit') || 10, $c->param('offset') || 0);
234             return $c->respond_to(
235             json => $c->list_for_json(\@range, [Ado::Model::Users->select_range(@range)],{foo=>bar})
236             );
237             Outputs:
238             {
239             links => [{href=>$url, rel=>'self'},{...}],
240             data=>[..],
241             query=>{limit=>10, offset=>0},
242             meta=> {foo=>'bar'}
243             }
244              
245             return $c->respond_to(
246             json => $c->list_for_json(\@range, [$dbix->query($SQL,@range)->hashes])
247             );
248              
249              
250             =head2 require_formats
251              
252             Checks for a list of accepted formats or renders "415 - Unsupported Media
253             Type" with a text/html type and links to the preferred formats, and returns
254             false. If the URL is in the required format, returns true. Adds a header C
255             pointing to the first URL of the required formats.
256              
257             #in an action serving only json
258             sub list {
259             my $c = shift;
260             $c->require_formats('json') || return;
261             $c->debug('rendering json only');
262             #your stuff here...
263             return;
264             }
265              
266             This method exists only to show more descriptive message with available
267             formats to the end user and to give a chance to user agents to go to the
268             preferred resource URL.
269              
270             =head2 validate_input
271              
272             Uses L to validate all input parameters at
273             once given a validation template. The template consists of keys matching the
274             input parameters to be validated. The values are HASH references describing
275             the rules. Each rule name corresponds to a method/check in
276             L. You can use your own checks if you add them
277             using L.
278              
279             Returns a HASH reference. In case of errors it contains C and C
280             HASH references. In case of success contains only C HASH reference
281             from L.
282              
283             my $rules = {
284             to_uid => {
285             'required' => 1, like => qr/^\d{1,20}$/
286             },
287             subject => {
288             'required' => 1, like => qr/^.{1,255}$/
289             },
290             #...
291             }
292             my $result = $c->validate_input($rules);
293              
294             #400 Bad Request
295             return $c->render(
296             status => 400,
297             json => $result->{json}
298             ) if $result->{errors};
299              
300             =head2 user
301              
302             Returns the current user. This is the user C for not authenticated
303             users. Note that this instance is not meant for manipulation and some fields
304             are not available for security reasons. The fields are: C
305             created_by changed_by disabled start_date>. TODO: move as much as possible
306             checks and fields retrieval in SQL, not in Perl.
307              
308              
309             $c->user(Ado::Model::Users->by_login_name($login_name));
310             my $names = $c->user->name;
311              
312              
313             =head1 SEE ALSO
314              
315             L, L,
316             L, L
317              
318             =head1 AUTHOR
319              
320             Красимир Беров (Krasimir Berov)
321              
322             =head1 COPYRIGHT AND LICENSE
323              
324             Copyright 2013-2014 Красимир Беров (Krasimir Berov).
325              
326             This program is free software, you can redistribute it and/or modify it under
327             the terms of the GNU Lesser General Public License v3 (LGPL-3.0). You may
328             copy, distribute and modify the software provided that modifications are open
329             source. However, software that includes the license may release under a
330             different license.
331              
332             See http://opensource.org/licenses/lgpl-3.0.html for more information.
333              
334             =cut
335