File Coverage

blib/lib/DataTables.pm

Criterion	Covered	Total	%
statement	135	209	64.5
branch	24	66	36.3
condition	9	31	29.0
subroutine	22	26	84.6
pod	10	11	90.9
total	200	343	58.3

package DataTables;

use 5.008008;
use strict;
use warnings;

use Carp;
use CGI::Simple;
use DBI;
use JSON::XS;
use SQL::Abstract::Limit;
use JQuery::DataTables::Request;

our $VERSION = '0.08';

# Preloaded methods go here.

sub new {
    my $invocant = shift;
    my $class   = ref($invocant) || $invocant;
    my $self = {
        tables  => undef,
        columns   => undef,
        dbh => undef,
        query => CGI::Simple->new,
        data_output_format => 'column-id', # or: key-value
        patterns  => {},
        join_clause  => '',
        where_clause  => '',
        @_,                 # Override previous attributes
    };
    return bless $self, $class;
}




sub tables {
    my $self = shift;

    if (@_) {
        my $a_ref = shift;
        croak "tables must be an array ref" unless UNIVERSAL::isa($a_ref,'ARRAY');
        $self->{tables} = $a_ref;
    }
    return $self->{tables};
}




sub columns {
    my $self = shift;

    if (@_) {
        my $ref = shift;
        croak "columns_a must be an array or hash ref" unless UNIVERSAL::isa($ref,'ARRAY') or UNIVERSAL::isa($ref,'HASH');
        $self->{columns} = $ref;
    }
    return $self->{columns};
}




sub dbh {
    my $self = shift;

    if (@_) {
        my $ref = shift;
        croak "dbh must be a DBI object" unless UNIVERSAL::can($ref,'prepare');
        $self->{dbh} = $ref;
    }
    return $self->{dbh};
}




sub data_output_format {
    my $self = shift;
    my $new_val = shift;

    if ($new_val) {
        if( $new_val ne 'column-id' and $new_val ne 'key-value' ) {
            croak "data_output_format must be one of: column-id, key-value; you sent: $new_val";
        }else{
            $self->{data_output_format} = $new_val;
        }
    }
    return $self->{data_output_format};
}




sub patterns {
    my $self = shift;

    if (@_) {
        my $h_ref = shift;
        croak "patterns must be a hash ref" unless UNIVERSAL::isa($h_ref,'HASH');
        $self->{patterns} = $h_ref;
    }
    return $self->{patterns};
}




sub join_clause {
    my $self = shift;

    if (@_) {
        $self->{join_clause} = shift;
    }
    return $self->{join_clause};
}




sub where_clause {
    my $self = shift;

    if (@_) {
        $self->{where_clause} = shift;
    }
    return $self->{where_clause};
}




sub _columns_arr {
    my $self = shift;
    my $aColumns;
    my $regular_columns;
    my $as_hash;
    my $tables_hash;

    if(UNIVERSAL::isa($self->columns,'HASH')) {
        my $columns = $self->columns;

        for my $key (sort {$a <=> $b} keys %{$columns}) { #here we sort by key so columns show in the same order as they on the page
            my $as_exists = undef;

            #if two keys, we assume user passed in AS as a key. We could check for as below in loop, but that limits users from having a column named AS
            if(scalar(keys %{$columns->{$key}} == 2) and exists $columns->{$key}->{'AS'}) {
                $as_exists = $columns->{$key}->{'AS'};
                delete $columns->{$key}->{'AS'};
            }

            while(my ($column,$table) = each %{$columns->{$key}}) {
                my $column_name = "$table.$column";
                push @{$aColumns}, $column_name;

                if($as_exists) {
                    $as_hash->{$column_name} = $as_exists if $as_exists; #add 'AS' value for this column if one exists
                    $column = $as_exists; # we want to change the column name to what it will be selected as out of database so we can do correct pattern matching
                }

                $tables_hash->{$table} = 1;
                push @{$regular_columns}, $column;
            }
        }

        my @tables = keys %$tables_hash;
        $self->tables(\@tables);
    }
    elsif(UNIVERSAL::isa($self->columns,'ARRAY')) {
        $aColumns = $self->columns;
        $regular_columns = $aColumns;
    }
    else {
        croak "columns must be a hash or an array ref";
    }

    return ($aColumns,$regular_columns,$as_hash);
}




