X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=749c7901d44a50c801382f47942497bc09dd91c5;hb=d9e53b85a871e0a793d6b164a6ad977341c07b27;hp=f7ba45489803bf711e7cdc03d179ce9a429fced2;hpb=1685b25e531b0446832933e0f498ddff8855b285;p=dbsrgits%2FDBIx-Class-Historic.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index f7ba454..749c790 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -7,21 +7,22 @@ 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 - _conn_pid _conn_tid transaction_depth _dbh_autocommit savepoints/ + _conn_pid _conn_tid transaction_depth _dbh_autocommit _on_connect_do + _on_disconnect_do _on_connect_do_store _on_disconnect_do_store + savepoints/ ); # the values for these accessors are picked out (and deleted) from # the attribute hashref passed to connect_info my @storage_options = qw/ - on_connect_do on_disconnect_do disable_sth_caching unsafe auto_savepoint + on_connect_call on_disconnect_call disable_sth_caching unsafe auto_savepoint /; __PACKAGE__->mk_group_accessors('simple' => @storage_options); @@ -178,6 +179,91 @@ immediately before disconnecting from the database. Note, this only runs if you explicitly call L on the storage object. +=item on_connect_call + +A more generalized form of L that calls the specified +C methods in your storage driver. + + on_connect_do => 'select 1' + +is equivalent to: + + on_connect_call => [ [ do_sql => 'select 1' ] ] + +Its values may contain: + +=over + +=item a scalar + +Will call the C method. + +=item a code reference + +Will execute C<< $code->($storage) >> + +=item an array reference + +Each value can be a method name or code reference. + +=item an array of arrays + +For each array, the first item is taken to be the C method name +or code reference, and the rest are parameters to it. + +=back + +Some predefined storage methods you may use: + +=over + +=item do_sql + +Executes a SQL string or a code reference that returns a SQL string. This is +what L and L use. + +It can take: + +=over + +=item a scalar + +Will execute the scalar as SQL. + +=item an arrayref + +Taken to be arguments to L, the SQL string optionally followed by the +attributes hashref and bind values. + +=item a code reference + +Will execute C<< $code->($storage) >> and execute the return array refs as +above. + +=back + +=item datetime_setup + +Execute any statements necessary to initialize the database session to return +and accept datetime/timestamp values used with +L. + +Only necessary for some databases, see your specific storage driver for +implementation details. + +=back + +=item on_disconnect_call + +Takes arguments in the same form as L and executes them +immediately before disconnecting from the database. + +Calls the C methods as opposed to the +C methods called by L. + +Note, this only runs if you explicitly call L on the +storage object. + =item disable_sth_caching If set to a true value, this option will disable the caching of @@ -348,6 +434,11 @@ sub connect_info { $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val; } } + for my $connect_do_opt (qw/on_connect_do on_disconnect_do/) { + if(my $opt_val = delete $attrs{$connect_do_opt}) { + $self->$connect_do_opt($opt_val); + } + } } %attrs = () if (ref $args[0] eq 'CODE'); # _connect() never looks past $args[0] in this case @@ -360,6 +451,55 @@ sub connect_info { This method is deprecated in favour of setting via L. +=cut + +sub on_connect_do { + my $self = shift; + $self->_setup_connect_do(on_connect_do => @_); +} + +=head2 on_disconnect_do + +This method is deprecated in favour of setting via L. + +=cut + +sub on_disconnect_do { + my $self = shift; + $self->_setup_connect_do(on_disconnect_do => @_); +} + +sub _setup_connect_do { + my ($self, $opt) = (shift, shift); + + my $accessor = "_$opt"; + my $store = "_${opt}_store"; + + return $self->$accessor if not @_; + + my $val = shift; + + if (not defined $val) { + $self->$accessor(undef); + $self->$store(undef); + return; + } + + my @store; + + if (not ref($val)) { + push @store, [ 'do_sql', $val ]; + } elsif (ref($val) eq 'CODE') { + push @store, $val; + } elsif (ref($val) eq 'ARRAY') { + push @store, map [ 'do_sql', $_ ], @$val; + } else { + $self->throw_exception("Invalid type for $opt ".ref($val)); + } + + $self->$store(\@store); + $self->$accessor($val); +} =head2 dbh_do @@ -507,8 +647,12 @@ sub disconnect { my ($self) = @_; if( $self->connected ) { - my $connection_do = $self->on_disconnect_do; - $self->_do_connection_actions($connection_do) if ref($connection_do); + if (my $connection_call = $self->on_disconnect_call) { + $self->_do_connection_actions(disconnect_call_ => $connection_call) + } + if (my $connection_do = $self->_on_disconnect_do_store) { + $self->_do_connection_actions(disconnect_call_ => $connection_do) + } $self->_dbh->rollback unless $self->_dbh_autocommit; $self->_dbh->disconnect; @@ -603,6 +747,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; @@ -624,8 +769,12 @@ sub _populate_dbh { # there is no transaction in progress by definition $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1; - my $connection_do = $self->on_connect_do; - $self->_do_connection_actions($connection_do) if $connection_do; + if (my $connection_call = $self->on_connect_call) { + $self->_do_connection_actions(connect_call_ => $connection_call) + } + if (my $connection_do = $self->_on_connect_do_store) { + $self->_do_connection_actions(connect_call_ => $connection_do) + } } sub _determine_driver { @@ -650,25 +799,41 @@ sub _determine_driver { } sub _do_connection_actions { - my $self = shift; - my $connection_do = shift; - - if (!ref $connection_do) { - $self->_do_query($connection_do); - } - elsif (ref $connection_do eq 'ARRAY') { - $self->_do_query($_) foreach @$connection_do; - } - elsif (ref $connection_do eq 'CODE') { - $connection_do->($self); - } - else { - $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref $connection_do) ); + my $self = shift; + my $method_prefix = shift; + my $call = shift; + + if (not ref($call)) { + my $method = $method_prefix . $call; + $self->$method(@_); + } elsif (ref($call) eq 'CODE') { + $self->$call(@_); + } elsif (ref($call) eq 'ARRAY') { + if (ref($call->[0]) ne 'ARRAY') { + $self->_do_connection_actions($method_prefix, $_) for @$call; + } else { + $self->_do_connection_actions($method_prefix, @$_) for @$call; + } + } else { + $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref($call)) ); } return $self; } +sub connect_call_do_sql { + my $self = shift; + $self->_do_query(@_); +} + +sub disconnect_call_do_sql { + my $self = shift; + $self->_do_query(@_); +} + +# override in db-specific backend when necessary +sub connect_call_datetime_setup { 1 } + sub _do_query { my ($self, $action) = @_; @@ -717,7 +882,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]"); @@ -898,7 +1063,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(); } @@ -910,6 +1075,7 @@ sub _prep_for_execute { return ($sql, \@bind); } + sub _fix_bind_params { my ($self, @bind) = @_; @@ -931,7 +1097,7 @@ sub _query_start { if ( $self->debug ) { @bind = $self->_fix_bind_params(@bind); - + $self->debugobj->query_start( $sql, @bind ); } } @@ -990,8 +1156,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 = {}; @@ -1092,7 +1258,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, @_); } @@ -1104,7 +1270,7 @@ 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 { +sub _subq_update_delete { my $self = shift; my ($rs, $op, $values) = @_; @@ -1190,31 +1356,61 @@ sub _per_row_update_delete { 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 ($self, $ident, $select, $where, $attrs) = @_; - my $for = delete $attrs->{for}; my $sql_maker = $self->sql_maker; - $sql_maker->{for} = $for; - - my @in_order_attrs = qw/group_by having _virtual_order_by/; - if (List::Util::first { exists $attrs->{$_} } (@in_order_attrs) ) { - $order = { - ($order - ? (order_by => $order) - : () - ), - ( map { $_ => $attrs->{$_} } (@in_order_attrs) ) - }; + my $alias2source = $self->_resolve_ident_sources ($ident); + + # calculate bind_attrs before possible $ident mangling + my $bind_attrs = {}; + 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 - my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order); + + my @limit; if ($attrs->{software_limit} || $sql_maker->_default_limit_syntax eq "GenericSubQ") { $attrs->{software_limit} = 1; @@ -1224,32 +1420,246 @@ sub _select_args { # MySQL actually recommends this approach. I cringe. $attrs->{rows} = 2**48 if not defined $attrs->{rows} and defined $attrs->{offset}; - push @args, $attrs->{rows}, $attrs->{offset}; + + if ($attrs->{rows} && keys %{$attrs->{collapse}}) { + ($ident, $select, $where, $attrs) + = $self->_adjust_select_args_for_limited_prefetch ($ident, $select, $where, $attrs); + } + else { + push @limit, $attrs->{rows}, $attrs->{offset}; + } } - return @args; + +### + # This would be the point to deflate anything found in $where + # (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 $order = { map + { $attrs->{$_} ? ( $_ => $attrs->{$_} ) : () } + (qw/order_by group_by having _virtual_order_by/ ) + }; + + + $sql_maker->{for} = delete $attrs->{for}; + + return ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $where, $order, @limit); } -sub count { - my ($self, $source, $attrs) = @_; +sub _adjust_select_args_for_limited_prefetch { + my ($self, $from, $select, $where, $attrs) = @_; + + if ($attrs->{group_by} and @{$attrs->{group_by}}) { + $self->throw_exception ('Prefetch with limit (rows/offset) is not supported on resultsets with a group_by attribute'); + } - # take off any column specs, any pagers, record_filter is cdbi, and no point of ordering a count - delete $attrs->{$_} for (qw/columns +columns select +select as +as rows offset page pager order_by record_filter/); + $self->throw_exception ('Prefetch with limit (rows/offset) is not supported on resultsets with a custom from attribute') + if (ref $from ne 'ARRAY'); - $attrs->{select} = { count => '*' }; - $attrs->{as} = [qw/count/]; - my $tmp_rs = $source->resultset_class->new($source, $attrs); - my ($count) = $tmp_rs->cursor->next; + # separate attributes + my $sub_attrs = { %$attrs }; + delete $attrs->{$_} for qw/where bind rows offset/; + delete $sub_attrs->{$_} for qw/for collapse select order_by/; - return $count; + my $alias = $attrs->{alias}; + + # create subquery select list + my $sub_select = [ grep { $_ =~ /^$alias\./ } @{$attrs->{select}} ]; + + # bring over all non-collapse-induced order_by into the inner query (if any) + # the outer one will have to keep them all + if (my $ord_cnt = @{$attrs->{order_by}} - @{$attrs->{_collapse_order_by}} ) { + $sub_attrs->{order_by} = [ + @{$attrs->{order_by}}[ 0 .. ($#{$attrs->{order_by}} - $ord_cnt - 1) ] + ]; + } + + # mangle {from} + $from = [ @$from ]; + my $select_root = shift @$from; + my @outer_from = @$from; + + my %inner_joins; + my %join_info = map { $_->[0]{-alias} => $_->[0] } (@$from); + + # in complex search_related chains $alias may *not* be 'me' + # so always include it in the inner join, and also shift away + # from the outer stack, so that the two datasets actually do + # meet + if ($select_root->{-alias} ne $alias) { + $inner_joins{$alias} = 1; + + while (@outer_from && $outer_from[0][0]{-alias} ne $alias) { + shift @outer_from; + } + if (! @outer_from) { + $self->throw_exception ("Unable to find '$alias' in the {from} stack, something is wrong"); + } + + shift @outer_from; # the new subquery will represent this alias, so get rid of it + } + + + # decide which parts of the join will remain on the inside + # + # this is not a very viable optimisation, but it was written + # before I realised this, so might as well remain. We can throw + # away _any_ branches of the join tree that are: + # 1) not mentioned in the condition/order + # 2) left-join leaves (or left-join leaf chains) + # Most of the join ocnditions will not satisfy this, but for real + # complex queries some might, and we might make some RDBMS happy. + # + # + # since we do not have introspectable SQLA, we fall back to ugly + # scanning of raw SQL for WHERE, and for pieces of ORDER BY + # in order to determine what goes into %inner_joins + # It may not be very efficient, but it's a reasonable stop-gap + { + # produce stuff unquoted, so it can be scanned + my $sql_maker = $self->sql_maker; + local $sql_maker->{quote_char}; + + my @order_by = (map + { ref $_ ? $_->[0] : $_ } + $sql_maker->_order_by_chunks ($sub_attrs->{order_by}) + ); + + my $where_sql = $sql_maker->where ($where); + + # sort needed joins + for my $alias (keys %join_info) { + + # any table alias found on a column name in where or order_by + # gets included in %inner_joins + # Also any parent joins that are needed to reach this particular alias + for my $piece ($where_sql, @order_by ) { + if ($piece =~ /\b$alias\./) { + $inner_joins{$alias} = 1; + } + } + } + } + + # scan for non-leaf/non-left joins and mark as needed + # also mark all ancestor joins that are needed to reach this particular alias + # (e.g. join => { cds => 'tracks' } - tracks will bring cds too ) + # + # traverse by the size of the -join_path i.e. reverse depth first + for my $alias (sort { @{$join_info{$b}{-join_path}} <=> @{$join_info{$a}{-join_path}} } (keys %join_info) ) { + + my $j = $join_info{$alias}; + $inner_joins{$alias} = 1 if (! $j->{-join_type} || ($j->{-join_type} !~ /^left$/i) ); + + if ($inner_joins{$alias}) { + $inner_joins{$_} = 1 for (@{$j->{-join_path}}); + } + } + + # construct the inner $from for the subquery + my $inner_from = [ $select_root ]; + for my $j (@$from) { + push @$inner_from, $j if $inner_joins{$j->[0]{-alias}}; + } + + # if a multi-type join was needed in the subquery ("multi" is indicated by + # presence in {collapse}) - add a group_by to simulate the collapse in the subq + + for my $alias (keys %inner_joins) { + + # the dot comes from some weirdness in collapse + # remove after the rewrite + if ($attrs->{collapse}{".$alias"}) { + $sub_attrs->{group_by} = $sub_select; + last; + } + } + + # generate the subquery + my $subq = $self->_select_args_to_query ( + $inner_from, + $sub_select, + $where, + $sub_attrs + ); + + # put it in the new {from} + unshift @outer_from, { $alias => $subq }; + + # This is totally horrific - the $where ends up in both the inner and outer query + # Unfortunately not much can be done until SQLA2 introspection arrives + # + # OTOH it can be seen as a plus: (notes that this query would make a DBA cry ;) + return (\@outer_from, $select, $where, $attrs); +} + +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; } +# Returns a counting SELECT for a simple count +# query. Abstracted so that a storage could override +# this to { count => 'firstcol' } or whatever makes +# sense as a performance optimization +sub _count_select { + #my ($self, $source, $rs_attrs) = @_; + return { count => '*' }; +} + +# Returns a SELECT which will end up in the subselect +# There may or may not be a group_by, as the subquery +# might have been called to accomodate a limit +# +# Most databases would be happy with whatever ends up +# here, but some choke in various ways. +# +sub _subq_count_select { + my ($self, $source, $rs_attrs) = @_; + return $rs_attrs->{group_by} if $rs_attrs->{group_by}; + + my @pcols = map { join '.', $rs_attrs->{alias}, $_ } ($source->primary_columns); + return @pcols ? \@pcols : [ 1 ]; +} + + sub source_bind_attributes { my ($self, $source) = @_; - + my $bind_attributes; foreach my $column ($source->columns) { - + my $data_type = $source->column_info($column)->{data_type} || ''; $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type) if $data_type; @@ -1431,6 +1841,27 @@ sub bind_attribute_by_data_type { return; } +=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