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 });

__PACKAGE__->attr(cache => 1);
__PACKAGE__->attr(cache_method => sub {
    sub {
        my $self = shift;
        
        $self->{_cached} ||= {};
        
        if (@_ > 1) {
            $self->{_cached}{$_[0]} = $_[1] 
        }
        else {
            return $self->{_cached}{$_[0]}
        }
    }
});

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 disconnect {
    my $self = shift;
    
    # Disconnect
    my $ret = eval { $self->dbh->disconnect };
    croak $@ if $@;
    $self->dbh(undef);
    
    return $ret;
}

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

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

    # 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, %args) = @_;
    
    # 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 { shift->update(allow_update_all => 1, @_) };

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

sub delete {
    my ($self, %args) = @_;
    
    # 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 { shift->delete(allow_delete_all => 1, @_) }

our %VALID_SELECT_ARGS
  = map { $_ => 1 } qw/table column where append relation filter param/;

sub select {
    my ($self, %args) = @_;
    
    # 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    = $args{where} || {};
    my $relation = $args{relation};
    my $append   = $args{append};
    my $filter   = $args{filter};
    my $param    = $args{param} || {};
    
    # SQL template for select statement
    my $template = 'select ';
    
    # Column clause
    if (@$columns) {
        foreach my $column (@$columns) {
            $template .= "$column, ";
        }
        $template =~ s/, $/ /;
    }
    else {
        $template .= '* ';
    }
    
    # Table
    $template .= 'from ';
    foreach my $table (@$tables) {
        $template .= "$table, ";
    }
    $template =~ s/, $/ /;
    
    # Where clause
    my @where_keys = keys %$where;
    if (@where_keys) {
        $template .= 'where ';
        foreach my $where_key (@where_keys) {
            $template .= "{= $where_key} and ";
        }
    }
    $template =~ s/ and $//;
    
    # Relation
    if ($relation) {
        $template .= @where_keys ? "and " : "where ";
        foreach my $rkey (keys %$relation) {
            $template .= "$rkey = " . $relation->{$rkey} . " and ";
        }
    }
    $template =~ s/ and $//;
    
    # Append some statement
    $template .= " $append" if $append;
    
    # Execute query
    my $result = $self->execute($template, param  => $where, 
                                           filter => $filter);
    
    return $result;
}

sub create_query {
    my ($self, $template) = @_;
    
    # Create query from SQL template
    my $sql_template = $self->sql_template;
    
    my $cache = $self->cache;
    
    # Create query
    my $query;
    if ($cache) {
        
        # Cached query
        my $q = $self->cache_method->($self, $template);
        
        # Create query
        $query = DBIx::Custom::Query->new($q) if $q;
    }
    
    unless ($query) {
        
        # Create query
        $query = eval{$sql_template->create_query($template)};
        croak($@) if $@;
        
        # Cache query
        $self->cache_method->($self, $template,
                             {sql     => $query->sql, 
                              columns => $query->columns})
          if $cache;
    }
    
    # Prepare statement handle
    my $sth = eval {$self->dbh->prepare($query->{sql})};
    croak $@ if $@;
    
    # Set statement handle
    $query->sth($sth);
    
    return $query;
}

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

sub execute{
    my ($self, $query, %args)  = @_;
    
    # 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)};
    croak $@ if $@;
    
    # 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;
}

sub register_filter {
    my $invocant = shift;
    
    # Add filter
    my $filters = ref $_[0] eq 'HASH' ? $_[0] : {@_};
    $invocant->filters({%{$invocant->filters}, %$filters});
    
    return $invocant;
}

sub DESTROY {
    my $self = shift;
    
    # Disconnect
    $self->disconnect if $self->dbh;
}

=head1 NAME

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

=cut

our $VERSION = '0.1603';

=head1 STABILITY

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

=head1 SYNOPSYS
    
    # Connect
    my $dbi = DBIx::Custom->connect(data_source => "dbi:mysql:database=books",
                                    user => 'ken', password => '!LFKD%$&');
    
    # Disconnect
    $dbi->disconnect

    # 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'}
    );
    
    # Select(Join table)
    my $result = $dbi->select(
        table => ['books', 'rental'],
        column => ['books.name as book_name']
        relation => {'books.id' => 'rental.book_id'}
    );
    
    # 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'});

    # Create query and execute it
    my $query = $dbi->create_query(
        "select id from books where {= author} && {like title}"
    );
    $dbi->execute($query, param => {author => 'ken', title => '%Perl%'})
    
    # 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 DESCRIPTION

L<DBIx::Custom> is useful L<DBI> extention.
This module have hash parameter binding and filtering system.

Normally, binding parameter is array.
L<DBIx::Custom> enable you to pass binding parameter as hash.

This module also provide filtering system.
You can filter the binding parameter
or the value of fetching row.

