X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=d754a597f0d8f7f6bc6ac921a8d9a578bf7014b4;hb=wip%2Finsert_select_take2;hp=d207767d1ea3693a21dae85adc0a8b276d70c087;hpb=723f25e01d5265eab37b8281da0b22387cfa1aaa;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index d207767..d754a59 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -15,7 +15,6 @@ use Context::Preserve 'preserve_context'; use Try::Tiny; use overload (); use Data::Compare (); # no imports!!! guard against insane architecture -use DBI::Const::GetInfoType (); # no import of retarded global hash use namespace::clean; # default cursor class, overridable in connect_info attributes @@ -87,17 +86,23 @@ sub _determine_supports_join_optimizer { 1 }; # _determine_supports_X which obv. needs a correct driver as well my @rdbms_specific_methods = qw/ sqlt_type + deployment_statements + sql_maker + cursor_class + build_datetime_parser datetime_parser_type txn_begin + insert insert_bulk update delete select select_single + with_deferred_fk_checks get_use_dbms_capability @@ -120,9 +125,11 @@ for my $meth (@rdbms_specific_methods) { # would e.g. be setting a default for an inherited accessor ref $_[0] and - ! $_[0]->_driver_determined + ! $_[0]->{_driver_determined} and ! $_[0]->{_in_determine_driver} + and + ($_[0]->_dbi_connect_info||[])->[0] ) { $_[0]->_determine_driver; @@ -626,13 +633,13 @@ sub connect_info { my @args = @{ $info->{arguments} }; if (keys %attrs and ref $args[0] ne 'CODE') { - carp + carp_unique ( 'You provided explicit AutoCommit => 0 in your connection_info. ' . 'This is almost universally a bad idea (see the footnotes of ' . 'DBIx::Class::Storage::DBI for more info). If you still want to ' . 'do this you can set $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK} to disable ' . 'this warning.' - if ! $attrs{AutoCommit} and ! $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK}; + ) if ! $attrs{AutoCommit} and ! $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK}; push @args, \%attrs if keys %attrs; } @@ -785,7 +792,7 @@ sub dbh_do { # short circuit when we know there is no need for a runner # - # FIXME - asumption may be wrong + # FIXME - assumption may be wrong # the rationale for the txn_depth check is that if this block is a part # of a larger transaction, everything up to that point is screwed anyway return $self->$run_target($self->_get_dbh, @_) @@ -952,13 +959,13 @@ sub sql_maker { || do { my $s_class = (ref $self) || $self; - carp ( + carp_unique ( "Your storage class ($s_class) does not set sql_limit_dialect and you " . 'have not supplied an explicit limit_dialect in your connection_info. ' . 'DBIC will attempt to use the GenericSubQ dialect, which works on most ' . 'databases but can be (and often is) painfully slow. ' - . "Please file an RT ticket against '$s_class' ." - ); + . "Please file an RT ticket against '$s_class'" + ) if $self->_dbi_connect_info->[0]; 'GenericSubQ'; } @@ -969,7 +976,7 @@ sub sql_maker { if ($opts{quote_names}) { $quote_char = (delete $opts{quote_char}) || $self->sql_quote_char || do { my $s_class = (ref $self) || $self; - carp ( + carp_unique ( "You requested 'quote_names' but your storage class ($s_class) does " . 'not explicitly define a default sql_quote_char and you have not ' . 'supplied a quote_char as part of your connection_info. DBIC will ' @@ -1124,12 +1131,13 @@ sub _dbh_get_info { my ($self, $info) = @_; if ($info =~ /[^0-9]/) { + require DBI::Const::GetInfoType; $info = $DBI::Const::GetInfoType::GetInfoType{$info}; $self->throw_exception("Info type '$_[1]' not provided by DBI::Const::GetInfoType") unless defined $info; } - return $self->_get_dbh->get_info($info); + $self->_get_dbh->get_info($info); } sub _describe_connection { @@ -1371,13 +1379,36 @@ sub _do_query { sub _connect { my ($self, @info) = @_; - $self->throw_exception("You failed to provide any connection info") - if !@info; + $self->throw_exception("You did not provide any connection_info") + if ( ! defined $info[0] and ! $ENV{DBI_DSN} and ! $ENV{DBI_DRIVER} ); my ($old_connect_via, $dbh); local $DBI::connect_via = 'connect' if $INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}; + # this odd anonymous coderef dereference is in fact really + # necessary to avoid the unwanted effect described in perl5 + # RT#75792 + # + # in addition the coderef itself can't reside inside the try{} block below + # as it somehow triggers a leak under perl -d + my $dbh_error_handler_installer = sub { + weaken (my $weak_self = $_[0]); + + # the coderef is blessed so we can distinguish it from externally + # supplied handles (which must be preserved) + $_[1]->{HandleError} = bless sub { + if ($weak_self) { + $weak_self->throw_exception("DBI Exception: $_[0]"); + } + else { + # the handler may be invoked by something totally out of + # the scope of DBIC + DBIx::Class::Exception->throw("DBI Exception (unhandled by DBIC, ::Schema GCed): $_[0]"); + } + }, '__DBIC__DBH__ERROR__HANDLER__'; + }; + try { if(ref $info[0] eq 'CODE') { $dbh = $info[0]->(); @@ -1421,26 +1452,7 @@ sub _connect { $dbh->{RaiseError} = 1; } - # this odd anonymous coderef dereference is in fact really - # necessary to avoid the unwanted effect described in perl5 - # RT#75792 - sub { - my $weak_self = $_[0]; - weaken $weak_self; - - # the coderef is blessed so we can distinguish it from externally - # supplied handles (which must be preserved) - $_[1]->{HandleError} = bless sub { - if ($weak_self) { - $weak_self->throw_exception("DBI Exception: $_[0]"); - } - else { - # the handler may be invoked by something totally out of - # the scope of DBIC - DBIx::Class::Exception->throw("DBI Exception (unhandled by DBIC, ::Schema GCed): $_[0]"); - } - }, '__DBIC__DBH__ERROR__HANDLER__'; - }->($self, $dbh); + $dbh_error_handler_installer->($self, $dbh); } } catch { @@ -1573,14 +1585,25 @@ sub _gen_sql_bind { $colinfos = $ident->columns_info; } - my ($sql, @bind) = $self->sql_maker->$op( ($from || $ident), @$args ); + my ($sql, $bind); + ($sql, @$bind) = $self->sql_maker->$op( ($from || $ident), @$args ); + + $bind = $self->_resolve_bindattrs( + $ident, [ @{$args->[2]{bind}||[]}, @$bind ], $colinfos + ); if ( ! $ENV{DBIC_DT_SEARCH_OK} and $op eq 'select' and - first { blessed($_->[1]) && $_->[1]->isa('DateTime') } @bind + first { + length ref $_->[1] + and + blessed($_->[1]) + and + $_->[1]->isa('DateTime') + } @$bind ) { carp_unique 'DateTime objects passed to search() are not supported ' . 'properly (InflateColumn::DateTime formats and settings are not ' @@ -1589,9 +1612,7 @@ sub _gen_sql_bind { . 'set $ENV{DBIC_DT_SEARCH_OK} to true' } - return( $sql, $self->_resolve_bindattrs( - $ident, [ @{$args->[2]{bind}||[]}, @bind ], $colinfos - )); + return( $sql, $bind ); } sub _resolve_bindattrs { @@ -1620,24 +1641,42 @@ sub _resolve_bindattrs { }; return [ map { - if (ref $_ ne 'ARRAY') { - [{}, $_] - } - elsif (! defined $_->[0]) { - [{}, $_->[1]] - } - elsif (ref $_->[0] eq 'HASH') { - [ - ($_->[0]{dbd_attrs} or $_->[0]{sqlt_datatype}) ? $_->[0] : $resolve_bindinfo->($_->[0]), - $_->[1] - ] - } - elsif (ref $_->[0] eq 'SCALAR') { - [ { sqlt_datatype => ${$_->[0]} }, $_->[1] ] - } - else { - [ $resolve_bindinfo->({ dbic_colname => $_->[0] }), $_->[1] ] + my $resolved = + ( ref $_ ne 'ARRAY' or @$_ != 2 ) ? [ {}, $_ ] + : ( ! defined $_->[0] ) ? [ {}, $_->[1] ] + : (ref $_->[0] eq 'HASH') ? [ (exists $_->[0]{dbd_attrs} or $_->[0]{sqlt_datatype}) + ? $_->[0] + : $resolve_bindinfo->($_->[0]) + , $_->[1] ] + : (ref $_->[0] eq 'SCALAR') ? [ { sqlt_datatype => ${$_->[0]} }, $_->[1] ] + : [ $resolve_bindinfo->( + { dbic_colname => $_->[0] } + ), $_->[1] ] + ; + + if ( + ! exists $resolved->[0]{dbd_attrs} + and + ! $resolved->[0]{sqlt_datatype} + and + length ref $resolved->[1] + and + ! overload::Method($resolved->[1], '""') + ) { + require Data::Dumper; + local $Data::Dumper::Maxdepth = 1; + local $Data::Dumper::Terse = 1; + local $Data::Dumper::Useqq = 1; + local $Data::Dumper::Indent = 0; + local $Data::Dumper::Pad = ' '; + $self->throw_exception( + 'You must supply a datatype/bindtype (see DBIx::Class::ResultSet/DBIC BIND VALUES) ' + . 'for non-scalar value '. Data::Dumper::Dumper ($resolved->[1]) + ); } + + $resolved; + } @$bind ]; } @@ -1896,7 +1935,7 @@ sub insert { unless (@pri_values == @missing_pri); @returned_cols{@missing_pri} = @pri_values; - delete $retrieve_cols{$_} for @missing_pri; + delete @retrieve_cols{@missing_pri}; } # if there is more left to pull @@ -1925,6 +1964,7 @@ sub insert { sub insert_bulk { my ($self, $source, $cols, $data) = @_; + use DDP; p $data; my @col_range = (0..$#$cols); # FIXME SUBOPTIMAL - most likely this is not necessary at all @@ -2293,18 +2333,32 @@ sub _select_args_to_query { } sub _select_args { - my ($self, $ident, $select, $where, $attrs) = @_; + my ($self, $ident, $select, $where, $orig_attrs) = @_; + + # FIXME - that kind of caching would be nice to have + # however currently we *may* pass the same $orig_attrs + # with different ident/select/where + # the whole interface needs to be rethought, since it + # was centered around the flawed SQLA API. We can do + # soooooo much better now. But that is also another + # battle... + #return ( + # 'select', @{$orig_attrs->{_sqlmaker_select_args}} + #) if $orig_attrs->{_sqlmaker_select_args}; my $sql_maker = $self->sql_maker; - my ($alias2source, $rs_alias) = $self->_resolve_ident_sources ($ident); + my $alias2source = $self->_resolve_ident_sources ($ident); - $attrs = { - %$attrs, + my $attrs = { + %$orig_attrs, select => $select, from => $ident, where => $where, - $rs_alias && $alias2source->{$rs_alias} - ? ( _rsroot_rsrc => $alias2source->{$rs_alias} ) + + # limit dialects use this stuff + # yes, some CDBICompat crap does not supply an {alias} >.< + ( $orig_attrs->{alias} and $alias2source->{$orig_attrs->{alias}} ) + ? ( _rsroot_rsrc => $alias2source->{$orig_attrs->{alias}} ) : () , }; @@ -2325,36 +2379,49 @@ sub _select_args { $attrs->{rows} = $sql_maker->__max_int; } - my ($complex_prefetch, @limit); - # see if we will need to tear the prefetch apart to satisfy group_by == select - # this is *extremely tricky* to get right + # this is *extremely tricky* to get right, I am still not sure I did # - # Follows heavy but necessary analyzis of the group_by - if it refers to any - # sort of non-root column assume the user knows what they are doing and do - # not try to be clever - if ( - $attrs->{_related_results_construction} + my ($prefetch_needs_subquery, @limit_args); + + if ( $attrs->{_grouped_by_distinct} and $attrs->{collapse} ) { + # we already know there is a valid group_by (we made it) and we know it is + # intended to be based *only* on non-multi stuff + # short circuit the group_by parsing below + $prefetch_needs_subquery = 1; + } + elsif ( + # The rationale is that even if we do *not* have collapse, we still + # need to wrap the core grouped select/group_by in a subquery + # so that databases that care about group_by/select equivalence + # are happy (this includes MySQL in strict_mode) + # If any of the other joined tables are referenced in the group_by + # however - the user is on their own + ( $prefetch_needs_subquery or $attrs->{_related_results_construction} ) and $attrs->{group_by} and @{$attrs->{group_by}} and - my $grp_aliases = try { - $self->_resolve_aliastypes_from_select_args( $attrs->{from}, undef, undef, { group_by => $attrs->{group_by} } ) + my $grp_aliases = try { # try{} because $attrs->{from} may be unreadable + $self->_resolve_aliastypes_from_select_args({ from => $attrs->{from}, group_by => $attrs->{group_by} }) } ) { - $complex_prefetch = ! defined first { $_ ne $rs_alias } keys %{ $grp_aliases->{grouping} || {} }; + # no aliases other than our own in group_by + # if there are - do not allow subquery even if limit is present + $prefetch_needs_subquery = ! scalar grep { $_ ne $attrs->{alias} } keys %{ $grp_aliases->{grouping} || {} }; + } + elsif ( $attrs->{rows} && $attrs->{collapse} ) { + # active collapse with a limit - that one is a no-brainer unless + # overruled by a group_by above + $prefetch_needs_subquery = 1; } - $complex_prefetch ||= ( $attrs->{rows} && $attrs->{collapse} ); - - if ($complex_prefetch) { - ($ident, $select, $where, $attrs) = - $self->_adjust_select_args_for_complex_prefetch ($ident, $select, $where, $attrs); + if ($prefetch_needs_subquery) { + $attrs = $self->_adjust_select_args_for_complex_prefetch ($attrs); } elsif (! $attrs->{software_limit} ) { - push @limit, ( + push @limit_args, ( $attrs->{rows} || (), $attrs->{offset} || (), ); @@ -2362,19 +2429,19 @@ sub _select_args { # try to simplify the joinmap further (prune unreferenced type-single joins) if ( - ! $complex_prefetch + ! $prefetch_needs_subquery # already pruned and - ref $ident + ref $attrs->{from} and - reftype $ident eq 'ARRAY' + reftype $attrs->{from} eq 'ARRAY' and - @$ident != 1 + @{$attrs->{from}} != 1 ) { - $ident = $self->_prune_unused_joins ($ident, $select, $where, $attrs); + ($attrs->{from}, $attrs->{_aliastypes}) = $self->_prune_unused_joins ($attrs); } ### - # This would be the point to deflate anything found in $where + # This would be the point to deflate anything found in $attrs->{where} # (and leave $attrs->{bind} intact). Problem is - inflators historically # expect a result object. And all we have is a resultsource (it is trivial # to extract deflator coderefs via $alias2source above). @@ -2383,7 +2450,9 @@ sub _select_args { # invoked, and that's just bad... ### - return ('select', $ident, $select, $where, $attrs, @limit); + return ( 'select', @{ $orig_attrs->{_sqlmaker_select_args} = [ + @{$attrs}{qw(from select where)}, $attrs, @limit_args + ]} ); } # Returns a counting SELECT for a simple count @@ -2873,7 +2942,7 @@ sub deployment_statements { $self->throw_exception("Can't deploy without a ddl_dir or " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') ); } - # sources needs to be a parser arg, but for simplicty allow at top level + # sources needs to be a parser arg, but for simplicity allow at top level # coming in $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources} if exists $sqltargs->{sources};