package DBIx::Custom;

use strict;

use warnings;

use base 'Object::Simple';

use Carp 'croak';

use DBI;

use DBIx::Custom::Result;

use DBIx::Custom::SQLTemplate;

use DBIx::Custom::Query;

use Encode qw/encode_utf8 decode_utf8/;

__PACKAGE__->attr('dbh');

__PACKAGE__->attr([qw/user password data_source/]);

__PACKAGE__->attr([qw/default_query_filter default_fetch_filter/]);

__PACKAGE__->dual_attr('filters', default => sub { {} },

                                  inherit => 'hash_copy');

__PACKAGE__->register_filter(

    encode_utf8 => sub { encode_utf8($_[0]) },

    decode_utf8 => sub { decode_utf8($_[0]) }

);

__PACKAGE__->attr(result_class => 'DBIx::Custom::Result');

__PACKAGE__->attr(sql_template => sub { DBIx::Custom::SQLTemplate->new });

sub register_filter {

    my $invocant = shift;

    # Add filter

    my $filters = ref $_[0] eq 'HASH' ? $_[0] : {@_};

    $invocant->filters({%{$invocant->filters}, %$filters});

    return $invocant;

}

sub auto_commit {

    my $self = shift;

    # Not connected

    croak("Not yet connect to database") unless $self->connected;

    if (@_) {

        # Set AutoCommit

        $self->dbh->{AutoCommit} = $_[0];

        return $self;

    }

    return $self->dbh->{AutoCommit};

}

sub connect {

    my $proto = shift;

    # Create

    my $self = ref $proto ? $proto : $proto->new(@_);

    # Information

    my $data_source = $self->data_source;

    my $user        = $self->user;

    my $password    = $self->password;

    # Connect

    my $dbh = eval{DBI->connect(

        $data_source,

        $user,

        $password,

        {

            RaiseError => 1,

            PrintError => 0,

            AutoCommit => 1,

        }

    )};

    # Connect error

    croak $@ if $@;

    # Database handle

    $self->dbh($dbh);

    return $self;

}

sub DESTROY {

    my $self = shift;

    # Disconnect

    $self->disconnect if $self->connected;

}

sub connected { ref shift->{dbh} eq 'DBI::db' }

sub disconnect {

    my $self = shift;

    if ($self->connected) {

        # Disconnect

        $self->dbh->disconnect;

        delete $self->{dbh};

    }

    return $self;

}

sub reconnect {

    my $self = shift;

    # Reconnect

    $self->disconnect if $self->connected;

    $self->connect;

    return $self;

}

sub create_query {

    my ($self, $template) = @_;

    # Create query from SQL template

    my $sql_template = $self->sql_template;

    # Get cached query

    my $cache = $self->{_cache}->{"$template"};

    # Create query

    my $query;

    if ($cache) {

        $query = DBIx::Custom::Query->new(

            sql       => $cache->sql,

            columns   => $cache->columns

        );

    }

    else {

        $query = eval{$sql_template->create_query($template)};

        croak($@) if $@;

        $self->{_cache}->{$template} = $query

          unless $self->{_cache};

    }

    # Prepare statement handle

    my $sth = $self->dbh->prepare($query->{sql});

    # Set statement handle

    $query->sth($sth);

    return $query;

}

our %VALID_EXECUTE_ARGS = map { $_ => 1 } qw/param filter/;

sub execute{

    my $self  = shift;

    my $query = shift;

    # Arguments

    my $args = ref $_[0] eq 'HASH' ? $_[0] : {@_};

    # Check arguments

    foreach my $name (keys %$args) {

        croak "\"$name\" is invalid name"

          unless $VALID_EXECUTE_ARGS{$name};

    }

    my $params = $args->{param} || {};

    # First argument is SQL template

    unless (ref $query eq 'DBIx::Custom::Query') {

        my $template;

        if (ref $query eq 'ARRAY') {

            $template = $query->[0];

        }

        else { $template = $query }

        $query = $self->create_query($template);

    }

    my $filter = $args->{filter} || $query->filter || {};

    # Create bind value

    my $bind_values = $self->_build_bind_values($query, $params, $filter);

    # Execute

    my $sth      = $query->sth;

    my $affected = eval{$sth->execute(@$bind_values)};

    # Execute error

    if (my $execute_error = $@) {

        require Data::Dumper;

        my $sql              = $query->{sql} || '';

        my $params_dump      = Data::Dumper->Dump([$params], ['*params']);

        croak("$execute_error" . 

              "<Your SQL>\n$sql\n" . 

              "<Your parameters>\n$params_dump");

    }

    # Return resultset if select statement is executed

    if ($sth->{NUM_OF_FIELDS}) {

        # Get result class

        my $result_class = $self->result_class;

        # Create result

        my $result = $result_class->new({

            sth             => $sth,

            default_filter  => $self->default_fetch_filter,

            filters         => $self->filters

        });

        return $result;

    }

    return $affected;

}