sub print_json {
    my $self = shift;
    my $json = $self->json;

    print "Content-type: application/json\n\n";
    print $json;
}




sub table_data {
    my $self = shift;

    my %all_query_parameters = $self->_get_query_parameters();

    # may croak if client_params isn't recognized as containing DataTables parameters
    my $dt_req = $self->_create_datatables_request( \%all_query_parameters );

    # DB HANDLE
    my $dbh = $self->{dbh};
    croak "Database handle not defined" unless defined $dbh;

    #columns to use
    my ($aColumns,$regular_columns,undef) = $self->_columns_arr;

    # check table name(s)
    croak "Tables must be provided for the FROM clause" unless $self->tables;

    #filtering
    my $where_href = $self->_generate_where_clause($dt_req);

    #ordering
    my @order = $self->_generate_order_clause($dt_req);

    #paging
    my $limit = $dt_req->length || 10;
    my $offset = $dt_req->start || 0;

    #join
    if($self->join_clause ne '') {
        $where_href = $self->_add_where_clause($where_href, $self->join_clause);
    }

    #SQL queries
    my $sql = SQL::Abstract::Limit->new( limit_dialect => $dbh );

    my ($sQuery, @bind) = $sql->select($self->tables, $aColumns, $where_href, \@order, $limit, $offset );
    #die("SQL: " . $sQuery);

    #get columns out of db with query we created
    my $result_sth = $dbh->prepare($sQuery);
    $result_sth->execute(@bind) or croak "error in mysql query: $!\n$sQuery";

    # Data set length after filtering
    my ($sQuery_cnt_filtered, @bind_cnt_filtered) = $sql->select($self->tables, 'COUNT(*)', $where_href );

    my $sth_cnt_filtered = $dbh->prepare($sQuery_cnt_filtered);
    $sth_cnt_filtered->execute(@bind_cnt_filtered) or croak "mysql error: $!";

    my @aResultFilterTotal = $sth_cnt_filtered->fetchrow_array();
    my $iFilteredTotal = $aResultFilterTotal[0];


    my $num_tables = scalar(@{$self->tables});

    my ($sQuery_cnt_total, @bind_cnt_total) = $sql->select($self->tables, 'COUNT(*)');
    my $sth_cnt_total = $dbh->prepare($sQuery_cnt_total);
    $sth_cnt_total->execute() or croak "error in query: $!\n$sQuery";

    my @aResultTotal = $sth_cnt_total->fetchrow_array;
    my $iTotal = $aResultTotal[0];

    # output hash
    my %output = ();
    my $sEcho = $dt_req->draw;
    my $version = $dt_req->version( \%all_query_parameters );

    my $data_key_name = 'aaData'; # defaults to v1.9

    if( $version eq '1.10' ) {
        # new interface

        $data_key_name = 'data';
        %output = (
            "draw" => int($sEcho),
            "recordsTotal" => int($iTotal),
            "recordsFiltered" => int($iFilteredTotal),
            $data_key_name => [],
        );

    }else{
        # old interface

        $data_key_name = 'aaData';
        %output = (
            "sEcho" => int($sEcho),
            "iTotalRecords" => int($iTotal),
            "iTotalDisplayRecords" => int($iFilteredTotal),
            $data_key_name => [],
        );

    }

    my $count = 0;
    my $patterns = $self->patterns;

    while(my @aRow = $result_sth->fetchrow_array) {
        my @row = ();
        for (my $i = 0; $i < @$aColumns; $i++) {
            my $pat_name = $regular_columns->[$i]; #get out the name that would be used in the pattern
            my $val = $aRow[$i];

            # apply user specified pattern for this column if one exists
            if(exists $patterns->{$pat_name}) {
                my $pattern = $patterns->{$pat_name};
                $pattern =~ s/\[\%\s$pat_name\s\%\]/$val/g;
                $val = $pattern;
            }

            push @row, $val;
        }

        if( $self->data_output_format eq 'column-id' ) {
            @{$output{$data_key_name}}[$count] = [@row];
        }else{
            my %row = map { $aColumns->[$_] => $row[$_] } 0 .. $#row;
            push @{$output{$data_key_name}}, \%row;
        }

        $count++;
    }

    return \%output;
} # /table_data




