X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=9a456d4c1cc805b7aece65af11bb087fce8395bf;hb=a9e985b78735ff61e4443139aa510915222cd550;hp=9e340f0ff34f9e48d10f1b4a0e47ecaba696a8b2;hpb=85ad63df4eaa9b308b9ca5a3cd1aa20b9f730312;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 9e340f0..9a456d4 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -10,11 +10,11 @@ use mro 'c3'; use DBIx::Class::Carp; use Scalar::Util qw/refaddr weaken reftype blessed/; use List::Util qw/first/; -use Sub::Name 'subname'; use Context::Preserve 'preserve_context'; use Try::Tiny; -use overload (); use Data::Compare (); # no imports!!! guard against insane architecture +use SQL::Abstract qw(is_plain_value is_literal_value); +use DBIx::Class::_Util qw(quote_sub perlstring); use namespace::clean; # default cursor class, overridable in connect_info attributes @@ -79,30 +79,35 @@ __PACKAGE__->_use_join_optimizer (1); sub _determine_supports_join_optimizer { 1 }; # Each of these methods need _determine_driver called before itself -# in order to function reliably. This is a purely DRY optimization +# in order to function reliably. We also need to separate accessors +# from plain old method calls, since an accessor called as a setter +# does *not* need the driver determination loop fired (and in fact +# can produce hard to find bugs, like e.g. losing on_connect_* +# semantics on fresh connections) # -# get_(use)_dbms_capability need to be called on the correct Storage -# class, as _use_X may be hardcoded class-wide, and _supports_X calls -# _determine_supports_X which obv. needs a correct driver as well -my @rdbms_specific_methods = qw/ +# The construct below is simply a parameterized around() +my $storage_accessor_idx = { map { $_ => 1 } qw( sqlt_type - deployment_statements + datetime_parser_type sql_maker cursor_class +)}; +for my $meth (keys %$storage_accessor_idx, qw( + deployment_statements build_datetime_parser - datetime_parser_type txn_begin insert - insert_bulk update delete select select_single + _insert_bulk + with_deferred_fk_checks get_use_dbms_capability @@ -110,16 +115,16 @@ my @rdbms_specific_methods = qw/ _server_info _get_server_version -/; - -for my $meth (@rdbms_specific_methods) { +)) { my $orig = __PACKAGE__->can ($meth) or die "$meth is not a ::Storage::DBI method!"; - no strict qw/refs/; - no warnings qw/redefine/; - *{__PACKAGE__ ."::$meth"} = subname $meth => sub { + my $is_getter = $storage_accessor_idx->{$meth} ? 0 : 1; + + quote_sub + __PACKAGE__ ."::$meth", sprintf( <<'EOC', $is_getter, perlstring $meth ), { '$orig' => \$orig }; + if ( # only fire when invoked on an instance, a valid class-based invocation # would e.g. be setting a default for an inherited accessor @@ -129,6 +134,10 @@ for my $meth (@rdbms_specific_methods) { and ! $_[0]->{_in_determine_driver} and + # if this is a known *setter* - just set it, no need to connect + # and determine the driver + ( %1$s or @_ <= 1 ) + and # Only try to determine stuff if we have *something* that either is or can # provide a DSN. Allows for bare $schema's generated with a plain ->connect() # to still be marginally useful @@ -136,16 +145,15 @@ for my $meth (@rdbms_specific_methods) { ) { $_[0]->_determine_driver; - # This for some reason crashes and burns on perl 5.8.1 - # IFF the method ends up throwing an exception - #goto $_[0]->can ($meth); + # work around http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878 + goto $_[0]->can(%2$s) unless DBIx::Class::_ENV_::BROKEN_GOTO; - my $cref = $_[0]->can ($meth); + my $cref = $_[0]->can(%2$s); goto $cref; } goto $orig; - }; +EOC } =head1 NAME @@ -246,12 +254,10 @@ sub new { } sub DESTROY { - my $self = shift; - + $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; # some databases spew warnings on implicit disconnect - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; local $SIG{__WARN__} = sub {}; - $self->_dbh(undef); + $_[0]->_dbh(undef); # this op is necessary, since the very last perl runtime statement # triggers a global destruction shootout, and the $SIG localization @@ -262,14 +268,14 @@ sub DESTROY { # handle pid changes correctly - do not destroy parent's connection sub _verify_pid { - my $self = shift; - my $pid = $self->_conn_pid; - if( defined $pid and $pid != $$ and my $dbh = $self->_dbh ) { + my $pid = $_[0]->_conn_pid; + + if( defined $pid and $pid != $$ and my $dbh = $_[0]->_dbh ) { $dbh->{InactiveDestroy} = 1; - $self->_dbh(undef); - $self->transaction_depth(0); - $self->savepoints([]); + $_[0]->_dbh(undef); + $_[0]->transaction_depth(0); + $_[0]->savepoints([]); } return; @@ -822,7 +828,7 @@ Example: sub dbh_do { my $self = shift; - my $run_target = shift; + my $run_target = shift; # either a coderef or a method name # short circuit when we know there is no need for a runner # @@ -839,10 +845,15 @@ sub dbh_do { DBIx::Class::Storage::BlockRunner->new( storage => $self, - run_code => sub { $self->$run_target ($self->_get_dbh, @$args ) }, wrap_txn => 0, - retry_handler => sub { ! ( $_[0]->retried_count or $_[0]->storage->connected ) }, - )->run; + retry_handler => sub { + $_[0]->failed_attempt_count == 1 + and + ! $_[0]->storage->connected + }, + )->run(sub { + $self->$run_target ($self->_get_dbh, @$args ) + }); } sub txn_do { @@ -858,22 +869,20 @@ database is not in C mode. =cut sub disconnect { - my ($self) = @_; - - if( $self->_dbh ) { - my @actions; - push @actions, ( $self->on_disconnect_call || () ); - push @actions, $self->_parse_connect_do ('on_disconnect_do'); + if( my $dbh = $_[0]->_dbh ) { - $self->_do_connection_actions(disconnect_call_ => $_) for @actions; + $_[0]->_do_connection_actions(disconnect_call_ => $_) for ( + ( $_[0]->on_disconnect_call || () ), + $_[0]->_parse_connect_do ('on_disconnect_do') + ); # stops the "implicit rollback on disconnect" warning - $self->_exec_txn_rollback unless $self->_dbh_autocommit; + $_[0]->_exec_txn_rollback unless $_[0]->_dbh_autocommit; - %{ $self->_dbh->{CachedKids} } = (); - $self->_dbh->disconnect; - $self->_dbh(undef); + %{ $dbh->{CachedKids} } = (); + $dbh->disconnect; + $_[0]->_dbh(undef); } } @@ -894,8 +903,8 @@ in MySQL's case disabled entirely. # Storage subclasses should override this sub with_deferred_fk_checks { - my ($self, $sub) = @_; - $sub->(); + #my ($self, $sub) = @_; + $_[1]->(); } =head2 connected @@ -915,40 +924,26 @@ answering, etc.) This method is used internally by L. =cut sub connected { - my $self = shift; - return 0 unless $self->_seems_connected; + return 0 unless $_[0]->_seems_connected; #be on the safe side - local $self->_dbh->{RaiseError} = 1; + local $_[0]->_dbh->{RaiseError} = 1; - return $self->_ping; + return $_[0]->_ping; } sub _seems_connected { - my $self = shift; - - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; - - my $dbh = $self->_dbh - or return 0; + $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; - return $dbh->FETCH('Active'); + ($_[0]->_dbh || return 0)->FETCH('Active'); } sub _ping { - my $self = shift; - - my $dbh = $self->_dbh or return 0; - - return $dbh->ping; + ($_[0]->_dbh || return 0)->ping; } sub ensure_connected { - my ($self) = @_; - - unless ($self->connected) { - $self->_populate_dbh; - } + $_[0]->connected || ( $_[0]->_populate_dbh && 1 ); } =head2 dbh @@ -962,26 +957,26 @@ instead. =cut sub dbh { - my ($self) = @_; - - if (not $self->_dbh) { - $self->_populate_dbh; - } else { - $self->ensure_connected; - } - return $self->_dbh; + # maybe save a ping call + $_[0]->_dbh + ? ( $_[0]->ensure_connected and $_[0]->_dbh ) + : $_[0]->_populate_dbh + ; } # this is the internal "get dbh or connect (don't check)" method sub _get_dbh { - my $self = shift; - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; - $self->_populate_dbh unless $self->_dbh; - return $self->_dbh; + $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; + $_[0]->_dbh || $_[0]->_populate_dbh; } +# *DELIBERATELY* not a setter (for the time being) +# Too intertwined with everything else for any kind of sanity sub sql_maker { - my ($self) = @_; + my $self = shift; + + $self->throw_exception('sql_maker() is not a setter method') if @_; + unless ($self->_sql_maker) { my $sql_maker_class = $self->sql_maker_class; @@ -1041,32 +1036,35 @@ sub _rebless {} sub _init {} sub _populate_dbh { - my ($self) = @_; - $self->_dbh(undef); # in case ->connected failed we might get sent here - $self->_dbh_details({}); # reset everything we know + $_[0]->_dbh(undef); # in case ->connected failed we might get sent here + + $_[0]->_dbh_details({}); # reset everything we know - $self->_dbh($self->_connect); + # FIXME - this needs reenabling with the proper "no reset on same DSN" check + #$_[0]->_sql_maker(undef); # this may also end up being different - $self->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads + $_[0]->_dbh($_[0]->_connect); - $self->_determine_driver; + $_[0]->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads + + $_[0]->_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; + $_[0]->{transaction_depth} = $_[0]->_dbh_autocommit ? 0 : 1; + + $_[0]->_run_connection_actions unless $_[0]->{_in_determine_driver}; - $self->_run_connection_actions unless $self->{_in_determine_driver}; + $_[0]->_dbh; } sub _run_connection_actions { - my $self = shift; - my @actions; - push @actions, ( $self->on_connect_call || () ); - push @actions, $self->_parse_connect_do ('on_connect_do'); - - $self->_do_connection_actions(connect_call_ => $_) for @actions; + $_[0]->_do_connection_actions(connect_call_ => $_) for ( + ( $_[0]->on_connect_call || () ), + $_[0]->_parse_connect_do ('on_connect_do'), + ); } @@ -1293,7 +1291,7 @@ sub _determine_driver { "Your storage subclass @{[ ref $self ]} provides (or inherits) the method " . 'source_bind_attributes() for which support has been removed as of Jan 2013. ' . 'If you are not sure how to proceed please contact the development team via ' - . 'http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT' + . DBIx::Class::_ENV_::HELP_URL ); } @@ -1524,19 +1522,17 @@ sub _connect { } sub txn_begin { - my $self = shift; - # this means we have not yet connected and do not know the AC status # (e.g. coderef $dbh), need a full-fledged connection check - if (! defined $self->_dbh_autocommit) { - $self->ensure_connected; + if (! defined $_[0]->_dbh_autocommit) { + $_[0]->ensure_connected; } # Otherwise simply connect or re-connect on pid changes else { - $self->_get_dbh; + $_[0]->_get_dbh; } - $self->next::method(@_); + shift->next::method(@_); } sub _exec_txn_begin { @@ -1557,9 +1553,8 @@ sub _exec_txn_begin { sub txn_commit { my $self = shift; - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $self->throw_exception("Unable to txn_commit() on a disconnected storage") - unless $self->_dbh; + unless $self->_seems_connected; # esoteric case for folks using external $dbh handles if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) { @@ -1588,9 +1583,8 @@ sub _exec_txn_commit { sub txn_rollback { my $self = shift; - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $self->throw_exception("Unable to txn_rollback() on a disconnected storage") - unless $self->_dbh; + unless $self->_seems_connected; # esoteric case for folks using external $dbh handles if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) { @@ -1616,17 +1610,12 @@ sub _exec_txn_rollback { shift->_dbh->rollback; } -# generate some identical methods -for my $meth (qw/svp_begin svp_release svp_rollback/) { - no strict qw/refs/; - *{__PACKAGE__ ."::$meth"} = subname $meth => sub { - my $self = shift; - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; - $self->throw_exception("Unable to $meth() on a disconnected storage") - unless $self->_dbh; - $self->next::method(@_); - }; -} +# generate the DBI-specific stubs, which then fallback to ::Storage proper +quote_sub __PACKAGE__ . "::$_" => sprintf (<<'EOS', $_) for qw(svp_begin svp_release svp_rollback); + $_[0]->throw_exception('Unable to %s() on a disconnected storage') + unless $_[0]->_seems_connected; + shift->next::method(@_); +EOS # This used to be the top-half of _execute. It was split out to make it # easier to override in NoBindVars without duping the rest. It takes up @@ -1678,13 +1667,10 @@ sub _gen_sql_bind { sub _resolve_bindattrs { my ($self, $ident, $bind, $colinfos) = @_; - $colinfos ||= {}; - my $resolve_bindinfo = sub { #my $infohash = shift; - %$colinfos = %{ $self->_resolve_column_info($ident) } - unless keys %$colinfos; + $colinfos ||= { %{ $self->_resolve_column_info($ident) } }; my $ret; if (my $col = $_[0]->{dbic_colname}) { @@ -1704,10 +1690,16 @@ sub _resolve_bindattrs { 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 'HASH') ? [( + ! keys %{$_->[0]} + or + 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] } @@ -1721,7 +1713,7 @@ sub _resolve_bindattrs { and length ref $resolved->[1] and - ! overload::Method($resolved->[1], '""') + ! is_plain_value $resolved->[1] ) { require Data::Dumper; local $Data::Dumper::Maxdepth = 1; @@ -1875,14 +1867,15 @@ sub _bind_sth_params { ); } else { - # FIXME SUBOPTIMAL - most likely this is not necessary at all - # confirm with dbi-dev whether explicit stringification is needed - my $v = ( length ref $bind->[$i][1] and overload::Method($bind->[$i][1], '""') ) + # FIXME SUBOPTIMAL - DBI needs fixing to always stringify regardless of DBD + my $v = ( length ref $bind->[$i][1] and is_plain_value $bind->[$i][1] ) ? "$bind->[$i][1]" : $bind->[$i][1] ; + $sth->bind_param( $i + 1, + # The temp-var is CRUCIAL - DO NOT REMOVE IT, breaks older DBD::SQLite RT#79576 $v, $bind_attrs->[$i], ); @@ -1903,9 +1896,7 @@ sub _prefetch_autovalues { ( ! exists $to_insert->{$col} or - ref $to_insert->{$col} eq 'SCALAR' - or - (ref $to_insert->{$col} eq 'REF' and ref ${$to_insert->{$col}} eq 'ARRAY') + is_literal_value($to_insert->{$col}) ) ) { $values{$col} = $self->_sequence_fetch( @@ -1942,11 +1933,9 @@ sub insert { } # nothing to retrieve when explicit values are supplied - next if (defined $to_insert->{$col} and ! ( - ref $to_insert->{$col} eq 'SCALAR' - or - (ref $to_insert->{$col} eq 'REF' and ref ${$to_insert->{$col}} eq 'ARRAY') - )); + next if ( + defined $to_insert->{$col} and ! is_literal_value($to_insert->{$col}) + ); # the 'scalar keys' is a trick to preserve the ->columns declaration order $retrieve_cols{$col} = scalar keys %retrieve_cols if ( @@ -2022,26 +2011,28 @@ sub insert { } sub insert_bulk { - my ($self, $source, $cols, $data) = @_; + carp_unique( + 'insert_bulk() should have never been exposed as a public method and ' + . 'calling it is depecated as of Aug 2014. If you believe having a genuine ' + . 'use for this method please contact the development team via ' + . DBIx::Class::_ENV_::HELP_URL + ); - my @col_range = (0..$#$cols); + return '0E0' unless @{$_[3]||[]}; - # FIXME SUBOPTIMAL - most likely this is not necessary at all - # confirm with dbi-dev whether explicit stringification is needed - # - # forcibly stringify whatever is stringifiable - # ResultSet::populate() hands us a copy - safe to mangle - for my $r (0 .. $#$data) { - for my $c (0 .. $#{$data->[$r]}) { - $data->[$r][$c] = "$data->[$r][$c]" - if ( length ref $data->[$r][$c] and overload::Method($data->[$r][$c], '""') ); - } - } + shift->_insert_bulk(@_); +} + +sub _insert_bulk { + my ($self, $source, $cols, $data) = @_; + + $self->throw_exception('Calling _insert_bulk without a dataset to process makes no sense') + unless @{$data||[]}; my $colinfos = $source->columns_info($cols); local $self->{_autoinc_supplied_for_op} = - (first { $_->{is_auto_increment} } values %$colinfos) + (grep { $_->{is_auto_increment} } values %$colinfos) ? 1 : 0 ; @@ -2068,16 +2059,16 @@ sub insert_bulk { # can be later matched up by address), because we want to supply a real # value on which perhaps e.g. datatype checks will be performed my ($proto_data, $value_type_by_col_idx); - for my $i (@col_range) { - my $colname = $cols->[$i]; - if (ref $data->[0][$i] eq 'SCALAR') { + for my $col_idx (0..$#$cols) { + my $colname = $cols->[$col_idx]; + if (ref $data->[0][$col_idx] eq 'SCALAR') { # no bind value at all - no type - $proto_data->{$colname} = $data->[0][$i]; + $proto_data->{$colname} = $data->[0][$col_idx]; } - elsif (ref $data->[0][$i] eq 'REF' and ref ${$data->[0][$i]} eq 'ARRAY' ) { + elsif (ref $data->[0][$col_idx] eq 'REF' and ref ${$data->[0][$col_idx]} eq 'ARRAY' ) { # repack, so we don't end up mangling the original \[] - my ($sql, @bind) = @${$data->[0][$i]}; + my ($sql, @bind) = @${$data->[0][$col_idx]}; # normalization of user supplied stuff my $resolved_bind = $self->_resolve_bindattrs( @@ -2086,23 +2077,23 @@ sub insert_bulk { # store value-less (attrs only) bind info - we will be comparing all # supplied binds against this for sanity - $value_type_by_col_idx->{$i} = [ map { $_->[0] } @$resolved_bind ]; + $value_type_by_col_idx->{$col_idx} = [ map { $_->[0] } @$resolved_bind ]; $proto_data->{$colname} = \[ $sql, map { [ # inject slice order to use for $proto_bind construction - { %{$resolved_bind->[$_][0]}, _bind_data_slice_idx => $i, _literal_bind_subindex => $_+1 } + { %{$resolved_bind->[$_][0]}, _bind_data_slice_idx => $col_idx, _literal_bind_subindex => $_+1 } => $resolved_bind->[$_][1] ] } (0 .. $#bind) ]; } else { - $value_type_by_col_idx->{$i} = undef; + $value_type_by_col_idx->{$col_idx} = undef; $proto_data->{$colname} = \[ '?', [ - { dbic_colname => $colname, _bind_data_slice_idx => $i } + { dbic_colname => $colname, _bind_data_slice_idx => $col_idx } => - $data->[0][$i] + $data->[0][$col_idx] ] ]; } } @@ -2117,7 +2108,7 @@ sub insert_bulk { # if the bindlist is empty and we had some dynamic binds, this means the # storage ate them away (e.g. the NoBindVars component) and interpolated # them directly into the SQL. This obviously can't be good for multi-inserts - $self->throw_exception('Cannot insert_bulk without support for placeholders'); + $self->throw_exception('Unable to invoke fast-path insert without storage placeholder support'); } # sanity checks @@ -2135,13 +2126,13 @@ sub insert_bulk { Data::Dumper::Concise::Dumper ({ map { $cols->[$_] => $data->[$r_idx][$_] - } @col_range + } 0..$#$cols }), } ); }; - for my $col_idx (@col_range) { + for my $col_idx (0..$#$cols) { my $reference_val = $data->[0][$col_idx]; for my $row_idx (1..$#$data) { # we are comparing against what we got from [0] above, hence start from 1 @@ -2164,7 +2155,7 @@ sub insert_bulk { } } elsif (! defined $value_type_by_col_idx->{$col_idx} ) { # regular non-literal value - if (ref $val eq 'SCALAR' or (ref $val eq 'REF' and ref $$val eq 'ARRAY') ) { + if (is_literal_value($val)) { $bad_slice_report_cref->("Literal SQL found where a plain bind value is expected", $row_idx, $col_idx); } } @@ -2245,16 +2236,13 @@ sub insert_bulk { sub _dbh_execute_for_fetch { my ($self, $source, $sth, $proto_bind, $cols, $data) = @_; - my @idx_range = ( 0 .. $#$proto_bind ); - # If we have any bind attributes to take care of, we will bind the # proto-bind data (which will never be used by execute_for_fetch) # However since column bindtypes are "sticky", this is sufficient # to get the DBD to apply the bindtype to all values later on - my $bind_attrs = $self->_dbi_attrs_for_bind($source, $proto_bind); - for my $i (@idx_range) { + for my $i (0 .. $#$proto_bind) { $sth->bind_param ( $i+1, # DBI bind indexes are 1-based $proto_bind->[$i][1], @@ -2274,12 +2262,28 @@ sub _dbh_execute_for_fetch { my $fetch_tuple = sub { return undef if ++$fetch_row_idx > $#$data; - return [ map { defined $_->{_literal_bind_subindex} - ? ${ $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]} - ->[ $_->{_literal_bind_subindex} ] - ->[1] - : $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ] - } map { $_->[0] } @$proto_bind]; + return [ map { + my $v = ! defined $_->{_literal_bind_subindex} + + ? $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ] + + # There are no attributes to resolve here - we already did everything + # when we constructed proto_bind. However we still want to sanity-check + # what the user supplied, so pass stuff through to the resolver *anyway* + : $self->_resolve_bindattrs ( + undef, # a fake rsrc + [ ${ $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]}->[ $_->{_literal_bind_subindex} ] ], + {}, # a fake column_info bag + )->[0][1] + ; + + # FIXME SUBOPTIMAL - DBI needs fixing to always stringify regardless of DBD + # For the time being forcibly stringify whatever is stringifiable + (length ref $v and is_plain_value $v) + ? "$v" + : $v + ; + } map { $_->[0] } @$proto_bind ]; }; my $tuple_status = []; @@ -2402,24 +2406,16 @@ sub _select_args { # soooooo much better now. But that is also another # battle... #return ( - # 'select', @{$orig_attrs->{_sqlmaker_select_args}} - #) if $orig_attrs->{_sqlmaker_select_args}; + # 'select', $orig_attrs->{!args_as_stored_at_the_end_of_this_method!} + #) if $orig_attrs->{!args_as_stored_at_the_end_of_this_method!}; my $sql_maker = $self->sql_maker; - my $alias2source = $self->_resolve_ident_sources ($ident); my $attrs = { %$orig_attrs, select => $select, from => $ident, where => $where, - - # 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}} ) - : () - , }; # Sanity check the attributes (SQLMaker does it too, but @@ -2456,7 +2452,7 @@ sub _select_args { # 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} ) + ( $prefetch_needs_subquery or ! $attrs->{_simple_passthrough_construction} ) and $attrs->{group_by} and @@ -2499,7 +2495,19 @@ sub _select_args { ($attrs->{from}, $attrs->{_aliastypes}) = $self->_prune_unused_joins ($attrs); } + # FIXME this is a gross, inefficient, largely incorrect and fragile hack + # during the result inflation stage we *need* to know what was the aliastype + # map as sqla saw it when the final pieces of SQL were being assembled + # Originally we simply carried around the entirety of $attrs, but this + # resulted in resultsets that are being reused growing continuously, as + # the hash in question grew deeper and deeper. + # Instead hand-pick what to take with us here (we actually don't need much + # at this point just the map itself) + $orig_attrs->{_last_sqlmaker_alias_map} = $attrs->{_aliastypes}; + ### + # my $alias2source = $self->_resolve_ident_sources ($ident); + # # 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 @@ -2509,9 +2517,7 @@ sub _select_args { # invoked, and that's just bad... ### - return ( 'select', @{ $orig_attrs->{_sqlmaker_select_args} = [ - @{$attrs}{qw(from select where)}, $attrs, @limit_args - ]} ); + return ( 'select', @{$attrs}{qw(from select where)}, $attrs, @limit_args ); } # Returns a counting SELECT for a simple count @@ -2849,6 +2855,7 @@ sub create_ddl_dir { add_drop_table => 1, ignore_constraint_names => 1, ignore_index_names => 1, + quote_identifiers => $self->sql_maker->_quoting_enabled, %{$sqltargs || {}} }; @@ -2943,10 +2950,21 @@ sub create_ddl_dir { unless $dest_schema->name; } - my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db, - $dest_schema, $db, - $sqltargs - ); + my $diff = do { + # FIXME - this is a terrible workaround for + # https://github.com/dbsrgits/sql-translator/commit/2d23c1e + # Fixing it in this sloppy manner so that we don't hve to + # lockstep an SQLT release as well. Needs to be removed at + # some point, and SQLT dep bumped + local $SQL::Translator::Producer::SQLite::NO_QUOTES + if $SQL::Translator::Producer::SQLite::NO_QUOTES; + + SQL::Translator::Diff::schema_diff($source_schema, $db, + $dest_schema, $db, + $sqltargs + ); + }; + if(!open $file, ">$difffile") { $self->throw_exception("Can't write to $difffile ($!)"); next; @@ -3006,6 +3024,9 @@ sub deployment_statements { $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources} if exists $sqltargs->{sources}; + $sqltargs->{quote_identifiers} = $self->sql_maker->_quoting_enabled + unless exists $sqltargs->{quote_identifiers}; + my $tr = SQL::Translator->new( producer => "SQL::Translator::Producer::${type}", %$sqltargs,