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