File Coverage

blib/lib/App/AutoCRUD/Controller/Table.pm

Criterion	Covered	Total	%
statement	139	221	62.9
branch	25	60	41.6
condition	8	25	32.0
subroutine	20	25	80.0
pod	3	10	30.0
total	195	341	57.1

package App::AutoCRUD::Controller::Table;

use 5.010;
use strict;
use warnings;

use Moose;
extends 'App::AutoCRUD::Controller';
use SQL::Abstract::More 1.27;
use List::MoreUtils            qw/mesh firstval/;
use JSON::MaybeXS ();
use URI;

use namespace::clean -except => 'meta';

#----------------------------------------------------------------------
# entry point to the controller
#----------------------------------------------------------------------
sub serve {
  my ($self) = @_;

  my $context = $self->context;

  # extract from path : table name and method to dispatch to
  my ($table, $meth_name) = $context->extract_path_segments(2)
    or die "URL too short, missing table and method name";
  my $method = $self->can($meth_name)
    or die "no such method: $meth_name";

  # set default template and title
  $context->set_template("table/$meth_name.tt");
  $context->set_title($context->title . "-" . $table);

  # dispatch to method
  return $self->$method($table);
}


#----------------------------------------------------------------------
# published methods
#----------------------------------------------------------------------

sub descr {
  my ($self, $table) = @_;

  my $datasource = $self->datasource;
  my $descr      = $datasource->config(tables => $table => 'descr');

  # datastructure describing this table
  return {table       => $table,
          colgroups   => $datasource->colgroups($table),
          primary_key => [$datasource->primary_key($table)],
          descr       => $descr};

}


sub list {
  my ($self, $table) = @_;

  my $context    = $self->context;
  my $req_data   = $context->req_data;
  my $datasource = $context->datasource;

  # the "message" arg is sent once from inserts/updates/deletes; not to
  # be repeated in links to other queries
  my $message = delete $req_data->{-message};

  # dashed args are set apart
  my %where_args  = %$req_data; # need a clone because of deletes below
  my %dashed_args = $context->view->default_dashed_args($context);
  foreach my $arg (grep {/^-/} keys %where_args) {
    $dashed_args{$arg} = delete $where_args{$arg};
  }

  # some dashed args are treated here (not sent to the SQL request)
  my $with_count = delete $dashed_args{-with_count};
  my $template   = delete $dashed_args{-template};
  $context->set_template($template) if $template;

  # select from database
  my $criteria  = $datasource->query_parser->parse(\%where_args) || {};
  my $statement = $datasource->schema->db_table($table)->select(
    -where => $criteria,
    %dashed_args,
    -result_as => 'statement',
   );
  my $rows         = $statement->select();

  # recuperate SQL for logging / informational purposes
  my ($sql, @bind) = $statement->sql;
  my $show_sql     = join " / ", $sql, @bind;
  $self->logger({level => 'debug', message => $show_sql});

  # assemble results
  my $data = $self->descr($table);
  $data->{rows}       = $rows;
  $data->{message}    = $message;
  $data->{criteria}   = $show_sql;
  if ($with_count) {
    $data->{row_count}  = $statement->row_count;
    $data->{page_count} = $statement->page_count;
  }

  # links to prev/next pages
  $self->_add_links_to_other_pages($data, $req_data,
                                   $dashed_args{-page_index},
                                   $dashed_args{-page_size});

  # link to update/delete forms
  $data->{where_args} = $self->_query_string(
    map { ("where.$_" => $where_args{$_}) } keys %where_args,
   );

  return $data;
}


sub _add_links_to_other_pages {
  my ($self, $data, $req_data, $page_index, $page_size) = @_;

  return unless defined $page_index && defined $page_size;

  $data->{page_index}    = $page_index;
  $data->{offset}        = ($page_index - 1) * $page_size + 1;
  $data->{similar_query} = $self->_query_string(%$req_data,
                                                -page_index => 1);
  $data->{next_page}     = $self->_query_string(%$req_data,
                                                -page_index => $page_index+1)
    unless @{$data->{rows}} < $page_size;
  $data->{prev_page}     = $self->_query_string(%$req_data,
                                                -page_index => $page_index-1)
    unless $page_index <= 1;
}



sub id {
  my ($self, $table) = @_;

  my $data     = $self->descr($table);

  my $pk       = $data->{primary_key};
  my @vals     = $self->context->extract_path_segments(scalar(@$pk));
  my %criteria = mesh @$pk, @vals;

  # get row from database
  my $row = $self->datasource->schema->db_table($table)->fetch(@vals);

  # assemble results
  $data->{row}    = $row;
  $data->{pk_val} = join "/", @vals;

  # links
  my %where_pk = map { ("where_pk.$_" => $criteria{$_}) } keys %criteria;
  $data->{where_pk} = $self->_query_string(%where_pk);

  return $data;
}