sub json {
    my $self = shift;

    my $output_href = $self->table_data;

    return encode_json $output_href;
} # /json




sub _create_datatables_request {
    my $self = shift;
    my $query_params = shift;
    return JQuery::DataTables::Request->new( client_params => $query_params );
}




sub _generate_where_clause {
    my $self = shift;
    my $dt_req = shift;

    my ($aColumns,undef,undef) = $self->_columns_arr;

    my $where_href = {};

    if( $dt_req->search && defined $dt_req->search->{value} ) {
        my $search_string = $dt_req->search->{value}; # the global search value

        # XXX: maybe use $dt_req->columns()?
		for( my $i = 0; $i < @$aColumns; $i++ ) {
			# Iterate over each column and check if it is searchable.
			# If so, add a constraint to the where clause restricting the given
			# column. In the query, the column is identified by it's index, we
			# need to translates the index to the column name.
			if ( defined $dt_req->column($i) and $dt_req->column($i)->{searchable} ) {
                # XXX: maybe use $dt_req->column($i)->{name}?
                my $column = $aColumns->[$i];
				push @{$where_href->{'-or'}}, { $column => {-like => '%'.$search_string.'%' } };
            }
		}
	}

    # XXX: merge with previous loop
    #individual column filtering
    for (my $i = 0; $i < @$aColumns; $i++) {
        if( defined $dt_req->column($i) and $dt_req->column($i)->{searchable}
           and ($dt_req->column($i)->{search}->{value} and $dt_req->column($i)->{search}->{value} ne '') ) {
            my $individual_column_search = $dt_req->column($i)->{search}->{value};
            $where_href->{$aColumns->[$i]} = {-like => '%'.$individual_column_search.'%'};
        }
    }

    # add user where if given
    if( $self->where_clause ) {
        $where_href = $self->_add_where_clause($where_href, $self->where_clause);
    }

    return $where_href;
} # /_generate_where_clause




#
# convert
# \%where = {key => value, -or => \@ }
# to
# \%where = {-and => [{key => value, -or => \@ }, $plus]}
#
# $plus can be a hashref for SQL::Abstract.
# $plus can also be scalarref (deprecated).
#

sub _add_where_clause {
    my $self = shift;
    my $existing_clauses_href = shift or croak('Missing where clause');
    my $new_clause = shift;

    return $existing_clauses_href unless $new_clause;

    if( UNIVERSAL::isa($new_clause, 'HASH') ) {
        return {
            -and => [
                $existing_clauses_href,
                $new_clause,
            ],
        };
    }

    # Add arbitrary WHERE clause. This might be dangerous.
    return {
        -and => [
            $existing_clauses_href,
            \$new_clause
        ],
    };
} # /_add_where_clause




sub _generate_order_clause {
    my $self = shift;
    my $dt_req = shift;

    my ($aColumns,undef,undef) = $self->_columns_arr;

    my @order = ();

    foreach my $order_instruction ( @{$dt_req->orders()} ) {

        # build direction, must be '-asc' or '-desc' (cf. SQL::Abstract)
        # we only get 'asc' or 'desc', so they have to be prefixed with '-'
        my $sortable_column_nr = $order_instruction->{column};
        my $direction =  '-' . $order_instruction->{dir};

        # We only get the column index (starting from 0), so we have to
        # translate the index into a column name.
        my $column_name = $aColumns->[$sortable_column_nr];
        push @order, { $direction => $column_name };

    }

    return @order;
} # /_generate_order_clause




sub _get_query_parameters {
    my $self = shift;

    # CGI OBJECT
    my $q = $self->{query};

    # TODO: available from Perl 5.20.0: get multiple key-value pairs in 1 request, e.g. my %new_hash = %hash{qw/a b/};
    # XXX: encapsulate to make testing easier (re-use the encapsulated method in tests instead of custom code)
    my %all_query_parameters = $q->Vars;

    return %all_query_parameters;
} # /_get_query_parameters

1; # /DataTables

__END__