@@ -10,6 +10,9 @@ my $builder = Module::Build->new(

     build_requires => {

         'Test::More' => 0,

     },

+    requires => {

+        'Object::Simple' => 0.0602,

+    },

     add_to_cleanup      => [ 'DBI-Custom-*' ],

     create_makefile_pl => 'traditional',

 );

@@ -5,64 +5,62 @@ our $VERSION = '0.0101';

 use Carp 'croak';

 use DBI;

+use DBI::Custom::SQL::Template;

+

+### Class-Object Accessors

+sub connect_info : ClassObjectAttr { type => 'hash',  auto_build => sub {

+    shift->Object::Simple::initialize_class_object_attr(

+        default => sub { {} }, clone => sub {

+            my $value = shift;

+            my $new_value = \%{$value || {}};

+            $new_value->{options} = $value->{options} if $value->{options};

+            return $new_value;

+        }

+    )

+}}

-# Model

-sub prototype : ClassAttr { auto_build => sub {

-    my $class = shift;

-    my $super = do {

-        no strict 'refs';

-        ${"${class}::ISA"}[0];

-    };

-    my $prototype = eval{$super->can('prototype')}

-                         ? $super->prototype->clone

-                         : $class->Object::Simple::new;

-    

-    $class->prototype(bless $prototype, $class);

+sub bind_filter  : ClassObjectAttr { auto_build => sub {

+    shift->Object::Simple::initialize_class_object_attr(clone => 'scalar')

+}}

+sub fetch_filter : ClassObjectAttr { auto_build => sub {

+    shift->Object::Simple::initialize_class_object_attr(clone => 'scalar')

 }}

-# New

-sub new {

-    my $invocant = shift;

-    my $class = ref $invocant || $invocant;

-    my $prototype = $class->prototype;

-    my $self = $class->Object::Simple::new(%{$prototype->clone}, @_);

-    return bless $self, $class;

-}

+sub filters : ClassObjectAttr { type => 'hash', deref => 1, auto_build => sub {

+    shift->Object::Simple::initialize_class_object_attr(clone => 'hash')

+}}

-# Clone

-sub clone {

-    my $self = shift;

-    my $new = $self->Object::Simple::new;

-    

-    # Scalar copy

-    foreach my $attr (qw/bind_filter fetch_filter result_class/) {

-        $new->$attr($self->$attr);

-    }

-    

-    # Hash ref copy

-    foreach my $attr (qw/connect_info filters valid_connect_info/) {

-        $new->$attr(\%{$self->$attr || {}});

-    }

-    

-    # Other

-    $new->connect_info->{options} = \%{$self->connect_info->{options}};

-    $new->sql_template($self->sql_template->clone);

-}

+sub result_class : ClassObjectAttr { auto_build => sub {

+    shift->Object::Simple::initialize_class_object_attr(clone => 'scalar')

+}}

-# Attribute

-sub connect_info : Attr { type => 'hash',  default => sub { {} } }

-sub bind_filter  : Attr {}

-sub fetch_filter : Attr {}

+sub sql_template : ClassObjectAttr { auto_build => sub {

+    shift->Object::Simple::initialize_class_object_attr(

+        clone   => sub {my $value = shift; $value ? $value->clone : undef},

+        default => sub { DBI::Custom::SQL::Template->new }

+    )

+}}

-sub filters : Attr { type => 'hash', deref => 1, default => sub { {} } }

-sub add_filter { shift->filters(@_) }

+sub valid_connect_info : ClassObjectAttr { type => 'hash', deref => 1, auto_build => sub {

+    shift->Object::Simple::initialize_class_object_attr(

+        default => sub { return {map {$_ => 1} qw/data_source user password options/} },

+        clone => 'hash'

+    )

+}}

-sub result_class : Attr { default => 'DBI::Custom::Result' }

+### Object Accessor

 sub dbh          : Attr {}

-sub sql_template : Attr { default => sub { DBI::Custom::SQL::Template->new } }

-sub valid_connect_info : Attr { type => 'hash', deref => 1, default => sub {

-    return {map {$_ => 1} qw/data_source user password options/}

-}}

+

+

+### Methods

+# Add filter

+sub add_filter {

+    my $invocant = shift;

+    

+    my %old_filters = $invocant->filters;

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

+    $invocant->filters(%old_filters, %new_filters);

+}

 # Auto commit

 sub auto_commit {

@@ -104,6 +102,7 @@ sub connect {

     return $self;

 }

+# DESTROY

 sub DESTROY {

     my $self = shift;

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

@@ -223,404 +222,6 @@ sub query_raw_sql {

 Object::Simple->build_class;

-

-package DBI::Custom::Result;

-use Object::Simple;

-

-# Attributes

-sub sth          : Attr {}

-sub fetch_filter : Attr {}

-

-

-# Fetch (array)

-sub fetch {

-    my ($self, $type) = @_;

-    my $sth = $self->sth;

-    my $fetch_filter = $self->fetch_filter;

-    

-    # Fetch

-    my $row = $sth->fetchrow_arrayref;

-    

-    # Cannot fetch

-    return unless $row;

-    

-    # Filter

-    if ($fetch_filter) {

-        my $keys  = $sth->{NAME_lc};

-        my $types = $sth->{TYPE};

-        for (my $i = 0; $i < @$keys; $i++) {

-            $row->[$i]= $fetch_filter->($keys->[$i], $row->[$i], $types->[$i],

-                                        $sth, $i);

-        }

-    }

-    return wantarray ? @$row : $row;

-}

-

-# Fetch (hash)

-sub fetch_hash {

-    my $self = shift;

-    my $sth = $self->sth;

-    my $fetch_filter = $self->fetch_filter;

-    

-    # Fetch

-    my $row = $sth->fetchrow_arrayref;

-    

-    # Cannot fetch

-    return unless $row;

-    

-    # Keys

-    my $keys  = $sth->{NAME_lc};

-    

-    # Filter

-    my $row_hash = {};

-    if ($fetch_filter) {

-        my $types = $sth->{TYPE};

-        for (my $i = 0; $i < @$keys; $i++) {

-            $row_hash->{$keys->[$i]} = $fetch_filter->($keys->[$i], $row->[$i],

-                                                       $types->[$i], $sth, $i);

-        }

-    }

-    

-    # No filter

-    else {

-        for (my $i = 0; $i < @$keys; $i++) {

-            $row_hash->{$keys->[$i]} = $row->[$i];

-        }

-    }

-    return wantarray ? %$row_hash : $row_hash;

-}

-

-# Fetch all (array)

-sub fetch_all {

-    my $self = shift;

-    

-    my $rows = [];

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

-        push @$rows, [@row];

-    }

-    return wantarray ? @$rows : $rows;

-}

-

-# Fetch all (hash)

-sub fetch_all_hash {

-    my $self = shift;

-    

-    my $rows = [];

-    while(my %row = $self->fetch_hash) {

-        push @$rows, {%row};

-    }

-    return wantarray ? @$rows : $rows;

-}

-

-# Finish

-sub finish { shift->sth->finish }

-

-# Error

-sub error { 

-    my $self = shift;

-    my $sth  = $self->sth;

-    return wantarray ? ($sth->errstr, $sth->err, $sth->state) : $sth->errstr;

-}

-

-Object::Simple->build_class;

-

-

-package DBI::Custom::SQL::Template;

-use Object::Simple;

-use Carp 'croak';

-

-# Clone

-sub clone {

-    my $self = shift;

-    my $new = $self->Object::Simple::new;

-    

-    # Scalar copy

-    foreach my $attr (qw/tag_start tag_end bind_filter upper_case tag_syntax template/) {

-        $new->$attr($self->$attr);

-    }

-    

-    # Hash ref copy

-    foreach my $attr (qw/tag_processors/) {

-        $new->$attr(\%{$self->$attr || {}});

-    }

-    

-    # Other

-    $new->tree([]);

-    

-    return $new;

-}

-

-

-### Attributes;

-sub tag_start   : Attr { default => '{' }

-sub tag_end     : Attr { default => '}' }

-sub template    : Attr {};

-sub tree        : Attr { default => sub { [] } }

-sub bind_filter : Attr {}

-sub upper_case  : Attr {default => 0}

-

-sub tag_syntax : Attr { default => <<'EOS' };

-{? name}         ?

-{= name}         name = ?

-{<> name}        name <> ?

-

-{< name}         name < ?

-{> name}         name > ?

-{>= name}        name >= ?

-{<= name}        name <= ?

-

-{like name}      name like ?

-{in name}        name in [?, ?, ..]

-

-{insert_values}  (key1, key2, key3) values (?, ?, ?)

-{update_values}  set key1 = ?, key2 = ?, key3 = ?

-EOS

-

-sub tag_processors : Attr {type => 'hash', deref => 1, auto_build => sub { 

-    shift->tag_processors(

-        '?'             => \&DBI::Custom::SQL::Template::TagProcessor::expand_place_holder,

-        '='             => \&DBI::Custom::SQL::Template::TagProcessor::expand_place_holder,

-        '<>'            => \&DBI::Custom::SQL::Template::TagProcessor::expand_place_holder,

-        '>'             => \&DBI::Custom::SQL::Template::TagProcessor::expand_place_holder,

-        '<'             => \&DBI::Custom::SQL::Template::TagProcessor::expand_place_holder,

-        '>='            => \&DBI::Custom::SQL::Template::TagProcessor::expand_place_holder,

-        '<='            => \&DBI::Custom::SQL::Template::TagProcessor::expand_place_holder,

-        'like'          => \&DBI::Custom::SQL::Template::TagProcessor::expand_place_holder,

-        'in'            => \&DBI::Custom::SQL::Template::TagProcessor::expand_place_holder,

-        'insert_values' => \&DBI::Custom::SQL::Template::TagProcessor::expand_insert_values,

-        'update_set'    => \&DBI::Custom::SQL::Template::TagProcessor::expand_update_set

-    );

-}}

-

-sub add_tag_processor {

-    my $class = shift;

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

-    $class->tag_processor(%{$class->tag_processor}, %{$tag_processors});

-}

-

-sub create_sql {

-    my ($self, $template, $values, $filter)  = @_;

-    

-    $filter ||= $self->bind_filter;

-    

-    $self->parse($template);

-    

-    my ($sql, @bind) = $self->build_sql({bind_filter => $filter, values => $values});

-    

-    return ($sql, @bind);

-}

-

-sub parse {

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

-    $self->template($template);

-    

-    # Clean start;

-    $self->tree([]);

-    

-    # Tags

-    my $tag_start = quotemeta $self->tag_start;

-    my $tag_end   = quotemeta $self->tag_end;

-    

-    # Tokenize

-    my $state = 'text';

-    

-    # Save original template

-    my $original_template = $template;

-    

-    # Text

-    while ($template =~ s/([^$tag_start]*?)$tag_start([^$tag_end].*?)$tag_end//sm) {

-        my $text = $1;

-        my $tag  = $2;

-        

-        push @{$self->tree}, {type => 'text', args => [$text]} if $text;

-        

-        if ($tag) {

-            

-            my ($tag_name, @args) = split /\s+/, $tag;

-            

-            $tag ||= '';

-            unless ($self->tag_processors->{$tag_name}) {

-                my $tag_syntax = $self->tag_syntax;

-                croak("Tag '{$tag}' in SQL template is not exist.\n\n" .

-                      "SQL template tag syntax\n" .

-                      "$tag_syntax\n\n" .

-                      "Your SQL template is \n$original_template\n\n");

-            }

-            

-            push @{$self->tree}, {type => 'tag', tag_name => $tag_name, args => [@args]};

-        }

-    }

-    

-    push @{$self->tree}, {type => 'text', args => [$template]} if $template;

-}

-

-sub build_sql {

-    my ($self, $args) = @_;

-    

-    my $tree        = $args->{tree} || $self->tree;

-    my $bind_filter = $args->{bind_filter} || $self->bind_filter;

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

-    

-    my @bind_values_all;

-    my $sql = '';

-    foreach my $node (@$tree) {

-        my $type     = $node->{type};

-        my $tag_name = $node->{tag_name};

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

-        

-        if ($type eq 'text') {

-            # Join text

-            $sql .= $args->[0];

-        }

-        elsif ($type eq 'tag') {

-            my $tag_processor = $self->tag_processors->{$tag_name};

-            

-            croak("Tag processor '$type' must be code reference")

-              unless ref $tag_processor eq 'CODE';

-            

-            my ($expand, @bind_values)

-              = $tag_processor->($tag_name, $args, $values,

-                                 $bind_filter, $self);

-            

-            $DB::single = 1;

-            unless ($self->_placeholder_count($expand) == @bind_values) {

-                require Data::Dumper;

-                

-                my $bind_values_dump

-                  = Data::Dumper->Dump([\@bind_values], ['*bind_values']);

-                

-                croak("Place holder count must be same as bind value count\n" .

-                      "Tag        : $tag_name\n" .

-                      "Expand     : $expand\n" .

-                      "Bind values: $bind_values_dump\n");

-            }

-            push @bind_values_all, @bind_values;

-            $sql .= $expand;

-        }

-    }

-    $sql .= ';' unless $sql =~ /;$/;

-    return ($sql, @bind_values_all);

-}

-

-sub _placeholder_count {

-    my ($self, $expand) = @_;

-    $expand ||= '';

-    

-    my $count = 0;

-    my $pos   = -1;

-    while (($pos = index($expand, '?', $pos + 1)) != -1) {

-        $count++;

-    }

-    return $count;

-}

-

-Object::Simple->build_class;

-

-

-package DBI::Custom::SQL::Template::TagProcessor;

-use strict;

-use warnings;

-

-sub expand_place_holder {

-    my ($tag_name, $args, $values, $bind_filter, $sql_tmpl_obj) = @_;

-    

-    my $key = $args->[0];

-    

-    my @bind_values;

-    # Filter Value

-    if ($tag_name eq 'in') {

-        $values->{$key} = [$values->{$key}] unless ref $values->{$key} eq 'ARRAY';

-        if ($bind_filter) {

-            for (my $i = 0; $i < @$values; $i++) {

-                push @bind_values, scalar $bind_filter->($key, $values->{$key}->[$i]);

-            }

-        }

-        else {

-            for (my $i = 0; $i < @$values; $i++) {

-                push @bind_values, $values->{$key}->[$i];

-            }

-        }

-    }

-    else {

-        if ($bind_filter) {

-            push @bind_values, scalar $bind_filter->($key, $values->{$key});

-        }

-        else {

-            push @bind_values, $values->{$key};

-        }

-    }

-    

-    $tag_name = uc $tag_name if $sql_tmpl_obj->upper_case;

-    

-    my $expand;

-    if ($tag_name eq '?') {

-        $expand = '?';

-    }

-    elsif ($tag_name eq 'in') {

-        $expand = '(';

-        for (my $i = 0; $i < @$values; $i++) {

-            $expand .= '?, ';

-        }

-        $expand =~ s/, $'//;

-        $expand .= ')';

-    }

-    else {

-        $expand = "$key $tag_name ?";

-    }

-    

-    return ($expand, @bind_values);

-}

-

-sub expand_insert_values {

-    my ($tag_name, $args, $values, $bind_filter, $sql_tmpl_obj) = @_;

-    

-    my $insert_keys = '(';

-    my $place_holders = '(';

-    

-    $values = $args->[0] ? $values->{$args->[0]} : $values->{insert_values};

-    

-    my @bind_values;

-    foreach my $key (sort keys %$values) {

-        $bind_filter ? push @bind_values, scalar $bind_filter->($key, $values->{$key})

-                     : push @bind_values, $values->{$key};

-        

-        $insert_keys   .= "$key, ";

-        $place_holders .= "?, ";

-    }

-    

-    $insert_keys =~ s/, $//;

-    $insert_keys .= ')';

-    

-    $place_holders =~ s/, $//;

-    $place_holders .= ')';

-    

-    my $expand = $sql_tmpl_obj->upper_case ? "$insert_keys VALUES $place_holders"

-                                           : "$insert_keys values $place_holders";

-    

-    return ($expand, @bind_values);

-}

-

-sub expand_update_set {

-    my ($tag_name, $args, $values, $bind_filter, $sql_tmpl_obj) = @_;

-    

-    my $expand = $sql_tmpl_obj->upper_case ? 'SET ' : 'set ';

-    $values = $args->[0] ? $values->{$args->[0]} : $values->{update_set};

-    

-    my @bind_values;

-    foreach my $key (sort keys %$values) {

-        $bind_filter ? push @bind_values, scalar $bind_filter->($key, $values->{$key})

-                     : push @bind_values, $values->{$key};

-        

-        $expand .= "$key = ?, ";

-    }

-    $expand =~ s/, $//;

-    return ($expand, @bind_values);

-}

-

-

-package DBI::Custom;

-1;

-

 =head1 NAME

 DBI::Custom - Customizable simple DBI

@@ -4,6 +4,7 @@ use warnings;

 use DBI::Custom;

 use Scalar::Util qw/blessed/;

+use DBI::Custom::SQL::Template;

 my $sql_tmpl1 = DBI::Custom::SQL::Template->new->upper_case(0);

 my $sql_tmpl2 = DBI::Custom::SQL::Template->new->upper_case(1);

@@ -22,14 +23,13 @@ my $sql_tmpl3 = DBI::Custom::SQL::Template->new->upper_case(2);

         },

         bind_filter => 'f',

         fetch_filter => 'g',

-        dbh => 'e',

         result_class => 'g',

         sql_template => $sql_tmpl1,

         valid_connect_info => {i => 1}

     );

     is_deeply($dbi,{connect_info => {user => 'a', password => 'b', data_source => 'c', 

                     options => {d => 1, e => 2}}, filters => {f => 3}, bind_filter => 'f',

-                    fetch_filter => 'g', dbh => 'e', result_class => 'g',

+                    fetch_filter => 'g', result_class => 'g',

                     sql_template => $sql_tmpl1, valid_connect_info => {i => 1}}, 'new');

     isa_ok($dbi, 'DBI::Custom');

@@ -40,9 +40,9 @@ my $sql_tmpl3 = DBI::Custom::SQL::Template->new->upper_case(2);

     package DBI::Custom::T1;

     use base 'DBI::Custom';

-    my $prototype = __PACKAGE__->prototype;

+    my $class = __PACKAGE__;

-    $prototype

+    $class

       ->connect_info(

           user => 'a',

           password => 'b',

@@ -54,7 +54,6 @@ my $sql_tmpl3 = DBI::Custom::SQL::Template->new->upper_case(2);

       )

       ->bind_filter('f')

       ->fetch_filter('g')

-      ->dbh('e')

       ->result_class('DBI::Custom::Result')

       ->sql_template($sql_tmpl1)

       ->valid_connect_info({p => 1})

@@ -90,11 +89,13 @@ my $sql_tmpl3 = DBI::Custom::SQL::Template->new->upper_case(2);

 {

     my $dbi = DBI::Custom::T1->new;

-    my $sql_tmpl = delete $dbi->{sql_template};

-    is_deeply($dbi,{connect_info => {user => 'a', password => 'b', data_source => 'c', options => {d => 1, e => 2}},

-                    filters => {f => 3}, bind_filter => 'f', fetch_filter => 'g', result_class => 'DBI::Custom::Result',

-                    valid_connect_info => {p => 1}}, 'new custom class');

-    

+    is_deeply($dbi->connect_info, {user => 'a', password => 'b', data_source => 'c', options => {d => 1, e => 2}});

+    is_deeply({$dbi->filters}, {f => 3});

+    is($dbi->bind_filter, 'f');

+    is($dbi->fetch_filter, 'g');

+    is($dbi->result_class, 'DBI::Custom::Result');

+    is_deeply({$dbi->valid_connect_info},{p => 1});

+    is($dbi->sql_template->upper_case, 0);

     isa_ok($dbi, 'DBI::Custom::T1');

 }

@@ -107,11 +108,13 @@ my $sql_tmpl3 = DBI::Custom::SQL::Template->new->upper_case(2);

 {

     my $dbi = DBI::Custom::T1_2->new;

-    my $sql_tmpl = delete $dbi->{sql_template};

-    is($sql_tmpl->upper_case, 0);

-    is_deeply($dbi,{connect_info => {user => 'a', password => 'b', data_source => 'c', options => {d => 1, e => 2}},

-                    filters => {f => 3}, bind_filter => 'f', fetch_filter => 'g', result_class => 'DBI::Custom::Result',

-                    valid_connect_info => {p => 1}}, 'new custom class inherit');

+    is_deeply($dbi->connect_info, {user => 'a', password => 'b', data_source => 'c', options => {d => 1, e => 2}});

+    is_deeply(scalar $dbi->filters, {f => 3});

+    is($dbi->bind_filter, 'f');

+    is($dbi->fetch_filter, 'g');

+    is($dbi->result_class, 'DBI::Custom::Result');

+    is_deeply({$dbi->valid_connect_info}, {p => 1});

+    is($dbi->sql_template->upper_case, 0);

     isa_ok($dbi, 'DBI::Custom::T1_2');

 }

@@ -120,9 +123,9 @@ my $sql_tmpl3 = DBI::Custom::SQL::Template->new->upper_case(2);

     package DBI::Custom::T1_3;

     use base 'DBI::Custom::T1';

-    my $prototype = __PACKAGE__->prototype;

+    my $class = __PACKAGE__;

-    $prototype

+    $class

       ->connect_info(

         user => 'ao',

         password => 'bo',

@@ -134,7 +137,6 @@ my $sql_tmpl3 = DBI::Custom::SQL::Template->new->upper_case(2);

       )

       ->bind_filter('fo')

       ->fetch_filter('go')

-      ->dbh('eo')

       ->result_class('ho')

       ->sql_template($sql_tmpl2)

       ->valid_connect_info({p => 3})

@@ -144,11 +146,13 @@ my $sql_tmpl3 = DBI::Custom::SQL::Template->new->upper_case(2);

 {

     my $dbi = DBI::Custom::T1_3->new;

-    my $sql_tmpl = delete $dbi->{sql_template};

-    is($sql_tmpl->upper_case, 1);

-    is_deeply($dbi,{connect_info => {user => 'ao', password => 'bo', data_source => 'co', options => {do => 10, eo => 20}},

-                    filters => {fo => 30}, bind_filter => 'fo', fetch_filter => 'go', result_class => 'ho',

-                    valid_connect_info => {p => 3}}, 'new custom class');

+    is_deeply($dbi->connect_info, {user => 'ao', password => 'bo', data_source => 'co', options => {do => 10, eo => 20}});

+    is_deeply(scalar $dbi->filters, {fo => 30});

+    is($dbi->bind_filter, 'fo');

+    is($dbi->fetch_filter, 'go');

+    is($dbi->result_class, 'ho');

+    is_deeply(scalar $dbi->valid_connect_info, {p => 3});

+    is($dbi->sql_template->upper_case, 1);

     isa_ok($dbi, 'DBI::Custom::T1_3');

 }

@@ -166,7 +170,6 @@ my $sql_tmpl3 = DBI::Custom::SQL::Template->new->upper_case(2);

         },

         bind_filter => 'f',

         fetch_filter => 'g',

-        dbh => 'e',

         result_class => 'h',

         sql_template => $sql_tmpl3,

         valid_connect_info => {p => 4}

@@ -175,7 +178,7 @@ my $sql_tmpl3 = DBI::Custom::SQL::Template->new->upper_case(2);

     my $sql_tmpl = delete $dbi->{sql_template};

     is($sql_tmpl->upper_case, 2);

     is_deeply($dbi,{connect_info => {user => 'a', password => 'b', data_source => 'c', options => {d => 1, e => 2}},

-                    filters => {f => 3}, bind_filter => 'f', fetch_filter => 'g', dbh => 'e', result_class => 'h',

+                    filters => {f => 3}, bind_filter => 'f', fetch_filter => 'g', result_class => 'h',

                     valid_connect_info => {p => 4}}, 'new');

     isa_ok($dbi, 'DBI::Custom');