sub search {
  my ($self, $table) = @_;

  my $context  = $self->context;
  my $req_data = $context->req_data;

  if ($context->req->method eq 'POST') {
    my $output = delete $req_data->{-output} || "";
    my $cols   = [keys %{delete $req_data->{col} || {}}];
    $req_data->{-columns} = join ",", @$cols;
    $self->redirect("list$output?" . $self->_query_string(%$req_data));
  }
  else {
    # display the search form
    my @cols = split /,/, (delete $req_data->{-columns} || "");
    $req_data->{"col.$_"} = 1 foreach @cols;
    my $data = $self->descr($table);
    $data->{init_form} = $self->_encode_json($req_data);
    return $data;
  }
}


sub update {
  my ($self, $table) = @_;

  if ($self->context->req->method eq 'POST') {
    $self->_do_update_data($table);
  }
  else {
    $self->_display_update_form($table);
  }
}


sub _do_update_data {
  my ($self, $table) = @_;

  my $context    = $self->context;
  my $req_data   = $context->req_data;
  my $datasource = $context->datasource;

  # columns to update
  my $to_set = $req_data->{set} || {};
  foreach my $key (keys %$to_set) {
    my $val = $to_set->{$key};
    delete $to_set->{$key} if ! length $val;
    $to_set->{$key} = undef if $val eq 'Null';
  }
  keys %$to_set or die "nothing to update";

  # build filtering criteria
  my $where  = $req_data->{where} or die "update without any '-where' clause";
  my $criteria = $datasource->query_parser->parse($where);
  $criteria and keys %$criteria or die "update without any '-where' criteria";

  # perform the update
  my $db_table  = $datasource->schema->db_table($table);
  my $n_updates = $db_table->update(-set => $to_set, -where => $criteria);

  # redirect to a list to display the results
  my $message = ($n_updates == 1) ? "1 record was updated"
                                  : "$n_updates records were updated";
  # TODO: $message could repeat the $to_set pairs
  my $query_string = $self->_query_string(%$where, -message => $message);
  $self->redirect("list?$query_string");
}

sub _display_update_form {
  my ($self, $table) = @_;

  my $context    = $self->context;
  my $req_data   = $context->req_data;
  my $datasource = $context->datasource;
  my $data       = $self->descr($table);

  if (my $where_pk  = delete $req_data->{where_pk}) {
    # we got the primary key of one single record
    $data->{where_pk}  = $where_pk;
    $req_data->{where} = $where_pk;

    # fetch current values so that we can display them on page
    my $criteria = $datasource->query_parser->parse($where_pk);
    my $db_table = $datasource->schema->db_table($table);
    $req_data->{curr} = $db_table->select(-where     => $criteria,
                                          -result_as => 'firstrow');
  }
  else {
    # we got criteria that may touch several records
    $self->_mark_multicols_keys($data);
  }

  # fields that should not be updatable
  if (my $noupd = delete $req_data->{_noupd}) {
    $data->{noupd}{$_} = 1 foreach split qr[/], $noupd;
  }

  # initial values for the form
  $data->{init_form} = $self->_encode_json($req_data);

  return $data;
}


sub delete {
  my ($self, $table) = @_;

  my $context    = $self->context;
  my $req_data   = $context->req_data;
  my $datasource = $context->datasource;

  if ($context->req->method eq 'POST') { # POST => delete in database
    # build filtering criteria
    my $where = $req_data->{where} or die "delete without any '-where' clause";
    my $criteria = $datasource->query_parser->parse($where);
    $criteria and keys %$criteria or die "delete without any '-where' criteria";

    # perform the delete
    my $db_table  = $datasource->schema->db_table($table);
    my $n_deletes = $db_table->delete(-where => $criteria);

    # redirect to a list to display the results
    my $message = ($n_deletes == 1) ? "1 record was deleted"
                                    : "$n_deletes records were deleted";
    my $query_string = $self->_query_string(%$where, -message => $message);
    $self->redirect("list?$query_string");
  }
  else {                                  # GET => display the delete form
    # display the delete form
    my $data = $self->descr($table);
    if (my $where_pk  = delete $req_data->{where_pk}) {
      # we got the primary key of one single record
      $data->{where_pk}  = $where_pk;
      $req_data->{where} = $where_pk;
    }
    else {
      # we got criteria that may touch several records
      $self->_mark_multicols_keys($data);
    }

    # initial values for the form
    $data->{init_form} = $self->_encode_json($req_data);

    return $data;
  }
}




