X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=e0799df282b6875950878cc77c58371829fe5edd;hb=24e9db5ec274aff56ed871cd315331e4472fc69b;hp=0b244d4091ab7322439f7bc4ba3de92c65424071;hpb=194311161bdbebd2402c457ded300fc83b773f02;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 0b244d4..e0799df 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -7,10 +7,9 @@ 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' => @@ -603,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; @@ -717,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]"); @@ -898,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(); } @@ -910,6 +910,7 @@ sub _prep_for_execute { return ($sql, \@bind); } + sub _fix_bind_params { my ($self, @bind) = @_; @@ -931,7 +932,7 @@ sub _query_start { if ( $self->debug ) { @bind = $self->_fix_bind_params(@bind); - + $self->debugobj->query_start( $sql, @bind ); } } @@ -990,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 = {}; @@ -1052,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 ); @@ -1072,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, @_); } @@ -1084,7 +1105,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) = @_; @@ -1143,8 +1164,10 @@ sub _per_row_update_delete { my $guard = $self->txn_scope_guard; - my $subrs_cur = $rs->cursor; + # 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) { my $cond; @@ -1168,31 +1191,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; @@ -1202,9 +1255,258 @@ 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}; + } + } + +### + # 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 _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'); + } + + $self->throw_exception ('Prefetch with limit (rows/offset) is not supported on resultsets with a custom from attribute') + if (ref $from ne 'ARRAY'); + + # separate attributes + my $sub_attrs = { %$attrs }; + delete $attrs->{$_} for qw/where bind rows offset/; + delete $sub_attrs->{$_} for qw/for collapse select order_by/; + + 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 the head of the {from} + my $self_ident = shift @$from; + + my %join_info = map { $_->[0]{-alias} => $_->[0] } (@$from); + + my (%inner_joins); + + # 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 = [ $self_ident ]; + if (keys %inner_joins) { + 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 back in $from + unshift @$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 ($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 @args; + + return $alias2source; +} + +sub count { + my ($self, $source, $attrs) = @_; + + my $tmp_attrs = { %$attrs }; + + # take off any limits, record_filter is cdbi, and no point of ordering a count + delete $tmp_attrs->{$_} for (qw/select as rows offset 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/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 collapse group_by having having_bind rows offset/; + + 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 { @@ -1394,7 +1696,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 @@ -1403,7 +1726,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 @@ -1414,6 +1768,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 { @@ -1549,8 +1909,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 @@ -1618,7 +1979,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 );