X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=8a99d068f504664db4a023fbcac41e95f6676504;hb=2aa3f4c0bc1ce479776c96a1bc7bb44f7cfd1233;hp=bd201a19c7756a7b31f4d86f5367529dcab15cc0;hpb=08ac7648665ed86e88b2a752b31e8a34a8552dc7;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index bd201a1..8a99d06 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -12,9 +12,8 @@ use Scalar::Util qw/refaddr weaken reftype blessed/; use List::Util qw/first/; use Context::Preserve 'preserve_context'; use Try::Tiny; -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 DBIx::Class::_Util qw(quote_sub perlstring serialize); use namespace::clean; # default cursor class, overridable in connect_info attributes @@ -101,12 +100,13 @@ for my $meth (keys %$storage_accessor_idx, qw( txn_begin insert - insert_bulk update delete select select_single + _insert_bulk + with_deferred_fk_checks get_use_dbms_capability @@ -253,12 +253,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 @@ -269,14 +267,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; @@ -870,22 +868,20 @@ database is not in C mode. =cut sub disconnect { - my ($self) = @_; - if( $self->_dbh ) { - my @actions; + if( my $dbh = $_[0]->_dbh ) { - push @actions, ( $self->on_disconnect_call || () ); - push @actions, $self->_parse_connect_do ('on_disconnect_do'); - - $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); } } @@ -906,8 +902,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 @@ -927,40 +923,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 @@ -974,22 +956,17 @@ 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) @@ -1058,33 +1035,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 - $self->_sql_maker(undef); # this may also end up being different + $_[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'), + ); } @@ -1422,7 +1401,19 @@ sub disconnect_call_do_sql { $self->_do_query(@_); } -# override in db-specific backend when necessary +=head2 connect_call_datetime_setup + +A no-op stub method, provided so that one can always safely supply the +L + + on_connect_call => 'datetime_setup' + +This way one does not need to know in advance whether the underlying +storage requires any sort of hand-holding when dealing with calendar +data. + +=cut + sub connect_call_datetime_setup { 1 } sub _do_query { @@ -1542,19 +1533,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 { @@ -1575,9 +1564,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') ) { @@ -1606,9 +1594,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') ) { @@ -1636,9 +1623,8 @@ sub _exec_txn_rollback { # 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]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $_[0]->throw_exception('Unable to %s() on a disconnected storage') - unless $_[0]->_dbh; + unless $_[0]->_seems_connected; shift->next::method(@_); EOS @@ -2036,24 +2022,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 - DBI needs fixing to always stringify regardless of DBD - # For the time being 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 is_plain_value $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 ; @@ -2079,17 +2069,17 @@ sub insert_bulk { # can't just hand SQLA a set of some known "values" (e.g. hashrefs that # 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') { + my ($proto_data, $serialized_bind_type_by_col_idx); + 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( @@ -2098,23 +2088,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 ]; + $serialized_bind_type_by_col_idx->{$col_idx} = serialize [ 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; + $serialized_bind_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] ] ]; } } @@ -2125,11 +2115,11 @@ sub insert_bulk { [ $proto_data ], ); - if (! @$proto_bind and keys %$value_type_by_col_idx) { + if (! @$proto_bind and keys %$serialized_bind_type_by_col_idx) { # 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 @@ -2147,19 +2137,19 @@ 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 my $val = $data->[$row_idx][$col_idx]; - if (! exists $value_type_by_col_idx->{$col_idx}) { # literal no binds + if (! exists $serialized_bind_type_by_col_idx->{$col_idx}) { # literal no binds if (ref $val ne 'SCALAR') { $bad_slice_report_cref->( "Incorrect value (expecting SCALAR-ref \\'$$reference_val')", @@ -2175,7 +2165,7 @@ sub insert_bulk { ); } } - elsif (! defined $value_type_by_col_idx->{$col_idx} ) { # regular non-literal value + elsif (! defined $serialized_bind_type_by_col_idx->{$col_idx} ) { # regular non-literal value if (is_literal_value($val)) { $bad_slice_report_cref->("Literal SQL found where a plain bind value is expected", $row_idx, $col_idx); } @@ -2203,16 +2193,17 @@ sub insert_bulk { } # need to check the bind attrs - a bind will happen only once for # the entire dataset, so any changes further down will be ignored. - elsif (! Data::Compare::Compare( - $value_type_by_col_idx->{$col_idx}, - [ + elsif ( + $serialized_bind_type_by_col_idx->{$col_idx} + ne + serialize [ map { $_->[0] } @{$self->_resolve_bindattrs( $source, [ @{$$val}[1 .. $#$$val] ], $colinfos, )} - ], - )) { + ] + ) { $bad_slice_report_cref->( 'Differing bind attributes on literal/bind values not supported', $row_idx, @@ -2257,16 +2248,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], @@ -2287,7 +2275,7 @@ sub _dbh_execute_for_fetch { return undef if ++$fetch_row_idx > $#$data; return [ map { - ! defined $_->{_literal_bind_subindex} + my $v = ! defined $_->{_literal_bind_subindex} ? $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ] @@ -2299,7 +2287,14 @@ sub _dbh_execute_for_fetch { [ ${ $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 ]; }; @@ -2872,7 +2867,7 @@ sub create_ddl_dir { add_drop_table => 1, ignore_constraint_names => 1, ignore_index_names => 1, - quote_identifiers => !!$self->sql_maker->_quote_chars, + quote_identifiers => $self->sql_maker->_quoting_enabled, %{$sqltargs || {}} }; @@ -2999,7 +2994,8 @@ sub create_ddl_dir { =back -Returns the statements used by L and L. +Returns the statements used by L +and L. The L (not L) database driver name can be explicitly provided in C<$type>, otherwise the result of L is used as default. @@ -3041,9 +3037,8 @@ sub deployment_statements { $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources} if exists $sqltargs->{sources}; - $sqltargs->{quote_identifiers} - = !!$self->sql_maker->_quote_chars - if ! exists $sqltargs->{quote_identifiers}; + $sqltargs->{quote_identifiers} = $self->sql_maker->_quoting_enabled + unless exists $sqltargs->{quote_identifiers}; my $tr = SQL::Translator->new( producer => "SQL::Translator::Producer::${type}", @@ -3277,13 +3272,13 @@ transactions. You're on your own for handling all sorts of exceptional cases if you choose the C<< AutoCommit => 0 >> path, just as you would be with raw DBI. +=head1 FURTHER QUESTIONS? -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. - -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L.