sub clone {
  my ($self, $table) = @_;

  my $context = $self->context;
  $context->req->method eq 'GET'
    or die "the /clone URL only accepts GET requests";

  # get primary key
  my $data    = $self->descr($table);
  my $pk      = $data->{primary_key};
  my %is_pk   = map {$_ => 1} @$pk;
  my @vals    = $context->extract_path_segments(scalar(@$pk));

  # get row from database
  my $row = $self->datasource->schema->db_table($table)->fetch(@vals);

  # populate req_data before calling insert()
  my $req_data   = $context->req_data;
  foreach my $col (keys %$row) {
    my $val = $row->{$col};
    $req_data->{$col} = $val if $val and !$is_pk{$col};
  }

  # cheat with path (simulating a call to insert())
  my $path = $context->path;
  $path =~ s/clone$/insert/;
  $context->set_path($path);
  $context->set_template('table/insert.tt');

  # forward to insert()
  $self->insert($table);
}


sub insert {
  my ($self, $table) = @_;

  my $context    = $self->context;
  my $req_data   = $context->req_data;
  my $datasource = $context->datasource;

  if ($context->req->method eq 'POST') {
    # perform the insert
    my $db_table  = $datasource->schema->db_table($table);
    my @pk = $db_table->insert($req_data);

    # redirect to a list to display the results
    my $message = "1 record was inserted";
    my $query_string = $self->_query_string(-message => $message);
    $self->redirect(join("/", "id", @pk) . "?$query_string");
  }
  else {
    # display the insert form
    my $data = $self->descr($table);
    $data->{init_form} = $self->_encode_json($req_data);

    return $data;
  }
}



sub count_where { # used in Ajax mode by update and delete forms
  my ($self, $table) = @_;

  my $context    = $self->context;
  my $req_data   = $context->req_data;
  my $datasource = $context->datasource;

  my $n_records = -1;

  if (my $where = $req_data->{where}) {
    my $criteria = $datasource->query_parser->parse($where);
    if ($criteria and keys %$criteria) {
      my $db_table  = $datasource->schema->db_table($table);
      my $result = $db_table->select(
        -columns   => 'COUNT(*)',
        -where     => $criteria,
        -result_as => 'flat_arrayref',
       );
      $n_records = $result->[0];
    }
  }

  return {n_records => $n_records};
}




#----------------------------------------------------------------------
# auxiliary methods
#----------------------------------------------------------------------


sub _query_string {
  my ($self, %params) = @_;
  my @fragments;
 KEY:
  foreach my $key (sort keys %params) {
    my $val = $params{$key};
    length $val or next KEY;

    # cheap URI escape (for chars '=', '&', ';' and '+')
    s/=/%3D/g, s/&/%26/g, s/;/%3B/g, s/\+/%2B/g for $key, $val;

    push @fragments, "$key=$val";
  }

  return join "&", @fragments;
}


sub _encode_json {
  my ($self, $data) = @_;

  # utf8-encoding is done in the view, so here we turn it off
  my $json_maker = JSON::MaybeXS->new(allow_blessed   => 1,
                                      convert_blessed => 1,
                                      utf8            => 0);
  return $json_maker->encode($data);
}


sub _mark_multicols_keys {
  my ($self, $data) = @_;

  if (my $sep = $self->datasource->schema->sql_abstract->multicols_sep) {
    # in case of multi-columns keys, the form needs to add special fields
    # and to ignore regular fields for those columns
    my $where = $self->context->req_data->{where} || {};
    my @multi_cols_keys = grep m[$sep], keys %$where;
    $data->{multi_cols_keys} = \@multi_cols_keys;
    $data->{ignore_col}{$_} = 1 foreach map {split m[$sep]} @multi_cols_keys;
  }
}


1;

__END__

=head1 NAME

App::AutoCRUD::Controller::Table - Table controller

=head1 DESCRIPTION

This controller provides methods for searching and describing
a given table within some datasource.

=head1 METHODS

=head2 serve

Entry point to the controller; from the URL, it extracts the table
name and the name of the method to dispatch to (the URL is expected
to be of shape C<< table/{table_name}/{$method_name}?{arguments} >>).
It also sets the default template to C<< table/{method_name}.tt >>.

=head2 descr

Returns a hashref describing the table, with keys C<descr>
(description information from the config), C<table> (table name),
C<colgroups> (datastructure as returned from
L<App::AutoCRUD::DataSource/colgroups>), and
C<primary_key> (arrayref of primary key columns).

=head2 list

Returns a list of records from the table, corresponding to the query
parameters specified in the URL.
[TODO: EXPLAIN MORE -- in particular the "-template" arg ]