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 |