X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=f4159a2a62143cfb82eef742a5b078a23237bf71;hb=d63c9e64;hp=b55672851946e8423d27232af6e97f2998843824;hpb=e01fd1cb593cf66ee6016ad6de89706f02d56ffe;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index b556728..f4159a2 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -12,9 +12,8 @@ use Scalar::Util qw/refaddr weaken reftype blessed/; use List::Util qw/first/; use Context::Preserve 'preserve_context'; use Try::Tiny; -use Data::Compare (); # no imports!!! guard against insane architecture use SQL::Abstract qw(is_plain_value is_literal_value); -use DBIx::Class::_Util qw(quote_sub perlstring); +use DBIx::Class::_Util qw(quote_sub perlstring serialize detected_reinvoked_destructor); use namespace::clean; # default cursor class, overridable in connect_info attributes @@ -254,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 {}; @@ -1038,8 +1039,11 @@ sub _init {} sub _populate_dbh { $_[0]->_dbh(undef); # in case ->connected failed we might get sent here + $_[0]->_dbh_details({}); # reset everything we know - $_[0]->_sql_maker(undef); # this may also end up being different + + # FIXME - this needs reenabling with the proper "no reset on same DSN" check + #$_[0]->_sql_maker(undef); # this may also end up being different $_[0]->_dbh($_[0]->_connect); @@ -1399,7 +1403,19 @@ sub disconnect_call_do_sql { $self->_do_query(@_); } -# override in db-specific backend when necessary +=head2 connect_call_datetime_setup + +A no-op stub method, provided so that one can always safely supply the +L + + on_connect_call => 'datetime_setup' + +This way one does not need to know in advance whether the underlying +storage requires any sort of hand-holding when dealing with calendar +data. + +=cut + sub connect_call_datetime_setup { 1 } sub _do_query { @@ -1550,9 +1566,8 @@ sub _exec_txn_begin { sub txn_commit { my $self = shift; - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $self->throw_exception("Unable to txn_commit() on a disconnected storage") - unless $self->_dbh; + unless $self->_seems_connected; # esoteric case for folks using external $dbh handles if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) { @@ -1581,9 +1596,8 @@ sub _exec_txn_commit { sub txn_rollback { my $self = shift; - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $self->throw_exception("Unable to txn_rollback() on a disconnected storage") - unless $self->_dbh; + unless $self->_seems_connected; # esoteric case for folks using external $dbh handles if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) { @@ -1611,9 +1625,8 @@ sub _exec_txn_rollback { # generate the DBI-specific stubs, which then fallback to ::Storage proper quote_sub __PACKAGE__ . "::$_" => sprintf (<<'EOS', $_) for qw(svp_begin svp_release svp_rollback); - $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; $_[0]->throw_exception('Unable to %s() on a disconnected storage') - unless $_[0]->_dbh; + unless $_[0]->_seems_connected; shift->next::method(@_); EOS @@ -1762,31 +1775,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} ||= {}; - return \@attrs; + $cache->{$_->{sqlt_datatype}} = $_[0]->bind_attribute_by_data_type($_->{sqlt_datatype}) + if ! exists $cache->{$_->{sqlt_datatype}}; + + $cache->{$_->{sqlt_datatype}}; + + } } map { $_->[0] } @{$_[2]} ]; } sub _execute { @@ -2058,7 +2068,7 @@ sub _insert_bulk { # can't just hand SQLA a set of some known "values" (e.g. hashrefs that # can be later matched up by address), because we want to supply a real # value on which perhaps e.g. datatype checks will be performed - my ($proto_data, $value_type_by_col_idx); + my ($proto_data, $serialized_bind_type_by_col_idx); for my $col_idx (0..$#$cols) { my $colname = $cols->[$col_idx]; if (ref $data->[0][$col_idx] eq 'SCALAR') { @@ -2077,7 +2087,7 @@ sub _insert_bulk { # store value-less (attrs only) bind info - we will be comparing all # supplied binds against this for sanity - $value_type_by_col_idx->{$col_idx} = [ map { $_->[0] } @$resolved_bind ]; + $serialized_bind_type_by_col_idx->{$col_idx} = serialize [ map { $_->[0] } @$resolved_bind ]; $proto_data->{$colname} = \[ $sql, map { [ # inject slice order to use for $proto_bind construction @@ -2088,7 +2098,7 @@ sub _insert_bulk { ]; } else { - $value_type_by_col_idx->{$col_idx} = undef; + $serialized_bind_type_by_col_idx->{$col_idx} = undef; $proto_data->{$colname} = \[ '?', [ { dbic_colname => $colname, _bind_data_slice_idx => $col_idx } @@ -2104,7 +2114,7 @@ sub _insert_bulk { [ $proto_data ], ); - if (! @$proto_bind and keys %$value_type_by_col_idx) { + if (! @$proto_bind and keys %$serialized_bind_type_by_col_idx) { # if the bindlist is empty and we had some dynamic binds, this means the # storage ate them away (e.g. the NoBindVars component) and interpolated # them directly into the SQL. This obviously can't be good for multi-inserts @@ -2138,7 +2148,7 @@ sub _insert_bulk { for my $row_idx (1..$#$data) { # we are comparing against what we got from [0] above, hence start from 1 my $val = $data->[$row_idx][$col_idx]; - if (! exists $value_type_by_col_idx->{$col_idx}) { # literal no binds + if (! exists $serialized_bind_type_by_col_idx->{$col_idx}) { # literal no binds if (ref $val ne 'SCALAR') { $bad_slice_report_cref->( "Incorrect value (expecting SCALAR-ref \\'$$reference_val')", @@ -2154,7 +2164,7 @@ sub _insert_bulk { ); } } - elsif (! defined $value_type_by_col_idx->{$col_idx} ) { # regular non-literal value + elsif (! defined $serialized_bind_type_by_col_idx->{$col_idx} ) { # regular non-literal value if (is_literal_value($val)) { $bad_slice_report_cref->("Literal SQL found where a plain bind value is expected", $row_idx, $col_idx); } @@ -2182,16 +2192,17 @@ sub _insert_bulk { } # need to check the bind attrs - a bind will happen only once for # the entire dataset, so any changes further down will be ignored. - elsif (! Data::Compare::Compare( - $value_type_by_col_idx->{$col_idx}, - [ + elsif ( + $serialized_bind_type_by_col_idx->{$col_idx} + ne + serialize [ map { $_->[0] } @{$self->_resolve_bindattrs( $source, [ @{$$val}[1 .. $#$$val] ], $colinfos, )} - ], - )) { + ] + ) { $bad_slice_report_cref->( 'Differing bind attributes on literal/bind values not supported', $row_idx, @@ -2572,9 +2583,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, '%' ); @@ -2591,39 +2602,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; @@ -2859,8 +2906,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 ); @@ -2982,7 +3029,8 @@ sub create_ddl_dir { =back -Returns the statements used by L and L. +Returns the statements used by L +and L. The L (not L) database driver name can be explicitly provided in C<$type>, otherwise the result of L is used as default. @@ -3015,8 +3063,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 @@ -3259,13 +3307,13 @@ transactions. You're on your own for handling all sorts of exceptional cases if you choose the C<< AutoCommit => 0 >> path, just as you would be with raw DBI. +=head1 FURTHER QUESTIONS? -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. - -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L.