File Coverage

blib/lib/App/AutoCRUD/Controller/Table.pm
Criterion Covered Total %
statement 139 221 62.9
branch 25 60 41.6
condition 8 25 32.0
subroutine 20 25 80.0
pod 3 10 30.0
total 195 341 57.1


line stmt bran cond sub pod time code
1             package App::AutoCRUD::Controller::Table;
2              
3 1     1   573 use 5.010;
  1         3  
  1         53  
4 1     1   5 use strict;
  1         2  
  1         31  
5 1     1   3 use warnings;
  1         2  
  1         27  
6              
7 1     1   5 use Moose;
  1         1  
  1         8  
8             extends 'App::AutoCRUD::Controller';
9 1     1   4738 use SQL::Abstract::More 1.27;
  1         32  
  1         55  
10 1     1   5 use List::MoreUtils qw/mesh firstval/;
  1         2  
  1         11  
11 1     1   368 use JSON::MaybeXS ();
  1         2  
  1         13  
12 1     1   3 use URI;
  1         2  
  1         23  
13              
14 1     1   4 use namespace::clean -except => 'meta';
  1         2  
  1         9  
15              
16             #----------------------------------------------------------------------
17             # entry point to the controller
18             #----------------------------------------------------------------------
19             sub serve {
20 15     15 1 30 my ($self) = @_;
21              
22 15         417 my $context = $self->context;
23              
24             # extract from path : table name and method to dispatch to
25 15 50       59 my ($table, $meth_name) = $context->extract_path_segments(2)
26             or die "URL too short, missing table and method name";
27 15 50       95 my $method = $self->can($meth_name)
28             or die "no such method: $meth_name";
29              
30             # set default template and title
31 15         505 $context->set_template("table/$meth_name.tt");
32 15         367 $context->set_title($context->title . "-" . $table);
33              
34             # dispatch to method
35 15         68 return $self->$method($table);
36             }
37              
38              
39             #----------------------------------------------------------------------
40             # published methods
41             #----------------------------------------------------------------------
42              
43             sub descr {
44 9     9 1 21 my ($self, $table) = @_;
45              
46 9         47 my $datasource = $self->datasource;
47 9         50 my $descr = $datasource->config(tables => $table => 'descr');
48              
49             # datastructure describing this table
50 9         47 return {table => $table,
51             colgroups => $datasource->colgroups($table),
52             primary_key => [$datasource->primary_key($table)],
53             descr => $descr};
54              
55             }
56              
57              
58             sub list {
59 2     2 1 4 my ($self, $table) = @_;
60              
61 2         47 my $context = $self->context;
62 2         47 my $req_data = $context->req_data;
63 2         46 my $datasource = $context->datasource;
64              
65             # the "message" arg is sent once from inserts/updates/deletes; not to
66             # be repeated in links to other queries
67 2         9 my $message = delete $req_data->{-message};
68              
69             # dashed args are set apart
70 2         5 my %where_args = %$req_data; # need a clone because of deletes below
71 2         46 my %dashed_args = $context->view->default_dashed_args($context);
72 2         9 foreach my $arg (grep {/^-/} keys %where_args) {
  1         4  
73 0         0 $dashed_args{$arg} = delete $where_args{$arg};
74             }
75              
76             # some dashed args are treated here (not sent to the SQL request)
77 2         7 my $with_count = delete $dashed_args{-with_count};
78 2         7 my $template = delete $dashed_args{-template};
79 2 50       6 $context->set_template($template) if $template;
80              
81             # select from database
82 2   50     60 my $criteria = $datasource->query_parser->parse(\%where_args) || {};
83 2         6506 my $statement = $datasource->schema->db_table($table)->select(
84             -where => $criteria,
85             %dashed_args,
86             -result_as => 'statement',
87             );
88 2         10714 my $rows = $statement->select();
89              
90             # recuperate SQL for logging / informational purposes
91 2         2616 my ($sql, @bind) = $statement->sql;
92 2         24 my $show_sql = join " / ", $sql, @bind;
93 2         23 $self->logger({level => 'debug', message => $show_sql});
94              
95             # assemble results
96 2         41 my $data = $self->descr($table);
97 2         29 $data->{rows} = $rows;
98 2         5 $data->{message} = $message;
99 2         5 $data->{criteria} = $show_sql;
100 2 50       7 if ($with_count) {
101 0         0 $data->{row_count} = $statement->row_count;
102 0         0 $data->{page_count} = $statement->page_count;
103             }
104              
105             # links to prev/next pages
106 2         14 $self->_add_links_to_other_pages($data, $req_data,
107             $dashed_args{-page_index},
108             $dashed_args{-page_size});
109              
110             # link to update/delete forms
111 1         5 $data->{where_args} = $self->_query_string(
112 2         5 map { ("where.$_" => $where_args{$_}) } keys %where_args,
113             );
114              
115 2         72 return $data;
116             }
117              
118              
119             sub _add_links_to_other_pages {
120 2     2   5 my ($self, $data, $req_data, $page_index, $page_size) = @_;
121              
122 2 50 33     15 return unless defined $page_index && defined $page_size;
123              
124 2         8 $data->{page_index} = $page_index;
125 2         7 $data->{offset} = ($page_index - 1) * $page_size + 1;
126 2         13 $data->{similar_query} = $self->_query_string(%$req_data,
127             -page_index => 1);
128 2         8 $data->{next_page} = $self->_query_string(%$req_data,
129             -page_index => $page_index+1)
130 2 50       4 unless @{$data->{rows}} < $page_size;
131 2 50       9 $data->{prev_page} = $self->_query_string(%$req_data,
132             -page_index => $page_index-1)
133             unless $page_index <= 1;
134             }
135              
136              
137              
138             sub id {
139 5     5 0 15 my ($self, $table) = @_;
140              
141 5         22 my $data = $self->descr($table);
142              
143 5         85 my $pk = $data->{primary_key};
144 5         139 my @vals = $self->context->extract_path_segments(scalar(@$pk));
145 5         80 my %criteria = mesh @$pk, @vals;
146              
147             # get row from database
148 5         22 my $row = $self->datasource->schema->db_table($table)->fetch(@vals);
149              
150             # assemble results
151 5         6760 $data->{row} = $row;
152 5         19 $data->{pk_val} = join "/", @vals;
153              
154             # links
155 5         16 my %where_pk = map { ("where_pk.$_" => $criteria{$_}) } keys %criteria;
  5         30  
156 5         25 $data->{where_pk} = $self->_query_string(%where_pk);
157              
158 5         26 return $data;
159             }
160              
161              
162             sub search {
163 2     2 0 6 my ($self, $table) = @_;
164              
165 2         50 my $context = $self->context;
166 2         49 my $req_data = $context->req_data;
167              
168 2 100       48 if ($context->req->method eq 'POST') {
169 1   50     16 my $output = delete $req_data->{-output} || "";
170 1 50       3 my $cols = [keys %{delete $req_data->{col} || {}}];
  1         9  
171 1         5 $req_data->{-columns} = join ",", @$cols;
172 1         7 $self->redirect("list$output?" . $self->_query_string(%$req_data));
173             }
174             else {
175             # display the search form
176 1   50     17 my @cols = split /,/, (delete $req_data->{-columns} || "");
177 1         3 $req_data->{"col.$_"} = 1 foreach @cols;
178 1         5 my $data = $self->descr($table);
179 1         20 $data->{init_form} = $self->_encode_json($req_data);
180 1         5 return $data;
181             }
182             }
183              
184              
185             sub update {
186 3     3 0 7 my ($self, $table) = @_;
187              
188 3 50       71 if ($self->context->req->method eq 'POST') {
189 3         28 $self->_do_update_data($table);
190             }
191             else {
192 0         0 $self->_display_update_form($table);
193             }
194             }
195              
196              
197             sub _do_update_data {
198 3     3   6 my ($self, $table) = @_;
199              
200 3         70 my $context = $self->context;
201 3         70 my $req_data = $context->req_data;
202 3         72 my $datasource = $context->datasource;
203              
204             # columns to update
205 3   50     12 my $to_set = $req_data->{set} || {};
206 3         8 foreach my $key (keys %$to_set) {
207 3         8 my $val = $to_set->{$key};
208 3 50       12 delete $to_set->{$key} if ! length $val;
209 3 50       12 $to_set->{$key} = undef if $val eq 'Null';
210             }
211 3 50       11 keys %$to_set or die "nothing to update";
212              
213             # build filtering criteria
214 3 100       24 my $where = $req_data->{where} or die "update without any '-where' clause";
215 2         57 my $criteria = $datasource->query_parser->parse($where);
216 2 100 66     797 $criteria and keys %$criteria or die "update without any '-where' criteria";
217              
218             # perform the update
219 1         31 my $db_table = $datasource->schema->db_table($table);
220 1         190 my $n_updates = $db_table->update(-set => $to_set, -where => $criteria);
221              
222             # redirect to a list to display the results
223 1 50       879 my $message = ($n_updates == 1) ? "1 record was updated"
224             : "$n_updates records were updated";
225             # TODO: $message could repeat the $to_set pairs
226 1         9 my $query_string = $self->_query_string(%$where, -message => $message);
227 1         7 $self->redirect("list?$query_string");
228             }
229              
230             sub _display_update_form {
231 0     0   0 my ($self, $table) = @_;
232              
233 0         0 my $context = $self->context;
234 0         0 my $req_data = $context->req_data;
235 0         0 my $datasource = $context->datasource;
236 0         0 my $data = $self->descr($table);
237              
238 0 0       0 if (my $where_pk = delete $req_data->{where_pk}) {
239             # we got the primary key of one single record
240 0         0 $data->{where_pk} = $where_pk;
241 0         0 $req_data->{where} = $where_pk;
242              
243             # fetch current values so that we can display them on page
244 0         0 my $criteria = $datasource->query_parser->parse($where_pk);
245 0         0 my $db_table = $datasource->schema->db_table($table);
246 0         0 $req_data->{curr} = $db_table->select(-where => $criteria,
247             -result_as => 'firstrow');
248             }
249             else {
250             # we got criteria that may touch several records
251 0         0 $self->_mark_multicols_keys($data);
252             }
253              
254             # fields that should not be updatable
255 0 0       0 if (my $noupd = delete $req_data->{_noupd}) {
256 0         0 $data->{noupd}{$_} = 1 foreach split qr[/], $noupd;
257             }
258              
259             # initial values for the form
260 0         0 $data->{init_form} = $self->_encode_json($req_data);
261              
262 0         0 return $data;
263             }
264              
265              
266             sub delete {
267 2     2 0 5 my ($self, $table) = @_;
268              
269 2         60 my $context = $self->context;
270 2         60 my $req_data = $context->req_data;
271 2         60 my $datasource = $context->datasource;
272              
273 2 50       54 if ($context->req->method eq 'POST') { # POST => delete in database
274             # build filtering criteria
275 2 100       36 my $where = $req_data->{where} or die "delete without any '-where' clause";
276 1         39 my $criteria = $datasource->query_parser->parse($where);
277 1 50 33     96 $criteria and keys %$criteria or die "delete without any '-where' criteria";
278              
279             # perform the delete
280 0         0 my $db_table = $datasource->schema->db_table($table);
281 0         0 my $n_deletes = $db_table->delete(-where => $criteria);
282              
283             # redirect to a list to display the results
284 0 0       0 my $message = ($n_deletes == 1) ? "1 record was deleted"
285             : "$n_deletes records were deleted";
286 0         0 my $query_string = $self->_query_string(%$where, -message => $message);
287 0         0 $self->redirect("list?$query_string");
288             }
289             else { # GET => display the delete form
290             # display the delete form
291 0         0 my $data = $self->descr($table);
292 0 0       0 if (my $where_pk = delete $req_data->{where_pk}) {
293             # we got the primary key of one single record
294 0         0 $data->{where_pk} = $where_pk;
295 0         0 $req_data->{where} = $where_pk;
296             }
297             else {
298             # we got criteria that may touch several records
299 0         0 $self->_mark_multicols_keys($data);
300             }
301              
302             # initial values for the form
303 0         0 $data->{init_form} = $self->_encode_json($req_data);
304              
305 0         0 return $data;
306             }
307             }
308              
309              
310              
311              
312             sub clone {
313 0     0 0 0 my ($self, $table) = @_;
314              
315 0         0 my $context = $self->context;
316 0 0       0 $context->req->method eq 'GET'
317             or die "the /clone URL only accepts GET requests";
318              
319             # get primary key
320 0         0 my $data = $self->descr($table);
321 0         0 my $pk = $data->{primary_key};
322 0         0 my %is_pk = map {$_ => 1} @$pk;
  0         0  
323 0         0 my @vals = $context->extract_path_segments(scalar(@$pk));
324              
325             # get row from database
326 0         0 my $row = $self->datasource->schema->db_table($table)->fetch(@vals);
327              
328             # populate req_data before calling insert()
329 0         0 my $req_data = $context->req_data;
330 0         0 foreach my $col (keys %$row) {
331 0         0 my $val = $row->{$col};
332 0 0 0     0 $req_data->{$col} = $val if $val and !$is_pk{$col};
333             }
334              
335             # cheat with path (simulating a call to insert())
336 0         0 my $path = $context->path;
337 0         0 $path =~ s/clone$/insert/;
338 0         0 $context->set_path($path);
339 0         0 $context->set_template('table/insert.tt');
340              
341             # forward to insert()
342 0         0 $self->insert($table);
343             }
344              
345              
346             sub insert {
347 0     0 0 0 my ($self, $table) = @_;
348              
349 0         0 my $context = $self->context;
350 0         0 my $req_data = $context->req_data;
351 0         0 my $datasource = $context->datasource;
352              
353 0 0       0 if ($context->req->method eq 'POST') {
354             # perform the insert
355 0         0 my $db_table = $datasource->schema->db_table($table);
356 0         0 my @pk = $db_table->insert($req_data);
357              
358             # redirect to a list to display the results
359 0         0 my $message = "1 record was inserted";
360 0         0 my $query_string = $self->_query_string(-message => $message);
361 0         0 $self->redirect(join("/", "id", @pk) . "?$query_string");
362             }
363             else {
364             # display the insert form
365 0         0 my $data = $self->descr($table);
366 0         0 $data->{init_form} = $self->_encode_json($req_data);
367              
368 0         0 return $data;
369             }
370             }
371              
372              
373              
374             sub count_where { # used in Ajax mode by update and delete forms
375 0     0 0 0 my ($self, $table) = @_;
376              
377 0         0 my $context = $self->context;
378 0         0 my $req_data = $context->req_data;
379 0         0 my $datasource = $context->datasource;
380              
381 0         0 my $n_records = -1;
382              
383 0 0       0 if (my $where = $req_data->{where}) {
384 0         0 my $criteria = $datasource->query_parser->parse($where);
385 0 0 0     0 if ($criteria and keys %$criteria) {
386 0         0 my $db_table = $datasource->schema->db_table($table);
387 0         0 my $result = $db_table->select(
388             -columns => 'COUNT(*)',
389             -where => $criteria,
390             -result_as => 'flat_arrayref',
391             );
392 0         0 $n_records = $result->[0];
393             }
394             }
395              
396 0         0 return {n_records => $n_records};
397             }
398              
399              
400              
401              
402             #----------------------------------------------------------------------
403             # auxiliary methods
404             #----------------------------------------------------------------------
405              
406              
407             sub _query_string {
408 11     11   32 my ($self, %params) = @_;
409 11         15 my @fragments;
410             KEY:
411 11         44 foreach my $key (sort keys %params) {
412 12         24 my $val = $params{$key};
413 12 100       47 length $val or next KEY;
414              
415             # cheap URI escape (for chars '=', '&', ';' and '+')
416 11         62 s/=/%3D/g, s/&/%26/g, s/;/%3B/g, s/\+/%2B/g for $key, $val;
417              
418 11         39 push @fragments, "$key=$val";
419             }
420              
421 11         54 return join "&", @fragments;
422             }
423              
424              
425             sub _encode_json {
426 1     1   3 my ($self, $data) = @_;
427              
428             # utf8-encoding is done in the view, so here we turn it off
429 1         11 my $json_maker = JSON::MaybeXS->new(allow_blessed => 1,
430             convert_blessed => 1,
431             utf8 => 0);
432 1         41 return $json_maker->encode($data);
433             }
434              
435              
436             sub _mark_multicols_keys {
437 0     0     my ($self, $data) = @_;
438              
439 0 0         if (my $sep = $self->datasource->schema->sql_abstract->multicols_sep) {
440             # in case of multi-columns keys, the form needs to add special fields
441             # and to ignore regular fields for those columns
442 0   0       my $where = $self->context->req_data->{where} || {};
443 0           my @multi_cols_keys = grep m[$sep], keys %$where;
444 0           $data->{multi_cols_keys} = \@multi_cols_keys;
445 0           $data->{ignore_col}{$_} = 1 foreach map {split m[$sep]} @multi_cols_keys;
  0            
446             }
447             }
448              
449              
450             1;
451              
452             __END__
453              
454             =head1 NAME
455              
456             App::AutoCRUD::Controller::Table - Table controller
457              
458             =head1 DESCRIPTION
459              
460             This controller provides methods for searching and describing
461             a given table within some datasource.
462              
463             =head1 METHODS
464              
465             =head2 serve
466              
467             Entry point to the controller; from the URL, it extracts the table
468             name and the name of the method to dispatch to (the URL is expected
469             to be of shape C<< table/{table_name}/{$method_name}?{arguments} >>).
470             It also sets the default template to C<< table/{method_name}.tt >>.
471              
472             =head2 descr
473              
474             Returns a hashref describing the table, with keys C<descr>
475             (description information from the config), C<table> (table name),
476             C<colgroups> (datastructure as returned from
477             L<App::AutoCRUD::DataSource/colgroups>), and
478             C<primary_key> (arrayref of primary key columns).
479              
480             =head2 list
481              
482             Returns a list of records from the table, corresponding to the query
483             parameters specified in the URL.
484             [TODO: EXPLAIN MORE -- in particular the "-template" arg ]
485              
486              
487              
488              
489