sub _build_bind_values {

    my ($self, $query, $params, $filter) = @_;

    # binding values

    my @bind_values;

    # Build bind values

    my $count = {};

    foreach my $column (@{$query->columns}) {

        croak "\"$column\" is not exists in params"

          unless exists $params->{$column};

        # Value

        my $value = ref $params->{$column} eq 'ARRAY'

                  ? $params->{$column}->[$count->{$column} || 0]

                  : $params->{$column};

        # Filter

        $filter ||= {};

        # Filter name

        my $fname = $filter->{$column} || $self->default_query_filter || '';

        my $filter_func;

        if ($fname) {

            if (ref $fname eq 'CODE') {

                $filter_func = $fname;

            }

            else {

                my $filters = $self->filters;

                croak "Not exists filter \"$fname\"" unless exists $filters->{$fname};

                $filter_func = $filters->{$fname};

            }            

        }

        push @bind_values, $filter_func

                         ? $filter_func->($value)

                         : $value;

        # Count up 

        $count->{$column}++;

    }

    return \@bind_values;

}

our %VALID_INSERT_ARGS = map { $_ => 1 } qw/table param append filter/;

sub insert {

    my $self = shift;

    # Arguments

    my $args = ref $_[0] eq 'HASH' ? $_[0] : {@_};

    # Check arguments

    foreach my $name (keys %$args) {

        croak "\"$name\" is invalid name"

          unless $VALID_INSERT_ARGS{$name};

    }

    # Arguments

    my $table  = $args->{table} || '';

    my $param  = $args->{param} || {};

    my $append = $args->{append} || '';

    my $filter = $args->{filter};

    # Insert keys

    my @insert_keys = keys %$param;

    # Not exists insert keys

    croak("Key-value pairs for insert must be specified to 'insert' second argument")

      unless @insert_keys;

    # Templte for insert

    my $template = "insert into $table {insert " . join(' ', @insert_keys) . '}';

    $template .= " $append" if $append;

    # Execute query

    my $ret_val = $self->execute($template, param  => $param, 

                                            filter => $filter);

    return $ret_val;

}

our %VALID_UPDATE_ARGS

  = map { $_ => 1 } qw/table param where append filter allow_update_all/;

sub update {

    my $self = shift;

    my $args = ref $_[0] eq 'HASH' ? $_[0] : {@_};

    # Check arguments

    foreach my $name (keys %$args) {

        croak "\"$name\" is invalid name"

          unless $VALID_UPDATE_ARGS{$name};

    }

    # Arguments

    my $table            = $args->{table} || '';

    my $param            = $args->{param} || {};

    my $where            = $args->{where} || {};

    my $append_statement = $args->{append} || '';

    my $filter           = $args->{filter};

    my $allow_update_all = $args->{allow_update_all};

    # Update keys

    my @update_keys = keys %$param;

    # Not exists update kyes

    croak("Key-value pairs for update must be specified to 'update' second argument")

      unless @update_keys;

    # Where keys

    my @where_keys = keys %$where;

    # Not exists where keys

    croak("Key-value pairs for where clause must be specified to 'update' third argument")

      if !@where_keys && !$allow_update_all;

    # Update clause

    my $update_clause = '{update ' . join(' ', @update_keys) . '}';

    # Where clause

    my $where_clause = '';

    my $new_where = {};

    if (@where_keys) {

        $where_clause = 'where ';

        foreach my $where_key (@where_keys) {

            $where_clause .= "{= $where_key} and ";

        }

        $where_clause =~ s/ and $//;

    }

    # Template for update

    my $template = "update $table $update_clause $where_clause";

    $template .= " $append_statement" if $append_statement;

    # Rearrange parammeters

    foreach my $wkey (@where_keys) {

        if (exists $param->{$wkey}) {

            $param->{$wkey} = [$param->{$wkey}]

              unless ref $param->{$wkey} eq 'ARRAY';

            push @{$param->{$wkey}}, $where->{$wkey};

        }

        else {

            $param->{$wkey} = $where->{$wkey};

        }

    }

    # Execute query

    my $ret_val = $self->execute($template, param  => $param, 

                                            filter => $filter);

    return $ret_val;

}

