X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=3e746ad924d782222b129b6a558b111629f59e12;hb=0e3647497ee2cbaa511b05262c902ee50d813c32;hp=8a99d068f504664db4a023fbcac41e95f6676504;hpb=cf9ba393c6309a66fe31b2decb7574fdf068a759;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 8a99d06..3e746ad 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -13,7 +13,7 @@ use List::Util qw/first/; use Context::Preserve 'preserve_context'; use Try::Tiny; use SQL::Abstract qw(is_plain_value is_literal_value); -use DBIx::Class::_Util qw(quote_sub perlstring serialize); +use DBIx::Class::_Util qw(quote_sub perlstring serialize detected_reinvoked_destructor); use namespace::clean; # default cursor class, overridable in connect_info attributes @@ -119,12 +119,16 @@ for my $meth (keys %$storage_accessor_idx, qw( my $orig = __PACKAGE__->can ($meth) or die "$meth is not a ::Storage::DBI method!"; - my $is_getter = $storage_accessor_idx->{$meth} ? 0 : 1; + my $possibly_a_setter = $storage_accessor_idx->{$meth} ? 1 : 0; quote_sub - __PACKAGE__ ."::$meth", sprintf( <<'EOC', $is_getter, perlstring $meth ), { '$orig' => \$orig }; + __PACKAGE__ ."::$meth", sprintf( <<'EOC', $possibly_a_setter, perlstring $meth ), { '$orig' => \$orig }; if ( + # if this is an actual *setter* - just set it, no need to connect + # and determine the driver + !( %1$s and @_ > 1 ) + and # only fire when invoked on an instance, a valid class-based invocation # would e.g. be setting a default for an inherited accessor ref $_[0] @@ -133,10 +137,6 @@ for my $meth (keys %$storage_accessor_idx, qw( and ! $_[0]->{_in_determine_driver} and - # if this is a known *setter* - just set it, no need to connect - # and determine the driver - ( %1$s or @_ <= 1 ) - and # Only try to determine stuff if we have *something* that either is or can # provide a DSN. Allows for bare $schema's generated with a plain ->connect() # to still be marginally useful @@ -253,6 +253,8 @@ sub new { } sub DESTROY { + return if &detected_reinvoked_destructor; + $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; # some databases spew warnings on implicit disconnect local $SIG{__WARN__} = sub {}; @@ -1108,10 +1110,16 @@ sub get_dbms_capability { sub _server_info { my $self = shift; - my $info; - unless ($info = $self->_dbh_details->{info}) { + # FIXME - ideally this needs to be an ||= assignment, and the final + # assignment at the end of this do{} should be gone entirely. However + # this confuses CXSA: https://rt.cpan.org/Ticket/Display.html?id=103296 + $self->_dbh_details->{info} || do { - $info = {}; + # this guarantees that problematic conninfo won't be hidden + # by the try{} below + $self->ensure_connected; + + my $info = {}; my $server_version = try { $self->_get_server_version @@ -1148,9 +1156,7 @@ sub _server_info { } $self->_dbh_details->{info} = $info; - } - - return $info; + }; } sub _get_server_version { @@ -1329,7 +1335,7 @@ sub _extract_driver_from_connect_info { sub _determine_connector_driver { my ($self, $conn) = @_; - my $dbtype = $self->_dbh_get_info('SQL_DBMS_NAME'); + my $dbtype = $self->_get_rdbms_name; if (not $dbtype) { $self->_warn_undetermined_driver( @@ -1356,6 +1362,8 @@ sub _determine_connector_driver { } } +sub _get_rdbms_name { shift->_dbh_get_info('SQL_DBMS_NAME') } + sub _warn_undetermined_driver { my ($self, $msg) = @_; @@ -1369,24 +1377,40 @@ sub _warn_undetermined_driver { } sub _do_connection_actions { - my $self = shift; - my $method_prefix = shift; - my $call = shift; - - if (not ref($call)) { - my $method = $method_prefix . $call; - $self->$method(@_); - } elsif (ref($call) eq 'CODE') { - $self->$call(@_); - } elsif (ref($call) eq 'ARRAY') { - if (ref($call->[0]) ne 'ARRAY') { - $self->_do_connection_actions($method_prefix, $_) for @$call; - } else { - $self->_do_connection_actions($method_prefix, @$_) for @$call; + my ($self, $method_prefix, $call, @args) = @_; + + try { + if (not ref($call)) { + my $method = $method_prefix . $call; + $self->$method(@args); + } + elsif (ref($call) eq 'CODE') { + $self->$call(@args); + } + elsif (ref($call) eq 'ARRAY') { + if (ref($call->[0]) ne 'ARRAY') { + $self->_do_connection_actions($method_prefix, $_) for @$call; + } + else { + $self->_do_connection_actions($method_prefix, @$_) for @$call; + } + } + else { + $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref($call)) ); } - } else { - $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref($call)) ); } + catch { + if ( $method_prefix =~ /^connect/ ) { + # this is an on_connect cycle - we can't just throw while leaving + # a handle in an undefined state in our storage object + # kill it with fire and rethrow + $self->_dbh(undef); + $self->throw_exception( $_[0] ); + } + else { + carp "Disconnect action failed: $_[0]"; + } + }; return $self; } @@ -1667,8 +1691,8 @@ sub _gen_sql_bind { ) { carp_unique 'DateTime objects passed to search() are not supported ' . 'properly (InflateColumn::DateTime formats and settings are not ' - . 'respected.) See "Formatting DateTime objects in queries" in ' - . 'DBIx::Class::Manual::Cookbook. To disable this warning for good ' + . 'respected.) See ".. format a DateTime object for searching?" in ' + . 'DBIx::Class::Manual::FAQ. To disable this warning for good ' . 'set $ENV{DBIC_DT_SEARCH_OK} to true' } @@ -1698,7 +1722,6 @@ sub _resolve_bindattrs { }; return [ map { - my $resolved = ( ref $_ ne 'ARRAY' or @$_ != 2 ) ? [ {}, $_ ] : ( ! defined $_->[0] ) ? [ {}, $_->[1] ] : (ref $_->[0] eq 'HASH') ? [( @@ -1715,31 +1738,6 @@ sub _resolve_bindattrs { : [ $resolve_bindinfo->( { dbic_colname => $_->[0] } ), $_->[1] ] - ; - - if ( - ! exists $resolved->[0]{dbd_attrs} - and - ! $resolved->[0]{sqlt_datatype} - and - length ref $resolved->[1] - and - ! is_plain_value $resolved->[1] - ) { - require Data::Dumper; - local $Data::Dumper::Maxdepth = 1; - local $Data::Dumper::Terse = 1; - local $Data::Dumper::Useqq = 1; - local $Data::Dumper::Indent = 0; - local $Data::Dumper::Pad = ' '; - $self->throw_exception( - 'You must supply a datatype/bindtype (see DBIx::Class::ResultSet/DBIC BIND VALUES) ' - . 'for non-scalar value '. Data::Dumper::Dumper ($resolved->[1]) - ); - } - - $resolved; - } @$bind ]; } @@ -1773,31 +1771,28 @@ sub _query_end { } sub _dbi_attrs_for_bind { - my ($self, $ident, $bind) = @_; + #my ($self, $ident, $bind) = @_; - my @attrs; + return [ map { - for (map { $_->[0] } @$bind) { - push @attrs, do { - if (exists $_->{dbd_attrs}) { - $_->{dbd_attrs} - } - elsif($_->{sqlt_datatype}) { - # cache the result in the dbh_details hash, as it can not change unless - # we connect to something else - my $cache = $self->_dbh_details->{_datatype_map_cache} ||= {}; - if (not exists $cache->{$_->{sqlt_datatype}}) { - $cache->{$_->{sqlt_datatype}} = $self->bind_attribute_by_data_type($_->{sqlt_datatype}) || undef; - } - $cache->{$_->{sqlt_datatype}}; - } - else { - undef; # always push something at this position - } - } - } + exists $_->{dbd_attrs} ? $_->{dbd_attrs} + + : ! $_->{sqlt_datatype} ? undef + + : do { + + # cache the result in the dbh_details hash, as it (usually) can not change + # unless we connect to something else + # FIXME: for the time being Oracle is an exception, pending a rewrite of + # the LOB storage + my $cache = $_[0]->_dbh_details->{_datatype_map_cache} ||= {}; + + $cache->{$_->{sqlt_datatype}} = $_[0]->bind_attribute_by_data_type($_->{sqlt_datatype}) + if ! exists $cache->{$_->{sqlt_datatype}}; + + $cache->{$_->{sqlt_datatype}}; - return \@attrs; + } } map { $_->[0] } @{$_[2]} ]; } sub _execute { @@ -2220,7 +2215,7 @@ sub _insert_bulk { # scope guard my $guard = $self->txn_scope_guard; - $self->_query_start( $sql, @$proto_bind ? [[undef => '__BULK_INSERT__' ]] : () ); + $self->_query_start( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () ); my $sth = $self->_prepare_sth($self->_dbh, $sql); my $rv = do { if (@$proto_bind) { @@ -2234,7 +2229,7 @@ sub _insert_bulk { } }; - $self->_query_end( $sql, @$proto_bind ? [[ undef => '__BULK_INSERT__' ]] : () ); + $self->_query_end( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () ); $guard->commit; @@ -2584,9 +2579,9 @@ see L. sub _dbh_columns_info_for { my ($self, $dbh, $table) = @_; - if ($dbh->can('column_info')) { - my %result; - my $caught; + my %result; + + if (! DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE and $dbh->can('column_info')) { try { my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table); my $sth = $dbh->column_info( undef,$schema, $tab, '%' ); @@ -2603,39 +2598,75 @@ sub _dbh_columns_info_for { $result{$col_name} = \%column_info; } } catch { - $caught = 1; + %result = (); }; - return \%result if !$caught && scalar keys %result; + + return \%result if keys %result; } - my %result; my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0')); $sth->execute; - my @columns = @{$sth->{NAME_lc}}; - for my $i ( 0 .. $#columns ){ - my %column_info; - $column_info{data_type} = $sth->{TYPE}->[$i]; - $column_info{size} = $sth->{PRECISION}->[$i]; - $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0; - - if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) { - $column_info{data_type} = $1; - $column_info{size} = $2; + +### The acrobatics with lc names is necessary to support both the legacy +### API that used NAME_lc exclusively, *AND* at the same time work properly +### with column names differing in cas eonly (thanks pg!) + + my ($columns, $seen_lcs); + + ++$seen_lcs->{lc($_)} and $columns->{$_} = { + idx => scalar keys %$columns, + name => $_, + lc_name => lc($_), + } for @{$sth->{NAME}}; + + $seen_lcs->{$_->{lc_name}} == 1 + and + $_->{name} = $_->{lc_name} + for values %$columns; + + for ( values %$columns ) { + my $inf = { + data_type => $sth->{TYPE}->[$_->{idx}], + size => $sth->{PRECISION}->[$_->{idx}], + is_nullable => $sth->{NULLABLE}->[$_->{idx}] ? 1 : 0, + }; + + if ($inf->{data_type} =~ m/^(.*?)\((.*?)\)$/) { + @{$inf}{qw( data_type size)} = ($1, $2); } - $result{$columns[$i]} = \%column_info; + $result{$_->{name}} = $inf; } + $sth->finish; - foreach my $col (keys %result) { - my $colinfo = $result{$col}; - my $type_num = $colinfo->{data_type}; - my $type_name; - if(defined $type_num && $dbh->can('type_info')) { - my $type_info = $dbh->type_info($type_num); - $type_name = $type_info->{TYPE_NAME} if $type_info; - $colinfo->{data_type} = $type_name if $type_name; + if ($dbh->can('type_info')) { + for my $inf (values %result) { + next if ! defined $inf->{data_type}; + + $inf->{data_type} = ( + ( + ( + $dbh->type_info( $inf->{data_type} ) + || + next + ) + || + next + )->{TYPE_NAME} + || + next + ); + + # FIXME - this may be an artifact of the DBD::Pg implmentation alone + # needs more testing in the future... + $inf->{size} -= 4 if ( + ( $inf->{size}||0 > 4 ) + and + $inf->{data_type} =~ qr/^text$/i + ); } + } return \%result; @@ -2871,8 +2902,8 @@ sub create_ddl_dir { %{$sqltargs || {}} }; - unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')) { - $self->throw_exception("Can't create a ddl file without " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') ); + if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')) { + $self->throw_exception("Can't create a ddl file without $missing"); } my $sqlt = SQL::Translator->new( $sqltargs ); @@ -3028,8 +3059,8 @@ sub deployment_statements { return join('', @rows); } - unless (DBIx::Class::Optional::Dependencies->req_ok_for ('deploy') ) { - $self->throw_exception("Can't deploy without a ddl_dir or " . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') ); + if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') ) { + $self->throw_exception("Can't deploy without a pregenerated 'ddl_dir' directory or $missing"); } # sources needs to be a parser arg, but for simplicity allow at top level