X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=1ed743d7c15cb1c96f72f3ef40b59c73310f0217;hb=f1952f5c69e092d9ce416586f29942f8c2f66bce;hp=dc66cb6b924d04e8748a23c1d7b2088cb9ac8b29;hpb=d40080c39809e75e0aa8b949ea157e274db1b66d;p=dbsrgits%2FDBIx-Class-Historic.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index dc66cb6..1ed743d 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -7,10 +7,10 @@ use strict; use warnings; use Carp::Clan qw/^DBIx::Class/; use DBI; -use DBIx::Class::SQLAHacks; use DBIx::Class::Storage::DBI::Cursor; use DBIx::Class::Storage::Statistics; -use Scalar::Util qw/blessed weaken/; +use Scalar::Util(); +use List::Util(); __PACKAGE__->mk_group_accessors('simple' => qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts @@ -602,6 +602,7 @@ sub sql_maker { my ($self) = @_; unless ($self->_sql_maker) { my $sql_maker_class = $self->sql_maker_class; + $self->ensure_class_loaded ($sql_maker_class); $self->_sql_maker($sql_maker_class->new( $self->_sql_maker_args )); } return $self->_sql_maker; @@ -614,15 +615,15 @@ sub _populate_dbh { my @info = @{$self->_dbi_connect_info || []}; $self->_dbh($self->_connect(@info)); + $self->_conn_pid($$); + $self->_conn_tid(threads->tid) if $INC{'threads.pm'}; + $self->_determine_driver; # Always set the transaction depth on connect, since # there is no transaction in progress by definition $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1; - $self->_conn_pid($$); - $self->_conn_tid(threads->tid) if $INC{'threads.pm'}; - my $connection_do = $self->on_connect_do; $self->_do_connection_actions($connection_do) if $connection_do; } @@ -716,7 +717,7 @@ sub _connect { if($dbh && !$self->unsafe) { my $weak_self = $self; - weaken($weak_self); + Scalar::Util::weaken($weak_self); $dbh->{HandleError} = sub { if ($weak_self) { $weak_self->throw_exception("DBI Exception: $_[0]"); @@ -897,7 +898,7 @@ sub txn_rollback { sub _prep_for_execute { my ($self, $op, $extra_bind, $ident, $args) = @_; - if( blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) { + if( Scalar::Util::blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) { $ident = $ident->from(); } @@ -909,6 +910,7 @@ sub _prep_for_execute { return ($sql, \@bind); } + sub _fix_bind_params { my ($self, @bind) = @_; @@ -930,7 +932,7 @@ sub _query_start { if ( $self->debug ) { @bind = $self->_fix_bind_params(@bind); - + $self->debugobj->query_start( $sql, @bind ); } } @@ -989,8 +991,8 @@ sub _execute { sub insert { my ($self, $source, $to_insert) = @_; - - my $ident = $source->from; + + my $ident = $source->from; my $bind_attributes = $self->source_bind_attributes($source); my $updated_cols = {}; @@ -1051,7 +1053,27 @@ sub insert_bulk { $sth->bind_param_array( $placeholder_index, [@data], $attributes ); $placeholder_index++; } - my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status}); + my $rv = eval { $sth->execute_array({ArrayTupleStatus => $tuple_status}) }; + if (my $err = $@) { + my $i = 0; + ++$i while $i <= $#$tuple_status && !ref $tuple_status->[$i]; + + $self->throw_exception($sth->errstr || "Unexpected populate error: $err") + if ($i > $#$tuple_status); + + require Data::Dumper; + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Indent = 1; + local $Data::Dumper::Useqq = 1; + local $Data::Dumper::Quotekeys = 0; + + $self->throw_exception(sprintf "%s for populate slice:\n%s", + $tuple_status->[$i][1], + Data::Dumper::Dumper( + { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) } + ), + ); + } $self->throw_exception($sth->errstr) if !$rv; $self->_query_end( $sql, @bind ); @@ -1071,7 +1093,7 @@ sub delete { my $self = shift @_; my $source = shift @_; - my $bind_attrs = {}; ## If ever it's needed... + my $bind_attrs = $self->source_bind_attributes($source); return $self->_execute('delete' => [], $source, $bind_attrs, @_); } @@ -1082,66 +1104,69 @@ sub delete { # # Genarating a single PK column subquery is trivial and supported # by all RDBMS. However if we have a multicolumn PK, things get ugly. -# Look at multipk_update_delete() -sub subq_update_delete { +# Look at _multipk_update_delete() +sub _subq_update_delete { my $self = shift; my ($rs, $op, $values) = @_; - if ($rs->result_source->primary_columns == 1) { - return $self->_onepk_update_delete (@_); + my $rsrc = $rs->result_source; + + # we already check this, but double check naively just in case. Should be removed soon + my $sel = $rs->_resolved_attrs->{select}; + $sel = [ $sel ] unless ref $sel eq 'ARRAY'; + my @pcols = $rsrc->primary_columns; + if (@$sel != @pcols) { + $self->throw_exception ( + 'Subquery update/delete can not be called on resultsets selecting a' + .' number of columns different than the number of primary keys' + ); } + + if (@pcols == 1) { + return $self->$op ( + $rsrc, + $op eq 'update' ? $values : (), + { $pcols[0] => { -in => $rs->as_query } }, + ); + } + else { return $self->_multipk_update_delete (@_); } } -# Generally a single PK resultset operation is trivially expressed -# with PK IN (subquery). However some databases (mysql) do not support -# modification of a table mentioned in the subselect. This method -# should be overriden in the appropriate storage class to be smarter -# in such situations -sub _onepk_update_delete { - - my $self = shift; - my ($rs, $op, $values) = @_; - - my $rsrc = $rs->result_source; - my $attrs = $rs->_resolved_attrs; - my @pcols = $rsrc->primary_columns; - - $self->throw_exception ('_onepk_update_delete can not be called on resultsets selecting multiple columns') - if (ref $attrs->{select} eq 'ARRAY' and @{$attrs->{select}} > 1); - - return $self->$op ( - $rsrc, - $op eq 'update' ? $values : (), - { $pcols[0] => { -in => $rs->as_query } }, - ); +# ANSI SQL does not provide a reliable way to perform a multicol-PK +# resultset update/delete involving subqueries. So by default resort +# to simple (and inefficient) delete_all style per-row opearations, +# while allowing specific storages to override this with a faster +# implementation. +# +sub _multipk_update_delete { + return shift->_per_row_update_delete (@_); } -# ANSI SQL does not provide a reliable way to perform a multicol-PK -# resultset update/delete involving subqueries. So resort to simple -# (and inefficient) delete_all style per-row opearations, while allowing -# specific storages to override this with a faster implementation. +# This is the default loop used to delete/update rows for multi PK +# resultsets, and used by mysql exclusively (because it can't do anything +# else). # # We do not use $row->$op style queries, because resultset update/delete # is not expected to cascade (this is what delete_all/update_all is for). # # There should be no race conditions as the entire operation is rolled # in a transaction. -sub _multipk_update_delete { +# +sub _per_row_update_delete { my $self = shift; my ($rs, $op, $values) = @_; my $rsrc = $rs->result_source; my @pcols = $rsrc->primary_columns; - my $attrs = $rs->_resolved_attrs; - - $self->throw_exception ('Number of columns selected by supplied resultset does not match number of primary keys') - if ( ref $attrs->{select} ne 'ARRAY' or @{$attrs->{select}} != @pcols ); my $guard = $self->txn_scope_guard; + # emulate the return value of $sth->execute for non-selects + my $row_cnt = '0E0'; + my $subrs_cur = $rs->cursor; while (my @pks = $subrs_cur->next) { @@ -1155,40 +1180,90 @@ sub _multipk_update_delete { $op eq 'update' ? $values : (), $cond, ); + + $row_cnt++; } $guard->commit; - return 1; + return $row_cnt; } - sub _select { my $self = shift; + + # localization is neccessary as + # 1) there is no infrastructure to pass this around (easy to do, but will wait) + # 2) _select_args sets it and _prep_for_execute consumes it my $sql_maker = $self->sql_maker; local $sql_maker->{for}; + return $self->_execute($self->_select_args(@_)); } +sub _select_args_to_query { + my $self = shift; + + # localization is neccessary as + # 1) there is no infrastructure to pass this around (easy to do, but will wait) + # 2) _select_args sets it and _prep_for_execute consumes it + my $sql_maker = $self->sql_maker; + local $sql_maker->{for}; + + # my ($op, $bind, $ident, $bind_attrs, $select, $cond, $order, $rows, $offset) + # = $self->_select_args($ident, $select, $cond, $attrs); + my ($op, $bind, $ident, $bind_attrs, @args) = + $self->_select_args(@_); + + # my ($sql, $prepared_bind) = $self->_prep_for_execute($op, $bind, $ident, [ $select, $cond, $order, $rows, $offset ]); + my ($sql, $prepared_bind) = $self->_prep_for_execute($op, $bind, $ident, \@args); + $prepared_bind ||= []; + + return wantarray + ? ($sql, $prepared_bind, $bind_attrs) + : \[ "($sql)", @$prepared_bind ] + ; +} + sub _select_args { my ($self, $ident, $select, $condition, $attrs) = @_; - my $order = $attrs->{order_by}; - my $for = delete $attrs->{for}; my $sql_maker = $self->sql_maker; - $sql_maker->{for} = $for; + $sql_maker->{for} = delete $attrs->{for}; - if (exists $attrs->{group_by} || $attrs->{having}) { - $order = { - group_by => $attrs->{group_by}, - having => $attrs->{having}, - ($order ? (order_by => $order) : ()) - }; + my $order = { map + { $attrs->{$_} ? ( $_ => $attrs->{$_} ) : () } + (qw/order_by group_by having _virtual_order_by/ ) + }; + + + my $bind_attrs = {}; + + my $alias2source = $self->_resolve_ident_sources ($ident); + + for my $alias (keys %$alias2source) { + my $bindtypes = $self->source_bind_attributes ($alias2source->{$alias}) || {}; + for my $col (keys %$bindtypes) { + + my $fqcn = join ('.', $alias, $col); + $bind_attrs->{$fqcn} = $bindtypes->{$col} if $bindtypes->{$col}; + + # so that unqualified searches can be bound too + $bind_attrs->{$col} = $bind_attrs->{$fqcn} if $alias eq 'me'; + } } - my $bind_attrs = {}; ## Future support + + # This would be the point to deflate anything found in $condition + # (and leave $attrs->{bind} intact). Problem is - inflators historically + # expect a row object. And all we have is a resultsource (it is trivial + # to extract deflator coderefs via $alias2source above). + # + # I don't see a way forward other than changing the way deflators are + # invoked, and that's just bad... + my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order); if ($attrs->{software_limit} || - $self->sql_maker->_default_limit_syntax eq "GenericSubQ") { + $sql_maker->_default_limit_syntax eq "GenericSubQ") { $attrs->{software_limit} = 1; } else { $self->throw_exception("rows attribute must be positive if present") @@ -1201,6 +1276,99 @@ sub _select_args { return @args; } +sub _resolve_ident_sources { + my ($self, $ident) = @_; + + my $alias2source = {}; + + # the reason this is so contrived is that $ident may be a {from} + # structure, specifying multiple tables to join + if ( Scalar::Util::blessed($ident) && $ident->isa("DBIx::Class::ResultSource") ) { + # this is compat mode for insert/update/delete which do not deal with aliases + $alias2source->{me} = $ident; + } + elsif (ref $ident eq 'ARRAY') { + + for (@$ident) { + my $tabinfo; + if (ref $_ eq 'HASH') { + $tabinfo = $_; + } + if (ref $_ eq 'ARRAY' and ref $_->[0] eq 'HASH') { + $tabinfo = $_->[0]; + } + + $alias2source->{$tabinfo->{-alias}} = $tabinfo->{-source_handle}->resolve + if ($tabinfo->{-source_handle}); + } + } + + return $alias2source; +} + +sub count { + my ($self, $source, $attrs) = @_; + + my $tmp_attrs = { %$attrs }; + + # take off any pagers, record_filter is cdbi, and no point of ordering a count + delete $tmp_attrs->{$_} for (qw/select as rows offset page order_by record_filter/); + + # overwrite the selector + $tmp_attrs->{select} = { count => '*' }; + + my $tmp_rs = $source->resultset_class->new($source, $tmp_attrs); + my ($count) = $tmp_rs->cursor->next; + + # if the offset/rows attributes are still present, we did not use + # a subquery, so we need to make the calculations in software + $count -= $attrs->{offset} if $attrs->{offset}; + $count = $attrs->{rows} if $attrs->{rows} and $attrs->{rows} < $count; + $count = 0 if ($count < 0); + + return $count; +} + +sub count_grouped { + my ($self, $source, $attrs) = @_; + + # copy for the subquery, we need to do some adjustments to it too + my $sub_attrs = { %$attrs }; + + # these can not go in the subquery, and there is no point of ordering it + delete $sub_attrs->{$_} for qw/prefetch collapse select as order_by/; + + # if we prefetch, we group_by primary keys only as this is what we would get out of the rs via ->next/->all + # simply deleting group_by suffices, as the code below will re-fill it + # Note: we check $attrs, as $sub_attrs has collapse deleted + if (ref $attrs->{collapse} and keys %{$attrs->{collapse}} ) { + delete $sub_attrs->{group_by}; + } + + $sub_attrs->{group_by} ||= [ map { "$attrs->{alias}.$_" } ($source->primary_columns) ]; + $sub_attrs->{select} = $self->_grouped_count_select ($source, $sub_attrs); + + $attrs->{from} = [{ + count_subq => $source->resultset_class->new ($source, $sub_attrs )->as_query + }]; + + # the subquery replaces this + delete $attrs->{$_} for qw/where bind prefetch collapse group_by having having_bind rows offset page pager/; + + return $self->count ($source, $attrs); +} + +# +# Returns a SELECT to go with a supplied GROUP BY +# (caled by count_grouped so a group_by is present) +# Most databases expect them to match, but some +# choke in various ways. +# +sub _grouped_count_select { + my ($self, $source, $rs_args) = @_; + return $rs_args->{group_by}; +} + sub source_bind_attributes { my ($self, $source) = @_; @@ -1388,7 +1556,28 @@ sub bind_attribute_by_data_type { return; } -=head2 create_ddl_dir +=head2 is_datatype_numeric + +Given a datatype from column_info, returns a boolean value indicating if +the current RDBMS considers it a numeric value. This controls how +L decides whether to mark the column as +dirty - when the datatype is deemed numeric a C<< != >> comparison will +be performed instead of the usual C. + +=cut + +sub is_datatype_numeric { + my ($self, $dt) = @_; + + return 0 unless $dt; + + return $dt =~ /^ (?: + numeric | int(?:eger)? | (?:tiny|small|medium|big)int | dec(?:imal)? | real | float | double (?: \s+ precision)? | (?:big)?serial + ) $/ix; +} + + +=head2 create_ddl_dir (EXPERIMENTAL) =over 4 @@ -1397,7 +1586,38 @@ sub bind_attribute_by_data_type { =back Creates a SQL file based on the Schema, for each of the specified -database types, in the given directory. +database engines in C<\@databases> in the given directory. +(note: specify L names, not L driver names). + +Given a previous version number, this will also create a file containing +the ALTER TABLE statements to transform the previous schema into the +current one. Note that these statements may contain C or +C statements that can potentially destroy data. + +The file names are created using the C method below, please +override this method in your schema if you would like a different file +name format. For the ALTER file, the same format is used, replacing +$version in the name with "$preversion-$version". + +See L for a list of values for C<\%sqlt_args>. +The most common value for this would be C<< { add_drop_table => 1 } >> +to have the SQL produced include a C statement for each table +created. For quoting purposes supply C and +C. + +If no arguments are passed, then the following default values are assumed: + +=over 4 + +=item databases - ['MySQL', 'SQLite', 'PostgreSQL'] + +=item version - $schema->schema_version + +=item directory - './' + +=item preversion - + +=back By default, C<\%sqlt_args> will have @@ -1408,6 +1628,12 @@ hashref like the following { ignore_constraint_names => 0, # ... other options } + +Note that this feature is currently EXPERIMENTAL and may not work correctly +across all databases, or fully handle complex relationships. + +WARNING: Please check all SQL files created, before applying them. + =cut sub create_ddl_dir { @@ -1543,8 +1769,9 @@ sub create_ddl_dir { =back Returns the statements used by L and L. -The database driver name is given by C<$type>, though the value from -L is used if it is not specified. + +The L (not L) database driver name can be explicitly +provided in C<$type>, otherwise the result of L is used as default. C<$directory> is used to return statements from files in a previously created L directory and is optional. The filenames are constructed @@ -1612,7 +1839,7 @@ sub deploy { } $self->_query_end($line); }; - my @statements = $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ); + my @statements = $self->deployment_statements($schema, $type, undef, $dir, { %{ $sqltargs || {} }, no_comments => 1 } ); if (@statements > 1) { foreach my $statement (@statements) { $deploy->( $statement );