sub update_all {

    my $self = shift;;

    # Arguments

    my $args = ref $_[0] eq 'HASH' ? $_[0] : {@_};

    # Allow all update

    $args->{allow_update_all} = 1;

    # Update all rows

    return $self->update($args);

}

our %VALID_DELETE_ARGS

  = map { $_ => 1 } qw/table where append filter allow_delete_all/;

sub delete {

    my $self = shift;

    # Arguments

    my $args = ref $_[0] eq 'HASH' ? $_[0] : {@_};

    # Check arguments

    foreach my $name (keys %$args) {

        croak "\"$name\" is invalid name"

          unless $VALID_DELETE_ARGS{$name};

    }

    # Arguments

    my $table            = $args->{table} || '';

    my $where            = $args->{where} || {};

    my $append_statement = $args->{append};

    my $filter           = $args->{filter};

    my $allow_delete_all = $args->{allow_delete_all};

    # Where keys

    my @where_keys = keys %$where;

    # Not exists where keys

    croak("Key-value pairs for where clause must be specified to 'delete' second argument")

      if !@where_keys && !$allow_delete_all;

    # Where clause

    my $where_clause = '';

    if (@where_keys) {

        $where_clause = 'where ';

        foreach my $wkey (@where_keys) {

            $where_clause .= "{= $wkey} and ";

        }

        $where_clause =~ s/ and $//;

    }

    # Template for delete

    my $template = "delete from $table $where_clause";

    $template .= " $append_statement" if $append_statement;

    # Execute query

    my $ret_val = $self->execute($template, param  => $where, 

                                            filter => $filter);

    return $ret_val;

}

sub delete_all {

    my $self = shift;

    # Arguments

    my $args = ref $_[0] eq 'HASH' ? $_[0] : {@_};

    # Allow all delete

    $args->{allow_delete_all} = 1;

    # Delete all rows

    return $self->delete($args);

}

our %VALID_SELECT_ARGS

  = map { $_ => 1 } qw/table column where append filter/;

sub select {

    my $self = shift;;

    my $args = ref $_[0] eq 'HASH' ? $_[0] : {@_};

    # Check arguments

    foreach my $name (keys %$args) {

        croak "\"$name\" is invalid name"

          unless $VALID_SELECT_ARGS{$name};

    }

    # Arguments

    my $tables = $args->{table} || [];

    $tables = [$tables] unless ref $tables eq 'ARRAY';

    my $columns          = $args->{column} || [];

    my $where_params     = $args->{where} || {};

    my $append_statement = $args->{append} || '';

    my $filter    = $args->{filter};

    # SQL template for select statement

    my $template = 'select ';

    # Join column clause

    if (@$columns) {

        foreach my $column (@$columns) {

            $template .= "$column, ";

        }

        $template =~ s/, $/ /;

    }

    else {

        $template .= '* ';

    }

    # Join table

    $template .= 'from ';

    foreach my $table (@$tables) {

        $template .= "$table, ";

    }

    $template =~ s/, $/ /;

    # Where clause keys

    my @where_keys = keys %$where_params;

    # Join where clause

    if (@where_keys) {

        $template .= 'where ';

        foreach my $where_key (@where_keys) {

            $template .= "{= $where_key} and ";

        }

    }

    $template =~ s/ and $//;

    # Append something to last of statement

    if ($append_statement =~ s/^where //) {

        if (@where_keys) {

            $template .= " and $append_statement";

        }

        else {

            $template .= " where $append_statement";

        }

    }

    else {

        $template .= " $append_statement";

    }

    # Execute query

    my $result = $self->execute($template, param  => $where_params, 

                                           filter => $filter);

    return $result;

}

=head1 NAME

DBIx::Custom - DBI with hash parameter binding and filtering system

=head1 VERSION

Version 0.1502

=cut

our $VERSION = '0.1502';

$VERSION = eval $VERSION;

=head1 STATE

This module is not stable. Method name and functionality will be change.

