and
|
426
|
|
|
|
|
|
|
C. |
|
427
|
|
|
|
|
|
|
|
|
428
|
|
|
|
|
|
|
=item C |
|
429
|
|
|
|
|
|
|
|
|
430
|
|
|
|
|
|
|
An arrayref of hashrefs to specify custom columns to appear in the list view |
|
431
|
|
|
|
|
|
|
of an entity. (Previously, this was just a hashref of column names and specs, |
|
432
|
|
|
|
|
|
|
and this style is still supported for backwards compatibility, but is deprecated |
|
433
|
|
|
|
|
|
|
because it leaves the order of the columns unpredictable.) |
|
434
|
|
|
|
|
|
|
|
|
435
|
|
|
|
|
|
|
The keys of each hash are C, the name to use for this custom column, |
|
436
|
|
|
|
|
|
|
C indicating a column from the table that should be selected to |
|
437
|
|
|
|
|
|
|
build the custom column from, C, a subref to be used as a |
|
438
|
|
|
|
|
|
|
HTML::Table::FromDatabase callback on the resulting column, and C, |
|
439
|
|
|
|
|
|
|
to specify a CSS class for the the column. C is optional, and if |
|
440
|
|
|
|
|
|
|
no C is provided, sub { return shift; } will be used. |
|
441
|
|
|
|
|
|
|
|
|
442
|
|
|
|
|
|
|
If your custom column has the same name as an existing column, your customizations |
|
443
|
|
|
|
|
|
|
will be used in-place to override the display of the content in that column. |
|
444
|
|
|
|
|
|
|
If sorting is enabled, the column will be sorted by the |
|
445
|
|
|
|
|
|
|
underlying database content for that row, and not by the output of your transform function. |
|
446
|
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
For a somewhat spurious example: |
|
448
|
|
|
|
|
|
|
|
|
449
|
|
|
|
|
|
|
... |
|
450
|
|
|
|
|
|
|
custom_columns => [ |
|
451
|
|
|
|
|
|
|
{ |
|
452
|
|
|
|
|
|
|
name => 'email_provider', |
|
453
|
|
|
|
|
|
|
raw_column => 'email', |
|
454
|
|
|
|
|
|
|
transform => sub { |
|
455
|
|
|
|
|
|
|
my $value = shift; |
|
456
|
|
|
|
|
|
|
return (split /@/, 1)[1]; |
|
457
|
|
|
|
|
|
|
}, |
|
458
|
|
|
|
|
|
|
column_class => 'column-class', |
|
459
|
|
|
|
|
|
|
}, |
|
460
|
|
|
|
|
|
|
], |
|
461
|
|
|
|
|
|
|
... |
|
462
|
|
|
|
|
|
|
|
|
463
|
|
|
|
|
|
|
|
|
464
|
|
|
|
|
|
|
The C code ref is passed to L as a |
|
465
|
|
|
|
|
|
|
callback for that column, so it can do anything a |
|
466
|
|
|
|
|
|
|
L |
|
467
|
|
|
|
|
|
|
can do. In particular, the coderef will receive the value of the |
|
468
|
|
|
|
|
|
|
column as the first parameter, but also a reference to the whole row hashref |
|
469
|
|
|
|
|
|
|
as the second parameter, so you can do a variety of cunning things. |
|
470
|
|
|
|
|
|
|
|
|
471
|
|
|
|
|
|
|
An example of a custom column whose C coderef uses the row |
|
472
|
|
|
|
|
|
|
hashref to get other values for the same row could be: |
|
473
|
|
|
|
|
|
|
|
|
474
|
|
|
|
|
|
|
... |
|
475
|
|
|
|
|
|
|
custom_columns => [ |
|
476
|
|
|
|
|
|
|
{ |
|
477
|
|
|
|
|
|
|
name => 'salutation', |
|
478
|
|
|
|
|
|
|
raw_column => 'name', |
|
479
|
|
|
|
|
|
|
transform => sub { |
|
480
|
|
|
|
|
|
|
my ($name_value, $row) = @_; |
|
481
|
|
|
|
|
|
|
return "Hi, $row->{title} $name_value!"; |
|
482
|
|
|
|
|
|
|
}, |
|
483
|
|
|
|
|
|
|
} |
|
484
|
|
|
|
|
|
|
], |
|
485
|
|
|
|
|
|
|
... |
|
486
|
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
=item C |
|
488
|
|
|
|
|
|
|
|
|
489
|
|
|
|
|
|
|
You can require that users be authenticated to view/edit records using the C |
|
490
|
|
|
|
|
|
|
option to enable authentication powered by L. |
|
491
|
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
You can set different requirements for viewing and editing, for example: |
|
493
|
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
auth => { |
|
495
|
|
|
|
|
|
|
view => { |
|
496
|
|
|
|
|
|
|
require_login => 1, |
|
497
|
|
|
|
|
|
|
}, |
|
498
|
|
|
|
|
|
|
edit => { |
|
499
|
|
|
|
|
|
|
require_role => 'Admin', |
|
500
|
|
|
|
|
|
|
}, |
|
501
|
|
|
|
|
|
|
}, |
|
502
|
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
The example above means that any logged in user can view records, but only users |
|
504
|
|
|
|
|
|
|
with the 'Admin' role are able to create/edit/delete records. |
|
505
|
|
|
|
|
|
|
|
|
506
|
|
|
|
|
|
|
Or, to just require login for anything (same requirements for both viewing and |
|
507
|
|
|
|
|
|
|
editing), you can use the shorthand: |
|
508
|
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
auth => { |
|
510
|
|
|
|
|
|
|
require_login => 1, |
|
511
|
|
|
|
|
|
|
}, |
|
512
|
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
|
|
514
|
|
|
|
|
|
|
=item C |
|
515
|
|
|
|
|
|
|
|
|
516
|
|
|
|
|
|
|
This provides a CSS class for the tables. |
|
517
|
|
|
|
|
|
|
|
|
518
|
|
|
|
|
|
|
=item C |
|
519
|
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
This provides a CSS class for the tables paginate buttons. |
|
521
|
|
|
|
|
|
|
|
|
522
|
|
|
|
|
|
|
=cut |
|
523
|
|
|
|
|
|
|
|
|
524
|
|
|
|
|
|
|
sub simple_crud { |
|
525
|
8
|
|
|
8
|
|
112981
|
my (%args) = @_; |
|
526
|
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
# Get a database connection to verify that the table name is OK, etc. |
|
528
|
8
|
|
|
|
|
55
|
my $dbh = database($args{db_connection_name}); |
|
529
|
|
|
|
|
|
|
|
|
530
|
8
|
50
|
|
|
|
837
|
if (!$dbh) { |
|
531
|
0
|
|
|
|
|
0
|
warn "No database handle"; |
|
532
|
0
|
|
|
|
|
0
|
return; |
|
533
|
|
|
|
|
|
|
} |
|
534
|
|
|
|
|
|
|
|
|
535
|
8
|
50
|
|
|
|
37
|
if (!$args{prefix}) { die "Need prefix to create routes!"; } |
|
|
0
|
|
|
|
|
0
|
|
|
536
|
8
|
50
|
|
|
|
50
|
if ($args{prefix} !~ m{^/}) { |
|
537
|
0
|
|
|
|
|
0
|
$args{prefix} = '/' . $args{prefix}; |
|
538
|
|
|
|
|
|
|
} |
|
539
|
|
|
|
|
|
|
|
|
540
|
|
|
|
|
|
|
# If there's a Dancer prefix in use, as well as a prefix we're told about, |
|
541
|
|
|
|
|
|
|
# then _construct_url() will need to be told about that later so it can |
|
542
|
|
|
|
|
|
|
# construct URLs. It can't just call Dancer::App->current->prefix itself, |
|
543
|
|
|
|
|
|
|
# though, as the prefix may have changed by the time the code is actually |
|
544
|
|
|
|
|
|
|
# running. (See RT #73620.) So, we need to grab it here and add it to |
|
545
|
|
|
|
|
|
|
# %args, so it can see it later. |
|
546
|
8
|
|
50
|
|
|
52
|
$args{dancer_prefix} = Dancer::App->current->prefix || ''; |
|
547
|
|
|
|
|
|
|
|
|
548
|
8
|
50
|
|
|
|
364
|
if (!$args{db_table}) { die "Need table name!"; } |
|
|
0
|
|
|
|
|
0
|
|
|
549
|
|
|
|
|
|
|
|
|
550
|
|
|
|
|
|
|
# Accept deleteable as a synonym for deletable |
|
551
|
|
|
|
|
|
|
$args{deletable} = delete $args{deleteable} |
|
552
|
8
|
50
|
33
|
|
|
52
|
if !exists $args{deletable} && exists $args{deleteable}; |
|
553
|
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
# Sane default values: |
|
555
|
8
|
|
50
|
|
|
58
|
$args{key_column} ||= 'id'; |
|
556
|
8
|
|
50
|
|
|
24
|
$args{record_title} ||= 'record'; |
|
557
|
8
|
50
|
|
|
|
38
|
$args{editable} = 1 unless exists $args{editable}; |
|
558
|
8
|
100
|
|
|
|
37
|
$args{addable} = $args{editable} unless exists $args{addable}; |
|
559
|
8
|
50
|
|
|
|
36
|
$args{query_auto_focus} = 1 unless exists $args{query_auto_focus}; |
|
560
|
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
# Sanitise things we'll have to interpolate into queries (yes, that makes me |
|
562
|
|
|
|
|
|
|
# feel bad, but you can't use params for field/table names): |
|
563
|
8
|
|
|
|
|
22
|
my $table_name = $args{db_table}; |
|
564
|
8
|
|
|
|
|
20
|
my $key_column = $args{key_column}; |
|
565
|
8
|
|
|
|
|
24
|
for ($table_name, $key_column) { |
|
566
|
16
|
50
|
|
|
|
55
|
die "Invalid table name/key column - SQL injection attempt?" |
|
567
|
|
|
|
|
|
|
if /--/; |
|
568
|
16
|
|
|
|
|
55
|
s/[^a-zA-Z0-9_-]//g; |
|
569
|
|
|
|
|
|
|
} |
|
570
|
|
|
|
|
|
|
|
|
571
|
|
|
|
|
|
|
# OK, create a route handler to deal with adding/editing: |
|
572
|
|
|
|
|
|
|
my $handler |
|
573
|
8
|
|
|
6
|
|
61
|
= sub { _create_add_edit_route(\%args, $table_name, $key_column); }; |
|
|
6
|
|
|
|
|
93386
|
|
|
574
|
|
|
|
|
|
|
|
|
575
|
8
|
100
|
|
|
|
35
|
if ($args{editable}) { |
|
576
|
3
|
|
|
|
|
10
|
for ('/edit/:id') { |
|
577
|
3
|
|
|
|
|
12
|
my $url = _construct_url($args{prefix}, $_); |
|
578
|
3
|
|
|
|
|
32
|
Dancer::Logger::debug("Setting up route for $url"); |
|
579
|
3
|
|
|
|
|
23
|
any ['get', 'post'] => $url => _ensure_auth( |
|
580
|
|
|
|
|
|
|
'edit', $handler, \%args, |
|
581
|
|
|
|
|
|
|
); |
|
582
|
|
|
|
|
|
|
} |
|
583
|
|
|
|
|
|
|
} |
|
584
|
8
|
100
|
|
|
|
3231
|
if ($args{addable}) { |
|
585
|
2
|
|
|
|
|
7
|
for ('/add') { |
|
586
|
2
|
|
|
|
|
10
|
my $url = _construct_url($args{prefix}, $_); |
|
587
|
2
|
|
|
|
|
15
|
Dancer::Logger::debug("Setting up route for $url"); |
|
588
|
2
|
|
|
|
|
17
|
any ['get', 'post'] => $url => _ensure_auth( |
|
589
|
|
|
|
|
|
|
'edit', $handler, \%args |
|
590
|
|
|
|
|
|
|
); |
|
591
|
|
|
|
|
|
|
} |
|
592
|
|
|
|
|
|
|
} |
|
593
|
|
|
|
|
|
|
|
|
594
|
|
|
|
|
|
|
# And a route to list records already in the table: |
|
595
|
|
|
|
|
|
|
my $list_handler |
|
596
|
|
|
|
|
|
|
= _ensure_auth( |
|
597
|
|
|
|
|
|
|
'view', |
|
598
|
14
|
|
|
14
|
|
284362
|
sub { _create_list_handler(\%args, $table_name, $key_column); }, |
|
599
|
8
|
|
|
|
|
2049
|
\%args, |
|
600
|
|
|
|
|
|
|
); |
|
601
|
|
|
|
|
|
|
get _construct_url( |
|
602
|
|
|
|
|
|
|
$args{prefix}, |
|
603
|
8
|
|
|
|
|
40
|
) => $list_handler; |
|
604
|
|
|
|
|
|
|
|
|
605
|
|
|
|
|
|
|
# If we should allow deletion of records, set up routes to handle that, |
|
606
|
|
|
|
|
|
|
# too. |
|
607
|
8
|
50
|
66
|
|
|
5539
|
if ($args{editable} && $args{deletable}) { |
|
608
|
|
|
|
|
|
|
|
|
609
|
|
|
|
|
|
|
# A route for GET requests, to present a "Do you want to delete this" |
|
610
|
|
|
|
|
|
|
# message with a form to submit (this is only for browsers which didn't |
|
611
|
|
|
|
|
|
|
# support Javascript, otherwise the list page will have POSTed the ID |
|
612
|
|
|
|
|
|
|
# to us) (or they just came here directly for some reason) |
|
613
|
|
|
|
|
|
|
get _construct_url( |
|
614
|
|
|
|
|
|
|
$args{prefix}, "/delete/:id" |
|
615
|
|
|
|
|
|
|
) => sub { |
|
616
|
0
|
|
|
0
|
|
0
|
return _apply_template(<
|
|
617
|
|
|
|
|
|
|
|
|
618
|
|
|
|
|
|
|
Do you really wish to delete this record? |
|
619
|
|
|
|
|
|
|
|
|
620
|
|
|
|
|
|
|
|
|
621
|
|
|
|
|
|
|
|
|
622
|
|
|
|
|
|
|
|
|
623
|
|
|
|
|
|
|
|
|
624
|
|
|
|
|
|
|
|
|
625
|
|
|
|
|
|
|
CONFIRMDELETE |
|
626
|
|
|
|
|
|
|
|
|
627
|
0
|
|
|
|
|
0
|
}; |
|
628
|
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
# A route for POST requests, to actually delete the record |
|
630
|
|
|
|
|
|
|
my $del_url_stub = _construct_url( |
|
631
|
0
|
|
|
|
|
0
|
$args{prefix}, '/delete' |
|
632
|
|
|
|
|
|
|
); |
|
633
|
|
|
|
|
|
|
my $delete_handler = sub { |
|
634
|
0
|
|
0
|
0
|
|
0
|
my ($id) = params->{record_id} || splat; |
|
635
|
0
|
|
|
|
|
0
|
my $dbh = database($args{db_connection_name}); |
|
636
|
0
|
|
|
|
|
0
|
my $where = _get_where_filter_from_args(\%args); |
|
637
|
0
|
|
|
|
|
0
|
$where->{$key_column} = $id; |
|
638
|
|
|
|
|
|
|
|
|
639
|
0
|
|
|
|
|
0
|
my %params = params; |
|
640
|
0
|
|
|
|
|
0
|
my $meta_for_hook = { |
|
641
|
|
|
|
|
|
|
args => \%args, |
|
642
|
|
|
|
|
|
|
params => \%params, |
|
643
|
|
|
|
|
|
|
table_name => $table_name, |
|
644
|
|
|
|
|
|
|
key_column => $key_column, |
|
645
|
|
|
|
|
|
|
}; |
|
646
|
|
|
|
|
|
|
# fire the pre-delete hook, in case user wants to perform trickery before the delete |
|
647
|
0
|
|
|
|
|
0
|
execute_hook('delete_row_pre_delete', $meta_for_hook ); |
|
648
|
|
|
|
|
|
|
|
|
649
|
|
|
|
|
|
|
my $rows_deleted = $dbh->quick_delete($table_name, $where) |
|
650
|
|
|
|
|
|
|
or return _apply_template(" Failed to delete! ", |
|
651
|
0
|
0
|
|
|
|
0
|
$args{'template'}); |
|
652
|
|
|
|
|
|
|
|
|
653
|
0
|
|
|
|
|
0
|
$meta_for_hook->{success} = $rows_deleted; |
|
654
|
0
|
0
|
|
|
|
0
|
if ($rows_deleted) { |
|
655
|
|
|
|
|
|
|
# post-delete hook, in case user wants to do cunning things after the delete |
|
656
|
0
|
|
|
|
|
0
|
execute_hook('delete_row_post_delete', $meta_for_hook ); |
|
657
|
|
|
|
|
|
|
} |
|
658
|
|
|
|
|
|
|
|
|
659
|
0
|
|
|
|
|
0
|
redirect _external_url($args{dancer_prefix}, $args{prefix}); |
|
660
|
0
|
|
|
|
|
0
|
}; |
|
661
|
0
|
|
|
|
|
0
|
post qr[$del_url_stub/?(.+)?$] => _ensure_auth( |
|
662
|
|
|
|
|
|
|
'edit', $delete_handler, \%args |
|
663
|
|
|
|
|
|
|
); |
|
664
|
|
|
|
|
|
|
} |
|
665
|
|
|
|
|
|
|
my $view_url_stub = _construct_url( |
|
666
|
8
|
|
|
|
|
33
|
$args{prefix}, '/view' |
|
667
|
|
|
|
|
|
|
); |
|
668
|
|
|
|
|
|
|
my $view_handler = _ensure_auth( |
|
669
|
|
|
|
|
|
|
'view', |
|
670
|
2
|
|
|
2
|
|
13533
|
sub { _create_view_handler(\%args, $table_name, $key_column); }, |
|
671
|
8
|
|
|
|
|
57
|
\%args, |
|
672
|
|
|
|
|
|
|
); |
|
673
|
|
|
|
|
|
|
|
|
674
|
8
|
|
|
|
|
52
|
get $view_url_stub.'/:id' => $view_handler; |
|
675
|
|
|
|
|
|
|
} |
|
676
|
|
|
|
|
|
|
|
|
677
|
|
|
|
|
|
|
sub _create_view_handler { |
|
678
|
2
|
|
|
2
|
|
10
|
my ($args, $table_name, $key_column) = @_; |
|
679
|
2
|
|
|
|
|
10
|
my $params = params; |
|
680
|
2
|
50
|
|
|
|
539
|
my $id = $params->{id} or return _apply_template(" Need id to view! ", $args->{'template'}); |
|
681
|
|
|
|
|
|
|
|
|
682
|
2
|
|
|
|
|
15
|
my $dbh = database($args->{db_connection_name}); |
|
683
|
|
|
|
|
|
|
|
|
684
|
|
|
|
|
|
|
# a hash containing the current values in the database. Take where_filter |
|
685
|
|
|
|
|
|
|
# into account, so we can't fetch a row if it doesn't match the filter |
|
686
|
|
|
|
|
|
|
# (otherwise people could load any record they wished just by changing the |
|
687
|
|
|
|
|
|
|
# ID in the URL, which would be considered a Bad Thing) |
|
688
|
2
|
|
|
|
|
245
|
my $where = _get_where_filter_from_args($args); |
|
689
|
2
|
|
|
|
|
11
|
$where->{$key_column} = $id; |
|
690
|
2
|
|
|
|
|
13
|
my $values_from_database = $dbh->quick_select($table_name, $where); |
|
691
|
|
|
|
|
|
|
|
|
692
|
|
|
|
|
|
|
# Find out about table columns: |
|
693
|
2
|
|
|
|
|
1121
|
my $all_table_columns = _find_columns($dbh, $args->{db_table}); |
|
694
|
2
|
|
|
|
|
13
|
my @rows = (['Column Name', 'Value']); |
|
695
|
2
|
|
|
|
|
24
|
my $table = HTML::Table->new( -border=>1 ); |
|
696
|
2
|
|
|
|
|
186
|
$table->addSectionRow('thead', 0, 'Column Name', 'Value'); |
|
697
|
2
|
|
|
|
|
98
|
$table->setSectionCellHead('thead', 0, 1, 1, 1); |
|
698
|
2
|
|
|
|
|
82
|
$table->setSectionCellHead('thead', 0, 1, 2, 1); |
|
699
|
2
|
|
|
|
|
62
|
foreach my $col (@$all_table_columns) { |
|
700
|
6
|
|
|
|
|
145
|
$table->addSectionRow('tbody', 0, $col->{COLUMN_NAME}, $values_from_database->{$col->{COLUMN_NAME}}); |
|
701
|
|
|
|
|
|
|
} |
|
702
|
2
|
|
50
|
|
|
65
|
my $html = $table->getTable || ''; |
|
703
|
2
|
|
|
|
|
1273
|
return _apply_template($html, $args->{'template'}); |
|
704
|
|
|
|
|
|
|
} |
|
705
|
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
register simple_crud => \&simple_crud; |
|
707
|
|
|
|
|
|
|
register_hook(qw( |
|
708
|
|
|
|
|
|
|
add_edit_row |
|
709
|
|
|
|
|
|
|
add_edit_row_pre_save |
|
710
|
|
|
|
|
|
|
add_edit_row_post_save |
|
711
|
|
|
|
|
|
|
delete_row_pre_delete |
|
712
|
|
|
|
|
|
|
delete_row_post_delete |
|
713
|
|
|
|
|
|
|
)); |
|
714
|
|
|
|
|
|
|
register_plugin; |
|
715
|
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
sub _create_add_edit_route { |
|
717
|
6
|
|
|
6
|
|
24
|
my ($args, $table_name, $key_column) = @_; |
|
718
|
6
|
|
|
|
|
29
|
my $params = params; |
|
719
|
6
|
|
|
|
|
1278
|
my $id = $params->{id}; |
|
720
|
|
|
|
|
|
|
|
|
721
|
6
|
|
|
|
|
46
|
my $dbh = database($args->{db_connection_name}); |
|
722
|
|
|
|
|
|
|
|
|
723
|
|
|
|
|
|
|
# a hash containing the current values in the database |
|
724
|
6
|
|
|
|
|
663
|
my $values_from_database; |
|
725
|
6
|
100
|
|
|
|
28
|
if (defined $id) { |
|
726
|
5
|
|
|
|
|
20
|
my $where = _get_where_filter_from_args($args); |
|
727
|
5
|
|
|
|
|
21
|
$where->{$key_column} = $id; |
|
728
|
5
|
|
|
|
|
28
|
$values_from_database |
|
729
|
|
|
|
|
|
|
= $dbh->quick_select($table_name, $where); |
|
730
|
5
|
100
|
|
|
|
2456
|
if (!$values_from_database) { |
|
731
|
3
|
|
|
|
|
24
|
send_error "$args->{record_title} $id not found", 404; |
|
732
|
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
} |
|
734
|
|
|
|
|
|
|
} |
|
735
|
|
|
|
|
|
|
|
|
736
|
|
|
|
|
|
|
# Find out about table columns: |
|
737
|
3
|
|
|
|
|
17
|
my $all_table_columns = _find_columns($dbh, $args->{db_table}); |
|
738
|
3
|
|
|
|
|
10
|
my @editable_columns; |
|
739
|
|
|
|
|
|
|
|
|
740
|
|
|
|
|
|
|
# Now, find out which ones we can edit. |
|
741
|
3
|
50
|
|
|
|
16
|
if ($args->{editable_columns}) { |
|
742
|
|
|
|
|
|
|
|
|
743
|
|
|
|
|
|
|
# We were given an explicit list of fields we can edit, so this is |
|
744
|
|
|
|
|
|
|
# easy: |
|
745
|
0
|
|
|
|
|
0
|
@editable_columns = @{ $args->{editable_columns} }; |
|
|
0
|
|
|
|
|
0
|
|
|
746
|
|
|
|
|
|
|
} else { |
|
747
|
|
|
|
|
|
|
|
|
748
|
|
|
|
|
|
|
# OK, take all the columns from the table, except the key field: |
|
749
|
9
|
|
|
|
|
28
|
@editable_columns = grep { $_ ne $key_column } |
|
750
|
3
|
|
|
|
|
10
|
map { $_->{COLUMN_NAME} } @$all_table_columns; |
|
|
9
|
|
|
|
|
27
|
|
|
751
|
|
|
|
|
|
|
} |
|
752
|
|
|
|
|
|
|
|
|
753
|
3
|
50
|
|
|
|
13
|
if ($args->{not_editable_columns}) { |
|
754
|
0
|
|
|
|
|
0
|
for my $col (@{ $args->{not_editable_columns} }) { |
|
|
0
|
|
|
|
|
0
|
|
|
755
|
0
|
|
|
|
|
0
|
@editable_columns = grep { $_ ne $col } @editable_columns; |
|
|
0
|
|
|
|
|
0
|
|
|
756
|
|
|
|
|
|
|
} |
|
757
|
|
|
|
|
|
|
} |
|
758
|
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
# Some DWIMery: if we don't have a validation rule specified for a |
|
760
|
|
|
|
|
|
|
# field, and it's pretty clear what it is supposed to be, just do it: |
|
761
|
3
|
|
100
|
|
|
20
|
my $validation = $args->{validation} || {}; |
|
762
|
3
|
|
|
|
|
9
|
for my $field (grep { $_ ne $key_column } @editable_columns) { |
|
|
6
|
|
|
|
|
20
|
|
|
763
|
6
|
50
|
|
|
|
21
|
next if $validation->{$field}; |
|
764
|
6
|
50
|
|
|
|
29
|
if ($field =~ /email/) { |
|
765
|
0
|
|
|
|
|
0
|
$validation->{$field} = 'EMAIL'; |
|
766
|
|
|
|
|
|
|
} |
|
767
|
|
|
|
|
|
|
} |
|
768
|
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
# More DWIMmery: if the user hasn't supplied a list of required fields, |
|
770
|
|
|
|
|
|
|
# work out what fields are required by whether they're nullable in the |
|
771
|
|
|
|
|
|
|
# DB: |
|
772
|
3
|
|
|
|
|
6
|
my %required_fields; |
|
773
|
3
|
50
|
|
|
|
13
|
if (exists $args->{required}) { |
|
774
|
0
|
|
|
|
|
0
|
$required_fields{$_}++ for @{ $args->{required} }; |
|
|
0
|
|
|
|
|
0
|
|
|
775
|
|
|
|
|
|
|
} else { |
|
776
|
|
|
|
|
|
|
$_->{NULLABLE} || $required_fields{ $_->{COLUMN_NAME} }++ |
|
777
|
3
|
|
33
|
|
|
20
|
for @$all_table_columns; |
|
778
|
|
|
|
|
|
|
} |
|
779
|
|
|
|
|
|
|
|
|
780
|
|
|
|
|
|
|
# If the user didn't supply a list of acceptable values for a field, but |
|
781
|
|
|
|
|
|
|
# it's an ENUM column, use the possible values declared in the ENUM. |
|
782
|
|
|
|
|
|
|
# Also remember field types for easy reference later |
|
783
|
3
|
|
|
|
|
9
|
my %constrain_values; |
|
784
|
|
|
|
|
|
|
my %field_type; |
|
785
|
3
|
|
|
|
|
10
|
for my $field (@$all_table_columns) { |
|
786
|
9
|
|
|
|
|
40
|
my $name = $field->{COLUMN_NAME}; |
|
787
|
9
|
|
|
|
|
23
|
$field_type{$name} = $field->{TYPE_NAME}; |
|
788
|
9
|
50
|
|
|
|
48
|
if (my $values_specified = $args->{acceptable_values}->{$name}) { |
|
|
|
50
|
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
789
|
|
|
|
|
|
|
|
|
790
|
|
|
|
|
|
|
# It may have been given to us as a coderef; if so, execute it to |
|
791
|
|
|
|
|
|
|
# get the results |
|
792
|
0
|
0
|
|
|
|
0
|
if (ref $values_specified eq 'CODE') { |
|
793
|
0
|
|
|
|
|
0
|
$values_specified = $values_specified->(); |
|
794
|
|
|
|
|
|
|
} |
|
795
|
0
|
|
|
|
|
0
|
$constrain_values{$name} = $values_specified; |
|
796
|
|
|
|
|
|
|
|
|
797
|
|
|
|
|
|
|
} elsif (my $foreign_key = $args->{foreign_keys}{$name}) { |
|
798
|
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
# Find out the possible values for this column from the other table: |
|
800
|
0
|
|
|
|
|
0
|
my %possible_values; |
|
801
|
0
|
|
|
|
|
0
|
debug "Looking for rows for foreign relation: " => $foreign_key; |
|
802
|
0
|
|
|
|
|
0
|
for my $row ($dbh->quick_select($foreign_key->{table}, {})) { |
|
803
|
0
|
|
|
|
|
0
|
debug "Row from foreign relation: " => $row; |
|
804
|
|
|
|
|
|
|
$possible_values{ $row->{ $foreign_key->{key_column} } } |
|
805
|
0
|
|
|
|
|
0
|
= $row->{ $foreign_key->{label_column} }; |
|
806
|
|
|
|
|
|
|
} |
|
807
|
0
|
|
|
|
|
0
|
$constrain_values{$name} = \%possible_values; |
|
808
|
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
} elsif (my $values_from_db = $field->{mysql_values}) { |
|
810
|
0
|
|
|
|
|
0
|
$constrain_values{$name} = $values_from_db; |
|
811
|
|
|
|
|
|
|
} |
|
812
|
|
|
|
|
|
|
} |
|
813
|
|
|
|
|
|
|
|
|
814
|
|
|
|
|
|
|
# Only give CGI::FormBuilder our fake CGI object if the form has been |
|
815
|
|
|
|
|
|
|
# POSTed to us already; otherwise, it will ignore default values from |
|
816
|
|
|
|
|
|
|
# the DB, it seems. |
|
817
|
|
|
|
|
|
|
my $paramsobj |
|
818
|
3
|
50
|
|
|
|
16
|
= request->{method} eq 'POST' |
|
819
|
|
|
|
|
|
|
? Dancer::Plugin::SimpleCRUD::ParamsObject->new({ params() }) |
|
820
|
|
|
|
|
|
|
: undef; |
|
821
|
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
my $form = CGI::FormBuilder->new( |
|
823
|
|
|
|
|
|
|
fields => \@editable_columns, |
|
824
|
|
|
|
|
|
|
params => $paramsobj, |
|
825
|
|
|
|
|
|
|
values => $values_from_database, |
|
826
|
|
|
|
|
|
|
validate => $validation, |
|
827
|
|
|
|
|
|
|
method => 'post', |
|
828
|
|
|
|
|
|
|
action => _external_url( |
|
829
|
|
|
|
|
|
|
$args->{dancer_prefix}, |
|
830
|
|
|
|
|
|
|
$args->{prefix}, |
|
831
|
|
|
|
|
|
|
( |
|
832
|
|
|
|
|
|
|
params->{id} |
|
833
|
|
|
|
|
|
|
? '/edit/' . params->{id} |
|
834
|
3
|
100
|
|
|
|
48
|
: '/add' |
|
835
|
|
|
|
|
|
|
) |
|
836
|
|
|
|
|
|
|
), |
|
837
|
|
|
|
|
|
|
); |
|
838
|
3
|
|
|
|
|
57911
|
for my $field (@editable_columns) { |
|
839
|
|
|
|
|
|
|
# first check if there's data from the database for this field, |
|
840
|
|
|
|
|
|
|
# then if there's a value in params() for this field, |
|
841
|
|
|
|
|
|
|
# then if args->{default_value} was set for this field via the |
|
842
|
|
|
|
|
|
|
# 'default_value' hash when the route was created. |
|
843
|
|
|
|
|
|
|
my $default = |
|
844
|
|
|
|
|
|
|
exists $values_from_database->{$field} |
|
845
|
|
|
|
|
|
|
? $values_from_database->{$field} |
|
846
|
|
|
|
|
|
|
: exists params->{$field} |
|
847
|
|
|
|
|
|
|
? uri_unescape(params->{$field}) |
|
848
|
|
|
|
|
|
|
: exists $args->{default_value}->{$field} |
|
849
|
6
|
50
|
|
|
|
711
|
? $args->{default_value}->{$field} |
|
|
|
50
|
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
: ''; |
|
851
|
6
|
|
|
|
|
99
|
my %field_params = ( |
|
852
|
|
|
|
|
|
|
name => $field, |
|
853
|
|
|
|
|
|
|
value => $default, |
|
854
|
|
|
|
|
|
|
); |
|
855
|
|
|
|
|
|
|
|
|
856
|
6
|
|
|
|
|
21
|
$field_params{required} = $required_fields{$field}; |
|
857
|
|
|
|
|
|
|
|
|
858
|
6
|
50
|
|
|
|
21
|
if ($constrain_values{$field}) { |
|
859
|
0
|
|
|
|
|
0
|
$field_params{options} = $constrain_values{$field}; |
|
860
|
|
|
|
|
|
|
} |
|
861
|
|
|
|
|
|
|
|
|
862
|
|
|
|
|
|
|
# Certain options in $args simply cause that value to be added to the |
|
863
|
|
|
|
|
|
|
# params for this field we'll pass to $form->field: |
|
864
|
6
|
|
|
|
|
36
|
my %option_map = ( |
|
865
|
|
|
|
|
|
|
labels => 'label', |
|
866
|
|
|
|
|
|
|
validation => 'validate', |
|
867
|
|
|
|
|
|
|
message => 'message', |
|
868
|
|
|
|
|
|
|
jsmessage => 'jsmessage', |
|
869
|
|
|
|
|
|
|
sort_options => 'sortopts', |
|
870
|
|
|
|
|
|
|
); |
|
871
|
6
|
|
|
|
|
27
|
while (my ($arg_name, $field_param_name) = each(%option_map)) { |
|
872
|
30
|
50
|
|
|
|
130
|
if (my $val = $args->{$arg_name}{$field}) { |
|
873
|
0
|
|
|
|
|
0
|
$field_params{$field_param_name} = $val; |
|
874
|
|
|
|
|
|
|
} |
|
875
|
|
|
|
|
|
|
} |
|
876
|
|
|
|
|
|
|
|
|
877
|
|
|
|
|
|
|
# Normally, CGI::FormBuilder can guess the type of field perfectly, |
|
878
|
|
|
|
|
|
|
# but give it some extra DWIMmy help: |
|
879
|
6
|
100
|
|
|
|
51
|
if ($field =~ /pass(?:wd|word)?$/i) { |
|
880
|
3
|
|
|
|
|
12
|
$field_params{type} = 'password'; |
|
881
|
|
|
|
|
|
|
} |
|
882
|
|
|
|
|
|
|
|
|
883
|
|
|
|
|
|
|
# use a |
|
884
|
6
|
50
|
|
|
|
24
|
if ($field_type{$field} eq 'TEXT') { |
|
885
|
0
|
|
|
|
|
0
|
$field_params{type} = 'textarea'; |
|
886
|
|
|
|
|
|
|
} |
|
887
|
|
|
|
|
|
|
|
|
888
|
|
|
|
|
|
|
# ... unless the user specified a type for this field, in which case, |
|
889
|
|
|
|
|
|
|
# use what they said |
|
890
|
6
|
50
|
|
|
|
24
|
if (my $override_type = $args->{input_types}{$field}) { |
|
891
|
0
|
|
|
|
|
0
|
$field_params{type} = $override_type; |
|
892
|
|
|
|
|
|
|
} |
|
893
|
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
# if the constraint on this is an array of arrays, |
|
895
|
|
|
|
|
|
|
# and there are three elements in the first array in that list, |
|
896
|
|
|
|
|
|
|
# (which will be intepreted as: value, label, category) |
|
897
|
|
|
|
|
|
|
# we are going to assume you want optgroups, with the |
|
898
|
|
|
|
|
|
|
# third element in each being the category. |
|
899
|
|
|
|
|
|
|
# |
|
900
|
|
|
|
|
|
|
# (See the optgroups option in CGI::FormBuilder) |
|
901
|
6
|
50
|
|
|
|
21
|
if (ref($field_params{options}) eq 'ARRAY') { |
|
902
|
0
|
0
|
|
|
|
0
|
if (ref( $field_params{options}->[0] ) eq 'ARRAY') { |
|
903
|
0
|
0
|
|
|
|
0
|
if (@{ $field_params{options}->[0] } == 3) { |
|
|
0
|
|
|
|
|
0
|
|
|
904
|
0
|
|
|
|
|
0
|
$field_params{optgroups} = 1; |
|
905
|
|
|
|
|
|
|
} |
|
906
|
|
|
|
|
|
|
} |
|
907
|
|
|
|
|
|
|
} |
|
908
|
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
|
|
910
|
|
|
|
|
|
|
# OK, add the field to the form: |
|
911
|
6
|
|
|
|
|
39
|
$form->field(%field_params); |
|
912
|
|
|
|
|
|
|
} |
|
913
|
|
|
|
|
|
|
|
|
914
|
|
|
|
|
|
|
# Now, if all is OK, go ahead and process: |
|
915
|
3
|
50
|
33
|
|
|
646
|
if (request->{method} eq 'POST' && $form->submitted && $form->validate) { |
|
|
|
|
33
|
|
|
|
|
|
916
|
|
|
|
|
|
|
|
|
917
|
|
|
|
|
|
|
# Assemble a hash of only fields from the DB (if other fields were |
|
918
|
|
|
|
|
|
|
# submitted with the form which don't belong in the DB, ignore them) |
|
919
|
0
|
|
|
|
|
0
|
my %params; |
|
920
|
0
|
|
|
|
|
0
|
$params{$_} = params('body')->{$_} for @editable_columns; |
|
921
|
|
|
|
|
|
|
|
|
922
|
0
|
|
|
|
|
0
|
my $meta_for_hook = { |
|
923
|
|
|
|
|
|
|
args => $args, |
|
924
|
|
|
|
|
|
|
params => \%params, |
|
925
|
|
|
|
|
|
|
table_name => $table_name, |
|
926
|
|
|
|
|
|
|
key_column => $key_column, |
|
927
|
|
|
|
|
|
|
}; |
|
928
|
|
|
|
|
|
|
# Fire a hook so the user can manipulate the data in a whole range of |
|
929
|
|
|
|
|
|
|
# cunning ways, if they wish |
|
930
|
0
|
|
|
|
|
0
|
execute_hook('add_edit_row', \%params); |
|
931
|
0
|
|
|
|
|
0
|
execute_hook('add_edit_row_pre_save', $meta_for_hook); |
|
932
|
|
|
|
|
|
|
|
|
933
|
0
|
|
|
|
|
0
|
my $verb; |
|
934
|
|
|
|
|
|
|
my $success; |
|
935
|
0
|
0
|
|
|
|
0
|
if (exists params('route')->{id}) { |
|
936
|
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
# We're editing an existing record - make sure the WHERE clause |
|
938
|
|
|
|
|
|
|
# hashref incorporates where_filter, if in use, so that users can't |
|
939
|
|
|
|
|
|
|
# edit stuff they shouldn't be able to |
|
940
|
0
|
|
|
|
|
0
|
my $where = _get_where_filter_from_args($args); |
|
941
|
0
|
|
|
|
|
0
|
$where->{$key_column} = params('route')->{id}; |
|
942
|
0
|
|
|
|
|
0
|
$success = $dbh->quick_update($table_name, $where, \%params); |
|
943
|
0
|
|
|
|
|
0
|
$verb = 'update'; |
|
944
|
|
|
|
|
|
|
} else { |
|
945
|
0
|
|
|
|
|
0
|
$success = $dbh->quick_insert($table_name, \%params); |
|
946
|
|
|
|
|
|
|
# pass them *this* dbh instance so that they can call last_insert_id() |
|
947
|
|
|
|
|
|
|
# against it if they need to. last_insert_id in some instances requires |
|
948
|
|
|
|
|
|
|
# catalog, schema, etc args, so we can't just call it and save the result. |
|
949
|
|
|
|
|
|
|
# important that we don't do any more database operations that would change |
|
950
|
|
|
|
|
|
|
# last_insert_id between here and the hook, or this won't work. |
|
951
|
0
|
|
|
|
|
0
|
$meta_for_hook->{dbh} = $dbh; |
|
952
|
0
|
|
|
|
|
0
|
$verb = 'create new'; |
|
953
|
|
|
|
|
|
|
} |
|
954
|
|
|
|
|
|
|
|
|
955
|
0
|
|
|
|
|
0
|
$meta_for_hook->{success} = $success; |
|
956
|
0
|
|
|
|
|
0
|
$meta_for_hook->{verb} = $verb; |
|
957
|
0
|
0
|
|
|
|
0
|
if ($success) { |
|
958
|
|
|
|
|
|
|
|
|
959
|
|
|
|
|
|
|
# Redirect to the list page |
|
960
|
|
|
|
|
|
|
# TODO: pass a param to cause it to show a message? |
|
961
|
0
|
|
|
|
|
0
|
execute_hook('add_edit_row_post_save', $meta_for_hook); |
|
962
|
0
|
|
|
|
|
0
|
redirect _external_url($args->{dancer_prefix}, $args->{prefix}); |
|
963
|
0
|
|
|
|
|
0
|
return; |
|
964
|
|
|
|
|
|
|
} else { |
|
965
|
0
|
|
|
|
|
0
|
execute_hook('add_edit_row_post_save', $meta_for_hook); |
|
966
|
|
|
|
|
|
|
# TODO: better error handling - options to provide error templates |
|
967
|
|
|
|
|
|
|
# etc |
|
968
|
|
|
|
|
|
|
# (below is one approach to that TODO--this, or perhaps the hook could return a hash |
|
969
|
|
|
|
|
|
|
# that would specify these overrides? Probably best to come up with a complete mechanism |
|
970
|
|
|
|
|
|
|
# consistent across hooks before we implement.) |
|
971
|
|
|
|
|
|
|
# return _apply_template( |
|
972
|
|
|
|
|
|
|
# $meta_for_hook->{return}{error_message} || " Unable to $verb $args->{record_title} ", |
|
973
|
|
|
|
|
|
|
# $meta_for_hook->{return}{error_template} || $args->{error_template} || $args->{'template'} |
|
974
|
|
|
|
|
|
|
#); |
|
975
|
|
|
|
|
|
|
return _apply_template( |
|
976
|
|
|
|
|
|
|
" Unable to $verb $args->{record_title} ", |
|
977
|
0
|
|
|
|
|
0
|
$args->{'template'}, $args->{'record_title'}); |
|
978
|
|
|
|
|
|
|
} |
|
979
|
|
|
|
|
|
|
|
|
980
|
|
|
|
|
|
|
} else { |
|
981
|
3
|
|
|
|
|
49
|
return _apply_template($form->render, $args->{'template'}, $args->{'record_title'}); |
|
982
|
|
|
|
|
|
|
} |
|
983
|
|
|
|
|
|
|
} |
|
984
|
|
|
|
|
|
|
|
|
985
|
|
|
|
|
|
|
sub _create_list_handler { |
|
986
|
14
|
|
|
14
|
|
61
|
my ($args, $table_name, $key_column) = @_; |
|
987
|
|
|
|
|
|
|
|
|
988
|
14
|
|
|
|
|
102
|
my $dbh = database($args->{db_connection_name}); |
|
989
|
14
|
|
|
|
|
1533
|
my $columns = _find_columns($dbh, $table_name); |
|
990
|
|
|
|
|
|
|
|
|
991
|
14
|
|
|
|
|
60
|
my $display_columns = $args->{'display_columns'}; |
|
992
|
|
|
|
|
|
|
|
|
993
|
14
|
|
50
|
|
|
93
|
my $table_class = $args->{'table_class'} || ''; |
|
994
|
14
|
|
50
|
|
|
74
|
my $paginate_table_class = $args->{'paginate_table_class'} || ''; |
|
995
|
|
|
|
|
|
|
|
|
996
|
|
|
|
|
|
|
# If display_columns argument was passed, filter the column list to only |
|
997
|
|
|
|
|
|
|
# have the ones we asked for. |
|
998
|
14
|
50
|
|
|
|
55
|
if (ref $display_columns eq 'ARRAY') { |
|
999
|
0
|
|
|
|
|
0
|
my @filtered_columns; |
|
1000
|
|
|
|
|
|
|
|
|
1001
|
0
|
|
|
|
|
0
|
foreach my $col (@$columns) { |
|
1002
|
0
|
0
|
|
|
|
0
|
if (grep { $_ eq $col->{'COLUMN_NAME'} } @$display_columns) { |
|
|
0
|
|
|
|
|
0
|
|
|
1003
|
0
|
|
|
|
|
0
|
push @filtered_columns, $col; |
|
1004
|
|
|
|
|
|
|
} |
|
1005
|
|
|
|
|
|
|
} |
|
1006
|
|
|
|
|
|
|
|
|
1007
|
0
|
0
|
|
|
|
0
|
if (@filtered_columns) { |
|
1008
|
0
|
|
|
|
|
0
|
$columns = \@filtered_columns; |
|
1009
|
|
|
|
|
|
|
} |
|
1010
|
|
|
|
|
|
|
} |
|
1011
|
|
|
|
|
|
|
|
|
1012
|
14
|
|
66
|
|
|
80
|
my $searchfield = params->{searchfield} || $key_column; |
|
1013
|
|
|
|
|
|
|
my $searchfield_options = join( |
|
1014
|
|
|
|
|
|
|
"\n", |
|
1015
|
|
|
|
|
|
|
map { |
|
1016
|
14
|
|
|
|
|
2372
|
my $friendly_name = $_->{COLUMN_NAME}; |
|
|
42
|
|
|
|
|
92
|
|
|
1017
|
42
|
50
|
|
|
|
131
|
if ($args->{labels}{$_->{COLUMN_NAME}}) { |
|
1018
|
0
|
|
|
|
|
0
|
$friendly_name = $args->{labels}{$_->{COLUMN_NAME}}; |
|
1019
|
|
|
|
|
|
|
} |
|
1020
|
|
|
|
|
|
|
my $sel |
|
1021
|
|
|
|
|
|
|
= ($searchfield eq $_->{COLUMN_NAME}) |
|
1022
|
42
|
100
|
|
|
|
120
|
? "selected" |
|
1023
|
|
|
|
|
|
|
: ""; |
|
1024
|
42
|
|
|
|
|
195
|
"" |
|
1025
|
|
|
|
|
|
|
} @$columns |
|
1026
|
|
|
|
|
|
|
); |
|
1027
|
14
|
|
|
|
|
44
|
my $default_searchtype = "e"; |
|
1028
|
14
|
|
|
|
|
318
|
my @searchtypes = ( |
|
1029
|
|
|
|
|
|
|
[ e => { name => "Equals", cmp => "=" } ], |
|
1030
|
|
|
|
|
|
|
[ c => { name => "Contains", cmp => "like" } ], |
|
1031
|
|
|
|
|
|
|
[ b => { name => "Begins With", cmp => "like" } ], |
|
1032
|
|
|
|
|
|
|
[ ne => { name => "Does Not Equal", cmp => "!=" } ], |
|
1033
|
|
|
|
|
|
|
[ nc => { name => "Does Not Contain", cmp => "not like" } ], |
|
1034
|
|
|
|
|
|
|
|
|
1035
|
|
|
|
|
|
|
[ lt => { name => "Less Than", cmp => "<" } ], |
|
1036
|
|
|
|
|
|
|
[ lte => { name => "Less Than or Equal To", cmp => "<=" } ], |
|
1037
|
|
|
|
|
|
|
[ gt => { name => "Greater Than", cmp => ">" } ], |
|
1038
|
|
|
|
|
|
|
[ gte => { name => "Greater Than or Equal To", cmp => ">=" } ], |
|
1039
|
|
|
|
|
|
|
|
|
1040
|
|
|
|
|
|
|
[ like => { name => "Like", cmp => "LIKE" } ], |
|
1041
|
|
|
|
|
|
|
); |
|
1042
|
|
|
|
|
|
|
my $searchtype_options = join( "\n", |
|
1043
|
|
|
|
|
|
|
map { |
|
1044
|
14
|
|
|
|
|
47
|
my ($search_code, $hashref) = @$_; |
|
|
140
|
|
|
|
|
317
|
|
|
1045
|
140
|
|
|
|
|
257
|
my $name = $hashref->{name}; |
|
1046
|
140
|
|
66
|
|
|
323
|
my $sel = (params->{searchtype} || $default_searchtype) eq $search_code; |
|
1047
|
140
|
100
|
|
|
|
2818
|
sprintf("", $search_code, $sel ? " selected" : "", $name); |
|
1048
|
|
|
|
|
|
|
} @searchtypes |
|
1049
|
|
|
|
|
|
|
); |
|
1050
|
|
|
|
|
|
|
|
|
1051
|
14
|
|
50
|
|
|
62
|
my $order_by_param = params->{'o'} || ""; |
|
1052
|
14
|
|
50
|
|
|
283
|
my $order_by_direction = params->{'d'} || ""; |
|
1053
|
14
|
|
|
|
|
270
|
my $q = _defined_or_empty(params->{'q'}); |
|
1054
|
14
|
|
|
|
|
83
|
my $display_q = encode_entities( $q ); |
|
1055
|
14
|
|
|
|
|
325
|
my $html = <<"SEARCHFORM"; |
|
1056
|
|
|
|
|
|
|
|
|
1057
|
|
|
|
|
|
|
Field: |
|
1058
|
|
|
|
|
|
|
|
|
1059
|
|
|
|
|
|
|
|
|
1060
|
|
|
|
|
|
|
|
|
1061
|
|
|
|
|
|
|
|
|
1062
|
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
|
|
1064
|
|
|
|
|
|
|
SEARCHFORM |
|
1065
|
|
|
|
|
|
|
|
|
1066
|
14
|
50
|
|
|
|
57
|
if ($args->{query_auto_focus}) { |
|
1067
|
14
|
|
|
|
|
37
|
$html |
|
1068
|
|
|
|
|
|
|
.= ""; |
|
1069
|
|
|
|
|
|
|
} |
|
1070
|
|
|
|
|
|
|
|
|
1071
|
|
|
|
|
|
|
# Explicitly select the columns we are displaying. (May have been filtered |
|
1072
|
|
|
|
|
|
|
# by display_columns above.) |
|
1073
|
|
|
|
|
|
|
|
|
1074
|
14
|
|
|
|
|
45
|
my @select_cols = map { $_->{COLUMN_NAME} } @$columns; |
|
|
42
|
|
|
|
|
106
|
|
|
1075
|
|
|
|
|
|
|
|
|
1076
|
|
|
|
|
|
|
# If we have some columns declared as foreign keys, though, we don't want to |
|
1077
|
|
|
|
|
|
|
# see the raw values in the result; we'll add JOIN clauses to fetch the info |
|
1078
|
|
|
|
|
|
|
# from the related table, so for now just select the defined label column |
|
1079
|
|
|
|
|
|
|
# from the related table instead of the raw ID value. |
|
1080
|
|
|
|
|
|
|
|
|
1081
|
|
|
|
|
|
|
# This _as_simplecrud_fk_ mechanism is clearly a bit of a hack. At some point we |
|
1082
|
|
|
|
|
|
|
# might want to pull in an existing solution for this--this is simple and |
|
1083
|
|
|
|
|
|
|
# may have pitfalls that have already been solved in Catalyst/DBIC code. |
|
1084
|
|
|
|
|
|
|
# For now, we're going with simple. git show 14cec4ea647 to see the |
|
1085
|
|
|
|
|
|
|
# basic change (that's previous to the add of LEFT to the JOIN, though), if you want |
|
1086
|
|
|
|
|
|
|
# to know exactly what to pull out when replacing this |
|
1087
|
|
|
|
|
|
|
|
|
1088
|
14
|
|
|
|
|
35
|
my @foreign_cols; |
|
1089
|
|
|
|
|
|
|
my %fk_alias; # foreign key aliases for cases where we might have collisions |
|
1090
|
14
|
100
|
|
|
|
50
|
if ($args->{foreign_keys}) { |
|
1091
|
1
|
|
|
|
|
6
|
my $seen_table = {$table_name=>1}; |
|
1092
|
1
|
|
|
|
|
4
|
while (my ($col, $foreign_key) = each(%{ $args->{foreign_keys} })) { |
|
|
1
|
|
|
|
|
10
|
|
|
1093
|
0
|
|
|
|
|
0
|
@select_cols = grep { $_ ne $col } @select_cols; |
|
|
0
|
|
|
|
|
0
|
|
|
1094
|
0
|
|
|
|
|
0
|
my $raw_ftable = $foreign_key->{table}; |
|
1095
|
0
|
|
|
|
|
0
|
my $ftable_alias; |
|
1096
|
0
|
0
|
|
|
|
0
|
if ($seen_table->{$raw_ftable}++) { |
|
1097
|
0
|
|
|
|
|
0
|
$ftable_alias = $fk_alias{ $col } = $dbh->quote_identifier($raw_ftable. "_as_simplecrud_fk_$seen_table->{$raw_ftable}"); |
|
1098
|
|
|
|
|
|
|
} |
|
1099
|
0
|
|
|
|
|
0
|
my $ftable = $dbh->quote_identifier($raw_ftable); |
|
1100
|
|
|
|
|
|
|
my $fcol |
|
1101
|
0
|
|
|
|
|
0
|
= $dbh->quote_identifier($foreign_key->{label_column}); |
|
1102
|
|
|
|
|
|
|
my $lcol |
|
1103
|
0
|
|
0
|
|
|
0
|
= $dbh->quote_identifier($args->{labels}{$col} || $col); |
|
1104
|
|
|
|
|
|
|
|
|
1105
|
0
|
|
0
|
|
|
0
|
my $table_or_alias = $fk_alias{ $col } || $ftable; |
|
1106
|
0
|
|
|
|
|
0
|
push @foreign_cols, "$table_or_alias.$fcol AS $lcol"; |
|
1107
|
|
|
|
|
|
|
} |
|
1108
|
|
|
|
|
|
|
} |
|
1109
|
|
|
|
|
|
|
|
|
1110
|
14
|
|
|
|
|
39
|
my @custom_cols; |
|
1111
|
|
|
|
|
|
|
|
|
1112
|
|
|
|
|
|
|
# For backwards compatibility, understand custom_columns being a hashref, |
|
1113
|
|
|
|
|
|
|
# and translate it |
|
1114
|
14
|
50
|
|
|
|
57
|
if (ref $args->{custom_columns} eq 'HASH') { |
|
1115
|
0
|
|
|
|
|
0
|
my @custom_cols_list; |
|
1116
|
0
|
|
|
|
|
0
|
for my $column_alias (keys %{ $args->{custom_columns} }) { |
|
|
0
|
|
|
|
|
0
|
|
|
1117
|
|
|
|
|
|
|
push @custom_cols_list, { |
|
1118
|
|
|
|
|
|
|
name => $column_alias, |
|
1119
|
0
|
|
|
|
|
0
|
%{ $args->{custom_columns}{$column_alias} } |
|
|
0
|
|
|
|
|
0
|
|
|
1120
|
|
|
|
|
|
|
}; |
|
1121
|
|
|
|
|
|
|
} |
|
1122
|
0
|
|
|
|
|
0
|
$args->{custom_columns} = \@custom_cols_list; |
|
1123
|
|
|
|
|
|
|
} |
|
1124
|
|
|
|
|
|
|
|
|
1125
|
|
|
|
|
|
|
# If we're not overriding a column with the same name, then add custom column |
|
1126
|
14
|
100
|
|
|
|
26
|
for my $custom_col_spec (@{ $args->{custom_columns} || [] }) { |
|
|
14
|
|
|
|
|
74
|
|
|
1127
|
11
|
|
|
|
|
155
|
my $column_alias = $custom_col_spec->{name}; |
|
1128
|
11
|
100
|
|
|
|
19
|
if( ! grep { $column_alias eq $_ } @select_cols) { |
|
|
33
|
|
|
|
|
67
|
|
|
1129
|
|
|
|
|
|
|
my $raw_column = $custom_col_spec->{raw_column} |
|
1130
|
4
|
50
|
|
|
|
14
|
or die "you must specify a raw_column that " |
|
1131
|
|
|
|
|
|
|
. "$column_alias will be built using"; |
|
1132
|
4
|
50
|
|
|
|
24
|
if ($raw_column =~ /^[\w_]+$/) { |
|
1133
|
4
|
|
|
|
|
28
|
push @custom_cols, "$table_name." |
|
1134
|
|
|
|
|
|
|
. $dbh->quote_identifier($raw_column) |
|
1135
|
|
|
|
|
|
|
. " AS ". $dbh->quote_identifier($column_alias); |
|
1136
|
|
|
|
|
|
|
} else { |
|
1137
|
0
|
|
|
|
|
0
|
push @custom_cols, "$raw_column AS $column_alias"; |
|
1138
|
|
|
|
|
|
|
} |
|
1139
|
|
|
|
|
|
|
} |
|
1140
|
|
|
|
|
|
|
} |
|
1141
|
|
|
|
|
|
|
|
|
1142
|
|
|
|
|
|
|
my $col_list = join( |
|
1143
|
|
|
|
|
|
|
',', |
|
1144
|
|
|
|
|
|
|
map( |
|
1145
|
14
|
|
|
|
|
87
|
{ $table_name . "." . $dbh->quote_identifier($_) } |
|
|
42
|
|
|
|
|
1013
|
|
|
1146
|
|
|
|
|
|
|
@select_cols |
|
1147
|
|
|
|
|
|
|
), |
|
1148
|
|
|
|
|
|
|
@foreign_cols, # already assembled from quoted identifiers |
|
1149
|
|
|
|
|
|
|
@custom_cols, |
|
1150
|
|
|
|
|
|
|
); |
|
1151
|
|
|
|
|
|
|
my $add_actions |
|
1152
|
|
|
|
|
|
|
= $args->{editable} |
|
1153
|
14
|
100
|
|
|
|
405
|
? ", $table_name.$key_column AS actions" |
|
1154
|
|
|
|
|
|
|
: ''; |
|
1155
|
14
|
|
|
|
|
48
|
my $query = "SELECT $col_list $add_actions FROM $table_name"; |
|
1156
|
14
|
|
|
|
|
63
|
my @binds; |
|
1157
|
|
|
|
|
|
|
|
|
1158
|
|
|
|
|
|
|
# If we have foreign key relationship info, we need to join on those tables: |
|
1159
|
14
|
100
|
|
|
|
44
|
if ($args->{foreign_keys}) { |
|
1160
|
1
|
|
|
|
|
3
|
while (my ($col, $foreign_key) = each %{ $args->{foreign_keys} }) { |
|
|
1
|
|
|
|
|
9
|
|
|
1161
|
0
|
|
|
|
|
0
|
my $ftable = $dbh->quote_identifier($foreign_key->{table}); |
|
1162
|
0
|
|
|
|
|
0
|
my $lkey = $dbh->quote_identifier($col); |
|
1163
|
0
|
|
|
|
|
0
|
my $rkey = $dbh->quote_identifier($foreign_key->{key_column}); |
|
1164
|
|
|
|
|
|
|
|
|
1165
|
|
|
|
|
|
|
# Identifiers quoted above, and $table_name quoted further up, so |
|
1166
|
|
|
|
|
|
|
# all safe to interpolate |
|
1167
|
0
|
|
|
|
|
0
|
my $what_to_join = $ftable; |
|
1168
|
0
|
|
|
|
|
0
|
my $join_reference = $ftable; |
|
1169
|
0
|
0
|
|
|
|
0
|
if (my $alias = $fk_alias{$col}) { |
|
1170
|
0
|
|
|
|
|
0
|
$what_to_join = " $ftable AS $alias "; |
|
1171
|
0
|
|
|
|
|
0
|
$join_reference = $alias; |
|
1172
|
|
|
|
|
|
|
} |
|
1173
|
|
|
|
|
|
|
# If this join is not a left join, the list view only shows rows where the |
|
1174
|
|
|
|
|
|
|
# foreign key is defined and matching a row |
|
1175
|
0
|
|
|
|
|
0
|
$query .= " LEFT JOIN $what_to_join ON $table_name.$lkey = $join_reference.$rkey "; |
|
1176
|
|
|
|
|
|
|
} |
|
1177
|
|
|
|
|
|
|
} |
|
1178
|
|
|
|
|
|
|
|
|
1179
|
|
|
|
|
|
|
# If we have a query or a where_filter, we need to assemble a WHERE clause... |
|
1180
|
14
|
|
|
|
|
49
|
my $where_filter = _get_where_filter_from_args($args); |
|
1181
|
14
|
100
|
66
|
|
|
88
|
if (length $q || $where_filter) { |
|
1182
|
|
|
|
|
|
|
|
|
1183
|
|
|
|
|
|
|
# Turn the $where_filter hashref into some SQL clauses and bind params, |
|
1184
|
|
|
|
|
|
|
# which we'll add to with the user's search params shortly |
|
1185
|
4
|
|
|
|
|
24
|
my ($where_filter_sql, @where_filter_binds) |
|
1186
|
|
|
|
|
|
|
= $dbh->generate_where_clauses($where_filter); |
|
1187
|
|
|
|
|
|
|
|
|
1188
|
4
|
|
|
|
|
58
|
my (@search_wheres, @search_binds); |
|
1189
|
4
|
50
|
|
|
|
17
|
if (length $q) { # this nested code is all for queries in $q |
|
1190
|
|
|
|
|
|
|
my ($column_data) |
|
1191
|
12
|
|
|
|
|
43
|
= grep { lc $_->{COLUMN_NAME} eq lc $searchfield } |
|
1192
|
4
|
|
|
|
|
9
|
@{$columns}; |
|
|
4
|
|
|
|
|
12
|
|
|
1193
|
4
|
|
|
|
|
35
|
debug( |
|
1194
|
|
|
|
|
|
|
"Searching on $column_data->{COLUMN_NAME} which is a " |
|
1195
|
|
|
|
|
|
|
. "$column_data->{TYPE_NAME}" |
|
1196
|
|
|
|
|
|
|
); |
|
1197
|
4
|
|
66
|
|
|
296
|
my $st = params->{searchtype} || $default_searchtype; |
|
1198
|
|
|
|
|
|
|
|
|
1199
|
4
|
50
|
|
|
|
100
|
if ($column_data) { |
|
1200
|
4
|
|
|
|
|
12
|
my $search_value = $q; |
|
1201
|
4
|
50
|
33
|
|
|
37
|
if ($st eq 'c' || $st eq 'nc') { # contains or does not contain |
|
|
|
50
|
|
|
|
|
|
|
1202
|
0
|
|
|
|
|
0
|
$search_value = '%' . $search_value . '%'; |
|
1203
|
|
|
|
|
|
|
} elsif ($st eq 'b') { # begins with |
|
1204
|
0
|
|
|
|
|
0
|
$search_value = $search_value . '%'; |
|
1205
|
|
|
|
|
|
|
} |
|
1206
|
|
|
|
|
|
|
|
|
1207
|
4
|
|
|
|
|
16
|
my ($searchtype_row) = grep { $_->[0] eq $st } @searchtypes; |
|
|
40
|
|
|
|
|
105
|
|
|
1208
|
4
|
|
50
|
|
|
21
|
my $cmp = $searchtype_row->[1]->{cmp} || '='; |
|
1209
|
4
|
|
|
|
|
31
|
push(@search_wheres, |
|
1210
|
|
|
|
|
|
|
"$table_name." |
|
1211
|
|
|
|
|
|
|
. $dbh->quote_identifier($searchfield) |
|
1212
|
|
|
|
|
|
|
. " $cmp ?" ); |
|
1213
|
4
|
|
|
|
|
143
|
push(@search_binds, $search_value); |
|
1214
|
|
|
|
|
|
|
|
|
1215
|
4
|
|
50
|
|
|
19
|
my $matchtype = lc($searchtype_row->[1]->{name} || "equals"); |
|
1216
|
4
|
|
|
|
|
20
|
$html |
|
1217
|
|
|
|
|
|
|
.= sprintf( |
|
1218
|
|
|
|
|
|
|
" Showing results from searching for '%s' %s '%s'", |
|
1219
|
|
|
|
|
|
|
encode_entities($searchfield), $matchtype, encode_entities($q) |
|
1220
|
|
|
|
|
|
|
); |
|
1221
|
|
|
|
|
|
|
$html .= sprintf '—Reset search', |
|
1222
|
4
|
|
|
|
|
156
|
_external_url($args->{dancer_prefix}, $args->{prefix}); |
|
1223
|
|
|
|
|
|
|
} |
|
1224
|
|
|
|
|
|
|
} |
|
1225
|
|
|
|
|
|
|
# add the 'where' clauses to $query and the binds to @binds |
|
1226
|
4
|
|
|
|
|
2646
|
$query .= " where " . join( " AND ", grep { length $_ } ($where_filter_sql, @search_wheres)); |
|
|
8
|
|
|
|
|
34
|
|
|
1227
|
4
|
|
|
|
|
18
|
push(@binds, @where_filter_binds, @search_binds); |
|
1228
|
|
|
|
|
|
|
} |
|
1229
|
|
|
|
|
|
|
|
|
1230
|
14
|
50
|
|
|
|
52
|
if ($args->{downloadable}) { |
|
1231
|
0
|
|
|
|
|
0
|
my $qt = uri_escape($q); |
|
1232
|
0
|
|
|
|
|
0
|
my $sf = uri_escape($searchfield); |
|
1233
|
0
|
|
0
|
|
|
0
|
my $st = uri_escape(params->{searchtype} || $default_searchtype); |
|
1234
|
0
|
|
0
|
|
|
0
|
my $o = uri_escape(params->{'o'} || ""); |
|
1235
|
0
|
|
0
|
|
|
0
|
my $d = uri_escape(params->{'d'} || ""); |
|
1236
|
0
|
|
0
|
|
|
0
|
my $page = uri_escape(params->{'p'} || 0); |
|
1237
|
|
|
|
|
|
|
|
|
1238
|
0
|
|
|
|
|
0
|
my @formats = qw/csv tabular json xml/; |
|
1239
|
|
|
|
|
|
|
|
|
1240
|
|
|
|
|
|
|
my $url = _external_url($args->{dancer_prefix}, $args->{prefix}) |
|
1241
|
0
|
|
|
|
|
0
|
. "?o=$o&d=$d&q=$qt&searchfield=$sf&searchtype=$st&p=$page"; |
|
1242
|
|
|
|
|
|
|
|
|
1243
|
|
|
|
|
|
|
$html |
|
1244
|
|
|
|
|
|
|
.= " Download as: " |
|
1245
|
0
|
|
|
|
|
0
|
. join(", ", map { "$_" } @formats) |
|
|
0
|
|
|
|
|
0
|
|
|
1246
|
|
|
|
|
|
|
. " "; |
|
1247
|
|
|
|
|
|
|
} |
|
1248
|
|
|
|
|
|
|
|
|
1249
|
14
|
|
|
|
|
30
|
my %columns_sort_options; |
|
1250
|
14
|
100
|
|
|
|
45
|
if ($args->{sortable}) { |
|
1251
|
4
|
|
|
|
|
16
|
my $qt = uri_escape($q); |
|
1252
|
4
|
|
|
|
|
50
|
my $sf = uri_escape($searchfield); |
|
1253
|
4
|
|
33
|
|
|
41
|
my $st = uri_escape(params->{searchtype} || $default_searchtype); |
|
1254
|
4
|
|
33
|
|
|
99
|
my $order_by_column = uri_escape(params->{'o'}) || $key_column; |
|
1255
|
|
|
|
|
|
|
|
|
1256
|
|
|
|
|
|
|
# Invalid column name ? discard it |
|
1257
|
4
|
|
|
|
|
102
|
my $valid = grep { $_->{COLUMN_NAME} eq $order_by_column } @$columns; |
|
|
12
|
|
|
|
|
35
|
|
|
1258
|
4
|
50
|
|
|
|
11
|
$order_by_column = $key_column unless $valid; |
|
1259
|
4
|
|
|
|
|
7
|
my $order_by_table = $table_name; |
|
1260
|
|
|
|
|
|
|
|
|
1261
|
|
|
|
|
|
|
my $order_by_direction |
|
1262
|
4
|
50
|
33
|
|
|
9
|
= (exists params->{'d'} && params->{'d'} eq "desc") |
|
1263
|
|
|
|
|
|
|
? "desc" |
|
1264
|
|
|
|
|
|
|
: "asc"; |
|
1265
|
4
|
50
|
|
|
|
60
|
my $opposite_order_by_direction |
|
1266
|
|
|
|
|
|
|
= ($order_by_direction eq "asc") ? "desc" : "asc"; |
|
1267
|
|
|
|
|
|
|
|
|
1268
|
|
|
|
|
|
|
# Get a list of all columns (normal, and custom_columns), then assemble |
|
1269
|
|
|
|
|
|
|
# the names and labels to pass to HTML::Table::FromDatabase |
|
1270
|
4
|
|
|
|
|
10
|
my @all_cols = map { $_->{COLUMN_NAME} } @$columns; |
|
|
12
|
|
|
|
|
24
|
|
|
1271
|
|
|
|
|
|
|
%columns_sort_options = map { |
|
1272
|
4
|
|
|
|
|
10
|
my $col_name = $_; |
|
|
12
|
|
|
|
|
19
|
|
|
1273
|
12
|
|
|
|
|
18
|
my $direction = $order_by_direction; |
|
1274
|
12
|
|
|
|
|
16
|
my $direction_char = ""; |
|
1275
|
12
|
|
|
|
|
14
|
my $friendly_name = $col_name; |
|
1276
|
12
|
50
|
|
|
|
27
|
if ($args->{labels}{$col_name}) { |
|
1277
|
0
|
|
|
|
|
0
|
$friendly_name = $args->{labels}{$col_name}; |
|
1278
|
|
|
|
|
|
|
} else { |
|
1279
|
12
|
|
|
|
|
20
|
$friendly_name = _prettify_column_name($friendly_name); |
|
1280
|
|
|
|
|
|
|
} |
|
1281
|
12
|
100
|
|
|
|
28
|
if ($col_name eq $order_by_column) { |
|
1282
|
4
|
|
|
|
|
6
|
$direction = $opposite_order_by_direction; |
|
1283
|
4
|
50
|
|
|
|
10
|
$direction_char = ($direction eq "asc") ? "↑" : "↓"; |
|
1284
|
|
|
|
|
|
|
} |
|
1285
|
|
|
|
|
|
|
my $url = _external_url($args->{dancer_prefix}, $args->{prefix}) |
|
1286
|
12
|
|
|
|
|
35
|
. "?o=$col_name&d=$direction&q=$q&searchfield=$sf&searchtype=$st"; |
|
1287
|
12
|
|
|
|
|
4837
|
$col_name => |
|
1288
|
|
|
|
|
|
|
"$friendly_name $direction_char"; |
|
1289
|
|
|
|
|
|
|
} @all_cols; |
|
1290
|
|
|
|
|
|
|
|
|
1291
|
|
|
|
|
|
|
# And for custom columns, do the prettification, but don't include a |
|
1292
|
|
|
|
|
|
|
# link for sorting unless we're overriding the display of an already |
|
1293
|
|
|
|
|
|
|
# sortable column. We can't sort non-overridden custom columns (sorting is |
|
1294
|
|
|
|
|
|
|
# done by SQL, and the custom column values are calculated after we get |
|
1295
|
|
|
|
|
|
|
# the results from the SQL query, so to support sorting by them we'd |
|
1296
|
|
|
|
|
|
|
# have to stop getting the database to sort the data and sort it |
|
1297
|
|
|
|
|
|
|
# ourselves afterwards). |
|
1298
|
4
|
50
|
|
|
|
15
|
if (exists $args->{custom_columns}) { |
|
1299
|
4
|
|
|
|
|
7
|
for my $custom_column_name ( |
|
1300
|
7
|
|
|
|
|
17
|
map { $_->{name} } @{ $args->{custom_columns} } |
|
|
4
|
|
|
|
|
10
|
|
|
1301
|
|
|
|
|
|
|
) { |
|
1302
|
7
|
100
|
|
|
|
11
|
if ( !grep { $_ eq $custom_column_name } @all_cols) { |
|
|
21
|
|
|
|
|
38
|
|
|
1303
|
2
|
|
|
|
|
6
|
$columns_sort_options{$custom_column_name} |
|
1304
|
|
|
|
|
|
|
= _prettify_column_name($custom_column_name); |
|
1305
|
|
|
|
|
|
|
} |
|
1306
|
|
|
|
|
|
|
} |
|
1307
|
|
|
|
|
|
|
} |
|
1308
|
|
|
|
|
|
|
|
|
1309
|
4
|
0
|
33
|
|
|
11
|
if (exists $args->{foreign_keys} and exists $args->{foreign_keys}{$order_by_column}) { |
|
1310
|
0
|
|
|
|
|
0
|
my $fk = $args->{foreign_keys}{$order_by_column}; |
|
1311
|
0
|
|
|
|
|
0
|
$order_by_column = $fk->{label_column}; |
|
1312
|
0
|
|
|
|
|
0
|
$order_by_table = $fk->{table}; |
|
1313
|
|
|
|
|
|
|
} |
|
1314
|
|
|
|
|
|
|
|
|
1315
|
4
|
|
|
|
|
21
|
$query .= " ORDER BY " |
|
1316
|
|
|
|
|
|
|
. $dbh->quote_identifier($order_by_table) . "." |
|
1317
|
|
|
|
|
|
|
. $dbh->quote_identifier($order_by_column) |
|
1318
|
|
|
|
|
|
|
. " $order_by_direction "; |
|
1319
|
|
|
|
|
|
|
} |
|
1320
|
|
|
|
|
|
|
|
|
1321
|
14
|
50
|
33
|
|
|
205
|
if ($args->{paginate} && $args->{paginate} =~ /^\d+$/) { |
|
1322
|
0
|
|
|
|
|
0
|
my $page_size = $args->{paginate}; |
|
1323
|
|
|
|
|
|
|
|
|
1324
|
0
|
|
|
|
|
0
|
my $qt = uri_escape($q); |
|
1325
|
0
|
|
|
|
|
0
|
my $sf = uri_escape($searchfield); |
|
1326
|
0
|
|
0
|
|
|
0
|
my $st = uri_escape(params->{searchtype} || $default_searchtype); |
|
1327
|
0
|
|
0
|
|
|
0
|
my $o = uri_escape(params->{'o'} || ""); |
|
1328
|
0
|
|
0
|
|
|
0
|
my $d = uri_escape(params->{'d'} || ""); |
|
1329
|
0
|
|
0
|
|
|
0
|
my $page = uri_escape(params->{'p'} || 0); |
|
1330
|
0
|
0
|
|
|
|
0
|
$page = 0 unless $page =~ /^\d+$/; |
|
1331
|
|
|
|
|
|
|
|
|
1332
|
0
|
|
|
|
|
0
|
my $offset = $page_size * $page; |
|
1333
|
0
|
|
|
|
|
0
|
my $limit = $page_size; |
|
1334
|
|
|
|
|
|
|
|
|
1335
|
|
|
|
|
|
|
my $url = _external_url($args->{dancer_prefix}, $args->{prefix}) |
|
1336
|
0
|
|
|
|
|
0
|
. "?o=$o&d=$d&q=$qt&searchfield=$sf&searchtype=$st"; |
|
1337
|
0
|
|
|
|
|
0
|
$html .= " "; |
|
1338
|
0
|
|
|
|
|
0
|
$html .= ""; |
|
1358
|
|
|
|
|
|
|
|
|
1359
|
0
|
|
|
|
|
0
|
$query .= " LIMIT $limit OFFSET $offset "; |
|
1360
|
|
|
|
|
|
|
} |
|
1361
|
|
|
|
|
|
|
|
|
1362
|
14
|
|
|
|
|
90
|
debug("Running query: $query"); |
|
1363
|
14
|
|
|
|
|
1005
|
my $sth = $dbh->prepare($query); |
|
1364
|
14
|
50
|
|
|
|
2013
|
$sth->execute(@binds) |
|
1365
|
|
|
|
|
|
|
or die "Failed to query for records in $table_name - " |
|
1366
|
|
|
|
|
|
|
. $dbh->errstr; |
|
1367
|
|
|
|
|
|
|
|
|
1368
|
14
|
0
|
33
|
|
|
91
|
if ($args->{downloadable} && params->{format}) { |
|
1369
|
|
|
|
|
|
|
|
|
1370
|
|
|
|
|
|
|
##Return results as a downloaded file, instead of generating the HTML table. |
|
1371
|
0
|
|
|
|
|
0
|
return _return_downloadable_query($args, $sth, params->{format}); |
|
1372
|
|
|
|
|
|
|
} |
|
1373
|
|
|
|
|
|
|
|
|
1374
|
14
|
|
|
|
|
46
|
my @custom_callbacks = (); |
|
1375
|
14
|
100
|
|
|
|
30
|
for my $custom_col_spec (@{ $args->{custom_columns} || [] } ) { |
|
|
14
|
|
|
|
|
82
|
|
|
1376
|
|
|
|
|
|
|
push @custom_callbacks, { |
|
1377
|
|
|
|
|
|
|
column=>$custom_col_spec->{name}, |
|
1378
|
11
|
|
50
|
0
|
|
57
|
transform=> ($custom_col_spec->{transform} or sub { return shift;}), |
|
|
0
|
|
|
|
|
0
|
|
|
1379
|
|
|
|
|
|
|
}; |
|
1380
|
|
|
|
|
|
|
} |
|
1381
|
|
|
|
|
|
|
|
|
1382
|
|
|
|
|
|
|
|
|
1383
|
|
|
|
|
|
|
my $table = HTML::Table::FromDatabase->new( |
|
1384
|
|
|
|
|
|
|
-sth => $sth, |
|
1385
|
|
|
|
|
|
|
-border => 1, |
|
1386
|
|
|
|
|
|
|
-callbacks => [ |
|
1387
|
|
|
|
|
|
|
{ |
|
1388
|
|
|
|
|
|
|
column => 'actions', |
|
1389
|
|
|
|
|
|
|
transform => sub { |
|
1390
|
16
|
|
|
16
|
|
5685
|
my $id = shift; |
|
1391
|
16
|
|
|
|
|
35
|
my $action_links; |
|
1392
|
16
|
50
|
33
|
|
|
88
|
if ($args->{editable} && _has_permission('edit', $args)) { |
|
1393
|
|
|
|
|
|
|
my $edit_url |
|
1394
|
|
|
|
|
|
|
= _external_url( |
|
1395
|
|
|
|
|
|
|
$args->{dancer_prefix}, $args->{prefix}, |
|
1396
|
16
|
|
|
|
|
73
|
"/edit/$id" |
|
1397
|
|
|
|
|
|
|
); |
|
1398
|
16
|
|
|
|
|
11410
|
$action_links |
|
1399
|
|
|
|
|
|
|
.= qq[Edit]; |
|
1400
|
16
|
50
|
33
|
|
|
200
|
if ($args->{deletable} && _has_permission('edit', $args)) { |
|
1401
|
|
|
|
|
|
|
my $del_url =_external_url( |
|
1402
|
|
|
|
|
|
|
$args->{dancer_prefix}, $args->{prefix}, |
|
1403
|
0
|
|
|
|
|
0
|
"/delete/$id" |
|
1404
|
|
|
|
|
|
|
); |
|
1405
|
0
|
|
|
|
|
0
|
$action_links |
|
1406
|
|
|
|
|
|
|
.= qq[ /
|
|
1407
|
|
|
|
|
|
|
. qq[ onclick="delrec('$id'); return false;">] |
|
1408
|
|
|
|
|
|
|
. qq[Delete]; |
|
1409
|
|
|
|
|
|
|
} |
|
1410
|
|
|
|
|
|
|
} |
|
1411
|
16
|
|
|
|
|
95
|
return $action_links; |
|
1412
|
|
|
|
|
|
|
}, |
|
1413
|
|
|
|
|
|
|
}, |
|
1414
|
14
|
|
|
|
|
296
|
@custom_callbacks, |
|
1415
|
|
|
|
|
|
|
], |
|
1416
|
|
|
|
|
|
|
-rename_headers => \%columns_sort_options, |
|
1417
|
|
|
|
|
|
|
-html => 'escape', |
|
1418
|
|
|
|
|
|
|
-class => $table_class, |
|
1419
|
|
|
|
|
|
|
); |
|
1420
|
|
|
|
|
|
|
|
|
1421
|
|
|
|
|
|
|
# apply custom columns' column_classes as specified. Can this be done via HTML::Table::FromDatabase->new() above? |
|
1422
|
14
|
|
|
|
|
19832
|
my @all_column_names = ( (map { $_->{COLUMN_NAME} } @$columns), (map { $_->{name} } @{$args->{custom_columns}}) ); |
|
|
42
|
|
|
|
|
122
|
|
|
|
11
|
|
|
|
|
26
|
|
|
|
14
|
|
|
|
|
55
|
|
|
1423
|
14
|
50
|
|
|
|
34
|
for my $custom_col_spec (@{ $args->{custom_columns} || [] } ) { |
|
|
14
|
|
|
|
|
65
|
|
|
1424
|
11
|
50
|
|
|
|
840
|
if (my $column_class = $custom_col_spec->{column_class}) { |
|
1425
|
11
|
|
|
27
|
|
95
|
my $first_index = first_index { $_ eq $custom_col_spec->{name} } uniq @all_column_names; |
|
|
27
|
|
|
|
|
45
|
|
|
1426
|
11
|
50
|
|
|
|
39
|
die "Cannot find index of column '$custom_col_spec->{name}'" if ($first_index == -1); |
|
1427
|
11
|
|
|
|
|
39
|
$table->setColClass( 1 + $first_index, $column_class ); |
|
1428
|
|
|
|
|
|
|
} |
|
1429
|
|
|
|
|
|
|
} |
|
1430
|
|
|
|
|
|
|
|
|
1431
|
14
|
|
100
|
|
|
972
|
$html .= $table->getTable || ''; |
|
1432
|
|
|
|
|
|
|
|
|
1433
|
14
|
100
|
66
|
|
|
14574
|
if ($args->{addable} && _has_permission('edit', $args)) { |
|
1434
|
|
|
|
|
|
|
$html .= sprintf 'Add a new %s', |
|
1435
|
|
|
|
|
|
|
_external_url($args->{dancer_prefix}, $args->{prefix}, '/add'), |
|
1436
|
1
|
|
|
|
|
6
|
$args->{record_title}; |
|
1437
|
|
|
|
|
|
|
|
|
1438
|
|
|
|
|
|
|
# Append a little Javascript which asks for confirmation that they'd |
|
1439
|
|
|
|
|
|
|
# like to delete the record, then makes a POST request via a hidden |
|
1440
|
|
|
|
|
|
|
# form. This could be made AJAXy in future. |
|
1441
|
|
|
|
|
|
|
my $del_action = _external_url( |
|
1442
|
1
|
|
|
|
|
645
|
$args->{dancer_prefix}, $args->{prefix}, '/delete' |
|
1443
|
|
|
|
|
|
|
); |
|
1444
|
1
|
|
|
|
|
698
|
$html .= <
|
|
1445
|
|
|
|
|
|
|
|
|
1446
|
|
|
|
|
|
|
|
|
1447
|
|
|
|
|
|
|
|
|
1448
|
|
|
|
|
|
|
|
|
1456
|
|
|
|
|
|
|
|
|
1457
|
|
|
|
|
|
|
DELETEJS |
|
1458
|
|
|
|
|
|
|
} |
|
1459
|
|
|
|
|
|
|
|
|
1460
|
14
|
|
|
|
|
94
|
return _apply_template($html, $args->{'template'}, $args->{'record_title'}); |
|
1461
|
|
|
|
|
|
|
} |
|
1462
|
|
|
|
|
|
|
|
|
1463
|
|
|
|
|
|
|
sub _apply_template { |
|
1464
|
19
|
|
|
19
|
|
50686
|
my ($html, $template, $title) = @_; |
|
1465
|
|
|
|
|
|
|
|
|
1466
|
19
|
50
|
|
|
|
72
|
if ($template) { |
|
1467
|
0
|
|
|
|
|
0
|
return template $template, { simple_crud => $html, record_title => $title }; |
|
1468
|
|
|
|
|
|
|
} else { |
|
1469
|
19
|
|
|
|
|
124
|
return engine('template')->apply_layout($html); |
|
1470
|
|
|
|
|
|
|
} |
|
1471
|
|
|
|
|
|
|
} |
|
1472
|
|
|
|
|
|
|
|
|
1473
|
|
|
|
|
|
|
sub _return_downloadable_query { |
|
1474
|
0
|
|
|
0
|
|
0
|
my ($args, $sth, $format) = @_; |
|
1475
|
|
|
|
|
|
|
|
|
1476
|
0
|
|
|
|
|
0
|
my $output; |
|
1477
|
|
|
|
|
|
|
|
|
1478
|
|
|
|
|
|
|
## Generate an informative filename |
|
1479
|
0
|
|
|
|
|
0
|
my $filename = $args->{db_table}; |
|
1480
|
0
|
0
|
|
|
|
0
|
if (params->{'o'}) { |
|
1481
|
0
|
|
|
|
|
0
|
my $order = params->{'o'}; |
|
1482
|
0
|
|
|
|
|
0
|
$order =~ s/[^\w\.\-]+/_/g; |
|
1483
|
0
|
|
|
|
|
0
|
$filename .= "__sorted_by_" . $order; |
|
1484
|
|
|
|
|
|
|
} |
|
1485
|
0
|
|
|
|
|
0
|
my $q = _defined_or_empty(params->{'q'}); |
|
1486
|
0
|
0
|
|
|
|
0
|
if (length($q)) { |
|
1487
|
0
|
|
|
|
|
0
|
my $query = $q; |
|
1488
|
0
|
|
|
|
|
0
|
$query =~ s/[^\w\.\-]+/_/g; |
|
1489
|
0
|
|
|
|
|
0
|
$filename .= "__query_" . $query; |
|
1490
|
|
|
|
|
|
|
} |
|
1491
|
0
|
0
|
|
|
|
0
|
if (params->{'p'}) { |
|
1492
|
0
|
|
|
|
|
0
|
my $page = params->{'p'}; |
|
1493
|
0
|
|
|
|
|
0
|
$page =~ s/[^0-9]+/_/g; |
|
1494
|
0
|
|
|
|
|
0
|
$filename .= "__page_" . $page; |
|
1495
|
|
|
|
|
|
|
} |
|
1496
|
|
|
|
|
|
|
|
|
1497
|
|
|
|
|
|
|
## Generate data in the requested format |
|
1498
|
0
|
0
|
|
|
|
0
|
if ($format eq "tabular") { |
|
|
|
0
|
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
1499
|
0
|
|
|
|
|
0
|
header('Content-Type' => 'text/tab-separated-values'); |
|
1500
|
0
|
|
|
|
|
0
|
header('Content-Disposition' => |
|
1501
|
|
|
|
|
|
|
"attachment; filename=\"$filename.txt\""); |
|
1502
|
0
|
|
|
|
|
0
|
my $aref = $sth->{NAME}; |
|
1503
|
0
|
|
|
|
|
0
|
$output = join("\t", @$aref) . "\r\n"; |
|
1504
|
0
|
|
|
|
|
0
|
while ($aref = $sth->fetchrow_arrayref) { |
|
1505
|
0
|
|
|
|
|
0
|
$output .= join("\t", @{$aref}) . "\r\n"; |
|
|
0
|
|
|
|
|
0
|
|
|
1506
|
|
|
|
|
|
|
} |
|
1507
|
|
|
|
|
|
|
} elsif ($format eq "csv") { |
|
1508
|
0
|
|
|
|
|
0
|
eval { require Text::CSV }; |
|
|
0
|
|
|
|
|
0
|
|
|
1509
|
|
|
|
|
|
|
return |
|
1510
|
0
|
0
|
|
|
|
0
|
"Error: required module Text::CSV not installed. Can't generate CSV file." |
|
1511
|
|
|
|
|
|
|
if $@; |
|
1512
|
|
|
|
|
|
|
|
|
1513
|
0
|
|
|
|
|
0
|
header('Content-Type' => 'text/comma-separated-values'); |
|
1514
|
0
|
|
|
|
|
0
|
header('Content-Disposition' => |
|
1515
|
|
|
|
|
|
|
"attachment; filename=\"$filename.csv\""); |
|
1516
|
|
|
|
|
|
|
|
|
1517
|
0
|
|
|
|
|
0
|
my $csv = Text::CSV->new(); |
|
1518
|
0
|
|
|
|
|
0
|
my $aref = $sth->{NAME}; |
|
1519
|
0
|
|
|
|
|
0
|
$csv->combine(@{$aref}); |
|
|
0
|
|
|
|
|
0
|
|
|
1520
|
0
|
|
|
|
|
0
|
$output = $csv->string() . "\r\n"; |
|
1521
|
0
|
|
|
|
|
0
|
while ($aref = $sth->fetchrow_arrayref) { |
|
1522
|
0
|
|
|
|
|
0
|
$csv->combine(@{$aref}); |
|
|
0
|
|
|
|
|
0
|
|
|
1523
|
0
|
|
|
|
|
0
|
$output .= $csv->string() . "\r\n"; |
|
1524
|
|
|
|
|
|
|
} |
|
1525
|
|
|
|
|
|
|
} elsif ($format eq "json") { |
|
1526
|
0
|
|
|
|
|
0
|
header('Content-Type' => 'text/json'); |
|
1527
|
0
|
|
|
|
|
0
|
header('Content-Disposition' => |
|
1528
|
|
|
|
|
|
|
"attachment; filename=\"$filename.json\""); |
|
1529
|
0
|
|
|
|
|
0
|
$output = to_json($sth->fetchall_arrayref({})); |
|
1530
|
|
|
|
|
|
|
} elsif ($format eq "xml") { |
|
1531
|
0
|
|
|
|
|
0
|
header('Content-Type' => 'text/xml'); |
|
1532
|
0
|
|
|
|
|
0
|
header('Content-Disposition' => |
|
1533
|
|
|
|
|
|
|
"attachment; filename=\"$filename.xml\""); |
|
1534
|
0
|
|
|
|
|
0
|
$output = to_xml($sth->fetchall_arrayref({})); |
|
1535
|
|
|
|
|
|
|
} else { |
|
1536
|
0
|
|
|
|
|
0
|
$output = "Error: unknown format $format"; |
|
1537
|
|
|
|
|
|
|
} |
|
1538
|
|
|
|
|
|
|
|
|
1539
|
0
|
|
|
|
|
0
|
return $output; |
|
1540
|
|
|
|
|
|
|
} |
|
1541
|
|
|
|
|
|
|
|
|
1542
|
|
|
|
|
|
|
# Given a table name, return an arrayref of hashrefs describing each column in |
|
1543
|
|
|
|
|
|
|
# the table. |
|
1544
|
|
|
|
|
|
|
# Expect to see the following keys: |
|
1545
|
|
|
|
|
|
|
# COLUMN_NAME |
|
1546
|
|
|
|
|
|
|
# COLUMN_SIZE |
|
1547
|
|
|
|
|
|
|
# NULLABLE |
|
1548
|
|
|
|
|
|
|
# DATETIME ? |
|
1549
|
|
|
|
|
|
|
# TYPE_NAME (e.g. INT, VARCHAR, ENUM) |
|
1550
|
|
|
|
|
|
|
# MySQL-specific stuff includes: |
|
1551
|
|
|
|
|
|
|
# mysql_type_name (e.g. "enum('One', 'Two', 'Three')" |
|
1552
|
|
|
|
|
|
|
# mysql_is_pri_key |
|
1553
|
|
|
|
|
|
|
# mysql_values (for an enum, ["One", "Two", "Three"] |
|
1554
|
|
|
|
|
|
|
sub _find_columns { |
|
1555
|
19
|
|
|
19
|
|
62
|
my ($dbh, $table_name) = @_; |
|
1556
|
19
|
50
|
|
|
|
172
|
my $sth = $dbh->column_info(undef, undef, $table_name, undef) |
|
1557
|
|
|
|
|
|
|
or die "Failed to get column info for $table_name - " . $dbh->errstr; |
|
1558
|
19
|
|
|
|
|
26234
|
my @columns; |
|
1559
|
19
|
|
|
|
|
239
|
while (my $col = $sth->fetchrow_hashref) { |
|
1560
|
|
|
|
|
|
|
|
|
1561
|
|
|
|
|
|
|
# Push a copy of the hashref, as I think DBI re-uses them |
|
1562
|
57
|
|
|
|
|
2375
|
push @columns, {%$col}; |
|
1563
|
|
|
|
|
|
|
} |
|
1564
|
|
|
|
|
|
|
|
|
1565
|
19
|
50
|
|
|
|
462
|
die "no columns for table [$table_name]--are you sure this table exists in the database [$dbh->{Driver}->{Name}:$dbh->{Name}]?" unless @columns; |
|
1566
|
|
|
|
|
|
|
|
|
1567
|
|
|
|
|
|
|
# Return the columns, sorted by their position in the table: |
|
1568
|
19
|
|
|
|
|
110
|
return [sort { $a->{ORDINAL_POSITION} <=> $b->{ORDINAL_POSITION} } |
|
|
57
|
|
|
|
|
889
|
|
|
1569
|
|
|
|
|
|
|
@columns]; |
|
1570
|
|
|
|
|
|
|
} |
|
1571
|
|
|
|
|
|
|
|
|
1572
|
|
|
|
|
|
|
# Given parts of an URL, assemble them together, prepending the current prefix |
|
1573
|
|
|
|
|
|
|
# setting if needed, and taking care to get slashes right. |
|
1574
|
|
|
|
|
|
|
# e.g. for the following example: |
|
1575
|
|
|
|
|
|
|
# prefix '/foo'; |
|
1576
|
|
|
|
|
|
|
# simple_crud( prefix => '/bar', ....); |
|
1577
|
|
|
|
|
|
|
# calling: _construct_url($args{prefix}, '/baz') |
|
1578
|
|
|
|
|
|
|
# would return: /foo/bar/baz |
|
1579
|
|
|
|
|
|
|
sub _construct_url { |
|
1580
|
58
|
|
|
58
|
|
187
|
my @url_parts = @_; |
|
1581
|
|
|
|
|
|
|
|
|
1582
|
|
|
|
|
|
|
# Just concatenate all parts together, then deal with multiple slashes. |
|
1583
|
|
|
|
|
|
|
# This could be problematic if any URL was ever supposed to contain multiple |
|
1584
|
|
|
|
|
|
|
# slashes, but that shouldn't be an issue here. |
|
1585
|
58
|
|
|
|
|
242
|
my $url = '/' . join '/', @url_parts; |
|
1586
|
58
|
|
|
|
|
408
|
$url =~ s{/{2,}}{/}g; |
|
1587
|
58
|
|
|
|
|
288
|
return $url; |
|
1588
|
|
|
|
|
|
|
} |
|
1589
|
|
|
|
|
|
|
|
|
1590
|
|
|
|
|
|
|
sub _external_url { |
|
1591
|
37
|
50
|
|
37
|
|
236
|
if ( plugin_setting()->{use_old_url_scheme} ) { |
|
1592
|
0
|
|
|
|
|
0
|
return _construct_url(@_); |
|
1593
|
|
|
|
|
|
|
} |
|
1594
|
|
|
|
|
|
|
else { |
|
1595
|
37
|
|
|
|
|
885
|
return uri_for(_construct_url(@_)); |
|
1596
|
|
|
|
|
|
|
} |
|
1597
|
|
|
|
|
|
|
} |
|
1598
|
|
|
|
|
|
|
|
|
1599
|
|
|
|
|
|
|
# Given a mode ("view" or "edit", a handler coderef, and an args coderef, works |
|
1600
|
|
|
|
|
|
|
# out if we need to wrap the handler coderef via |
|
1601
|
|
|
|
|
|
|
# Dancer::Plugin::Auth::Extensible to ensure authorisation, and if so, does so. |
|
1602
|
|
|
|
|
|
|
sub _ensure_auth { |
|
1603
|
21
|
|
|
21
|
|
68
|
my ($mode, $handler, $args) = @_; |
|
1604
|
|
|
|
|
|
|
|
|
1605
|
21
|
|
50
|
|
|
132
|
my $auth_settings = $args->{auth}{$mode} || $args->{auth} || {}; |
|
1606
|
|
|
|
|
|
|
|
|
1607
|
21
|
100
|
|
|
|
98
|
if (keys %$auth_settings) { |
|
1608
|
4
|
50
|
|
|
|
32
|
Dancer::ModuleLoader->load('Dancer::Plugin::Auth::Extensible') |
|
1609
|
|
|
|
|
|
|
or die "Can't use auth settings without" |
|
1610
|
|
|
|
|
|
|
. " Dancer::Plugin::Auth::Extensible!"; |
|
1611
|
|
|
|
|
|
|
} else { |
|
1612
|
|
|
|
|
|
|
# I think this can just be 'return;' given the way it is |
|
1613
|
|
|
|
|
|
|
# used currently, but the other branch returns a $handler, |
|
1614
|
|
|
|
|
|
|
# so this is more consistent |
|
1615
|
17
|
|
|
|
|
61
|
return $handler; |
|
1616
|
|
|
|
|
|
|
} |
|
1617
|
|
|
|
|
|
|
|
|
1618
|
4
|
50
|
|
|
|
13387
|
if ($auth_settings->{require_login}) { |
|
1619
|
4
|
|
|
|
|
17
|
return $handler = |
|
1620
|
|
|
|
|
|
|
Dancer::Plugin::Auth::Extensible::require_login($handler); |
|
1621
|
|
|
|
|
|
|
} else { |
|
1622
|
0
|
|
|
|
|
0
|
for my $keyword (qw(require_role require_any_role require_all_roles)) { |
|
1623
|
0
|
0
|
|
|
|
0
|
if (my $val = $auth_settings->{$keyword}) { |
|
1624
|
0
|
|
|
|
|
0
|
return $handler = Dancer::Plugin::Auth::Extensible->can($keyword)->( |
|
1625
|
|
|
|
|
|
|
$val, $handler |
|
1626
|
|
|
|
|
|
|
); |
|
1627
|
|
|
|
|
|
|
} |
|
1628
|
|
|
|
|
|
|
} |
|
1629
|
|
|
|
|
|
|
} |
|
1630
|
|
|
|
|
|
|
} |
|
1631
|
|
|
|
|
|
|
|
|
1632
|
|
|
|
|
|
|
# Given an action (view/edit) and an args coderef, returns whether the user has |
|
1633
|
|
|
|
|
|
|
# permission to perform that action (e.g. if require_login is set, checks the |
|
1634
|
|
|
|
|
|
|
# user is logged in; if require_role is set, checks they have that role, etc) |
|
1635
|
|
|
|
|
|
|
sub _has_permission { |
|
1636
|
17
|
|
|
17
|
|
54
|
my ($mode, $args) = @_; |
|
1637
|
|
|
|
|
|
|
|
|
1638
|
17
|
|
50
|
|
|
110
|
my $auth_settings = $args->{auth}{$mode} || $args->{auth} || {}; |
|
1639
|
17
|
50
|
|
|
|
64
|
if (keys %$auth_settings) { |
|
1640
|
0
|
0
|
|
|
|
0
|
Dancer::ModuleLoader->load('Dancer::Plugin::Auth::Extensible') |
|
1641
|
|
|
|
|
|
|
or die "Can't use auth settings without" |
|
1642
|
|
|
|
|
|
|
. " Dancer::Plugin::Auth::Extensible!"; |
|
1643
|
|
|
|
|
|
|
} else { |
|
1644
|
|
|
|
|
|
|
# If no auth settings provided, they can do what they like |
|
1645
|
17
|
|
|
|
|
84
|
return 1; |
|
1646
|
|
|
|
|
|
|
} |
|
1647
|
|
|
|
|
|
|
|
|
1648
|
0
|
0
|
|
|
|
0
|
if ($auth_settings->{require_login}) { |
|
1649
|
0
|
0
|
|
|
|
0
|
return Dancer::Plugin::Auth::Extensible::logged_in_user() ? 1 : 0; |
|
1650
|
|
|
|
|
|
|
} |
|
1651
|
|
|
|
|
|
|
|
|
1652
|
0
|
0
|
|
|
|
0
|
if (my $need_role = $auth_settings->{require_role}) { |
|
1653
|
0
|
|
|
|
|
0
|
return Dancer::Plugin::Auth::Extensible::user_has_role($need_role); |
|
1654
|
|
|
|
|
|
|
} |
|
1655
|
|
|
|
|
|
|
|
|
1656
|
|
|
|
|
|
|
# TODO: handle require_any_role / require_all_roles here |
|
1657
|
0
|
|
|
|
|
0
|
warn "TODO: handle require_any_role / requires_all_roles"; |
|
1658
|
0
|
|
|
|
|
0
|
return 0; |
|
1659
|
|
|
|
|
|
|
} |
|
1660
|
|
|
|
|
|
|
|
|
1661
|
|
|
|
|
|
|
sub _defined_or_empty { |
|
1662
|
14
|
|
|
14
|
|
242
|
my $v = shift; |
|
1663
|
14
|
100
|
|
|
|
56
|
return defined($v) ? $v : ""; |
|
1664
|
|
|
|
|
|
|
} |
|
1665
|
|
|
|
|
|
|
|
|
1666
|
|
|
|
|
|
|
# where_filter "if it's a coderef, call it and check it gave us a hashref to |
|
1667
|
|
|
|
|
|
|
# use, otherwise expect it to be a hashref" logic as we need this in several |
|
1668
|
|
|
|
|
|
|
# places. Returns a hashref, ready for us to add other stuff to in most cases |
|
1669
|
|
|
|
|
|
|
# (e.g. usually we'd call this, then add $key_column => ... to it) |
|
1670
|
|
|
|
|
|
|
sub _get_where_filter_from_args { |
|
1671
|
21
|
|
|
21
|
|
60
|
my $args = shift; |
|
1672
|
21
|
50
|
|
|
|
83
|
return unless $args->{where_filter}; |
|
1673
|
|
|
|
|
|
|
|
|
1674
|
0
|
0
|
|
|
|
0
|
if (ref $args->{where_filter} eq 'HASH') { |
|
|
|
0
|
|
|
|
|
|
|
1675
|
0
|
|
|
|
|
0
|
return $args->{where_filter}; |
|
1676
|
|
|
|
|
|
|
} elsif (ref $args->{where_filter} eq 'CODE') { |
|
1677
|
0
|
|
|
|
|
0
|
my $result = $args->{where_filter}->(); |
|
1678
|
0
|
0
|
|
|
|
0
|
if (ref $result eq 'HASH') { |
|
1679
|
0
|
|
|
|
|
0
|
return $result; |
|
1680
|
|
|
|
|
|
|
} else { |
|
1681
|
|
|
|
|
|
|
# TODO: better error reporting, so we know which one caused |
|
1682
|
|
|
|
|
|
|
# the problem |
|
1683
|
0
|
|
|
|
|
0
|
die "where_filter coderef didn't return a hashref!"; |
|
1684
|
|
|
|
|
|
|
} |
|
1685
|
|
|
|
|
|
|
} else { |
|
1686
|
0
|
|
|
|
|
0
|
die "Invalid where_filter"; |
|
1687
|
|
|
|
|
|
|
} |
|
1688
|
|
|
|
|
|
|
} |
|
1689
|
|
|
|
|
|
|
|
|
1690
|
|
|
|
|
|
|
sub _prettify_column_name { |
|
1691
|
14
|
|
|
14
|
|
23
|
my $name = shift; |
|
1692
|
14
|
|
|
|
|
26
|
for ($name) { |
|
1693
|
14
|
|
|
|
|
25
|
$_ = lc; |
|
1694
|
14
|
|
|
|
|
23
|
s{_}{ }g; |
|
1695
|
14
|
|
|
|
|
88
|
s{\b(\w)}{\u$1}g; |
|
1696
|
|
|
|
|
|
|
} |
|
1697
|
14
|
|
|
|
|
36
|
return $name; |
|
1698
|
|
|
|
|
|
|
} |
|
1699
|
|
|
|
|
|
|
|
|
1700
|
|
|
|
|
|
|
=back |
|
1701
|
|
|
|
|
|
|
|
|
1702
|
|
|
|
|
|
|
=head1 DWIMmery |
|
1703
|
|
|
|
|
|
|
|
|
1704
|
|
|
|
|
|
|
This module tries to do what you'd expect it to do, so you can rock up your web |
|
1705
|
|
|
|
|
|
|
app with as little code and effort as possible, whilst still giving you control |
|
1706
|
|
|
|
|
|
|
to override its decisions wherever you need to. |
|
1707
|
|
|
|
|
|
|
|
|
1708
|
|
|
|
|
|
|
=head2 Field types |
|
1709
|
|
|
|
|
|
|
|
|
1710
|
|
|
|
|
|
|
CGI::FormBuilder is excellent at working out what kind of field to use by |
|
1711
|
|
|
|
|
|
|
itself, but we give it a little help where needed. For instance, if a field |
|
1712
|
|
|
|
|
|
|
looks like it's supposed to contain a password, we'll have it rendered as a |
|
1713
|
|
|
|
|
|
|
password entry box, rather than a standard text box. |
|
1714
|
|
|
|
|
|
|
|
|
1715
|
|
|
|
|
|
|
If the column in the database is an ENUM, we'll limit the choices available for |
|
1716
|
|
|
|
|
|
|
this field to the choices defined by the ENUM list. (Unless you've provided a |
|
1717
|
|
|
|
|
|
|
set of acceptable values for this field using the C option to |
|
1718
|
|
|
|
|
|
|
C, in which case what you say goes.) |
|
1719
|
|
|
|
|
|
|
|
|
1720
|
|
|
|
|
|
|
=head1 Hooks |
|
1721
|
|
|
|
|
|
|
|
|
1722
|
|
|
|
|
|
|
Hooks are provided, which can be used in the normal Dancer way, using the |
|
1723
|
|
|
|
|
|
|
C keyword. |
|
1724
|
|
|
|
|
|
|
|
|
1725
|
|
|
|
|
|
|
=head2 add_edit_row (deprecated, use add_edit_row_pre_save) |
|
1726
|
|
|
|
|
|
|
|
|
1727
|
|
|
|
|
|
|
You can use the same code from your add_edit_row hook in an add_edit_row_pre_save |
|
1728
|
|
|
|
|
|
|
hook. The only modification is that the new hook passes the editable params |
|
1729
|
|
|
|
|
|
|
as a key of the first argument (called C), rather than as the first |
|
1730
|
|
|
|
|
|
|
argument itself. So, if your hook had C, it could just |
|
1731
|
|
|
|
|
|
|
use C<< my $args = shift->{params}; >> and it should work the same way. |
|
1732
|
|
|
|
|
|
|
|
|
1733
|
|
|
|
|
|
|
=head2 add_edit_row_pre_save, add_edit_row_post_save |
|
1734
|
|
|
|
|
|
|
|
|
1735
|
|
|
|
|
|
|
These fire right before and after a row is added/edited; a hashref is |
|
1736
|
|
|
|
|
|
|
passed with metadata such as the name of the table (in C), the |
|
1737
|
|
|
|
|
|
|
args from the original route setup (C), the table's key column |
|
1738
|
|
|
|
|
|
|
(C), and the values of the editable params (C). |
|
1739
|
|
|
|
|
|
|
|
|
1740
|
|
|
|
|
|
|
In the post-save hook, you are also sent C (the return value of |
|
1741
|
|
|
|
|
|
|
quick_insert or quick_update) telling you if the save was successful |
|
1742
|
|
|
|
|
|
|
(which is a little redundant because your post-save hook won't be called unless |
|
1743
|
|
|
|
|
|
|
the insert or update was successful). You'll also get |
|
1744
|
|
|
|
|
|
|
C giving you the instance of the handle used to save the entity |
|
1745
|
|
|
|
|
|
|
(so you can access last_insert_id()), and C (currently either |
|
1746
|
|
|
|
|
|
|
'create new' or 'update'). |
|
1747
|
|
|
|
|
|
|
|
|
1748
|
|
|
|
|
|
|
For instance, if you were dealing with a users table, you could use the |
|
1749
|
|
|
|
|
|
|
pre_save hook to hash the password before storing it - assuming for the sake |
|
1750
|
|
|
|
|
|
|
of example that you have a C function to return a hashed password: |
|
1751
|
|
|
|
|
|
|
|
|
1752
|
|
|
|
|
|
|
hook add_edit_row_pre_save => sub { |
|
1753
|
|
|
|
|
|
|
my $args = shift; |
|
1754
|
|
|
|
|
|
|
if ($args->{table_name} eq 'user') { |
|
1755
|
|
|
|
|
|
|
$args->{params}{password} = hash_pw($args->{params}{password}); |
|
1756
|
|
|
|
|
|
|
} |
|
1757
|
|
|
|
|
|
|
}; |
|
1758
|
|
|
|
|
|
|
|
|
1759
|
|
|
|
|
|
|
=head2 delete_row_pre_delete, delete_row_post_delete |
|
1760
|
|
|
|
|
|
|
|
|
1761
|
|
|
|
|
|
|
These fire right before and after a row is deleted. As with the |
|
1762
|
|
|
|
|
|
|
add_edit_row_pre_save and add_edit_row_post_save hooks, these are |
|
1763
|
|
|
|
|
|
|
passed a hashref with metadata such as the name of the table |
|
1764
|
|
|
|
|
|
|
(in C), the args from the original route setup (C), |
|
1765
|
|
|
|
|
|
|
the table's key column (C), and the values of the |
|
1766
|
|
|
|
|
|
|
editable params (C). As with the post-save hook, delete_row_post_delete hook won't be |
|
1767
|
|
|
|
|
|
|
called if we weren't able to delete the row. |
|
1768
|
|
|
|
|
|
|
|
|
1769
|
|
|
|
|
|
|
You could use these to clean up ancillary data associated with a |
|
1770
|
|
|
|
|
|
|
database row when it was deleted, for example. |
|
1771
|
|
|
|
|
|
|
|
|
1772
|
|
|
|
|
|
|
=head1 AUTHOR |
|
1773
|
|
|
|
|
|
|
|
|
1774
|
|
|
|
|
|
|
David Precious, C<< >> |
|
1775
|
|
|
|
|
|
|
|
|
1776
|
|
|
|
|
|
|
=head1 ACKNOWLEDGEMENTS |
|
1777
|
|
|
|
|
|
|
|
|
1778
|
|
|
|
|
|
|
Alberto Simões (ambs) |
|
1779
|
|
|
|
|
|
|
|
|
1780
|
|
|
|
|
|
|
WK |
|
1781
|
|
|
|
|
|
|
|
|
1782
|
|
|
|
|
|
|
Johnathan Barber |
|
1783
|
|
|
|
|
|
|
|
|
1784
|
|
|
|
|
|
|
saberworks |
|
1785
|
|
|
|
|
|
|
|
|
1786
|
|
|
|
|
|
|
jasonjayr |
|
1787
|
|
|
|
|
|
|
|
|
1788
|
|
|
|
|
|
|
Paul Johnson (pjcj) |
|
1789
|
|
|
|
|
|
|
|
|
1790
|
|
|
|
|
|
|
Rahul Kotamaraju |
|
1791
|
|
|
|
|
|
|
|
|
1792
|
|
|
|
|
|
|
Michael J South (msouth) |
|
1793
|
|
|
|
|
|
|
|
|
1794
|
|
|
|
|
|
|
Martijn Lievaart |
|
1795
|
|
|
|
|
|
|
|
|
1796
|
|
|
|
|
|
|
Josh Rabinowitz |
|
1797
|
|
|
|
|
|
|
|
|
1798
|
|
|
|
|
|
|
=head1 BUGS |
|
1799
|
|
|
|
|
|
|
|
|
1800
|
|
|
|
|
|
|
Please report any bugs or feature requests to C, or through |
|
1801
|
|
|
|
|
|
|
the web interface at L. I will be notified, and then you'll |
|
1802
|
|
|
|
|
|
|
automatically be notified of progress on your bug as I make changes. |
|
1803
|
|
|
|
|
|
|
|
|
1804
|
|
|
|
|
|
|
|
|
1805
|
|
|
|
|
|
|
=head1 CONTRIBUTING |
|
1806
|
|
|
|
|
|
|
|
|
1807
|
|
|
|
|
|
|
This module is developed on Github: |
|
1808
|
|
|
|
|
|
|
|
|
1809
|
|
|
|
|
|
|
http://github.com/bigpresh/Dancer-Plugin-SimpleCRUD |
|
1810
|
|
|
|
|
|
|
|
|
1811
|
|
|
|
|
|
|
Bug reports, ideas, suggestions, patches/pull requests all welcome. |
|
1812
|
|
|
|
|
|
|
|
|
1813
|
|
|
|
|
|
|
Even just a quick "Hey, this is great, thanks" or "This is no good to me |
|
1814
|
|
|
|
|
|
|
because..." is greatly appreciated. It's always good to know if people are |
|
1815
|
|
|
|
|
|
|
using your code, and what they think. |
|
1816
|
|
|
|
|
|
|
|
|
1817
|
|
|
|
|
|
|
|
|
1818
|
|
|
|
|
|
|
=head1 SUPPORT |
|
1819
|
|
|
|
|
|
|
|
|
1820
|
|
|
|
|
|
|
You can find documentation for this module with the perldoc command. |
|
1821
|
|
|
|
|
|
|
|
|
1822
|
|
|
|
|
|
|
perldoc Dancer::Plugin::SimpleCRUD |
|
1823
|
|
|
|
|
|
|
|
|
1824
|
|
|
|
|
|
|
You may find help with this module on the main Dancer IRC channel or mailing |
|
1825
|
|
|
|
|
|
|
list - see http://www.perldancer.org/ |
|
1826
|
|
|
|
|
|
|
|
|
1827
|
|
|
|
|
|
|
|
|
1828
|
|
|
|
|
|
|
You can also look for information at: |
|
1829
|
|
|
|
|
|
|
|
|
1830
|
|
|
|
|
|
|
=over 4 |
|
1831
|
|
|
|
|
|
|
|
|
1832
|
|
|
|
|
|
|
=item * RT: CPAN's request tracker |
|
1833
|
|
|
|
|
|
|
|
|
1834
|
|
|
|
|
|
|
L |
|
1835
|
|
|
|
|
|
|
|
|
1836
|
|
|
|
|
|
|
=item * AnnoCPAN: Annotated CPAN documentation |
|
1837
|
|
|
|
|
|
|
|
|
1838
|
|
|
|
|
|
|
L |
|
1839
|
|
|
|
|
|
|
|
|
1840
|
|
|
|
|
|
|
=item * CPAN Ratings |
|
1841
|
|
|
|
|
|
|
|
|
1842
|
|
|
|
|
|
|
L |
|
1843
|
|
|
|
|
|
|
|
|
1844
|
|
|
|
|
|
|
=item * Search CPAN |
|
1845
|
|
|
|
|
|
|
|
|
1846
|
|
|
|
|
|
|
L |
|
1847
|
|
|
|
|
|
|
|
|
1848
|
|
|
|
|
|
|
=back |
|
1849
|
|
|
|
|
|
|
|
|
1850
|
|
|
|
|
|
|
|
|
1851
|
|
|
|
|
|
|
=head1 LICENSE AND COPYRIGHT |
|
1852
|
|
|
|
|
|
|
|
|
1853
|
|
|
|
|
|
|
Copyright 2010-16 David Precious. |
|
1854
|
|
|
|
|
|
|
|
|
1855
|
|
|
|
|
|
|
This program is free software; you can redistribute it and/or modify it |
|
1856
|
|
|
|
|
|
|
under the terms of either: the GNU General Public License as published |
|
1857
|
|
|
|
|
|
|
by the Free Software Foundation; or the Artistic License. |
|
1858
|
|
|
|
|
|
|
|
|
1859
|
|
|
|
|
|
|
See http://dev.perl.org/licenses/ for more information. |
|
1860
|
|
|
|
|
|
|
|
|
1861
|
|
|
|
|
|
|
|
|
1862
|
|
|
|
|
|
|
=cut |
|
1863
|
|
|
|
|
|
|
|
|
1864
|
|
|
|
|
|
|
1; # End of Dancer::Plugin::SimpleCRUD |