X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=ed7930890826f98544cc55c479d0da375dfbc3dc;hb=0836d2fd0dbb872d82ccb2a20fc6b50ea1aa0f00;hp=b92546c477bd25f3d665e212bd24adbc314d348c;hpb=0bd2c1cdd249ba5866529b8316a1764a07a4871f;p=dbsrgits%2FDBIx-Class-Historic.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index b92546c..ed79308 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -44,7 +44,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 +119,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 +138,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 +354,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 +430,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 +563,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 +574,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 +620,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 +681,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 +810,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 +836,9 @@ sub sql_maker { return $self->_sql_maker; } +# nothing to do by default sub _rebless {} +sub _init {} sub _populate_dbh { my ($self) = @_; @@ -847,10 +881,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 +905,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 +966,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); } @@ -1067,27 +1111,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 +1151,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 +1165,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 +1188,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 +1287,7 @@ sub _dbh_execute { sub _execute { my $self = shift; - $self->dbh_do('_dbh_execute', @_) + $self->dbh_do('_dbh_execute', @_); # retry over disconnects } sub insert { @@ -1265,16 +1328,22 @@ sub insert { ## scalar refs, or at least, all the same type as the first set, the statement is ## only prepped once. sub insert_bulk { - my ($self, $source, $cols, $data) = @_; + my ($self, $source, $cols, $data, $sth_attr) = @_; + +# 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); +# XXX some bulk APIs require column list in database order my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues); - $self->_determine_driver; - $self->_query_start( $sql, @bind ); - my $sth = $self->sth($sql); + my $sth = $self->sth($sql, 'insert', $sth_attr); # @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args @@ -1303,7 +1372,7 @@ sub insert_bulk { $placeholder_index++; } my $rv = eval { $sth->execute_array({ArrayTupleStatus => $tuple_status}) }; - if (my $err = $@) { + if (my $err = $@ || $sth->errstr) { my $i = 0; ++$i while $i <= $#$tuple_status && !ref $tuple_status->[$i]; @@ -1315,6 +1384,7 @@ sub insert_bulk { local $Data::Dumper::Indent = 1; local $Data::Dumper::Useqq = 1; local $Data::Dumper::Quotekeys = 0; + local $Data::Dumper::Sortkeys = 1; $self->throw_exception(sprintf "%s for populate slice:\n%s", $tuple_status->[$i][1], @@ -1325,17 +1395,24 @@ sub insert_bulk { } $self->throw_exception($sth->errstr) if !$rv; + $sth->finish; + $self->_query_end( $sql, @bind ); return (wantarray ? ($rv, $sth, @bind) : $rv); } 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 +1989,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) = @_; @@ -1971,12 +2060,15 @@ Returns a L sth (statement handle) for the supplied SQL. =cut sub _dbh_sth { - my ($self, $dbh, $sql) = @_; + my ($self, $dbh, $sql, $op, $sth_attr) = @_; +# $op is ignored right now + + $sth_attr ||= {}; # 3 is the if_active parameter which avoids active sth re-use my $sth = $self->disable_sth_caching - ? $dbh->prepare($sql) - : $dbh->prepare_cached($sql, {}, 3); + ? $dbh->prepare($sql, $sth_attr) + : $dbh->prepare_cached($sql, $sth_attr, 3); # XXX You would think RaiseError would make this impossible, # but apparently that's not true :( @@ -1986,8 +2078,8 @@ sub _dbh_sth { } sub sth { - my ($self, $sql) = @_; - $self->dbh_do('_dbh_sth', $sql); + my ($self, $sql, $op, $sth_attr) = @_; + $self->dbh_do('_dbh_sth', $sql, $op, $sth_attr); # 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,7 +2167,7 @@ EOE sub last_insert_id { my $self = shift; - $self->dbh_do('_dbh_last_insert_id', @_); + $self->_dbh_last_insert_id ($self->_dbh, @_); } =head2 _native_data_type @@ -2109,6 +2201,36 @@ sub _native_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 Returns the database driver name. @@ -2240,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 ); @@ -2384,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 @@ -2445,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(@_); }; } @@ -2466,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 @@ -2516,10 +2624,12 @@ sub lag_behind_master { 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 }; }