And have useful method such as insert(), update(), delete(), and select().

=head2 Features

=over 4

=item 1. Hash parameter binding.

=item 2. Value filtering.

=item 3. Useful methos such as insert(), update(), delete(), and select().

=back

=head1 ATTRIBUTES

=head2 C<user>

Database user name.
    
    $dbi  = $dbi->user('Ken');
    $user = $dbi->user;
    
=head2 C<password>

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

=head2 C<data_source>

Database data source.
    
    $dbi         = $dbi->data_source("dbi:mysql:dbname=$database");
    $data_source = $dbi->data_source;
    
=head2 C<dbh>

Database handle. This is the innstance of L<DBI>
    
    $dbi = $dbi->dbh($dbh);
    $dbh = $dbi->dbh;

You can use all methods of L<DBI>

    my $sth    = $dbi->dbh->prepare("...");
    my $errstr = $dbi->dbh->errstr;
    
=head2 C<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 C<default_query_filter>

Default query filter.

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

=head2 C<default_fetch_filter>

Fetching filter.

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

=head2 C<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 C<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.

=head1 METHODS

This class is L<Object::Simple> subclass.
You can use all methods of L<Object::Simple>

=head2 C<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 C<disconnect>

Disconnect database.

    $dbi->disconnect;

If database is already disconnected, this method do nothing.

=head2 C<insert>

Insert row.

    $affected = $dbi->insert(table  => $table, 
                             param  => {%param},
                             append => $append,
                             filter => {%filter});

Retruned value is affected rows count.
    
Example:

    # insert
    $dbi->insert(table  => 'books', 
                 param  => {title => 'Perl', author => 'Taro'},
                 append => "some statement",
                 filter => {title => 'encode_utf8'})

=head2 C<update>

Update rows.

    $affected = $dbi->update(table  => $table, 
                             param  => {%params},
                             where  => {%where},
                             append => $append,
                             filter => {%filter})

Retruned 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 C<update_all>

Update all rows.

    $affected = $dbi->update_all(table  => $table, 
                                 param  => {%params},
                                 filter => {%filter},
                                 append => $append);

Retruned value is affected rows count.

Example:

    # update_all
    $dbi->update_all(table  => 'books', 
                     param  => {author => 'taro'},
                     filter => {author => 'encode_utf8'});

=head2 C<delete>

Delete rows.

    $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 C<delete_all>

Delete all rows.

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

Retruned value is affected rows count.

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

=head2 C<select>
    
Select rows.

    $result = $dbi->select(table    => $table,
                           column   => [@column],
                           where    => {%where},
                           append   => $append,
                           relation => {%relation},
                           filter   => {%filter});

Return value is the instance of L<DBIx::Custom::Result>.

Example:

    # select * from books;
    $result = $dbi->select(table => 'books');
    
    # select * from books where title = 'Perl';
    $result = $dbi->select(table => 'books', where => {title => 1});
    
    # select title, author from books where id = 1 for update;
    $result = $dbi->select(
        table  => 'books',
        column => ['title', 'author'],
        where  => {id => 1},
        appned => 'for update'
    );
    
    # select books.name as book_name from books, rental 
    # where books.id = rental.book_id;
    my $result = $dbi->select(
        table    => ['books', 'rental'],
        column   => ['books.name as book_name']
        relation => {'books.id' => 'rental.book_id'}
    );

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

Create the instance of L<DBIx::Custom::Query>. 
This receive the string written by SQL template.

=head2 C<execute>

    $result = $dbi->execute($query,    param => $params, filter => {%filter});
    $result = $dbi->execute($template, param => $params, filter => {%filter});

Execute the instace of L<DBIx::Custom::Query> or
the string written by SQL template.
Return value is the instance of L<DBIx::Custom::Result>.

B<Example:>

    $result = $dbi->execute("select * from authors where {= name} and {= age}", 
                            param => {name => 'taro', age => 19});
    
    while (my $row = $result->fetch) {
        # do something
    }

See also L<DBIx::Custom::SQLTemplate> to know how to write SQL template.

=head2 C<register_filter>

    $dbi->register_filter(%filters);
    
Resister filter.

B<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 C<cache>

    $dbi   = $dbi->cache(1);
    $cache = $dbi->cache;

Cache the result of parsing SQL template.
Default to 1.

=head2 C<cache_method>

    $dbi          = $dbi->cache_method(\&cache_method);
    $cache_method = $dbi->cache_method

Method for cache.

B<Example:>

    $dbi->cache_method(
        sub {
            my $self = shift;
            
            $self->{_cached} ||= {};
            
            if (@_ > 1) {
                $self->{_cached}{$_[0]} = $_[1] 
            }
            else {
                return $self->{_cached}{$_[0]}
            }
        }
    );

=head1 AUTHOR

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

=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