package DBIx::Custom; use Object::Simple -base; our $VERSION = '0.2101'; use 5.008001; use Carp 'croak'; use DBI; use DBIx::Custom::Result; use DBIx::Custom::Query; use DBIx::Custom::QueryBuilder; use DBIx::Custom::Where; use DBIx::Custom::Model; use DBIx::Custom::Tag; use DBIx::Custom::Order; use DBIx::Custom::Util qw/_array_to_hash _subname/; use DBIx::Custom::Mapper; use DBIx::Custom::NotExists; use Encode qw/encode encode_utf8 decode_utf8/; use Scalar::Util qw/weaken/; has [qw/connector dsn password quote user exclude_table user_table_info user_column_info safety_character/], cache => 0, cache_method => sub { sub { my $self = shift; $self->{_cached} ||= {}; if (@_ > 1) { $self->{_cached}{$_[0]} = $_[1]; } else { return $self->{_cached}{$_[0]}; } } }, option => sub { {} }, default_option => sub { { RaiseError => 1, PrintError => 0, AutoCommit => 1 } }, filters => sub { { encode_utf8 => sub { encode_utf8($_[0]) }, decode_utf8 => sub { decode_utf8($_[0]) } } }, last_sql => '', models => sub { {} }, now => sub { sub { my ($sec, $min, $hour, $mday, $mon, $year) = localtime; $mon++; $year += 1900; my $now = sprintf("%04d-%02d-%02d %02d:%02d:%02d", $year, $mon, $mday, $hour, $min, $sec); return $now; } }, query_builder => sub { my $self = shift; my $builder = DBIx::Custom::QueryBuilder->new(dbi => $self); weaken $builder->{dbi}; return $builder; }, result_class => 'DBIx::Custom::Result', separator => '.', stash => sub { {} }; sub available_datatype { my $self = shift; my $data_types = ''; for my $i (-1000 .. 1000) { my $type_info = $self->dbh->type_info($i); my $data_type = $type_info->{DATA_TYPE}; my $type_name = $type_info->{TYPE_NAME}; $data_types .= "$data_type ($type_name)\n" if defined $data_type; } return "Data Type maybe equal to Type Name" unless $data_types; $data_types = "Data Type (Type name)\n" . $data_types; return $data_types; } sub available_typename { my $self = shift; # Type Names my $type_names = {}; $self->each_column(sub { my ($self, $table, $column, $column_info) = @_; $type_names->{$column_info->{TYPE_NAME}} = 1 if $column_info->{TYPE_NAME}; }); my @output = sort keys %$type_names; unshift @output, "Type Name"; return join "\n", @output; } our $AUTOLOAD; sub AUTOLOAD { my $self = shift; # Method name my ($package, $mname) = $AUTOLOAD =~ /^([\w\:]+)\:\:(\w+)$/; # Call method $self->{_methods} ||= {}; if (my $method = $self->{_methods}->{$mname}) { return $self->$method(@_) } elsif ($self->{dbh} && (my $dbh_method = $self->dbh->can($mname))) { $self->dbh->$dbh_method(@_); } else { croak qq{Can't locate object method "$mname" via "$package" } . _subname; } } sub assign_clause { my ($self, $param, $opts) = @_; my $wrap = $opts->{wrap} || {}; my ($q, $p) = split //, $self->q(''); # Assign clause (performance is important) join( ', ', map { ref $param->{$_} eq 'SCALAR' ? "$q$_$p = " . ${$param->{$_}} : $wrap->{$_} ? "$q$_$p = " . $wrap->{$_}->(":$_") : "$q$_$p = :$_"; } sort keys %$param ); } sub column { my $self = shift; my $option = pop if ref $_[-1] eq 'HASH'; my $real_table = shift; my $columns = shift; my $table = $option->{alias} || $real_table; # Columns unless (defined $columns) { $columns ||= $self->model($real_table)->columns; } # Separator my $separator = $self->separator; # Column clause my @column; $columns ||= []; push @column, $self->q($table) . "." . $self->q($_) . " as " . $self->q("${table}${separator}$_") for @$columns; return join (', ', @column); } sub connect { my $self = ref $_[0] ? shift : shift->new(@_); my $connector = $self->connector; if (!ref $connector && $connector) { require DBIx::Connector; my $dsn = $self->dsn; my $user = $self->user; my $password = $self->password; my $option = $self->_option; my $connector = DBIx::Connector->new($dsn, $user, $password, {%{$self->default_option} , %$option}); $self->connector($connector); } # Connect $self->dbh; return $self; } sub count { shift->select(column => 'count(*)', @_)->fetch_first->[0] } sub dbh { my $self = shift; # Set if (@_) { $self->{dbh} = $_[0]; return $self; } # Get else { # From Connction manager if (my $connector = $self->connector) { croak "connector must have dbh() method " . _subname unless ref $connector && $connector->can('dbh'); $self->{dbh} = $connector->dbh; } # Connect $self->{dbh} ||= $self->_connect; # Quote if (!defined $self->reserved_word_quote && !defined $self->quote) { my $driver = $self->_driver; my $quote = $driver eq 'odbc' ? '[]' : $driver eq 'ado' ? '[]' : $driver eq 'mysql' ? '`' : '"'; $self->quote($quote); } return $self->{dbh}; } } sub delete { my ($self, %opt) = @_; warn "delete method where_param option is DEPRECATED!" if $opt{where_param}; # Don't allow delete all rows croak qq{delete method where or id option must be specified } . _subname if !$opt{where} && !defined $opt{id} && !$opt{allow_delete_all}; # Where my $w = $self->_where_clause_and_param($opt{where}, $opt{where_param}, delete $opt{id}, $opt{primary_key}, $opt{table}); # Delete statement my $sql = "delete "; $sql .= "$opt{prefix} " if defined $opt{prefix}; $sql .= "from " . $self->q($opt{table}) . " $w->{clause} "; # Execute query $opt{statement} = 'delete'; $self->execute($sql, $w->{param}, %opt); } sub delete_all { shift->delete(@_, allow_delete_all => 1) } sub DESTROY {} sub create_model { my $self = shift; # Options my $opt = ref $_[0] eq 'HASH' ? $_[0] : {@_}; $opt->{dbi} = $self; my $model_class = delete $opt->{model_class} || 'DBIx::Custom::Model'; my $model_name = delete $opt->{name}; my $model_table = delete $opt->{table}; $model_name ||= $model_table; # Create model my $model = $model_class->new($opt); weaken $model->{dbi}; $model->name($model_name) unless $model->name; $model->table($model_table) unless $model->table; # Apply filter(DEPRECATED logic) if ($model->{filter}) { my $filter = ref $model->filter eq 'HASH' ? [%{$model->filter}] : $model->filter; $filter ||= []; warn "DBIx::Custom::Model filter method is DEPRECATED!" if @$filter; $self->_apply_filter($model->table, @$filter); } # Set model $self->model($model->name, $model); return $self->model($model->name); } sub each_column { my ($self, $cb, %options) = @_; my $user_column_info = $self->user_column_info; if ($user_column_info) { $self->$cb($_->{table}, $_->{column}, $_->{info}) for @$user_column_info; } else { my $re = $self->exclude_table || $options{exclude_table}; # Tables my %tables; $self->each_table(sub { $tables{$_[1]}++ }); # Iterate all tables my @tables = sort keys %tables; for (my $i = 0; $i < @tables; $i++) { my $table = $tables[$i]; # Iterate all columns my $sth_columns; eval {$sth_columns = $self->dbh->column_info(undef, undef, $table, '%')}; next if $@; while (my $column_info = $sth_columns->fetchrow_hashref) { my $column = $column_info->{COLUMN_NAME}; $self->$cb($table, $column, $column_info); } } } } sub each_table { my ($self, $cb, %option) = @_; my $user_table_infos = $self->user_table_info; # Iterate tables if ($user_table_infos) { $self->$cb($_->{table}, $_->{info}) for @$user_table_infos; } else { my $re = $self->exclude_table || $option{exclude}; my $sth_tables = $self->dbh->table_info; while (my $table_info = $sth_tables->fetchrow_hashref) { # Table my $table = $table_info->{TABLE_NAME}; next if defined $re && $table =~ /$re/; $self->$cb($table, $table_info); } } } sub execute { my $self = shift; my $sql = shift; # Options my $param; $param = shift if @_ % 2; my %opt = @_; warn "sqlfilter option is DEPRECATED" if $opt{sqlfilter}; $param ||= $opt{param} || {}; my $tables = $opt{table} || []; $tables = [$tables] unless ref $tables eq 'ARRAY'; my $filter = ref $opt{filter} eq 'ARRAY' ? _array_to_hash($opt{filter}) : $opt{filter}; # Merge second parameter my @cleanup; my $saved_param; if (ref $param eq 'ARRAY') { my $param2 = $param->[1]; $param = $param->[0]; for my $column (keys %$param2) { if (!exists $param->{$column}) { $param->{$column} = $param2->{$column}; push @cleanup, $column; } else { delete $param->{$_} for @cleanup; @cleanup = (); $saved_param = $param; $param = $self->merge_param($param, $param2); delete $saved_param->{$_} for (@{$opt{cleanup} || []}); last; } } } # Append $sql .= $opt{append} if defined $opt{append} && !ref $sql; # Query my $query; if (ref $sql) { $query = $sql; warn "execute method receiving query object as first parameter is DEPRECATED!" . "because this is very buggy."; } else { $query = $opt{reuse}->{$sql} if $opt{reuse}; unless ($query) { my $c = $self->{safety_character}; # Check unsafety keys unless ((join('', keys %$param) || '') =~ /^[$c\.]+$/) { for my $column (keys %$param) { croak qq{"$column" is not safety column name } . _subname unless $column =~ /^[$c\.]+$/; } } $query = $self->_create_query($sql,$opt{after_build_sql} || $opt{sqlfilter}); } $query->{statement} = $opt{statement} || ''; $opt{reuse}->{$sql} = $query if $opt{reuse}; } # Save query $self->{last_sql} = $query->{sql}; # Return query if ($opt{query}) { delete $param->{$_} for (@cleanup, @{$opt{cleanup} || []}); return $query; }; # Merge query filter(DEPRECATED!) $filter ||= $query->{filter} || {}; # Tables unshift @$tables, @{$query->{tables} || []}; my $main_table = @{$tables}[-1]; # Merge id to parameter if (defined $opt{id}) { my $statement = $query->{statement}; warn "execute method id option is DEPRECATED!" unless $statement; croak "execute id option must be specified with primary_key option" unless $opt{primary_key}; $opt{primary_key} = [$opt{primary_key}] unless ref $opt{primary_key}; $opt{id} = [$opt{id}] unless ref $opt{id}; for (my $i = 0; $i < @{$opt{id}}; $i++) { my $key = $opt{primary_key}->[$i]; $key = "$main_table.$key" if $statement eq 'update' || $statement eq 'delete' || $statement eq 'select'; next if exists $param->{$key}; $param->{$key} = $opt{id}->[$i]; push @cleanup, $key;1 } } # Cleanup tables(DEPRECATED!) $tables = $self->_remove_duplicate_table($tables, $main_table) if @$tables > 1; # Type rule my $type_filters = {}; my $type_rule_off = !$self->{_type_rule_is_called} || $opt{type_rule_off}; unless ($type_rule_off) { my $type_rule_off_parts = { 1 => $opt{type_rule1_off}, 2 => $opt{type_rule2_off} }; for my $i (1, 2) { unless ($type_rule_off_parts->{$i}) { $type_filters->{$i} = {}; my $table_alias = $opt{table_alias} || {}; for my $alias (keys %$table_alias) { my $table = $table_alias->{$alias}; for my $column (keys %{$self->{"_into$i"}{key}{$table} || {}}) { $type_filters->{$i}->{"$alias.$column"} = $self->{"_into$i"}{key}{$table}{$column}; } } $type_filters->{$i} = {%{$type_filters->{$i}}, %{$self->{"_into$i"}{key}{$main_table} || {}}} if $main_table; } } } # Applied filter(DEPRECATED!) if ($self->{filter}{on}) { my $applied_filter = {}; for my $table (@$tables) { $applied_filter = { %$applied_filter, %{$self->{filter}{out}->{$table} || {}} } } $filter = {%$applied_filter, %$filter}; } # Replace filter name to code for my $column (keys %$filter) { my $name = $filter->{$column}; if (!defined $name) { $filter->{$column} = undef; } elsif (ref $name ne 'CODE') { croak qq{Filter "$name" is not registered" } . _subname unless exists $self->filters->{$name}; $filter->{$column} = $self->filters->{$name}; } } # Execute my $sth = $query->{sth}; my $affected; if (!$query->{duplicate} && $type_rule_off && !keys %$filter && !$opt{bind_type} && !$opt{type} && !$ENV{DBIX_CUSTOM_DEBUG}) { eval { $affected = $sth->execute(map { $param->{$_} } @{$query->{columns}}) }; } else { # Create bind values my ($bind, $bind_types) = $self->_create_bind_values($param, $query->{columns}, $filter, $type_filters, $opt{bind_type} || $opt{type} || {}); # Execute eval { if ($opt{bind_type} || $opt{type}) { $sth->bind_param($_ + 1, $bind->[$_], $bind_types->[$_] ? $bind_types->[$_] : ()) for (0 .. @$bind - 1); $affected = $sth->execute; } else { $affected = $sth->execute(@$bind); } # DEBUG message if ($ENV{DBIX_CUSTOM_DEBUG}) { warn "SQL:\n" . $query->{sql} . "\n"; my @output; for my $value (@$bind) { $value = 'undef' unless defined $value; $value = encode($ENV{DBIX_CUSTOM_DEBUG_ENCODING} || 'UTF-8', $value) if utf8::is_utf8($value); push @output, $value; } warn "Bind values: " . join(', ', @output) . "\n\n"; } }; } $self->_croak($@, qq{. Following SQL is executed.\n} . qq{$query->{sql}\n} . _subname) if $@; # Remove id from parameter delete $param->{$_} for (@cleanup, @{$opt{cleanup} || []}); # Not select statement return $affected unless $sth->{NUM_OF_FIELDS}; # Filter(DEPRECATED!) my $infilter = {}; if ($self->{filter}{on}) { $infilter->{in} = {}; $infilter->{end} = {}; push @$tables, $main_table if $main_table; for my $table (@$tables) { for my $way (qw/in end/) { $infilter->{$way} = {%{$infilter->{$way}}, %{$self->{filter}{$way}{$table} || {}}}; } } } # Result $self->result_class->new( sth => $sth, dbi => $self, default_filter => $self->{default_in_filter}, filter => $infilter->{in} || {}, end_filter => $infilter->{end} || {}, type_rule => { from1 => $self->type_rule->{from1}, from2 => $self->type_rule->{from2} }, ); } sub get_table_info { my ($self, %opt) = @_; my $exclude = delete $opt{exclude}; croak qq/"$_" is wrong option/ for keys %opt; my $table_info = []; $self->each_table( sub { push @$table_info, {table => $_[1], info => $_[2] } }, exclude => $exclude ); return [sort {$a->{table} cmp $b->{table} } @$table_info]; } sub get_column_info { my ($self, %opt) = @_; my $exclude_table = delete $opt{exclude_table}; croak qq/"$_" is wrong option/ for keys %opt; my $column_info = []; $self->each_column( sub { push @$column_info, {table => $_[1], column => $_[2], info => $_[3] } }, exclude_table => $exclude_table ); return [ sort {$a->{table} cmp $b->{table} || $a->{column} cmp $b->{column} } @$column_info]; } sub helper { my $self = shift; # Register method my $methods = ref $_[0] eq 'HASH' ? $_[0] : {@_}; $self->{_methods} = {%{$self->{_methods} || {}}, %$methods}; return $self; } sub insert { my $self = shift; # Options my $param = @_ % 2 ? shift : undef; my %opt = @_; warn "insert method param option is DEPRECATED!" if $opt{param}; $param ||= delete $opt{param} || {}; # Timestamp(DEPRECATED!) if ($opt{timestamp} && (my $insert_timestamp = $self->insert_timestamp)) { warn "insert timestamp option is DEPRECATED! use created_at with now attribute"; my $columns = $insert_timestamp->[0]; $columns = [$columns] unless ref $columns eq 'ARRAY'; my $value = $insert_timestamp->[1]; $value = $value->() if ref $value eq 'CODE'; $param->{$_} = $value for @$columns; } # Created time and updated time my @timestamp_cleanup; if (defined $opt{created_at} || defined $opt{updated_at}) { my $now = $self->now; $now = $now->() if ref $now eq 'CODE'; if (defined $opt{created_at}) { $param->{$opt{created_at}} = $now; push @timestamp_cleanup, $opt{created_at}; } if (defined $opt{updated_at}) { $param->{$opt{updated_at}} = $now; push @timestamp_cleanup, $opt{updated_at}; } } # Merge id to parameter my @cleanup; my $id_param = {}; if (defined $opt{id}) { croak "insert id option must be specified with primary_key option" unless $opt{primary_key}; $opt{primary_key} = [$opt{primary_key}] unless ref $opt{primary_key}; $opt{id} = [$opt{id}] unless ref $opt{id}; for (my $i = 0; $i < @{$opt{primary_key}}; $i++) { my $key = $opt{primary_key}->[$i]; next if exists $param->{$key}; $param->{$key} = $opt{id}->[$i]; push @cleanup, $key; } } # Insert statement my $sql = "insert "; $sql .= "$opt{prefix} " if defined $opt{prefix}; $sql .= "into " . $self->q($opt{table}) . " " . $self->values_clause($param, {wrap => $opt{wrap}}) . " "; # Remove id from parameter delete $param->{$_} for @cleanup; # Execute query $opt{statement} = 'insert'; $opt{cleanup} = \@timestamp_cleanup; $self->execute($sql, $param, %opt); } sub insert_timestamp { my $self = shift; warn "insert_timestamp method is DEPRECATED! use now attribute"; if (@_) { $self->{insert_timestamp} = [@_]; return $self; } return $self->{insert_timestamp}; } sub include_model { my ($self, $name_space, $model_infos) = @_; # Name space $name_space ||= ''; # Get Model infomations unless ($model_infos) { # Load name space module croak qq{"$name_space" is invalid class name } . _subname if $name_space =~ /[^\w:]/; eval "use $name_space"; croak qq{Name space module "$name_space.pm" is needed. $@ } . _subname if $@; # Search model modules my $path = $INC{"$name_space.pm"}; $path =~ s/\.pm$//; opendir my $dh, $path or croak qq{Can't open directory "$path": $! } . _subname $model_infos = []; while (my $module = readdir $dh) { push @$model_infos, $module if $module =~ s/\.pm$//; } close $dh; } # Include models for my $model_info (@$model_infos) { # Load model my $model_class; my $model_name; my $model_table; if (ref $model_info eq 'HASH') { $model_class = $model_info->{class}; $model_name = $model_info->{name}; $model_table = $model_info->{table}; $model_name ||= $model_class; $model_table ||= $model_name; } else { $model_class = $model_name = $model_table = $model_info } my $mclass = "${name_space}::$model_class"; croak qq{"$mclass" is invalid class name } . _subname if $mclass =~ /[^\w:]/; unless ($mclass->can('isa')) { eval "use $mclass"; croak "$@ " . _subname if $@; } # Create model my $opt = {}; $opt->{model_class} = $mclass if $mclass; $opt->{name} = $model_name if $model_name; $opt->{table} = $model_table if $model_table; $self->create_model($opt); } return $self; } sub like_value { sub { "%$_[0]%" } } sub mapper { my $self = shift; return DBIx::Custom::Mapper->new(@_); } sub merge_param { my ($self, @params) = @_; # Merge parameters my $merge = {}; for my $param (@params) { for my $column (keys %$param) { my $param_is_array = ref $param->{$column} eq 'ARRAY' ? 1 : 0; if (exists $merge->{$column}) { $merge->{$column} = [$merge->{$column}] unless ref $merge->{$column} eq 'ARRAY'; push @{$merge->{$column}}, ref $param->{$column} ? @{$param->{$column}} : $param->{$column}; } else { $merge->{$column} = $param->{$column}; } } } return $merge; } sub model { my ($self, $name, $model) = @_; # Set model if ($model) { $self->models->{$name} = $model; return $self; } # Check model existance croak qq{Model "$name" is not included } . _subname unless $self->models->{$name}; # Get model return $self->models->{$name}; } sub mycolumn { my ($self, $table, $columns) = @_; # Create column clause my @column; $columns ||= []; push @column, $self->q($table) . "." . $self->q($_) . " as " . $self->q($_) for @$columns; return join (', ', @column); } sub new { my $self = shift->SUPER::new(@_); # Check attributes my @attrs = keys %$self; for my $attr (@attrs) { croak qq{Invalid attribute: "$attr" } . _subname unless $self->can($attr); } $self->{safety_character} = 'a-zA-Z0-9_' unless exists $self->{safety_character}; # DEPRECATED $self->{_tags} = { '?' => \&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 }; $self->{tag_parse} = 1 unless exists $self->{tag_parse}; $self->{cache} = 0 unless exists $self->{cache}; return $self; } sub not_exists { DBIx::Custom::NotExists->singleton } sub order { my $self = shift; return DBIx::Custom::Order->new(dbi => $self, @_); } sub q { my ($self, $value, $quotemeta) = @_; my $quote = $self->{reserved_word_quote} || $self->{quote} || $self->quote || ''; return "$quote$value$quote" if !$quotemeta && ($quote eq '`' || $quote eq '"'); my $q = substr($quote, 0, 1) || ''; my $p; if (defined $quote && length $quote > 1) { $p = substr($quote, 1, 1); } else { $p = $q } if ($quotemeta) { $q = quotemeta($q); $p = quotemeta($p); } return "$q$value$p"; } sub register_filter { my $self = shift; # Register filter my $filters = ref $_[0] eq 'HASH' ? $_[0] : {@_}; $self->filters({%{$self->filters}, %$filters}); return $self; } sub select { my $self = shift; my $column = shift if @_ % 2; my %opt = @_; $opt{column} = $column if defined $column; # Options my $tables = ref $opt{table} eq 'ARRAY' ? $opt{table} : defined $opt{table} ? [$opt{table}] : []; $opt{table} = $tables; my $where_param = $opt{where_param} || delete $opt{param} || {}; warn "select method where_param option is DEPRECATED!" if $opt{where_param}; # Add relation tables(DEPRECATED!); if ($opt{relation}) { warn "select() relation option is DEPRECATED!"; $self->_add_relation_table($tables, $opt{relation}); } # Select statement my $sql = 'select '; # Prefix $sql .= "$opt{prefix} " if defined $opt{prefix}; # Column if (defined $opt{column}) { my $columns = ref $opt{column} eq 'ARRAY' ? $opt{column} : [$opt{column}]; for my $column (@$columns) { if (ref $column eq 'HASH') { $column = $self->column(%$column) if ref $column eq 'HASH'; } elsif (ref $column eq 'ARRAY') { warn "select column option [COLUMN => ALIAS] syntax is DEPRECATED!" . "use q method to quote the value"; if (@$column == 3 && $column->[1] eq 'as') { warn "[COLUMN, as => ALIAS] is DEPRECATED! use [COLUMN => ALIAS]"; splice @$column, 1, 1; } $column = join(' ', $column->[0], 'as', $self->q($column->[1])); } unshift @$tables, @{$self->_search_tables($column)}; $sql .= "$column, "; } $sql =~ s/, $/ /; } else { $sql .= '* ' } # Table $sql .= 'from '; if ($opt{relation}) { my $found = {}; for my $table (@$tables) { $sql .= $self->q($table) . ', ' unless $found->{$table}; $found->{$table} = 1; } } else { $sql .= $self->q($tables->[-1] || '') . ' ' } $sql =~ s/, $/ /; croak "select method table option must be specified " . _subname unless defined $tables->[-1]; # Add tables in parameter unshift @$tables, @{$self->_search_tables(join(' ', keys %$where_param) || '')}; # Where my $w = $self->_where_clause_and_param($opt{where}, $where_param, delete $opt{id}, $opt{primary_key}, $tables->[-1]); # Add table names in where clause unshift @$tables, @{$self->_search_tables($w->{clause})}; # Join statement $self->_push_join(\$sql, $opt{join}, $tables) if defined $opt{join}; # Add where clause $sql .= "$w->{clause} "; # Relation(DEPRECATED!); $self->_push_relation(\$sql, $tables, $opt{relation}, $w->{clause} eq '' ? 1 : 0) if $opt{relation}; # Execute query $opt{statement} = 'select'; my $result = $self->execute($sql, $w->{param}, %opt); $result; } sub setup_model { my $self = shift; # Setup model $self->each_column( sub { my ($self, $table, $column, $column_info) = @_; if (my $model = $self->models->{$table}) { push @{$model->columns}, $column; } } ); return $self; } sub show_datatype { my ($self, $table) = @_; croak "Table name must be specified" unless defined $table; print "$table\n"; my $result = $self->select(table => $table, where => "'0' <> '0'"); my $sth = $result->sth; my $columns = $sth->{NAME}; my $data_types = $sth->{TYPE}; for (my $i = 0; $i < @$columns; $i++) { my $column = $columns->[$i]; my $data_type = lc $data_types->[$i]; print "$column: $data_type\n"; } } sub show_typename { my ($self, $t) = @_; croak "Table name must be specified" unless defined $t; print "$t\n"; $self->each_column(sub { my ($self, $table, $column, $infos) = @_; return unless $table eq $t; my $typename = lc $infos->{TYPE_NAME}; print "$column: $typename\n"; }); return $self; } sub show_tables { my $self = shift; my %tables; $self->each_table(sub { $tables{$_[1]}++ }); print join("\n", sort keys %tables) . "\n"; return $self; } sub type_rule { my $self = shift; $self->{_type_rule_is_called} = 1; if (@_) { my $type_rule = ref $_[0] eq 'HASH' ? $_[0] : {@_}; # Into for my $i (1 .. 2) { my $into = "into$i"; my $exists_into = exists $type_rule->{$into}; $type_rule->{$into} = _array_to_hash($type_rule->{$into}); $self->{type_rule} = $type_rule; $self->{"_$into"} = {}; for my $type_name (keys %{$type_rule->{$into} || {}}) { croak qq{type name of $into section must be lower case} if $type_name =~ /[A-Z]/; } $self->each_column(sub { my ($dbi, $table, $column, $column_info) = @_; my $type_name = lc $column_info->{TYPE_NAME}; if ($type_rule->{$into} && (my $filter = $type_rule->{$into}->{$type_name})) { return unless exists $type_rule->{$into}->{$type_name}; if (defined $filter && ref $filter ne 'CODE') { my $fname = $filter; croak qq{Filter "$fname" is not registered" } . _subname unless exists $self->filters->{$fname}; $filter = $self->filters->{$fname}; } $self->{"_$into"}{key}{$table}{$column} = $filter; $self->{"_$into"}{dot}{"$table.$column"} = $filter; } }); } # From for my $i (1 .. 2) { $type_rule->{"from$i"} = _array_to_hash($type_rule->{"from$i"}); for my $data_type (keys %{$type_rule->{"from$i"} || {}}) { croak qq{data type of from$i section must be lower case or number} if $data_type =~ /[A-Z]/; my $fname = $type_rule->{"from$i"}{$data_type}; if (defined $fname && ref $fname ne 'CODE') { croak qq{Filter "$fname" is not registered" } . _subname unless exists $self->filters->{$fname}; $type_rule->{"from$i"}{$data_type} = $self->filters->{$fname}; } } } return $self; } return $self->{type_rule} || {}; } sub update { my $self = shift; # Options my $param = @_ % 2 ? shift : undef; my %opt = @_; warn "update param option is DEPRECATED!" if $opt{param}; warn "update method where_param option is DEPRECATED!" if $opt{where_param}; $param ||= $opt{param} || {}; # Don't allow update all rows croak qq{update method where option must be specified } . _subname if !$opt{where} && !defined $opt{id} && !$opt{allow_update_all}; # Timestamp(DEPRECATED!) if ($opt{timestamp} && (my $update_timestamp = $self->update_timestamp)) { warn "update timestamp option is DEPRECATED! use updated_at and now method"; my $columns = $update_timestamp->[0]; $columns = [$columns] unless ref $columns eq 'ARRAY'; my $value = $update_timestamp->[1]; $value = $value->() if ref $value eq 'CODE'; $param->{$_} = $value for @$columns; } # Created time and updated time my @timestamp_cleanup; if (defined $opt{updated_at}) { my $now = $self->now; $now = $now->() if ref $now eq 'CODE'; $param->{$opt{updated_at}} = $self->now->(); push @timestamp_cleanup, $opt{updated_at}; } # Assign clause my $assign_clause = $self->assign_clause($param, {wrap => $opt{wrap}}); # Where my $w = $self->_where_clause_and_param($opt{where}, $opt{where_param}, delete $opt{id}, $opt{primary_key}, $opt{table}); # Update statement my $sql = "update "; $sql .= "$opt{prefix} " if defined $opt{prefix}; $sql .= $self->q($opt{table}) . " set $assign_clause $w->{clause} "; # Execute query $opt{statement} = 'update'; $opt{cleanup} = \@timestamp_cleanup; $self->execute($sql, [$param, $w->{param}], %opt); } sub update_all { shift->update(@_, allow_update_all => 1) }; sub update_or_insert { my ($self, $param, %opt) = @_; croak "update_or_insert method need primary_key and id option " unless defined $opt{id} && defined $opt{primary_key}; my $statement_opt = $opt{option} || {}; my $rows = $self->select(%opt, %{$statement_opt->{select} || {}})->all; if (@$rows == 0) { return $self->insert($param, %opt, %{$statement_opt->{insert} || {}}); } elsif (@$rows == 1) { return 0 unless keys %$param; return $self->update($param, %opt, %{$statement_opt->{update} || {}}); } else { croak "selected row must be one " . _subname; } } sub update_timestamp { my $self = shift; warn "update_timestamp method is DEPRECATED! use now method"; if (@_) { $self->{update_timestamp} = [@_]; return $self; } return $self->{update_timestamp}; } sub values_clause { my ($self, $param, $opts) = @_; my $wrap = $opts->{wrap} || {}; # Create insert parameter tag my ($q, $p) = split //, $self->q(''); # values clause(performance is important) '(' . join( ', ', map { "$q$_$p" } sort keys %$param ) . ') values (' . join( ', ', map { ref $param->{$_} eq 'SCALAR' ? ${$param->{$_}} : $wrap->{$_} ? $wrap->{$_}->(":$_") : ":$_"; } sort keys %$param ) . ')' } sub where { DBIx::Custom::Where->new(dbi => shift, @_) } sub _create_query { my ($self, $source, $after_build_sql) = @_; # Cache my $cache = $self->{cache}; # Query my $query; # Get cached query if ($cache) { # Get query my $q = $self->cache_method->($self, $source); # Create query if ($q) { $query = DBIx::Custom::Query->new($q); $query->{filters} = $self->filters; } } # Create query unless ($query) { # Create query my $tag_parse = exists $ENV{DBIX_CUSTOM_TAG_PARSE} ? $ENV{DBIX_CUSTOM_TAG_PARSE} : $self->{tag_parse}; my $sql = $source || ''; if ($tag_parse && ($sql =~ /\s\{/ || $sql =~ /^\{/)) { $query = $self->query_builder->build_query($sql); } else { my @columns; my $c = $self->{safety_character}; my %duplicate; my $duplicate; # Parameter regex $sql =~ s/([0-9]):/$1\\:/g; while ($sql =~ /(^|.*?[^\\]):([$c\.]+)(?:\{(.*?)\})?(.*)/sg) { push @columns, $2; $duplicate = 1 if ++$duplicate{$columns[-1]} > 1; $sql = defined $3 ? "$1$2 $3 ?$4" : "$1?$4"; } $sql =~ s/\\:/:/g if index($sql, "\\:") != -1; # Create query $query = {sql => $sql, columns => \@columns, duplicate => $duplicate}; } # Save query to cache $self->cache_method->( $self, $source, { sql => $query->{sql}, columns => $query->{columns}, tables => $query->{tables} || [] } ) if $cache; } # Filter SQL $query->{sql} = $after_build_sql->($query->{sql}) if $after_build_sql; # Save sql $self->{last_sql} = $query->{sql}; # Prepare statement handle my $sth; eval { $sth = $self->dbh->prepare($query->{sql}) }; if ($@) { $self->_croak($@, qq{. Following SQL is executed.\n} . qq{$query->{sql}\n} . _subname); } # Set statement handle $query->{sth} = $sth; # Set filters $query->{filters} = $self->{filters} || $self->filters; return $query; } sub _create_bind_values { my ($self, $params, $columns, $filter, $type_filters, $bind_type) = @_; $bind_type = _array_to_hash($bind_type) if ref $bind_type eq 'ARRAY'; # Create bind values my @bind; my @types; my %count; my %not_exists; for my $column (@$columns) { # Bind 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 { push @bind, $params->{$column}->[$k]; $found = 1; last } } next unless $found; } else { push @bind, $params->{$column} } # Filter if (my $f = $filter->{$column} || $self->{default_out_filter} || '') { $bind[-1] = $f->($bind[-1]); } # Type rule if ($self->{_type_rule_is_called}) { my $tf1 = $self->{"_into1"}->{dot}->{$column} || $type_filters->{1}->{$column}; $bind[-1] = $tf1->($bind[-1]) if $tf1; my $tf2 = $self->{"_into2"}->{dot}->{$column} || $type_filters->{2}->{$column}; $bind[-1] = $tf2->($bind[-1]) if $tf2; } # Bind types push @types, $bind_type->{$column}; # Count up $count{$column}++; } return (\@bind, \@types); } sub _id_to_param { my ($self, $id, $primary_keys, $table) = @_; # Check primary key croak "primary_key option " . "must be specified when id option is used" . _subname unless defined $primary_keys; $primary_keys = [$primary_keys] unless ref $primary_keys eq 'ARRAY'; # Create parameter my $param = {}; if (defined $id) { $id = [$id] unless ref $id; for(my $i = 0; $i < @$id; $i++) { my $key = $primary_keys->[$i]; $key = "$table." . $key if $table; $param->{$key} = $id->[$i]; } } return $param; } sub _connect { my $self = shift; # Attributes my $dsn = $self->data_source; warn "data_source is DEPRECATED!\n" if $dsn; $dsn ||= $self->dsn; croak qq{"dsn" must be specified } . _subname unless $dsn; my $user = $self->user; my $password = $self->password; my $option = $self->_option; $option = {%{$self->default_option}, %$option}; # Connect my $dbh; eval { $dbh = DBI->connect( $dsn, $user, $password, $option ); }; # Connect error croak "$@ " . _subname if $@; return $dbh; } sub _croak { my ($self, $error, $append) = @_; # 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"; } } sub _driver { lc shift->{dbh}->{Driver}->{Name} } sub _need_tables { my ($self, $tree, $need_tables, $tables) = @_; # Get needed tables for my $table (@$tables) { if ($tree->{$table}) { $need_tables->{$table} = 1; $self->_need_tables($tree, $need_tables, [$tree->{$table}{parent}]) } } } sub _option { my $self = shift; my $option = {%{$self->dbi_options}, %{$self->dbi_option}, %{$self->option}}; warn "dbi_options is DEPRECATED! use option instead\n" if keys %{$self->dbi_options}; warn "dbi_option is DEPRECATED! use option instead\n" if keys %{$self->dbi_option}; return $option; } sub _push_join { my ($self, $sql, $join, $join_tables) = @_; $join = [$join] unless ref $join eq 'ARRAY'; # No join return unless @$join; # Push join clause my $tree = {}; for (my $i = 0; $i < @$join; $i++) { # Arrange my $join_clause;; my $option; if (ref $join->[$i] eq 'HASH') { $join_clause = $join->[$i]->{clause}; $option = {table => $join->[$i]->{table}}; } else { $join_clause = $join->[$i]; $option = {}; }; # Find tables in join clause my $table1; my $table2; if (my $table = $option->{table}) { $table1 = $table->[0]; $table2 = $table->[1]; } else { my $q = $self->_quote; my $j_clause = (split /\s+on\s+/, $join_clause)[-1]; $j_clause =~ s/'.+?'//g; my $q_re = quotemeta($q); $j_clause =~ s/[$q_re]//g; my @j_clauses = reverse split /\s(and|on)\s/, $j_clause; my $c = $self->{safety_character}; my $join_re = qr/([$c]+)\.[$c]+[^$c].*?([$c]+)\.[$c]+/sm; for my $clause (@j_clauses) { if ($clause =~ $join_re) { $table1 = $1; $table2 = $2; last; } } } croak qq{join clause must have two table name after "on" keyword. } . qq{"$join_clause" is passed } . _subname unless defined $table1 && defined $table2; croak qq{right side table of "$join_clause" must be unique } . _subname if exists $tree->{$table2}; croak qq{Same table "$table1" is specified} . _subname if $table1 eq $table2; $tree->{$table2} = {position => $i, parent => $table1, join => $join_clause}; } # Search need tables my $need_tables = {}; $self->_need_tables($tree, $need_tables, $join_tables); my @need_tables = sort { $tree->{$a}{position} <=> $tree->{$b}{position} } keys %$need_tables; # Add join clause $$sql .= $tree->{$_}{join} . ' ' for @need_tables; } sub _quote { my $self = shift; return $self->{reserved_word_quote} || $self->quote || ''; } sub _remove_duplicate_table { my ($self, $tables, $main_table) = @_; # Remove duplicate table my %tables = map {defined $_ ? ($_ => 1) : ()} @$tables; delete $tables{$main_table} if $main_table; my $new_tables = [keys %tables, $main_table ? $main_table : ()]; if (my $q = $self->_quote) { $q = quotemeta($q); $_ =~ s/[$q]//g for @$new_tables; } return $new_tables; } sub _search_tables { my ($self, $source) = @_; # Search tables my $tables = []; my $safety_character = $self->{safety_character}; my $q = $self->_quote; my $quoted_safety_character_re = $self->q("?([$safety_character]+)", 1); my $table_re = $q ? qr/(?:^|[^$safety_character])${quoted_safety_character_re}?\./ : qr/(?:^|[^$safety_character])([$safety_character]+)\./; while ($source =~ /$table_re/g) { push @$tables, $1; } return $tables; } sub _where_clause_and_param { my ($self, $where, $where_param, $id, $primary_key, $table) = @_; $where ||= {}; $where = $self->_id_to_param($id, $primary_key, $table) if defined $id; $where_param ||= {}; my $w = {}; my $where_clause = ''; my $obj; if (ref $where) { if (ref $where eq 'HASH') { my $clause = ['and']; my $column_join = ''; for my $column (keys %$where) { $column_join .= $column; my $table; my $c; if ($column =~ /(?:(.*?)\.)?(.*)/) { $table = $1; $c = $2; } my $table_quote; $table_quote = $self->q($table) if defined $table; my $column_quote = $self->q($c); $column_quote = $table_quote . '.' . $column_quote if defined $table_quote; push @$clause, "$column_quote = :$column"; } # Check unsafety column my $safety = $self->{safety_character}; unless ($column_join =~ /^[$safety\.]+$/) { for my $column (keys %$where) { croak qq{"$column" is not safety column name } . _subname unless $column =~ /^[$safety\.]+$/; } } $obj = $self->where(clause => $clause, param => $where); } elsif (ref $where eq 'DBIx::Custom::Where') { $obj = $where } elsif (ref $where eq 'ARRAY') { $obj = $self->where(clause => $where->[0], param => $where->[1]); } # Check where argument croak qq{"where" must be hash reference or DBIx::Custom::Where object} . qq{or array reference, which contains where clause and parameter} . _subname unless ref $obj eq 'DBIx::Custom::Where'; $w->{param} = keys %$where_param ? $self->merge_param($where_param, $obj->param) : $obj->param; $w->{clause} = $obj->to_string; } elsif ($where) { $w->{clause} = "where $where"; $w->{param} = $where_param; } return $w; } sub _apply_filter { my ($self, $table, @cinfos) = @_; # Initialize filters $self->{filter} ||= {}; $self->{filter}{on} = 1; $self->{filter}{out} ||= {}; $self->{filter}{in} ||= {}; $self->{filter}{end} ||= {}; # Usage my $usage = "Usage: \$dbi->apply_filter(" . "TABLE, COLUMN1, {in => INFILTER1, out => OUTFILTER1, end => ENDFILTER1}, " . "COLUMN2, {in => INFILTER2, out => OUTFILTER2, end => ENDFILTER2}, ...)"; # Apply filter for (my $i = 0; $i < @cinfos; $i += 2) { # Column my $column = $cinfos[$i]; if (ref $column eq 'ARRAY') { for my $c (@$column) { push @cinfos, $c, $cinfos[$i + 1]; } next; } # Filter infomation my $finfo = $cinfos[$i + 1] || {}; croak "$usage (table: $table) " . _subname unless ref $finfo eq 'HASH'; for my $ftype (keys %$finfo) { croak "$usage (table: $table) " . _subname unless $ftype eq 'in' || $ftype eq 'out' || $ftype eq 'end'; } # Set filters for my $way (qw/in out end/) { # Filter my $filter = $finfo->{$way}; # Filter state my $state = !exists $finfo->{$way} ? 'not_exists' : !defined $filter ? 'not_defined' : ref $filter eq 'CODE' ? 'code' : 'name'; # Filter is not exists next if $state eq 'not_exists'; # Check filter name croak qq{Filter "$filter" is not registered } . _subname if $state eq 'name' && ! exists $self->filters->{$filter}; # Set 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; $self->{filter}{$way}{$table}{"${table}-$column"} = $f; } } return $self; } # DEPRECATED! has 'data_source'; has dbi_options => sub { {} }; has filter_check => 1; has 'reserved_word_quote'; has dbi_option => sub { {} }; has default_dbi_option => sub { warn "default_dbi_option is DEPRECATED! use default_option instead"; return shift->default_option; }; # DEPRECATED sub tag_parse { my $self = shift; warn "tag_parse is DEPRECATED! use \$ENV{DBIX_CUSTOM_TAG_PARSE} " . "environment variable"; if (@_) { $self->{tag_parse} = $_[0]; return $self; } return $self->{tag_parse}; } # DEPRECATED! sub method { warn "method is DEPRECATED! use helper instead"; return shift->helper(@_); } # DEPRECATED! sub assign_param { my $self = shift; warn "assing_param is DEPRECATED! use assign_clause instead"; return $self->assign_clause(@_); } # DEPRECATED sub update_param { my ($self, $param, $opts) = @_; warn "update_param is DEPRECATED! use assign_clause instead."; # Create update parameter tag my $tag = $self->assign_clause($param, $opts); $tag = "set $tag" unless $opts->{no_set}; return $tag; } # DEPRECATED! sub create_query { warn "create_query is DEPRECATED! use query option of each method"; shift->_create_query(@_); } # DEPRECATED! sub apply_filter { my $self = shift; warn "apply_filter is DEPRECATED!"; return $self->_apply_filter(@_); } # DEPRECATED! sub select_at { my ($self, %opt) = @_; warn "select_at is DEPRECATED! use select method id option instead"; # Options my $primary_keys = delete $opt{primary_key}; my $where = delete $opt{where}; my $param = delete $opt{param}; # Table croak qq{"table" option must be specified } . _subname unless $opt{table}; my $table = ref $opt{table} ? $opt{table}->[-1] : $opt{table}; # Create where parameter my $where_param = $self->_id_to_param($where, $primary_keys); return $self->select(where => $where_param, %opt); } # DEPRECATED! sub delete_at { my ($self, %opt) = @_; warn "delete_at is DEPRECATED! use delete method id option instead"; # Options my $primary_keys = delete $opt{primary_key}; my $where = delete $opt{where}; # Create where parameter my $where_param = $self->_id_to_param($where, $primary_keys); return $self->delete(where => $where_param, %opt); } # DEPRECATED! sub update_at { my $self = shift; warn "update_at is DEPRECATED! use update method id option instead"; # Options my $param; $param = shift if @_ % 2; my %opt = @_; my $primary_keys = delete $opt{primary_key}; my $where = delete $opt{where}; my $p = delete $opt{param} || {}; $param ||= $p; # Create where parameter my $where_param = $self->_id_to_param($where, $primary_keys); return $self->update(where => $where_param, param => $param, %opt); } # DEPRECATED! sub insert_at { my $self = shift; warn "insert_at is DEPRECATED! use insert method id option instead"; # Options my $param; $param = shift if @_ % 2; my %opt = @_; my $primary_key = delete $opt{primary_key}; $primary_key = [$primary_key] unless ref $primary_key; my $where = delete $opt{where}; my $p = delete $opt{param} || {}; $param ||= $p; # Create where parameter my $where_param = $self->_id_to_param($where, $primary_key); $param = $self->merge_param($where_param, $param); return $self->insert(param => $param, %opt); } # DEPRECATED! sub register_tag { my $self = shift; warn "register_tag is DEPRECATED!"; # Merge tag my $tags = ref $_[0] eq 'HASH' ? $_[0] : {@_}; $self->{_tags} = {%{$self->{_tags} || {}}, %$tags}; return $self; } # DEPRECATED! sub register_tag_processor { my $self = shift; warn "register_tag_processor is DEPRECATED!"; # Merge tag my $tag_processors = ref $_[0] eq 'HASH' ? $_[0] : {@_}; $self->{_tags} = {%{$self->{_tags} || {}}, %{$tag_processors}}; return $self; } # DEPRECATED! sub default_bind_filter { my $self = shift; warn "default_bind_filter is DEPRECATED!"; 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; warn "default_fetch_filter is DEPRECATED!"; 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 insert_param { my $self = shift; warn "insert_param is DEPRECATED! use values_clause instead"; return $self->values_clause(@_); } # DEPRECATED! sub insert_param_tag { warn "insert_param_tag is DEPRECATED! " . "use insert_param instead!"; return shift->insert_param(@_); } # DEPRECATED! sub update_param_tag { warn "update_param_tag is DEPRECATED! " . "use update_param instead"; return shift->update_param(@_); } # DEPRECATED! sub _push_relation { my ($self, $sql, $tables, $relation, $need_where) = @_; if (keys %{$relation || {}}) { $$sql .= $need_where ? 'where ' : 'and '; for my $rcolumn (keys %$relation) { my $table1 = (split (/\./, $rcolumn))[0]; my $table2 = (split (/\./, $relation->{$rcolumn}))[0]; push @$tables, ($table1, $table2); $$sql .= "$rcolumn = " . $relation->{$rcolumn} . 'and '; } } $$sql =~ s/and $/ /; } # DEPRECATED! sub _add_relation_table { my ($self, $tables, $relation) = @_; if (keys %{$relation || {}}) { for my $rcolumn (keys %$relation) { my $table1 = (split (/\./, $rcolumn))[0]; my $table2 = (split (/\./, $relation->{$rcolumn}))[0]; my $table1_exists; my $table2_exists; for my $table (@$tables) { $table1_exists = 1 if $table eq $table1; $table2_exists = 1 if $table eq $table2; } unshift @$tables, $table1 unless $table1_exists; unshift @$tables, $table2 unless $table2_exists; } } } 1; =head1 NAME DBIx::Custom - DBI extension to execute insert, update, delete, and select easily =head1 SYNOPSIS use DBIx::Custom; # Connect my $dbi = DBIx::Custom->connect( dsn => "dbi:mysql:database=dbname", user => 'ken', password => '!LFKD%$&', option => {mysql_enable_utf8 => 1} ); # Insert $dbi->insert({title => 'Perl', author => 'Ken'}, table => 'book'); # Update $dbi->update({title => 'Perl', author => 'Ken'}, table => 'book', where => {id => 5}); # Delete $dbi->delete(table => 'book', where => {author => 'Ken'}); # Select my $result = $dbi->select(table => 'book', column => ['title', 'author'], where => {author => 'Ken'}); # Select, more complex my $result = $dbi->select( table => 'book', column => [ {book => [qw/title author/]}, {company => ['name']} ], where => {'book.author' => 'Ken'}, join => ['left outer join company on book.company_id = company.id'], append => 'order by id limit 5' ); # Fetch while (my $row = $result->fetch) { } # Fetch as hash while (my $row = $result->fetch_hash) { } # Execute SQL with parameter. $dbi->execute( "select id from book where author = :author and title like :title", {author => 'ken', title => '%Perl%'} ); =head1 DESCRIPTION L is L wrapper module to execute SQL easily. This module have the following features. =over 4 =item * Execute C, C, C, or C method's column option. Default to C<.>. =head2 C my $tag_parse = $dbi->tag_parse(0); $dbi = $dbi->tag_parse; Enable DEPRECATED tag parsing functionality, default to 1. If you want to disable tag parsing functionality, set to 0. =head2 C my $user = $dbi->user; $dbi = $dbi->user('Ken'); User name, used when C method is executed. =head2 C my $user_column_info = $dbi->user_column_info; $dbi = $dbi->user_column_info($user_column_info); You can set the date like the following one. [ {table => 'book', column => 'title', info => {...}}, {table => 'author', column => 'name', info => {...}} ] Usually, you set return value of C. my $user_column_info = $dbi->get_column_info(exclude_table => qr/^system/); $dbi->user_column_info($user_column_info); If C is set, C use C to find column info. this is very fast. =head2 C my $user_table_info = $dbi->user_table_info; $dbi = $dbi->user_table_info($user_table_info); You can set the following data. [ {table => 'book', info => {...}}, {table => 'author', info => {...}} ] Usually, you can set return value of C. my $user_table_info = $dbi->get_table_info(exclude => qr/^system/); $dbi->user_table_info($user_table_info); If C is set, C use C to find table info. =head1 METHODS L inherits all methods from L and use all methods of L and implements the following new ones. =head2 C print $dbi->available_datatype; Get available data types. You can use these data types in C's C and C section. =head2 C print $dbi->available_typename; Get available type names. You can use these type names in C's C and C section. =head2 C my $assign_clause = $dbi->assign_clause({title => 'a', age => 2}); Create assign clause title = :title, author = :author This is used to create update clause. "update book set " . $dbi->assign_clause({title => 'a', age => 2}); =head2 C my $column = $dbi->column(book => ['author', 'title']); Create column clause. The follwoing column clause is created. book.author as "book.author", book.title as "book.title" You can change separator by C attribute. # Separator is hyphen $dbi->separator('-'); book.author as "book-author", book.title as "book-title" =head2 C my $dbi = DBIx::Custom->connect( dsn => "dbi:mysql:database=dbname", user => 'ken', password => '!LFKD%$&', option => {mysql_enable_utf8 => 1} ); Connect to the database and create a new L object. L is a wrapper of L. C and C options are true, and C option is false by default. =head2 C my $count = $dbi->count(table => 'book'); Get rows count. Options is same as C method's C option. =back =head2 C $dbi->delete_all(table => $table); Execute delete statement for all rows. Options is same as C. =head2 C $dbi->each_column( sub { my ($dbi, $table, $column, $column_info) = @_; my $type = $column_info->{TYPE_NAME}; if ($type eq 'DATE') { # ... } } ); Iterate all column informations in database. Argument is callback which is executed when one column is found. Callback receive four arguments. C, C, C, and C. If C is set, C method use C infromation, you can improve the performance of C in the following way. my $column_infos = $dbi->get_column_info(exclude_table => qr/^system_/); $dbi->user_column_info($column_info); $dbi->each_column(sub { ... }); =head2 C $dbi->each_table( sub { my ($dbi, $table, $table_info) = @_; my $table_name = $table_info->{TABLE_NAME}; } ); Iterate all table informationsfrom in database. Argument is callback which is executed when one table is found. Callback receive three arguments, C, C
, C
. If C is set, C method use C infromation, you can improve the performance of C in the following way. my $table_infos = $dbi->get_table_info(exclude => qr/^system_/); $dbi->user_table_info($table_info); $dbi->each_table(sub { ... }); =head2 C my $result = $dbi->execute( "select * from book where title = :title and author like :author", {title => 'Perl', author => '%Ken%'} ); my $result = $dbi->execute( "select * from book where title = :book.title and author like :book.author", {'book.title' => 'Perl', 'book.author' => '%Ken%'} ); Execute SQL. SQL can contain column parameter such as :author and :title. You can append table name to column name such as :book.title and :book.author. Second argunet is data, embedded into column parameter. Return value is L object when select statement is executed, or the count of affected rows when insert, update, delete statement is executed. Named placeholder such as C<:title> is replaced by placeholder C. # Original select * from book where title = :title and author like :author # Replaced select * from where title = ? and author like ?; You can specify operator with named placeholder by C syntax. # Original select * from book where :title{=} and :author{like} # Replaced select * from where title = ? and author like ?; Note that colons in time format such as 12:13:15 is exeption, it is not parsed as named placeholder. If you want to use colon generally, you must escape it by C<\\> select * from where title = "aa\\:bb"; B The following opitons are available. =over 4 =item C You can filter sql after the sql is build. after_build_sql => $code_ref The following one is one example. $dbi->select( table => 'book', column => 'distinct(name)', after_build_sql => sub { "select count(*) from ($_[0]) as t1" } ); The following SQL is executed. select count(*) from (select distinct(name) from book) as t1; =item C append => 'order by name' Append some statement after SQL. =item C Specify database bind data type. bind_type => [image => DBI::SQL_BLOB] bind_type => [[qw/image audio/] => DBI::SQL_BLOB] This is used to bind parameter by C of statment handle. $sth->bind_param($pos, $value, DBI::SQL_BLOB); =item C filter => { title => sub { uc $_[0] } author => sub { uc $_[0] } } # Filter name filter => { title => 'upper_case', author => 'upper_case' } # At once filter => [ [qw/title author/] => sub { uc $_[0] } ] Filter. You can set subroutine or filter name registered by by C. This filter is executed before data is saved into database. and before type rule filter is executed. =item C query => 1 C method return hash reference which contain SQL and column infromation my $sql = $query->{sql}; my $columns = $query->{columns}; =item C reuse => $hash_ref Reuse query object if the hash reference variable is set. my $queries = {}; $dbi->execute($sql, $param, reuse => $queries); This will improved performance when you want to execute same query repeatedly because generally creating query object is slow. =item C primary_key => 'id' primary_key => ['id1', 'id2'] Priamry key. This is used for C option. =item C
table => 'author' If you want to omit table name in column name and enable C and C type filter, You must set C
option. $dbi->execute("select * from book where title = :title and author = :author", {title => 'Perl', author => 'Ken', table => 'book'); # Same $dbi->execute( "select * from book where title = :book.title and author = :book.author", {title => 'Perl', author => 'Ken'); =item C table_alias => {user => 'worker'} Table alias. Key is real table name, value is alias table name. If you set C, you can enable C and C type rule on alias table name. =item C type_rule_off => 1 Turn C and C type rule off. =item C type_rule1_off => 1 Turn C type rule off. =item C type_rule2_off => 1 Turn C type rule off. =back =head2 C my $column_infos = $dbi->get_column_info(exclude_table => qr/^system_/); get column infomation except for one which match C pattern. [ {table => 'book', column => 'title', info => {...}}, {table => 'author', column => 'name' info => {...}} ] =head2 C my $table_infos = $dbi->get_table_info(exclude => qr/^system_/); get table infomation except for one which match C pattern. [ {table => 'book', info => {...}}, {table => 'author', info => {...}} ] You can set this value to C. =head2 C $dbi->helper( find_or_create => sub { my $self = shift; # Process }, ... ); Register helper. These helper is called directly from L object. $dbi->find_or_create; =head2 C $dbi->insert({title => 'Perl', author => 'Ken'}, table => 'book'); Execute insert statement. First argument is row data. Return value is affected row count. If you want to set constant value to row data, use scalar reference as parameter value. {date => \"NOW()"} B C method use all of C method's options, and use the following new ones. =over 4 =item C created_at => 'created_datetime' Created timestamp column name. time when row is created is set to the column. default time format is "YYYY-mm-dd HH:MM:SS", which can be changed by C attribute. =item C id => 4 id => [4, 5] ID corresponding to C. You can insert a row by C and C. $dbi->insert( {title => 'Perl', author => 'Ken'} primary_key => ['id1', 'id2'], id => [4, 5], table => 'book' ); The above is same as the followin one. $dbi->insert( {id1 => 4, id2 => 5, title => 'Perl', author => 'Ken'}, table => 'book' ); =item C prefix => 'or replace' prefix before table name section insert or replace into book =item C
table => 'book' Table name. =item C This option is same as C method C option. =item C wrap => {price => sub { "max($_[0])" }} placeholder wrapped string. If the following statement $dbi->insert({price => 100}, table => 'book', {price => sub { "$_[0] + 5" }}); is executed, the following SQL is executed. insert into book price values ( ? + 5 ); =back =over 4 =head2 C $dbi->include_model('MyModel'); Include models from specified namespace, the following layout is needed to include models. lib / MyModel.pm / MyModel / book.pm / company.pm Name space module, extending L. B package MyModel; use DBIx::Custom::Model -base; 1; Model modules, extending name space module. B package MyModel::book; use MyModel -base; 1; B package MyModel::company; use MyModel -base; 1; MyModel::book and MyModel::company is included by C. You can get model object by C. my $book_model = $dbi->model('book'); my $company_model = $dbi->model('company'); See L to know model features. =head2 C my $like_value = $dbi->like_value Code reference which return a value for the like value. sub { "%$_[0]%" } =head2 C my $mapper = $dbi->mapper(param => $param); Create a new L object. =head2 C my $param = $dbi->merge_param({key1 => 1}, {key1 => 1, key2 => 2}); Merge parameters. The following new parameter is created. {key1 => [1, 1], key2 => 2} If same keys contains, the value is converted to array reference. =head2 C my $model = $dbi->model('book'); Get a L object create by C or C =head2 C my $column = $dbi->mycolumn(book => ['author', 'title']); Create column clause for myself. The follwoing column clause is created. book.author as author, book.title as title =head2 C my $dbi = DBIx::Custom->new( dsn => "dbi:mysql:database=dbname", user => 'ken', password => '!LFKD%$&', option => {mysql_enable_utf8 => 1} ); Create a new L object. =head2 C my $not_exists = $dbi->not_exists; DBIx::Custom::NotExists object, indicating the column is not exists. This is used in C of L . =head2 C my $order = $dbi->order; Create a new L object. =head2 C my $quooted = $dbi->q("title"); Quote string by value of C. =head2 C $dbi->register_filter( # Time::Piece object to database DATE format tp_to_date => sub { my $tp = shift; return $tp->strftime('%Y-%m-%d'); }, # database DATE format to Time::Piece object date_to_tp => sub { my $date = shift; return Time::Piece->strptime($date, '%Y-%m-%d'); } ); Register filters, used by C option of many methods. =head2 C method use all of C method's options, and use the following new ones. =over 4 =item C column => 'author' column => ['author', 'title'] Column clause. if C is not specified, '*' is set. column => '*' You can specify hash of array reference. column => [ {book => [qw/author title/]}, {person => [qw/name age/]} ] This is expanded to the following one by using C method. book.author as "book.author", book.title as "book.title", person.name as "person.name", person.age as "person.age" You can specify array of array reference, first argument is column name, second argument is alias. column => [ ['date(book.register_datetime)' => 'book.register_date'] ]; Alias is quoted properly and joined. date(book.register_datetime) as "book.register_date" =item C id => 4 id => [4, 5] ID corresponding to C. You can select rows by C and C. $dbi->select( primary_key => ['id1', 'id2'], id => [4, 5], table => 'book' ); The above is same as the followin one. $dbi->select( where => {id1 => 4, id2 => 5}, table => 'book' ); =item C param => {'table2.key3' => 5} Parameter shown before where clause. For example, if you want to contain tag in join clause, you can pass parameter by C option. join => ['inner join (select * from table2 where table2.key3 = :table2.key3)' . ' as table2 on table1.key1 = table2.key1'] =itme C prefix => 'SQL_CALC_FOUND_ROWS' Prefix of column cluase select SQL_CALC_FOUND_ROWS title, author from book; =item C join => [ 'left outer join company on book.company_id = company_id', 'left outer join location on company.location_id = location.id' ] Join clause. If column cluase or where clause contain table name like "company.name", join clausees needed when SQL is created is used automatically. $dbi->select( table => 'book', column => ['company.location_id as location_id'], where => {'company.name' => 'Orange'}, join => [ 'left outer join company on book.company_id = company.id', 'left outer join location on company.location_id = location.id' ] ); In above select, column and where clause contain "company" table, the following SQL is created select company.location_id as location_id from book left outer join company on book.company_id = company.id where company.name = ?; You can specify two table by yourself. This is useful when join parser can't parse the join clause correctly. $dbi->select( table => 'book', column => ['company.location_id as location_id'], where => {'company.name' => 'Orange'}, join => [ { clause => 'left outer join location on company.location_id = location.id', table => ['company', 'location'] } ] ); =item C
table => 'book' Table name. =item C # Hash refrence where => {author => 'Ken', 'title' => 'Perl'} # DBIx::Custom::Where object where => $dbi->where( clause => ['and', ':author{=}', ':title{like}'], param => {author => 'Ken', title => '%Perl%'} ); # Array reference, this is same as above where => [ ['and', ':author{=}', ':title{like}'], {author => 'Ken', title => '%Perl%'} ]; # String where => 'title is null' Where clause. See L. =back =head2 C $dbi->setup_model; Setup all model objects. C of model object is automatically set, parsing database information. =head2 C $dbi->type_rule( into1 => { date => sub { ... }, datetime => sub { ... } }, into2 => { date => sub { ... }, datetime => sub { ... } }, from1 => { # DATE 9 => sub { ... }, # DATETIME or TIMESTAMP 11 => sub { ... }, } from2 => { # DATE 9 => sub { ... }, # DATETIME or TIMESTAMP 11 => sub { ... }, } ); Filtering rule when data is send into and get from database. This has a little complex problem. In C and C you can specify type name as same as type name defined by create table, such as C or C. Note that type name and data type don't contain upper case. If these contain upper case charactor, you convert it to lower case. C is executed after C. Type rule of C and C is enabled on the following column name. =over 4 =item 1. column name issue_date issue_datetime This need C
option in each method. =item 2. table name and column name, separator is dot book.issue_date book.issue_datetime =back You get all type name used in database by C. print $dbi->available_typename; In C and C you specify data type, not type name. C is executed after C. You get all data type by C. print $dbi->available_datatype; You can also specify multiple types at once. $dbi->type_rule( into1 => [ [qw/DATE DATETIME/] => sub { ... }, ], ); =head2 C $dbi->update({title => 'Perl'}, table => 'book', where => {id => 4}); Execute update statement. First argument is update row data. If you want to set constant value to row data, use scalar reference as parameter value. {date => \"NOW()"} B C method use all of C method's options, and use the following new ones. =over 4 =item C id => 4 id => [4, 5] ID corresponding to C. You can update rows by C and C. $dbi->update( {title => 'Perl', author => 'Ken'} primary_key => ['id1', 'id2'], id => [4, 5], table => 'book' ); The above is same as the followin one. $dbi->update( {title => 'Perl', author => 'Ken'} where => {id1 => 4, id2 => 5}, table => 'book' ); =item C prefix => 'or replace' prefix before table name section update or replace book =item C
table => 'book' Table name. =item C Same as C method first to find row. If the row is exists, C is executed. If not, C is executed. C C method use all common option in C