X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=9a136fefe46e2dc63ee2035ada10ed919eef188a;hb=75a1d824dae50a309db204be15ef46aa52b1deb5;hp=533258239d71c1b26efd881ed8fdaac7b8b80e38;hpb=fb13a49f17a0e0a49638080a4bd826fb3702aebe;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 5332582..9a136fe 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -8,7 +8,6 @@ use base qw/DBIx::Class::Storage::DBIHacks DBIx::Class::Storage/; use mro 'c3'; use DBIx::Class::Carp; -use DBIx::Class::Exception; use Scalar::Util qw/refaddr weaken reftype blessed/; use List::Util qw/first/; use Sub::Name 'subname'; @@ -87,7 +86,6 @@ sub _determine_supports_join_optimizer { 1 }; # class, as _use_X may be hardcoded class-wide, and _supports_X calls # _determine_supports_X which obv. needs a correct driver as well my @rdbms_specific_methods = qw/ - deployment_statements sqlt_type sql_maker build_datetime_parser @@ -795,7 +793,10 @@ sub dbh_do { return $self->$run_target($self->_get_dbh, @_) if $self->{_in_do_block} or $self->transaction_depth; - my $args = \@_; + # take a ref instead of a copy, to preserve @_ aliasing + # semantics within the coderef, but only if needed + # (pseudoforking doesn't like this trick much) + my $args = @_ ? \@_ : []; DBIx::Class::Storage::BlockRunner->new( storage => $self, @@ -1180,7 +1181,9 @@ sub _describe_connection { SQL_TXN_ISOLATION_OPTION / ) { - my $v = $self->_dbh_get_info($inf); + # some drivers barf on things they do not know about instead + # of returning undef + my $v = try { $self->_dbh_get_info($inf) }; next unless defined $v; #my $key = sprintf( '%s(%s)', $inf, $DBI::Const::GetInfoType::GetInfoType{$inf} ); @@ -1247,6 +1250,15 @@ sub _determine_driver { Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO; + if ($self->can('source_bind_attributes')) { + $self->throw_exception( + "Your storage subclass @{[ ref $self ]} provides (or inherits) the method " + . 'source_bind_attributes() for which support has been removed as of Jan 2013. ' + . 'If you are not sure how to proceed please contact the development team via ' + . 'http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT' + ); + } + $self->_init; # run driver-specific initializations $self->_run_connection_actions @@ -1378,10 +1390,17 @@ sub _connect { $dbh = DBI->connect(@info); } - if (!$dbh) { - die $DBI::errstr; - } + die $DBI::errstr unless $dbh; + + die sprintf ("%s fresh DBI handle with a *false* 'Active' attribute. " + . 'This handle is disconnected as far as DBIC is concerned, and we can ' + . 'not continue', + ref $info[0] eq 'CODE' + ? "Connection coderef $info[0] returned a" + : 'DBI->connect($schema->storage->connect_info) resulted in a' + ) unless $dbh->FETCH('Active'); + # sanity checks unless asked otherwise unless ($self->unsafe) { $self->throw_exception( @@ -1551,10 +1570,13 @@ sub _prep_for_execute { sub _gen_sql_bind { my ($self, $op, $ident, $args) = @_; - my ($sql, @bind) = $self->sql_maker->$op( - blessed($ident) ? $ident->from : $ident, - @$args, - ); + my ($colinfos, $from); + if ( blessed($ident) ) { + $from = $ident->from; + $colinfos = $ident->columns_info; + } + + my ($sql, @bind) = $self->sql_maker->$op( ($from || $ident), @$args ); if ( ! $ENV{DBIC_DT_SEARCH_OK} @@ -1571,7 +1593,7 @@ sub _gen_sql_bind { } return( $sql, $self->_resolve_bindattrs( - $ident, [ @{$args->[2]{bind}||[]}, @bind ] + $ident, [ @{$args->[2]{bind}||[]}, @bind ], $colinfos )); } @@ -1651,30 +1673,9 @@ sub _query_end { if $self->debug; } -my $sba_compat; sub _dbi_attrs_for_bind { my ($self, $ident, $bind) = @_; - if (! defined $sba_compat) { - $self->_determine_driver; - $sba_compat = $self->can('source_bind_attributes') == \&source_bind_attributes - ? 0 - : 1 - ; - } - - my $sba_attrs; - if ($sba_compat) { - my $class = ref $self; - carp_unique ( - "The source_bind_attributes() override in $class relies on a deprecated codepath. " - .'You are strongly advised to switch your code to override bind_attribute_by_datatype() ' - .'instead. This legacy compat shim will also disappear some time before DBIC 0.09' - ); - - my $sba_attrs = $self->source_bind_attributes - } - my @attrs; for (map { $_->[0] } @$bind) { @@ -1691,9 +1692,6 @@ sub _dbi_attrs_for_bind { } $cache->{$_->{sqlt_datatype}}; } - elsif ($sba_attrs and $_->{dbic_colname}) { - $sba_attrs->{$_->{dbic_colname}} || undef; - } else { undef; # always push something at this position } @@ -1708,19 +1706,63 @@ sub _execute { my ($sql, $bind) = $self->_prep_for_execute($op, $ident, \@args); - shift->dbh_do( # retry over disconnects - '_dbh_execute', + shift->dbh_do( _dbh_execute => # retry over disconnects $sql, $bind, - $self->_dbi_attrs_for_bind($ident, $bind) + $self->_dbi_attrs_for_bind($ident, $bind), ); } sub _dbh_execute { - my ($self, undef, $sql, $bind, $bind_attrs) = @_; + my ($self, $dbh, $sql, $bind, $bind_attrs) = @_; $self->_query_start( $sql, $bind ); - my $sth = $self->_sth($sql); + + my $sth = $self->_bind_sth_params( + $self->_prepare_sth($dbh, $sql), + $bind, + $bind_attrs, + ); + + # Can this fail without throwing an exception anyways??? + my $rv = $sth->execute(); + $self->throw_exception( + $sth->errstr || $sth->err || 'Unknown error: execute() returned false, but error flags were not set...' + ) if !$rv; + + $self->_query_end( $sql, $bind ); + + return (wantarray ? ($rv, $sth, @$bind) : $rv); +} + +sub _prepare_sth { + my ($self, $dbh, $sql) = @_; + + # 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); + + # XXX You would think RaiseError would make this impossible, + # but apparently that's not true :( + $self->throw_exception( + $dbh->errstr + || + sprintf( "\$dbh->prepare() of '%s' through %s failed *silently* without " + .'an exception and/or setting $dbh->errstr', + length ($sql) > 20 + ? substr($sql, 0, 20) . '...' + : $sql + , + 'DBD::' . $dbh->{Driver}{Name}, + ) + ) if !$sth; + + $sth; +} + +sub _bind_sth_params { + my ($self, $sth, $bind, $bind_attrs) = @_; for my $i (0 .. $#$bind) { if (ref $bind->[$i][1] eq 'SCALAR') { # any scalarrefs are assumed to be bind_inouts @@ -1732,32 +1774,25 @@ sub _dbh_execute { ); } else { + # FIXME SUBOPTIMAL - most likely this is not necessary at all + # confirm with dbi-dev whether explicit stringification is needed + my $v = ( length ref $bind->[$i][1] and overload::Method($bind->[$i][1], '""') ) + ? "$bind->[$i][1]" + : $bind->[$i][1] + ; $sth->bind_param( $i + 1, - (ref $bind->[$i][1] and overload::Method($bind->[$i][1], '""')) - ? "$bind->[$i][1]" - : $bind->[$i][1] - , + $v, $bind_attrs->[$i], ); } } - # Can this fail without throwing an exception anyways??? - my $rv = $sth->execute(); - $self->throw_exception( - $sth->errstr || $sth->err || 'Unknown error: execute() returned false, but error flags were not set...' - ) if !$rv; - - $self->_query_end( $sql, $bind ); - - return (wantarray ? ($rv, $sth, @$bind) : $rv); + $sth; } sub _prefetch_autovalues { - my ($self, $source, $to_insert) = @_; - - my $colinfo = $source->columns_info; + my ($self, $source, $colinfo, $to_insert) = @_; my %values; for my $col (keys %$colinfo) { @@ -1787,7 +1822,9 @@ sub _prefetch_autovalues { sub insert { my ($self, $source, $to_insert) = @_; - my $prefetched_values = $self->_prefetch_autovalues($source, $to_insert); + my $col_infos = $source->columns_info; + + my $prefetched_values = $self->_prefetch_autovalues($source, $col_infos, $to_insert); # fuse the values, but keep a separate list of prefetched_values so that # they can be fused once again with the final return @@ -1795,7 +1832,6 @@ sub insert { # FIXME - we seem to assume undef values as non-supplied. This is wrong. # Investigate what does it take to s/defined/exists/ - my $col_infos = $source->columns_info; my %pcols = map { $_ => 1 } $source->primary_columns; my (%retrieve_cols, $autoinc_supplied, $retrieve_autoinc_col); for my $col ($source->columns) { @@ -1889,14 +1925,15 @@ sub insert_bulk { my @col_range = (0..$#$cols); - # FIXME - perhaps this is not even needed? does DBI stringify? + # FIXME SUBOPTIMAL - most likely this is not necessary at all + # confirm with dbi-dev whether explicit stringification is needed # # forcibly stringify whatever is stringifiable # ResultSet::populate() hands us a copy - safe to mangle for my $r (0 .. $#$data) { for my $c (0 .. $#{$data->[$r]}) { $data->[$r][$c] = "$data->[$r][$c]" - if ( ref $data->[$r][$c] and overload::Method($data->[$r][$c], '""') ); + if ( length ref $data->[$r][$c] and overload::Method($data->[$r][$c], '""') ); } } @@ -1929,7 +1966,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_idx); + my ($proto_data, $value_type_by_col_idx); for my $i (@col_range) { my $colname = $cols->[$i]; if (ref $data->[0][$i] eq 'SCALAR') { @@ -1948,18 +1985,18 @@ sub insert_bulk { # store value-less (attrs only) bind info - we will be comparing all # supplied binds against this for sanity - $value_type_idx->{$i} = [ map { $_->[0] } @$resolved_bind ]; + $value_type_by_col_idx->{$i} = [ map { $_->[0] } @$resolved_bind ]; $proto_data->{$colname} = \[ $sql, map { [ # inject slice order to use for $proto_bind construction - { %{$resolved_bind->[$_][0]}, _bind_data_slice_idx => $i } + { %{$resolved_bind->[$_][0]}, _bind_data_slice_idx => $i, _literal_bind_subindex => $_+1 } => $resolved_bind->[$_][1] ] } (0 .. $#bind) ]; } else { - $value_type_idx->{$i} = 0; + $value_type_by_col_idx->{$i} = undef; $proto_data->{$colname} = \[ '?', [ { dbic_colname => $colname, _bind_data_slice_idx => $i } @@ -1975,7 +2012,7 @@ sub insert_bulk { [ $proto_data ], ); - if (! @$proto_bind and keys %$value_type_idx) { + if (! @$proto_bind and keys %$value_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 @@ -2009,7 +2046,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_idx->{$col_idx}) { # literal no binds + if (! exists $value_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')", @@ -2025,7 +2062,7 @@ sub insert_bulk { ); } } - elsif (! $value_type_idx->{$col_idx} ) { # regular non-literal value + elsif (! defined $value_type_by_col_idx->{$col_idx} ) { # regular non-literal value if (ref $val eq 'SCALAR' or (ref $val eq 'REF' and ref $$val eq 'ARRAY') ) { $bad_slice_report_cref->("Literal SQL found where a plain bind value is expected", $row_idx, $col_idx); } @@ -2054,7 +2091,7 @@ 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_idx->{$col_idx}, + $value_type_by_col_idx->{$col_idx}, [ map { $_->[0] } @@ -2080,7 +2117,7 @@ sub insert_bulk { my $guard = $self->txn_scope_guard; $self->_query_start( $sql, @$proto_bind ? [[undef => '__BULK_INSERT__' ]] : () ); - my $sth = $self->_sth($sql); + my $sth = $self->_prepare_sth($self->_dbh, $sql); my $rv = do { if (@$proto_bind) { # proto bind contains the information on which pieces of $data to pull @@ -2131,23 +2168,17 @@ sub _dbh_execute_for_fetch { # alphabetical ordering by colname). We actually do want to # preserve this behavior so that prepare_cached has a better # chance of matching on unrelated calls - my %data_reorder = map { $proto_bind->[$_][0]{_bind_data_slice_idx} => $_ } @idx_range; my $fetch_row_idx = -1; # saner loop this way my $fetch_tuple = sub { return undef if ++$fetch_row_idx > $#$data; - return [ map - { (ref $_ eq 'REF' and ref $$_ eq 'ARRAY') - ? map { $_->[-1] } @{$$_}[1 .. $#$$_] - : $_ - } - map - { $data->[$fetch_row_idx][$_]} - sort - { $data_reorder{$a} <=> $data_reorder{$b} } - keys %data_reorder - ]; + return [ map { defined $_->{_literal_bind_subindex} + ? ${ $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]} + ->[ $_->{_literal_bind_subindex} ] + ->[1] + : $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ] + } map { $_->[0] } @$proto_bind]; }; my $tuple_status = []; @@ -2252,13 +2283,11 @@ sub _select_args_to_query { $self->_select_args(@_); # my ($sql, $prepared_bind) = $self->_gen_sql_bind($op, $ident, [ $select, $cond, $rs_attrs, $rows, $offset ]); - my ($sql, $prepared_bind) = $self->_gen_sql_bind($op, $ident, \@args); - $prepared_bind ||= []; + my ($sql, $bind) = $self->_gen_sql_bind($op, $ident, \@args); - return wantarray - ? ($sql, $prepared_bind) - : \[ "($sql)", @$prepared_bind ] - ; + # reuse the bind arrayref + unshift @{$bind}, "($sql)"; + \$bind; } sub _select_args { @@ -2353,15 +2382,6 @@ sub _count_select { return { count => '*' }; } -sub source_bind_attributes { - shift->throw_exception( - 'source_bind_attributes() was never meant to be a callable public method - ' - .'please contact the DBIC dev-team and describe your use case so that a reasonable ' - .'solution can be provided' - ."\nhttp://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT" - ); -} - =head2 select =over 4 @@ -2402,42 +2422,6 @@ see L. =cut -sub _dbh_sth { - my ($self, $dbh, $sql) = @_; - - # 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); - - # XXX You would think RaiseError would make this impossible, - # but apparently that's not true :( - $self->throw_exception( - $dbh->errstr - || - sprintf( "\$dbh->prepare() of '%s' through %s failed *silently* without " - .'an exception and/or setting $dbh->errstr', - length ($sql) > 20 - ? substr($sql, 0, 20) . '...' - : $sql - , - 'DBD::' . $dbh->{Driver}{Name}, - ) - ) if !$sth; - - $sth; -} - -sub sth { - carp_unique 'sth was mistakenly marked/documented as public, stop calling it (will be removed before DBIC v0.09)'; - shift->_sth(@_); -} - -sub _sth { - my ($self, $sql) = @_; - $self->dbh_do('_dbh_sth', $sql); # retry over disconnects -} - sub _dbh_columns_info_for { my ($self, $dbh, $table) = @_; @@ -2608,7 +2592,10 @@ Given a datatype from column info, returns a database specific bind attribute for C<< $dbh->bind_param($val,$attribute) >> or nothing if we will let the database planner just handle it. -Generally only needed for special case column types, like bytea in postgres. +This method is always called after the driver has been determined and a DBI +connection has been established. Therefore you can refer to C +and/or C directly, without worrying about loading +the correct modules. =cut