X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=d9e938c6ab8b33acedd3cda067dce2f54f34059e;hb=051f27062ec44febc8458a0e2ceb92981c710a3a;hp=d32154517447779d07c9d442dff6733e81276ad9;hpb=44e538d00c41e69899b48178c9dede95e2ef7e77;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index d321545..d9e938c 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -452,7 +452,11 @@ sub connect_info { } sub _default_dbi_connect_attributes { - return { AutoCommit => 1 }; + return { + AutoCommit => 1, + RaiseError => 1, + PrintError => 0, + }; } =head2 on_connect_do @@ -551,6 +555,7 @@ sub dbh_do { } }; + # ->connected might unset $@ - copy my $exception = $@; if(!$exception) { return $want_array ? @result : $result[0] } @@ -558,6 +563,8 @@ sub dbh_do { # We were not connected - reconnect and retry, but let any # exception fall right through this time + carp "Retrying $code after catching disconnected exception: $exception" + if $ENV{DBIC_DBIRETRY_DEBUG}; $self->_populate_dbh; $self->$code($self->_dbh, @_); } @@ -598,6 +605,7 @@ sub txn_do { $self->txn_commit; }; + # ->connected might unset $@ - copy my $exception = $@; if(!$exception) { return $want_array ? @result : $result[0] } @@ -619,6 +627,8 @@ sub txn_do { # We were not connected, and was first try - reconnect and retry # via the while loop + carp "Retrying $coderef after catching disconnected exception: $exception" + if $ENV{DBIC_DBIRETRY_DEBUG}; $self->_populate_dbh; } } @@ -688,22 +698,32 @@ answering, etc.) This method is used internally by L. =cut sub connected { - my ($self) = @_; + my $self = shift; + return 0 unless $self->_seems_connected; - if(my $dbh = $self->_dbh) { - if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) { - $self->_dbh(undef); - $self->{_dbh_gen}++; - return; - } - else { - $self->_verify_pid; - return 0 if !$self->_dbh; - } - return ($dbh->FETCH('Active') && $self->_ping); + #be on the safe side + local $self->_dbh->{RaiseError} = 1; + + return $self->_ping; +} + +sub _seems_connected { + my $self = shift; + + my $dbh = $self->_dbh + or return 0; + + if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) { + $self->_dbh(undef); + $self->{_dbh_gen}++; + return 0; + } + else { + $self->_verify_pid; + return 0 if !$self->_dbh; } - return 0; + return $dbh->FETCH('Active'); } sub _ping { @@ -740,7 +760,9 @@ sub ensure_connected { Returns a C<$dbh> - a data base handle of class L. The returned handle is guaranteed to be healthy by implicitly calling L, and if -necessary performing a reconnection before returning. +necessary performing a reconnection before returning. Keep in mind that this +is very B on some database engines. Consider using L +instead. =cut @@ -755,17 +777,8 @@ sub dbh { return $self->_dbh; } -=head2 last_dbh - -This returns the B available C<$dbh> if any, or attempts to -connect and returns the resulting handle. This method differs from -L by not validating if a preexisting handle is still healthy -via L. Make sure you take appropriate precautions -when using this method, as the C<$dbh> may be useless at this point. - -=cut - -sub last_dbh { +# this is the internal "get dbh or connect (don't check)" method +sub _get_dbh { my $self = shift; $self->_populate_dbh unless $self->_dbh; return $self->_dbh; @@ -777,7 +790,7 @@ sub _sql_maker_args { return ( bindtype=>'columns', array_datatypes => 1, - limit_dialect => $self->last_dbh, + limit_dialect => $self->_get_dbh, %{$self->_sql_maker_opts} ); } @@ -798,6 +811,7 @@ sub _populate_dbh { my ($self) = @_; my @info = @{$self->_dbi_connect_info || []}; + $self->_dbh(undef); # in case ->connected failed we might get sent here $self->_dbh($self->_connect(@info)); $self->_conn_pid($$); @@ -825,7 +839,7 @@ sub _run_connection_actions { sub _determine_driver { my ($self) = @_; - if (not $self->_driver_determined) { + if ((not $self->_driver_determined) && (not $self->{_in_determine_driver})) { my $started_unconnected = 0; local $self->{_in_determine_driver} = 1; @@ -1250,7 +1264,7 @@ sub insert { $updated_cols->{$col} = $to_insert->{$col} = $self->_sequence_fetch( 'nextval', $col_info->{sequence} || - $self->_dbh_get_autoinc_seq($self->last_dbh, $source) + $self->_dbh_get_autoinc_seq($self->_get_dbh, $source) ); } } @@ -1331,12 +1345,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); } @@ -1602,9 +1621,9 @@ sub _adjust_select_args_for_complex_prefetch { # alias any functions to the dbic-side 'as' label # adjust the outer select accordingly - if (ref $sel eq 'HASH' && !$sel->{-select}) { - $sel = { -select => $sel, -as => $attrs->{as}[$i] }; - $select->[$i] = join ('.', $attrs->{alias}, ($attrs->{as}[$i] || "select_$i") ); + if (ref $sel eq 'HASH' ) { + $sel->{-as} ||= $attrs->{as}[$i]; + $select->[$i] = join ('.', $attrs->{alias}, ($sel->{-as} || "select_$i") ); } push @$sub_select, $sel; @@ -1868,6 +1887,21 @@ 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) = @_; @@ -2040,7 +2074,7 @@ Returns the database driver name. =cut -sub sqlt_type { shift->last_dbh->{Driver}->{Name} } +sub sqlt_type { shift->_get_dbh->{Driver}->{Name} } =head2 bind_attribute_by_data_type @@ -2286,8 +2320,6 @@ See L for a list of values for C<$sqlt_args>. sub deployment_statements { my ($self, $schema, $type, $version, $dir, $sqltargs) = @_; - # Need to be connected to get the correct sqlt_type - $self->last_dbh() unless $type; $type ||= $self->sqlt_type; $version ||= $schema->schema_version || '1.x'; $dir ||= './'; @@ -2306,18 +2338,18 @@ sub deployment_statements { . $self->_check_sqlt_message . q{'}) if !$self->_check_sqlt_version; - require SQL::Translator::Parser::DBIx::Class; - eval qq{use SQL::Translator::Producer::${type}}; - $self->throw_exception($@) if $@; - # sources needs to be a parser arg, but for simplicty allow at top level # coming in $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources} if exists $sqltargs->{sources}; - my $tr = SQL::Translator->new(%$sqltargs); - SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema ); - return "SQL::Translator::Producer::${type}"->can('produce')->($tr); + my $tr = SQL::Translator->new( + producer => "SQL::Translator::Producer::${type}", + %$sqltargs, + parser => 'SQL::Translator::Parser::DBIx::Class', + data => $schema, + ); + return $tr->translate; } sub deploy { @@ -2332,10 +2364,9 @@ sub deploy { return if $line =~ /^\s+$/; # skip whitespace only $self->_query_start($line); eval { - # a previous error may invalidate $dbh - thus we need to use dbh() - # to guarantee a healthy $dbh (this is temporary until we get - # proper error handling on deploy() ) - $self->dbh->do($line); + # do a dbh_do cycle here, as we need some error checking in + # place (even though we will ignore errors) + $self->dbh_do (sub { $_[1]->do($line) }); }; if ($@) { carp qq{$@ (running "${line}")}; @@ -2364,7 +2395,7 @@ Returns the datetime parser class sub datetime_parser { my $self = shift; return $self->{datetime_parser} ||= do { - $self->last_dbh; + $self->_populate_dbh unless $self->_dbh; $self->build_datetime_parser(@_); }; } @@ -2433,27 +2464,15 @@ sub lag_behind_master { return; } -=head2 order_columns_for_select - -Returns an ordered list of column names for use with a C