=head1 SYNOPSYS

    # Connect

    my $dbi = DBIx::Custom->connect(data_source => "dbi:mysql:database=books",

                                    user => 'ken', password => '!LFKD%$&');

    # Insert 

    $dbi->insert(table  => 'books',

                 param  => {title => 'perl', author => 'Ken'},

                 filter => {title => 'encode_utf8'});

    # Update 

    $dbi->update(table  => 'books', 

                 param  => {title => 'aaa', author => 'Ken'}, 

                 where  => {id => 5},

                 filter => {title => 'encode_utf8'});

    # Update all

    $dbi->update_all(table  => 'books',

                     param  => {title => 'aaa'},

                     filter => {title => 'encode_utf8'});

    # Delete

    $dbi->delete(table  => 'books',

                 where  => {author => 'Ken'},

                 filter => {title => 'encode_utf8'});

    # Delete all

    $dbi->delete_all(table => 'books');

    # Select

    my $result = $dbi->select(table => 'books');

    # Select(more complex)

    my $result = $dbi->select(

        table  => 'books',

        column => [qw/author title/],

        where  => {author => 'Ken'},

        append => 'order by id limit 1',

        filter => {tilte => 'encode_utf8'}

    );

    # Execute SQL

    $dbi->execute("select title from books");

    # Execute SQL with parameters and filter

    $dbi->execute("select id from books where {= author} && {like title}",

                  param  => {author => 'ken', title => '%Perl%'},

                  filter => {tilte => 'encode_utf8'});

    # Default filter

    $dbi->default_query_filter('encode_utf8');

    $dbi->default_fetch_filter('decode_utf8');

    # Fetch

    while (my $row = $result->fetch) {

        # ...

    }

    # Fetch hash

    while (my $row = $result->fetch_hash) {

    }

    # DBI instance

    my $dbh = $dbi->dbh;

=head1 ATTRIBUTES

=head2 user

Database user name.

    $dbi  = $dbi->user('Ken');

    $user = $dbi->user;

=head2 password

Database password.

    $dbi      = $dbi->password('lkj&le`@s');

    $password = $dbi->password;

=head2 data_source

Database data source.

    $dbi         = $dbi->data_source("dbi:mysql:dbname=$database");

    $data_source = $dbi->data_source;

If you know data source more, See also L<DBI>.

=head2 sql_template

SQLTemplate instance. sql_template attribute must be 

the instance of L<DBIx::Cutom::SQLTemplate> subclass.

    $dbi          = $dbi->sql_template(DBIx::Cutom::SQLTemplate->new);

    $sql_template = $dbi->sql_template;

the instance of DBIx::Cutom::SQLTemplate is set to 

this attribute by default.

=head2 filters

Filters

    $dbi     = $dbi->filters({%filters});

    $filters = $dbi->filters;

encode_utf8 and decode_utf8 is set to this attribute by default.

    $encode_utf8 = $dbi->filters->{encode_utf8};

    $decode_utf8 = $dbi->filters->{decode_utf8};

=head2 default_query_filter

Default query filter.

    $dbi                  = $dbi->default_query_filter('encode_utf8');

    $default_query_filter = $dbi->default_query_filter

=head2 default_fetch_filter

Fetching filter.

    $dbi                  = $dbi->default_fetch_filter('decode_utf8');

    $default_fetch_filter = $dbi->default_fetch_filter;

=head2 result_class

Result class.

    $dbi          = $dbi->result_class('DBIx::Custom::Result');

    $result_class = $dbi->result_class;

L<DBIx::Custom::Result> is set to this attribute by default.

=head2 dbh

Database handle.

    $dbi = $dbi->dbh($dbh);

    $dbh = $dbi->dbh;

=head1 METHODS

This class is L<Object::Simple> subclass.

You can use all methods of L<Object::Simple>

=head2 auto_commit

Auto commit.

    $self        = $dbi->auto_commit(1);

    $auto_commit = $dbi->auto_commit;

This is equal to

    $dbi->dbh->{AutoCommit} = 1;

    $auto_commit = $dbi->dbh->{AutoCommit};

=head2 connect

Connect to database.

    my $dbi = DBIx::Custom->connect(data_source => "dbi:mysql:database=books",

                                    user => 'ken', password => '!LFKD%$&');

"AutoCommit" and "RaiseError" option is true, 

and "PrintError" option is false by dfault.

=head2 disconnect

