X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=01adf7de60bb867dd45cdbee4db490953a16f230;hb=763026c15bf2047020c261f430bd782bb5180850;hp=d461a0fc0bb394fdd6a4e1d33ce63ce62b732941;hpb=0434c7c9d8a93a650e7027cf08d013c9e8444d24;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index d461a0f..01adf7d 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -14,6 +14,11 @@ use DBIx::Class::Storage::Statistics; use Scalar::Util(); use List::Util(); +# what version of sqlt do we require if deploy() without a ddl_dir is invoked +# when changing also adjust the corresponding author_require in Makefile.PL +my $minimum_sqlt_version = '0.11002'; + + __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 _driver_determined savepoints/ @@ -44,7 +49,14 @@ DBIx::Class::Storage::DBI - DBI storage handler my $schema = MySchema->connect('dbi:SQLite:my.db'); $schema->storage->debug(1); - $schema->dbh_do("DROP TABLE authors"); + + my @stuff = $schema->storage->dbh_do( + sub { + my ($storage, $dbh, @args) = @_; + $dbh->do("DROP TABLE authors"); + }, + @column_list + ); $schema->resultset('Book')->search({ written_on => $schema->storage->datetime_parser(DateTime->now) @@ -112,6 +124,12 @@ mixed together: %extra_attributes, }]; + $connect_info_args = [{ + dbh_maker => sub { DBI->connect (...) }, + %dbi_attributes, + %extra_attributes, + }]; + This is particularly useful for L based applications, allowing the following config (L style): @@ -125,6 +143,10 @@ following config (L style): +The C/C/C combination can be substituted by the +C key whose value is a coderef that returns a connected +L + =back Please note that the L docs recommend that you always explicitly @@ -337,6 +359,12 @@ L # Connect via subref ->connect_info([ sub { DBI->connect(...) } ]); + # Connect via subref in hashref + ->connect_info([{ + dbh_maker => sub { DBI->connect(...) }, + on_connect_do => 'alter session ...', + }]); + # A bit more complicated ->connect_info( [ @@ -407,8 +435,21 @@ sub connect_info { elsif (ref $args[0] eq 'HASH') { # single hashref (i.e. Catalyst config) %attrs = %{$args[0]}; @args = (); - for (qw/password user dsn/) { - unshift @args, delete $attrs{$_}; + if (my $code = delete $attrs{dbh_maker}) { + @args = $code; + + my @ignored = grep { delete $attrs{$_} } (qw/dsn user password/); + if (@ignored) { + carp sprintf ( + 'Attribute(s) %s in connect_info were ignored, as they can not be applied ' + . "to the result of 'dbh_maker'", + + join (', ', map { "'$_'" } (@ignored) ), + ); + } + } + else { + @args = delete @attrs{qw/dsn user password/}; } } else { # otherwise assume dsn/user/password + \%attrs + \%extra_attrs @@ -527,7 +568,7 @@ sub dbh_do { my $self = shift; my $code = shift; - my $dbh = $self->_dbh; + my $dbh = $self->_get_dbh; return $self->$code($dbh, @_) if $self->{_in_dbh_do} || $self->{transaction_depth}; @@ -538,11 +579,6 @@ sub dbh_do { my $want_array = wantarray; eval { - $self->_verify_pid if $dbh; - if(!$self->_dbh) { - $self->_populate_dbh; - $dbh = $self->_dbh; - } if($want_array) { @result = $self->$code($dbh, @_); @@ -589,8 +625,7 @@ sub txn_do { my $tried = 0; while(1) { eval { - $self->_verify_pid if $self->_dbh; - $self->_populate_dbh if !$self->_dbh; + $self->_get_dbh; $self->txn_begin; if($want_array) { @@ -651,7 +686,8 @@ sub disconnect { $self->_do_connection_actions(disconnect_call_ => $_) for @actions; - $self->_dbh->rollback unless $self->_dbh_autocommit; + $self->_dbh_rollback unless $self->_dbh_autocommit; + $self->_dbh->disconnect; $self->_dbh(undef); $self->{_dbh_gen}++; @@ -779,6 +815,7 @@ sub dbh { # this is the internal "get dbh or connect (don't check)" method sub _get_dbh { my $self = shift; + $self->_verify_pid if $self->_dbh; $self->_populate_dbh unless $self->_dbh; return $self->_dbh; } @@ -804,7 +841,9 @@ sub sql_maker { return $self->_sql_maker; } +# nothing to do by default sub _rebless {} +sub _init {} sub _populate_dbh { my ($self) = @_; @@ -847,10 +886,18 @@ sub _determine_driver { if ($self->_dbh) { # we are connected $driver = $self->_dbh->{Driver}{Name}; } else { - # try to use dsn to not require being connected, the driver may still - # force a connection in _rebless to determine version - ($driver) = $self->_dbi_connect_info->[0] =~ /dbi:([^:]+):/i; - $started_unconnected = 1; + # if connect_info is a CODEREF, we have no choice but to connect + if (ref $self->_dbi_connect_info->[0] && + Scalar::Util::reftype($self->_dbi_connect_info->[0]) eq 'CODE') { + $self->_populate_dbh; + $driver = $self->_dbh->{Driver}{Name}; + } + else { + # try to use dsn to not require being connected, the driver may still + # force a connection in _rebless to determine version + ($driver) = $self->_dbi_connect_info->[0] =~ /dbi:([^:]+):/i; + $started_unconnected = 1; + } } my $storage_class = "DBIx::Class::Storage::DBI::${driver}"; @@ -863,6 +910,8 @@ sub _determine_driver { $self->_driver_determined(1); + $self->_init; # run driver-specific initializations + $self->_run_connection_actions if $started_unconnected && defined $self->_dbh; } @@ -922,7 +971,7 @@ sub _do_query { my @bind = map { [ undef, $_ ] } @do_args; $self->_query_start($sql, @bind); - $self->_dbh->do($sql, $attrs, @do_args); + $self->_get_dbh->do($sql, $attrs, @do_args); $self->_query_end($sql, @bind); } @@ -958,6 +1007,8 @@ sub _connect { $weak_self->throw_exception("DBI Exception: $_[0]"); } else { + # the handler may be invoked by something totally out of + # the scope of DBIC croak ("DBI Exception: $_[0]"); } }; @@ -1067,27 +1118,36 @@ sub txn_begin { if($self->{transaction_depth} == 0) { $self->debugobj->txn_begin() if $self->debug; - - # being here implies we have AutoCommit => 1 - # if the user is utilizing txn_do - good for - # him, otherwise we need to ensure that the - # $dbh is healthy on BEGIN - my $dbh_method = $self->{_in_dbh_do} ? '_dbh' : 'dbh'; - $self->$dbh_method->begin_work; - - } elsif ($self->auto_savepoint) { + $self->_dbh_begin_work; + } + elsif ($self->auto_savepoint) { $self->svp_begin; } $self->{transaction_depth}++; } +sub _dbh_begin_work { + my $self = shift; + + # if the user is utilizing txn_do - good for him, otherwise we need to + # ensure that the $dbh is healthy on BEGIN. + # We do this via ->dbh_do instead of ->dbh, so that the ->dbh "ping" + # will be replaced by a failure of begin_work itself (which will be + # then retried on reconnect) + if ($self->{_in_dbh_do}) { + $self->_dbh->begin_work; + } else { + $self->dbh_do(sub { $_[1]->begin_work }); + } +} + sub txn_commit { my $self = shift; if ($self->{transaction_depth} == 1) { my $dbh = $self->_dbh; $self->debugobj->txn_commit() if ($self->debug); - $dbh->commit; + $self->_dbh_commit; $self->{transaction_depth} = 0 if $self->_dbh_autocommit; } @@ -1098,6 +1158,11 @@ sub txn_commit { } } +sub _dbh_commit { + my $self = shift; + $self->_dbh->commit; +} + sub txn_rollback { my $self = shift; my $dbh = $self->_dbh; @@ -1107,7 +1172,7 @@ sub txn_rollback { if ($self->debug); $self->{transaction_depth} = 0 if $self->_dbh_autocommit; - $dbh->rollback; + $self->_dbh_rollback; } elsif($self->{transaction_depth} > 1) { $self->{transaction_depth}--; @@ -1130,6 +1195,11 @@ sub txn_rollback { } } +sub _dbh_rollback { + my $self = shift; + $self->_dbh->rollback; +} + # 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 # all of _execute's args, and emits $sql, @bind. @@ -1224,7 +1294,7 @@ sub _dbh_execute { sub _execute { my $self = shift; - $self->dbh_do('_dbh_execute', @_) + $self->dbh_do('_dbh_execute', @_); # retry over disconnects } sub insert { @@ -1266,12 +1336,22 @@ sub insert { ## only prepped once. sub insert_bulk { my ($self, $source, $cols, $data) = @_; + +# redispatch to insert_bulk method of storage we reblessed into, if necessary + if (not $self->_driver_determined) { + $self->_determine_driver; + goto $self->can('insert_bulk'); + } + my %colvalues; my $table = $source->from; @colvalues{@$cols} = (0..$#$cols); - my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues); - $self->_determine_driver; + my ($sql, $bind) = $self->_prep_for_execute ( + 'insert', undef, $source, [\%colvalues] + ); + my @bind = @$bind + or croak 'Cannot insert_bulk without support for placeholders'; $self->_query_start( $sql, @bind ); my $sth = $self->sth($sql); @@ -1303,6 +1383,7 @@ sub insert_bulk { $placeholder_index++; } my $rv = eval { $sth->execute_array({ArrayTupleStatus => $tuple_status}) }; + $sth->finish; if (my $err = $@) { my $i = 0; ++$i while $i <= $#$tuple_status && !ref $tuple_status->[$i]; @@ -1310,17 +1391,11 @@ sub insert_bulk { $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->_pretty_print ({ + map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) + }), ); } $self->throw_exception($sth->errstr) if !$rv; @@ -1330,12 +1405,17 @@ sub insert_bulk { } sub update { - my $self = shift @_; - my $source = shift @_; - $self->_determine_driver; + my ($self, $source, @args) = @_; + +# redispatch to update method of storage we reblessed into, if necessary + if (not $self->_driver_determined) { + $self->_determine_driver; + goto $self->can('update'); + } + my $bind_attributes = $self->source_bind_attributes($source); - return $self->_execute('update' => [], $source, $bind_attributes, @_); + return $self->_execute('update' => [], $source, $bind_attributes, @args); } @@ -1912,6 +1992,18 @@ sub _subq_count_select { return @pcols ? \@pcols : [ 1 ]; } +# +# Returns an ordered list of column names before they are used +# in a SELECT statement. By default simply returns the list +# passed in. +# +# This may be overridden in a specific storage when there are +# requirements such as moving BLOB columns to the end of the +# SELECT list. +sub _order_select_columns { + #my ($self, $source, $columns) = @_; + return @{$_[2]}; +} sub source_bind_attributes { my ($self, $source) = @_; @@ -1987,7 +2079,7 @@ sub _dbh_sth { sub sth { my ($self, $sql) = @_; - $self->dbh_do('_dbh_sth', $sql); + $self->dbh_do('_dbh_sth', $sql); # retry over disconnects } sub _dbh_columns_info_for { @@ -2049,7 +2141,7 @@ sub _dbh_columns_info_for { sub columns_info_for { my ($self, $table) = @_; - $self->dbh_do('_dbh_columns_info_for', $table); + $self->_dbh_columns_info_for ($self->_get_dbh, $table); } =head2 last_insert_id @@ -2075,15 +2167,69 @@ EOE sub last_insert_id { my $self = shift; - $self->dbh_do('_dbh_last_insert_id', @_); + $self->_dbh_last_insert_id ($self->_dbh, @_); } -# By default there is no resolution of DBIC data types to DBI data types -# In essence this makes e.g. AutoCast a noop -sub _dbi_data_type { +=head2 _native_data_type + +=over 4 + +=item Arguments: $type_name + +=back + +This API is B, will almost definitely change in the future, and +currently only used by L<::AutoCast|DBIx::Class::Storage::DBI::AutoCast> and +L<::Sybase|DBIx::Class::Storage::DBI::Sybase>. + +The default implementation returns C, implement in your Storage driver if +you need this functionality. + +Should map types from other databases to the native RDBMS type, for example +C to C. + +Types with modifiers should map to the underlying data type. For example, +C should become C. + +Composite types should map to the container type, for example +C becomes C. + +=cut + +sub _native_data_type { #my ($self, $data_type) = @_; return undef -}; +} + +# Check if placeholders are supported at all +sub _placeholders_supported { + my $self = shift; + my $dbh = $self->_get_dbh; + + # some drivers provide a $dbh attribute (e.g. Sybase and $dbh->{syb_dynamic_supported}) + # but it is inaccurate more often than not + eval { + local $dbh->{PrintError} = 0; + local $dbh->{RaiseError} = 1; + $dbh->do('select ?', {}, 1); + }; + return $@ ? 0 : 1; +} + +# Check if placeholders bound to non-string types throw exceptions +# +sub _typeless_placeholders_supported { + my $self = shift; + my $dbh = $self->_get_dbh; + + eval { + local $dbh->{PrintError} = 0; + local $dbh->{RaiseError} = 1; + # this specifically tests a bind that is NOT a string + $dbh->do('select 1 where 1 = ?', {}, 1); + }; + return $@ ? 0 : 1; +} =head2 sqlt_type @@ -2216,9 +2362,8 @@ sub create_ddl_dir { %{$sqltargs || {}} }; - $self->throw_exception(q{Can't create a ddl file without SQL::Translator 0.09003: '} - . $self->_check_sqlt_message . q{'}) - if !$self->_check_sqlt_version; + $self->throw_exception("Can't create a ddl file without SQL::Translator: " . $self->_sqlt_version_error) + if !$self->_sqlt_version_ok; my $sqlt = SQL::Translator->new( $sqltargs ); @@ -2360,9 +2505,8 @@ sub deployment_statements { return join('', @rows); } - $self->throw_exception(q{Can't deploy without SQL::Translator 0.09003: '} - . $self->_check_sqlt_message . q{'}) - if !$self->_check_sqlt_version; + $self->throw_exception("Can't deploy without either SQL::Translator or a ddl_dir: " . $self->_sqlt_version_error ) + if !$self->_sqlt_version_ok; # sources needs to be a parser arg, but for simplicty allow at top level # coming in @@ -2421,7 +2565,6 @@ Returns the datetime parser class sub datetime_parser { my $self = shift; return $self->{datetime_parser} ||= do { - $self->_populate_dbh unless $self->_dbh; $self->build_datetime_parser(@_); }; } @@ -2442,28 +2585,17 @@ See L =cut sub build_datetime_parser { + if (not $_[0]->_driver_determined) { + $_[0]->_determine_driver; + goto $_[0]->can('build_datetime_parser'); + } + my $self = shift; my $type = $self->datetime_parser_type(@_); - eval "use ${type}"; - $self->throw_exception("Couldn't load ${type}: $@") if $@; + $self->ensure_class_loaded ($type); return $type; } -{ - my $_check_sqlt_version; # private - my $_check_sqlt_message; # private - sub _check_sqlt_version { - return $_check_sqlt_version if defined $_check_sqlt_version; - eval 'use SQL::Translator "0.09003"'; - $_check_sqlt_message = $@ || ''; - $_check_sqlt_version = !$@; - } - - sub _check_sqlt_message { - _check_sqlt_version if !defined $_check_sqlt_message; - $_check_sqlt_message; - } -} =head2 is_replicating @@ -2490,12 +2622,41 @@ sub lag_behind_master { return; } +# SQLT version handling +{ + my $_sqlt_version_ok; # private + my $_sqlt_version_error; # private + + sub _sqlt_version_ok { + if (!defined $_sqlt_version_ok) { + eval "use SQL::Translator $minimum_sqlt_version"; + if ($@) { + $_sqlt_version_ok = 0; + $_sqlt_version_error = $@; + } + else { + $_sqlt_version_ok = 1; + } + } + return $_sqlt_version_ok; + } + + sub _sqlt_version_error { + shift->_sqlt_version_ok unless defined $_sqlt_version_ok; + return $_sqlt_version_error; + } + + sub _sqlt_minimum_version { $minimum_sqlt_version }; +} + sub DESTROY { my $self = shift; + $self->_verify_pid if $self->_dbh; # some databases need this to stop spewing warnings if (my $dbh = $self->_dbh) { + local $@; eval { $dbh->disconnect }; }