X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=533258239d71c1b26efd881ed8fdaac7b8b80e38;hb=fb13a49f17a0e0a49638080a4bd826fb3702aebe;hp=d9fa57ac85201376663574f81e6df45770c5e237;hpb=fabbd5cca97aaef8e605a783c78abc1eaf9bdbae;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index d9fa57a..5332582 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -12,9 +12,11 @@ use DBIx::Class::Exception; 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 DBI::Const::GetInfoType (); # no import of retarded global hash use namespace::clean; # default cursor class, overridable in connect_info attributes @@ -196,16 +198,15 @@ sub new { my %seek_and_destroy; sub _arm_global_destructor { - my $self = shift; - my $key = refaddr ($self); - $seek_and_destroy{$key} = $self; - weaken ($seek_and_destroy{$key}); + weaken ( + $seek_and_destroy{ refaddr($_[0]) } = $_[0] + ); } END { local $?; # just in case the DBI destructor changes it somehow - # destroy just the object if not native to this process/thread + # destroy just the object if not native to this process $_->_verify_pid for (grep { defined $_ } values %seek_and_destroy @@ -216,14 +217,18 @@ sub new { # As per DBI's recommendation, DBIC disconnects all handles as # soon as possible (DBIC will reconnect only on demand from within # the thread) - for (values %seek_and_destroy) { - next unless $_; + my @instances = grep { defined $_ } values %seek_and_destroy; + for (@instances) { $_->{_dbh_gen}++; # so that existing cursors will drop as well $_->_dbh(undef); $_->transaction_depth(0); $_->savepoints([]); } + + # properly renumber all existing refs + %seek_and_destroy = (); + $_->_arm_global_destructor for @instances; } } @@ -231,7 +236,7 @@ sub DESTROY { my $self = shift; # some databases spew warnings on implicit disconnect - $self->_verify_pid; + $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; local $SIG{__WARN__} = sub {}; $self->_dbh(undef); @@ -883,7 +888,7 @@ sub connected { sub _seems_connected { my $self = shift; - $self->_verify_pid; + $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; my $dbh = $self->_dbh or return 0; @@ -931,7 +936,7 @@ sub dbh { # this is the internal "get dbh or connect (don't check)" method sub _get_dbh { my $self = shift; - $self->_verify_pid; + $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $self->_populate_dbh unless $self->_dbh; return $self->_dbh; } @@ -1005,7 +1010,7 @@ sub _populate_dbh { $self->_dbh($self->_connect(@info)); - $self->_conn_pid($$) if $^O ne 'MSWin32'; # on win32 these are in fact threads + $self->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads $self->_determine_driver; @@ -1073,7 +1078,16 @@ sub _server_info { $info = {}; - my $server_version = try { $self->_get_server_version }; + my $server_version = try { + $self->_get_server_version + } catch { + # driver determination *may* use this codepath + # in which case we must rethrow + $self->throw_exception($_) if $self->{_in_determine_driver}; + + # $server_version on failure + undef; + }; if (defined $server_version) { $info->{dbms_version} = $server_version; @@ -1105,13 +1119,76 @@ sub _server_info { } sub _get_server_version { - shift->_dbh_get_info(18); + shift->_dbh_get_info('SQL_DBMS_VER'); } sub _dbh_get_info { my ($self, $info) = @_; - return try { $self->_get_dbh->get_info($info) } || undef; + if ($info =~ /[^0-9]/) { + $info = $DBI::Const::GetInfoType::GetInfoType{$info}; + $self->throw_exception("Info type '$_[1]' not provided by DBI::Const::GetInfoType") + unless defined $info; + } + + return $self->_get_dbh->get_info($info); +} + +sub _describe_connection { + require DBI::Const::GetInfoReturn; + + my $self = shift; + $self->ensure_connected; + + my $res = { + DBIC_DSN => $self->_dbi_connect_info->[0], + DBI_VER => DBI->VERSION, + DBIC_VER => DBIx::Class->VERSION, + DBIC_DRIVER => ref $self, + }; + + for my $inf ( + #keys %DBI::Const::GetInfoType::GetInfoType, + qw/ + SQL_CURSOR_COMMIT_BEHAVIOR + SQL_CURSOR_ROLLBACK_BEHAVIOR + SQL_CURSOR_SENSITIVITY + SQL_DATA_SOURCE_NAME + SQL_DBMS_NAME + SQL_DBMS_VER + SQL_DEFAULT_TXN_ISOLATION + SQL_DM_VER + SQL_DRIVER_NAME + SQL_DRIVER_ODBC_VER + SQL_DRIVER_VER + SQL_EXPRESSIONS_IN_ORDERBY + SQL_GROUP_BY + SQL_IDENTIFIER_CASE + SQL_IDENTIFIER_QUOTE_CHAR + SQL_MAX_CATALOG_NAME_LEN + SQL_MAX_COLUMN_NAME_LEN + SQL_MAX_IDENTIFIER_LEN + SQL_MAX_TABLE_NAME_LEN + SQL_MULTIPLE_ACTIVE_TXN + SQL_MULT_RESULT_SETS + SQL_NEED_LONG_DATA_LEN + SQL_NON_NULLABLE_COLUMNS + SQL_ODBC_VER + SQL_QUALIFIER_NAME_SEPARATOR + SQL_QUOTED_IDENTIFIER_CASE + SQL_TXN_CAPABLE + SQL_TXN_ISOLATION_OPTION + / + ) { + my $v = $self->_dbh_get_info($inf); + next unless defined $v; + + #my $key = sprintf( '%s(%s)', $inf, $DBI::Const::GetInfoType::GetInfoType{$inf} ); + my $expl = DBI::Const::GetInfoReturn::Explain($inf, $v); + $res->{$inf} = DBI::Const::GetInfoReturn::Format($inf, $v) . ( $expl ? " ($expl)" : '' ); + } + + $res; } sub _determine_driver { @@ -1126,7 +1203,8 @@ sub _determine_driver { if ($self->_dbh) { # we are connected $driver = $self->_dbh->{Driver}{Name}; $started_connected = 1; - } else { + } + else { # if connect_info is a CODEREF, we have no choice but to connect if (ref $self->_dbi_connect_info->[0] && reftype $self->_dbi_connect_info->[0] eq 'CODE') { @@ -1150,6 +1228,18 @@ sub _determine_driver { bless $self, $storage_class; $self->_rebless(); } + else { + $self->_warn_undetermined_driver( + 'This version of DBIC does not yet seem to supply a driver for ' + . "your particular RDBMS and/or connection method ('$driver')." + ); + } + } + else { + $self->_warn_undetermined_driver( + 'Unable to extract a driver name from connect info - this ' + . 'should not have happened.' + ); } } @@ -1164,6 +1254,48 @@ sub _determine_driver { } } +sub _determine_connector_driver { + my ($self, $conn) = @_; + + my $dbtype = $self->_dbh_get_info('SQL_DBMS_NAME'); + + if (not $dbtype) { + $self->_warn_undetermined_driver( + 'Unable to retrieve RDBMS type (SQL_DBMS_NAME) of the engine behind your ' + . "$conn connector - this should not have happened." + ); + return; + } + + $dbtype =~ s/\W/_/gi; + + my $subclass = "DBIx::Class::Storage::DBI::${conn}::${dbtype}"; + return if $self->isa($subclass); + + if ($self->load_optional_class($subclass)) { + bless $self, $subclass; + $self->_rebless; + } + else { + $self->_warn_undetermined_driver( + 'This version of DBIC does not yet seem to supply a driver for ' + . "your particular RDBMS and/or connection method ('$conn/$dbtype')." + ); + } +} + +sub _warn_undetermined_driver { + my ($self, $msg) = @_; + + require Data::Dumper::Concise; + + carp_once ($msg . ' While we will attempt to continue anyway, the results ' + . 'are likely to be underwhelming. Please upgrade DBIC, and if this message ' + . "does not go away, file a bugreport including the following info:\n" + . Data::Dumper::Concise::Dumper($self->_describe_connection) + ); +} + sub _do_connection_actions { my $self = shift; my $method_prefix = shift; @@ -1235,10 +1367,7 @@ sub _connect { my ($old_connect_via, $dbh); - if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) { - $old_connect_via = $DBI::connect_via; - $DBI::connect_via = 'connect'; - } + local $DBI::connect_via = 'connect' if $INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}; try { if(ref $info[0] eq 'CODE') { @@ -1300,9 +1429,6 @@ sub _connect { } catch { $self->throw_exception("DBI Connection failed: $_") - } - finally { - $DBI::connect_via = $old_connect_via if $old_connect_via; }; $self->_dbh_autocommit($dbh->{AutoCommit}); @@ -1343,7 +1469,7 @@ sub _exec_txn_begin { sub txn_commit { my $self = shift; - $self->_verify_pid if $self->_dbh; + $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $self->throw_exception("Unable to txn_commit() on a disconnected storage") unless $self->_dbh; @@ -1374,7 +1500,7 @@ sub _exec_txn_commit { sub txn_rollback { my $self = shift; - $self->_verify_pid if $self->_dbh; + $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $self->throw_exception("Unable to txn_rollback() on a disconnected storage") unless $self->_dbh; @@ -1407,7 +1533,7 @@ 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 if $self->_dbh; + $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(@_); @@ -2116,6 +2242,10 @@ sub _select { sub _select_args_to_query { my $self = shift; + $self->throw_exception( + "Unable to generate limited query representation with 'software_limit' enabled" + ) if ($_[3]->{software_limit} and ($_[3]->{offset} or $_[3]->{rows}) ); + # my ($op, $ident, $select, $cond, $rs_attrs, $rows, $offset) # = $self->_select_args($ident, $select, $cond, $attrs); my ($op, $ident, @args) = @@ -2191,12 +2321,20 @@ sub _select_args { } # try to simplify the joinmap further (prune unreferenced type-single joins) - $ident = $self->_prune_unused_joins ($ident, $select, $where, $attrs); + if ( + ref $ident + and + reftype $ident eq 'ARRAY' + and + @$ident != 1 + ) { + $ident = $self->_prune_unused_joins ($ident, $select, $where, $attrs); + } ### # This would be the point to deflate anything found in $where # (and leave $attrs->{bind} intact). Problem is - inflators historically - # expect a row object. And all we have is a resultsource (it is trivial + # expect a result object. And all we have is a resultsource (it is trivial # to extract deflator coderefs via $alias2source above). # # I don't see a way forward other than changing the way deflators are @@ -2503,7 +2641,7 @@ sub is_datatype_numeric { =over 4 -=item Arguments: $schema \@databases, $version, $directory, $preversion, \%sqlt_args +=item Arguments: $schema, \@databases, $version, $directory, $preversion, \%sqlt_args =back @@ -2565,7 +2703,7 @@ sub create_ddl_dir { } else { -d $dir or - (require File::Path and File::Path::make_path ("$dir")) # make_path does not like objects (i.e. Path::Class::Dir) + (require File::Path and File::Path::mkpath (["$dir"])) # mkpath does not like objects (i.e. Path::Class::Dir) or $self->throw_exception( "Failed to create '$dir': " . ($! || $@ || 'error unknown') @@ -2748,18 +2886,12 @@ sub deployment_statements { data => $schema, ); - my @ret; - if (wantarray) { - @ret = $tr->translate; - } - else { - $ret[0] = $tr->translate; - } - - $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error) - unless (@ret && defined $ret[0]); - - return wantarray ? @ret : $ret[0]; + return preserve_context { + $tr->translate + } after => sub { + $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error) + unless defined $_[0]; + }; } # FIXME deploy() currently does not accurately report sql errors @@ -2859,6 +2991,8 @@ sub lag_behind_master { =item Arguments: $relname, $join_count +=item Return Value: $alias + =back L uses L names as table aliases in @@ -2950,6 +3084,13 @@ sub _is_text_lob_type { |national\s*character\s*varying))\z/xi); } +# Determine if a data_type is some type of a binary type +sub _is_binary_type { + my ($self, $data_type) = @_; + $data_type && ($self->_is_binary_lob_type($data_type) + || $data_type =~ /(?:var)?(?:binary|bit|graphic)(?:\s*varying)?/i); +} + 1; =head1 USAGE NOTES @@ -2971,11 +3112,9 @@ cases if you choose the C<< AutoCommit => 0 >> path, just as you would be with raw DBI. -=head1 AUTHORS - -Matt S. Trout +=head1 AUTHOR AND CONTRIBUTORS -Andy Grundman +See L and L in DBIx::Class =head1 LICENSE