Disconnect database.

    $dbi->disconnect;

If database is already disconnected, this method do nothing.

=head2 reconnect

Reconnect to database.

    $dbi->reconnect;

=head2 connected

Check if database is connected.

    $is_connected = $dbi->connected;

=head2 register_filter

Resister filter.

    $dbi->register_filter(%filters);

Example.

    $dbi->register_filter(

        encode_utf8 => sub {

            my $value = shift;

            require Encode;

            return Encode::encode('UTF-8', $value);

        },

        decode_utf8 => sub {

            my $value = shift;

            require Encode;

            return Encode::decode('UTF-8', $value)

        }

    );

=head2 create_query

Create Query instance parsing SQL template

    my $query = $dbi->create_query("select * from authors where {= name} and {= age}");

$query is <DBIx::Query> instance. This is executed by query method as the following

    $dbi->execute($query, $params);

If you know SQL template, see also L<DBIx::Custom::SQLTemplate>.

=head2 execute

Query

    $result = $dbi->execute($template, $params);

The following is query example

    $result = $dbi->execute("select * from authors where {= name} and {= age}", 

                            {name => 'taro', age => 19});

    while (my @row = $result->fetch) {

        # do something

    }

If you now syntax of template, See also L<DBIx::Custom::SQLTemplate>

execute() return L<DBIx::Custom::Result> instance

=head2 insert

Insert row

    $affected = $dbi->insert(table  => $table, 

                             param  => {%param},

                             append => $append,

                             filter => {%filter});

Retrun value is affected rows count

Example

    # insert

    $dbi->insert(table  => 'books', 

                 param  => {title => 'Perl', author => 'Taro'},

                 append => "some statement",

                 filter => {title => 'encode_utf8'})

=head2 update

Update rows

    $affected = $dbi->update(table  => $table, 

                             param  => {%params},

                             where  => {%where},

                             append => $append,

                             filter => {%filter})

Retrun value is affected rows count

Example

    #update

    $dbi->update(table  => 'books',

                 param  => {title => 'Perl', author => 'Taro'},

                 where  => {id => 5},

                 append => "some statement",

                 filter => {title => 'encode_utf8'})

=head2 update_all

Update all rows

    $affected = $dbi->update_all(table  => $table, 

                                 param  => {%params},

                                 filter => {%filter},

                                 append => $append);

Retrun value is affected rows count

Example

    # update_all

    $dbi->update_all(table  => 'books', 

                     param  => {author => 'taro'},

                     filter => {author => 'encode_utf8'});

=head2 delete

Delete rows

    # delete

    $affected = $dbi->delete(table  => $table,

                             where  => {%where},

                             append => $append

                             filter => {%filter});

Retrun value is affected rows count

Example

    # delete

    $dbi->delete(table  => 'books',

                 where  => {id => 5},

                 append => 'some statement',

                 filter => {id => 'encode_utf8');

=head2 delete_all

Delete all rows

    $affected = $dbi->delete_all(table => $table);

Retrun value is affected rows count

Example

    # delete_all

    $dbi->delete_all('books');

=head2 select

Select rows

    $result = $dbi->select(table  => $table,

                           column => [@column],

                           where  => {%where},

                           append => $append,

                           filter => {%filter});

$reslt is L<DBIx::Custom::Result> instance

The following is some select examples

    # select

    $result = $dbi->select('books');

    # select * from books where title = 'Perl';

    $result = $dbi->select('books', {title => 1});

    # select title, author from books where id = 1 for update;

    $result = $dbi->select(

        table  => 'books',

        where  => ['title', 'author'],

        where  => {id => 1},

        appned => 'for update'

    );

You can join multi tables

    $result = $dbi->select(

        ['table1', 'table2'],                # tables

        ['table1.id as table1_id', 'title'], # columns (alias is ok)

        {table1.id => 1},                    # where clase

        "where table1.id = table2.id",       # join clause (must start 'where')

    );

=head1 AUTHOR

Yuki Kimoto, C<< <kimoto.yuki at gmail.com> >>

Github L<http://github.com/yuki-kimoto>

I develope this module L<http://github.com/yuki-kimoto/DBIx-Custom>

=head1 COPYRIGHT & LICENSE

Copyright 2009 Yuki Kimoto, all rights reserved.

This program is free software; you can redistribute it and/or modify it

under the same terms as Perl itself.

=cut