package DBIx::Custom; our $VERSION = '0.1643'; use 5.008001; use strict; use warnings; use base 'Object::Simple'; use Carp 'croak'; use DBI; use DBIx::Custom::Result; use DBIx::Custom::Query; use DBIx::Custom::QueryBuilder; use DBIx::Custom::Where; use DBIx::Custom::Table; use DBIx::Custom::Tag; use Encode qw/encode_utf8 decode_utf8/; __PACKAGE__->attr( [qw/data_source dbh password user/], cache => 1, dbi_option => sub { {} }, query_builder => sub { DBIx::Custom::QueryBuilder->new }, result_class => 'DBIx::Custom::Result', base_table => sub { DBIx::Custom::Table->new(dbi => shift) }, safety_column_name => sub { qr/^[\w\.]*$/ }, stash => sub { {} } ); __PACKAGE__->attr( cache_method => sub { sub { my $self = shift; $self->{_cached} ||= {}; if (@_ > 1) { $self->{_cached}{$_[0]} = $_[1] } else { return $self->{_cached}{$_[0]} } } } ); __PACKAGE__->attr( filters => sub { { encode_utf8 => sub { encode_utf8($_[0]) }, decode_utf8 => sub { decode_utf8($_[0]) } } } ); our $AUTOLOAD; sub AUTOLOAD { my $self = shift; # Method name my ($package, $mname) = $AUTOLOAD =~ /^([\w\:]+)\:\:(\w+)$/; # Method $self->{_methods} ||= {}; my $method = $self->{_methods}->{$mname}; return $self->$method(@_) if $method; # DBI method return $self->dbh->$mname(@_); } sub apply_filter { my ($self, $table, @cinfos) = @_; # Initialize filters $self->{filter} ||= {}; $self->{filter}{out} ||= {}; $self->{filter}{in} ||= {}; # Create filters my $usage = "Usage: \$dbi->apply_filter(" . "TABLE, COLUMN1, {in => INFILTER1, out => OUTFILTER1, end => ENDFILTER1}, " . "COLUMN2, {in => INFILTER2, out => OUTFILTER2, end => ENDFILTER2}, ...)"; for (my $i = 0; $i < @cinfos; $i += 2) { # Column my $column = $cinfos[$i]; # Filter info my $finfo = $cinfos[$i + 1] || {}; croak $usage unless ref $finfo eq 'HASH'; foreach my $ftype (keys %$finfo) { croak $usage unless $ftype eq 'in' || $ftype eq 'out' || $ftype eq 'end'; } foreach my $way (qw/in out end/) { my $filter = $finfo->{$way}; # State my $state = !exists $finfo->{$way} ? 'not_exists' : !defined $filter ? 'not_defined' : ref $filter eq 'CODE' ? 'code' : 'name'; next if $state eq 'not_exists'; # Check filter croak qq{Filter "$filter" is not registered} if $state eq 'name' && ! exists $self->filters->{$filter}; # Filter my $f = $state eq 'not_defined' ? undef : $state eq 'code' ? $filter : $self->filters->{$filter}; $self->{filter}{$way}{$table}{$column} = $f; $self->{filter}{$way}{$table}{"$table.$column"} = $f; $self->{filter}{$way}{$table}{"${table}__$column"} = $f; } } return $self; } sub method { my $self = shift; # Merge my $methods = ref $_[0] eq 'HASH' ? $_[0] : {@_}; $self->{_methods} = {%{$self->{_methods} || {}}, %$methods}; return $self; } sub connect { my $self = ref $_[0] ? shift : shift->new(@_);; # Attributes my $data_source = $self->data_source; croak qq{"data_source" must be specified to connect()"} unless $data_source; my $user = $self->user; my $password = $self->password; my $dbi_option = {%{$self->dbi_options}, %{$self->dbi_option}}; # Connect my $dbh = eval {DBI->connect( $data_source, $user, $password, { RaiseError => 1, PrintError => 0, AutoCommit => 1, %$dbi_option } )}; # Connect error croak $@ if $@; # Database handle $self->dbh($dbh); return $self; } sub create_query { my ($self, $source) = @_; # Cache my $cache = $self->cache; # Create query my $query; if ($cache) { # Get query my $q = $self->cache_method->($self, $source); # Create query $query = DBIx::Custom::Query->new($q) if $q; } unless ($query) { # Create SQL object my $builder = $self->query_builder; # Create query $query = $builder->build_query($source); # Cache query $self->cache_method->($self, $source, {sql => $query->sql, columns => $query->columns}) if $cache; } # Prepare statement handle my $sth; eval { $sth = $self->dbh->prepare($query->{sql})}; $self->_croak($@, qq{. Following SQL is executed. "$query->{sql}"}) if $@; # Set statement handle $query->sth($sth); # Set filters $query->filters($self->filters); return $query; } our %VALID_DELETE_ARGS = map { $_ => 1 } qw/table where append filter allow_delete_all query/; sub delete { my ($self, %args) = @_; # Check arguments foreach my $name (keys %args) { croak qq{"$name" is invalid argument} unless $VALID_DELETE_ARGS{$name}; } # Arguments my $table = $args{table} || ''; croak qq{"table" option must be specified} unless $table; my $where = $args{where} || {}; my $append = $args{append}; my $filter = $args{filter}; my $allow_delete_all = $args{allow_delete_all}; # Where my $w; if (ref $where eq 'HASH') { my $clause = ['and']; push @$clause, "{= $_}" for keys %$where; $w = $self->where; $w->clause($clause); $w->param($where); } elsif (ref $where eq 'DBIx::Custom::Where') { $w = $where; $where = $w->param; } croak qq{"where" must be hash refernce or DBIx::Custom::Where object} unless ref $w eq 'DBIx::Custom::Where'; # String where my $swhere = "$w"; croak qq{"where" must be specified} if $swhere eq '' && !$allow_delete_all; # SQL stack my @sql; # Delete push @sql, "delete from $table $swhere"; push @sql, $append if $append; my $sql = join(' ', @sql); # Create query my $query = $self->create_query($sql); return $query if $args{query}; # Execute query my $ret_val = $self->execute( $query, param => $where, filter => $filter, table => $table); return $ret_val; } sub delete_all { shift->delete(allow_delete_all => 1, @_) } sub DESTROY { } our %VALID_EXECUTE_ARGS = map { $_ => 1 } qw/param filter table/; sub execute{ my ($self, $query, %args) = @_; # Check arguments foreach my $name (keys %args) { croak qq{"$name" is invalid argument} unless $VALID_EXECUTE_ARGS{$name}; } my $params = $args{param} || {}; # First argument is the soruce of SQL $query = $self->create_query($query) unless ref $query; # Auto filter my $filter = {}; my $tables = $args{table} || []; $tables = [$tables] unless ref $tables eq 'ARRAY'; foreach my $table (@$tables) { $filter = { %$filter, %{$self->{filter}{out}->{$table} || {}} } } # Filter argument my $f = $args{filter} || $query->filter || {}; foreach my $column (keys %$f) { my $fname = $f->{$column}; if (!defined $fname) { $f->{$column} = undef; } elsif (ref $fname ne 'CODE') { croak qq{Filter "$fname" is not registered"} unless exists $self->filters->{$fname}; $f->{$column} = $self->filters->{$fname}; } } $filter = {%$filter, %$f}; # Bind my $bind = $self->_bind($params, $query->columns, $filter); # Execute my $sth = $query->sth; my $affected; eval {$affected = $sth->execute(@$bind)}; $self->_croak($@, qq{. Following SQL is executed. "$query->{sql}"}) if $@; # Return resultset if select statement is executed if ($sth->{NUM_OF_FIELDS}) { # Result in and end filter my $in_filter = {}; my $end_filter = {}; foreach my $table (@$tables) { $in_filter = { %$in_filter, %{$self->{filter}{in}{$table} || {}} }; $end_filter = { %$end_filter, %{$self->{filter}{end}{$table} || {}} }; } # Result my $result = $self->result_class->new( sth => $sth, filters => $self->filters, filter_check => $self->filter_check, default_filter => $self->{default_in_filter}, filter => $in_filter || {}, end_filter => $end_filter || {} ); return $result; } return $affected; } our %VALID_INSERT_ARGS = map { $_ => 1 } qw/table param append filter query/; sub insert { my ($self, %args) = @_; # Check arguments foreach my $name (keys %args) { croak qq{"$name" is invalid argument} unless $VALID_INSERT_ARGS{$name}; } # Arguments my $table = $args{table}; croak qq{"table" option must be specified} unless $table; my $param = $args{param} || {}; my $append = $args{append} || ''; my $filter = $args{filter}; # Columns my @columns; my $safety = $self->safety_column_name; foreach my $column (keys %$param) { croak qq{"$column" is not safety column name} unless $column =~ /$safety/; push @columns, $column; } # SQL stack my @sql; # Insert push @sql, "insert into $table {insert_param ". join(' ', @columns) . '}'; push @sql, $append if $append; # SQL my $sql = join (' ', @sql); # Create query my $query = $self->create_query($sql); return $query if $args{query}; # Execute query my $ret_val = $self->execute( $query, param => $param, filter => $filter, table => $table ); return $ret_val; } sub each_column { my ($self, $cb) = @_; # Iterate all tables my $sth_tables = $self->dbh->table_info; while (my $table_info = $sth_tables->fetchrow_hashref) { # Table my $table = $table_info->{TABLE_NAME}; # Iterate all columns my $sth_columns = $self->dbh->column_info(undef, undef, $table, '%'); while (my $column_info = $sth_columns->fetchrow_hashref) { my $column = $column_info->{COLUMN_NAME}; $self->$cb($table, $column, $column_info); } } } sub new { my $self = shift->SUPER::new(@_); # Check attribute names my @attrs = keys %$self; foreach my $attr (@attrs) { croak qq{"$attr" is invalid attribute name} unless $self->can($attr); } $self->register_tag( '?' => \&DBIx::Custom::Tag::placeholder, '=' => \&DBIx::Custom::Tag::equal, '<>' => \&DBIx::Custom::Tag::not_equal, '>' => \&DBIx::Custom::Tag::greater_than, '<' => \&DBIx::Custom::Tag::lower_than, '>=' => \&DBIx::Custom::Tag::greater_than_equal, '<=' => \&DBIx::Custom::Tag::lower_than_equal, 'like' => \&DBIx::Custom::Tag::like, 'in' => \&DBIx::Custom::Tag::in, 'insert_param' => \&DBIx::Custom::Tag::insert_param, 'update_param' => \&DBIx::Custom::Tag::update_param ); return $self; } sub not_exists { bless {}, 'DBIx::Custom::NotExists' } sub register_filter { my $invocant = shift; # Register filter my $filters = ref $_[0] eq 'HASH' ? $_[0] : {@_}; $invocant->filters({%{$invocant->filters}, %$filters}); return $invocant; } sub register_tag { shift->query_builder->register_tag(@_) } our %VALID_SELECT_ARGS = map { $_ => 1 } qw/table column where append relation filter query/; sub select { my ($self, %args) = @_; # Check arguments foreach my $name (keys %args) { croak qq{"$name" is invalid argument} unless $VALID_SELECT_ARGS{$name}; } # Arguments my $table = $args{table}; my $tables = ref $table eq 'ARRAY' ? $table : defined $table ? [$table] : []; croak qq{"table" option must be specified} unless @$tables; my $columns = $args{column} || []; my $where = $args{where} || {}; my $relation = $args{relation}; my $append = $args{append}; my $filter = $args{filter}; # SQL stack my @sql; push @sql, 'select'; # Column clause if (@$columns) { foreach my $column (@$columns) { push @sql, ($column, ','); } pop @sql if $sql[-1] eq ','; } else { push @sql, '*' } # Table push @sql, 'from'; foreach my $table (@$tables) { push @sql, ($table, ','); } pop @sql if $sql[-1] eq ','; # Where my $w; if (ref $where eq 'HASH') { my $clause = ['and']; push @$clause, "{= $_}" for keys %$where; $w = $self->where; $w->clause($clause); $w->param($where); } elsif (ref $where eq 'DBIx::Custom::Where') { $w = $where; $where = $w->param; } croak qq{"where" must be hash reference or DBIx::Custom::Where object} unless ref $w eq 'DBIx::Custom::Where'; # String where my $swhere = "$w"; push @sql, $swhere; # Relation if ($relation) { push @sql, $swhere eq '' ? 'where' : 'and'; foreach my $rcolumn (keys %$relation) { push @sql, ("$rcolumn = " . $relation->{$rcolumn}, 'and'); } } pop @sql if $sql[-1] eq 'and'; # Append statement push @sql, $append if $append; # SQL my $sql = join (' ', @sql); # Create query my $query = $self->create_query($sql); return $query if $args{query}; # Execute query my $result = $self->execute( $query, param => $where, filter => $filter, table => $tables); return $result; } sub table { my $self = shift; my $name = shift; # Create table $self->{_tables} ||= {}; unless (defined $self->{_tables}->{$name}) { # Base table my $base_table = $self->base_table; # Base methods my $bmethods = ref $base_table->{_methods} eq 'HASH' ? $base_table->{_methods} : {}; # Copy Methods my $methods = {}; $methods->{$_} = $bmethods->{$_} for keys %$bmethods; $methods->{"base_$_"} = $bmethods->{$_} for keys %$bmethods; # Create table my $table = $base_table->new( dbi => $self, name => $name, ); $table->method($methods); $self->{_tables}->{$name} = $table; } return $self->{_tables}{$name}; } our %VALID_UPDATE_ARGS = map { $_ => 1 } qw/table param where append filter allow_update_all query/; sub update { my ($self, %args) = @_; # Check arguments foreach my $name (keys %args) { croak qq{"$name" is invalid argument} unless $VALID_UPDATE_ARGS{$name}; } # Arguments my $table = $args{table} || ''; croak qq{"table" option must be specified} unless $table; my $param = $args{param} || {}; my $where = $args{where} || {}; my $append = $args{append} || ''; my $filter = $args{filter}; my $allow_update_all = $args{allow_update_all}; # Update keys my @clumns = keys %$param; # Columns my @columns; my $safety = $self->safety_column_name; foreach my $column (keys %$param) { croak qq{"$column" is not safety column name} unless $column =~ /$safety/; push @columns, $column; } # Update clause my $update_clause = '{update_param ' . join(' ', @clumns) . '}'; # Where my $w; if (ref $where eq 'HASH') { my $clause = ['and']; push @$clause, "{= $_}" for keys %$where; $w = $self->where; $w->clause($clause); $w->param($where); } elsif (ref $where eq 'DBIx::Custom::Where') { $w = $where; $where = $w->param; } croak qq{"where" must be hash refernce or DBIx::Custom::Where object} unless ref $w eq 'DBIx::Custom::Where'; # String where my $swhere = "$w"; croak qq{"where" must be specified} if "$swhere" eq '' && !$allow_update_all; # SQL stack my @sql; # Update push @sql, "update $table $update_clause $swhere"; push @sql, $append if $append; # Rearrange parameters foreach my $wkey (keys %$where) { if (exists $param->{$wkey}) { $param->{$wkey} = [$param->{$wkey}] unless ref $param->{$wkey} eq 'ARRAY'; push @{$param->{$wkey}}, $where->{$wkey}; } else { $param->{$wkey} = $where->{$wkey}; } } # SQL my $sql = join(' ', @sql); # Create query my $query = $self->create_query($sql); return $query if $args{query}; # Execute query my $ret_val = $self->execute($query, param => $param, filter => $filter, table => $table); return $ret_val; } sub update_all { shift->update(allow_update_all => 1, @_) }; sub where { my $self = shift; return DBIx::Custom::Where->new( query_builder => $self->query_builder, safety_column_name => $self->safety_column_name ); } sub _bind { my ($self, $params, $columns, $filter) = @_; # bind values my @bind; # Build bind values my $count = {}; my $not_exists = {}; foreach my $column (@$columns) { # Value my $value; if(ref $params->{$column} eq 'ARRAY') { my $i = $count->{$column} || 0; $i += $not_exists->{$column} || 0; my $found; for (my $k = $i; $i < @{$params->{$column}}; $k++) { if (ref $params->{$column}->[$k] eq 'DBIx::Custom::NotExists') { $not_exists->{$column}++; } else { $value = $params->{$column}->[$k]; $found = 1; last } } next unless $found; } else { $value = $params->{$column} } # Filter my $f = $filter->{$column} || $self->{default_out_filter} || ''; push @bind, $f ? $f->($value) : $value; # Count up $count->{$column}++; } return \@bind; } sub _croak { my ($self, $error, $append) = @_; $append ||= ""; # Verbose if ($Carp::Verbose) { croak $error } # Not verbose else { # Remove line and module infromation my $at_pos = rindex($error, ' at '); $error = substr($error, 0, $at_pos); $error =~ s/\s+$//; croak "$error$append"; } } # DEPRECATED! __PACKAGE__->attr( dbi_options => sub { {} }, filter_check => 1 ); # DEPRECATED! sub default_bind_filter { my $self = shift; if (@_) { my $fname = $_[0]; if (@_ && !$fname) { $self->{default_out_filter} = undef; } else { croak qq{Filter "$fname" is not registered} unless exists $self->filters->{$fname}; $self->{default_out_filter} = $self->filters->{$fname}; } return $self; } return $self->{default_out_filter}; } # DEPRECATED! sub default_fetch_filter { my $self = shift; if (@_) { my $fname = $_[0]; if (@_ && !$fname) { $self->{default_in_filter} = undef; } else { croak qq{Filter "$fname" is not registered} unless exists $self->filters->{$fname}; $self->{default_in_filter} = $self->filters->{$fname}; } return $self; } return $self->{default_in_filter}; } # DEPRECATED! sub register_tag_processor { return shift->query_builder->register_tag_processor(@_); } 1; =head1 NAME DBIx::Custom - DBI interface, having hash parameter binding and filtering system =head1 SYNOPSYS use DBIx::Custom; my $dbi = DBIx::Custom->connect(data_source => "dbi:mysql:database=dbname", user => 'ken', password => '!LFKD%$&', dbi_option => {mysql_enable_utf8 => 1}); # Insert $dbi->insert(table => 'book', param => {title => 'Perl', author => 'Ken'}, filter => {title => 'to_something'}); # Update $dbi->update(table => 'book', param => {title => 'Perl', author => 'Ken'}, where => {id => 5}, filter => {title => 'to_something'}); # Update all $dbi->update_all(table => 'book', param => {title => 'Perl'}, filter => {title => 'to_something'}); # Delete $dbi->delete(table => 'book', where => {author => 'Ken'}, filter => {title => 'to_something'}); # Delete all $dbi->delete_all(table => 'book'); # Select my $result = $dbi->select( table => 'book', column => [qw/author title/], where => {author => 'Ken'}, relation => {'book.id' => 'rental.book_id'}, append => 'order by id limit 5', filter => {title => 'to_something'} ); # Execute SQL $dbi->execute("select title from book"); # Execute SQL with hash binding and filtering $dbi->execute("select id from book where {= author} and {like title}", param => {author => 'ken', title => '%Perl%'}, filter => {title => 'to_something'}); # Create query and execute it my $query = $dbi->create_query( "select id from book where {= author} and {like title}" ); $dbi->execute($query, param => {author => 'Ken', title => '%Perl%'}) # Get DBI object my $dbh = $dbi->dbh; # Fetch while (my $row = $result->fetch) { # ... } # Fetch hash while (my $row = $result->fetch_hash) { } =head1 DESCRIPTIONS L is one of L interface modules, such as L, L. This module is not O/R mapper. O/R mapper is useful, but you must learn many syntax of the O/R mapper, which is almost another language. Created SQL statement is offten not effcient and damage SQL performance. so you have to execute raw SQL in the end. L is middle area between L and O/R mapper. L provide flexible hash parameter binding and filtering system, and suger methods, such as C, C, C, C to execute SQL easily. L respects SQL. SQL is very complex and not beautiful, but de-facto standard, so all people learing database know it. If you already know SQL, you learn a little thing to use L. See L for more details. =head1 GUIDE L - L complete guide =head1 EXAMPLES L - Many useful examples =head1 ATTRIBUTES =head2 C my $cache = $dbi->cache; $dbi = $dbi->cache(1); Enable parsed L object caching. Default to 1. =head2 C my $data_source = $dbi->data_source; $dbi = $dbi->data_source("DBI:mysql:database=dbname"); Data source. C method use this value to connect the database. =head2 C my $dbh = $dbi->dbh; $dbi = $dbi->dbh($dbh); L object. You can call all methods of L. =head2 C my $dbi_option = $dbi->dbi_option; $dbi = $dbi->dbi_option($dbi_option); DBI options. C method use this value to connect the database. Default filter when row is fetched. =head2 C my $filters = $dbi->filters; $dbi = $dbi->filters(\%filters); =head2 C my $password = $dbi->password; $dbi = $dbi->password('lkj&le`@s'); Password. C method use this value to connect the database. =head2 C my $sql_class = $dbi->query_builder; $dbi = $dbi->query_builder(DBIx::Custom::QueryBuilder->new); SQL builder. C must be the instance of L subclass. Default to L object. =head2 C my $result_class = $dbi->result_class; $dbi = $dbi->result_class('DBIx::Custom::Result'); Result class for select statement. Default to L. =head2 C<(experimental) safety_column_name> my $safety_column_name = $self->safety_column_name; $dbi = $self->safety_column_name($name); Safety column name regex. Default is qr/^[\w\.]*$/ =head2 C my $user = $dbi->user; $dbi = $dbi->user('Ken'); User name. C method use this value to connect the database. =head1 METHODS L inherits all methods from L and use all method of L and implements the following new ones. =head2 C<(experimental) apply_filter> $dbi->apply_filter( $table, $column1 => {in => $infilter1, out => $outfilter1, end => $endfilter1} $column2 => {in => $infilter2, out => $outfilter2, end =. $endfilter2} ..., ); C is automatically filter for columns of table. This have effect C, C, C. C my $result = $dbi->select(table => $table, column => [@column], where => \%where, append => $append, relation => \%relation, filter => \%filter, query => 1); Execute select statement. C