X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=baa9ed66251ce5936aa9e8d17b6d97b0600aa2bb;hb=4888397f2f384216ccade72327ea1c2d31eb8885;hp=6b6f7dd55218ee9e7282d429af04c57ce146fe5a;hpb=07cda1c5a7df6656772dfd65c488c19c15126168;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 6b6f7dd..baa9ed6 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -16,6 +16,7 @@ use Data::Dumper::Concise 'Dumper'; use Sub::Name 'subname'; use Try::Tiny; use File::Path 'make_path'; +use overload (); use namespace::clean; @@ -54,7 +55,13 @@ __PACKAGE__->mk_group_accessors('simple' => @storage_options); # will get the same rdbms version). _determine_supports_X does not need to # exist on a driver, as we ->can for it before calling. -my @capabilities = (qw/insert_returning placeholders typeless_placeholders join_optimizer/); +my @capabilities = (qw/ + insert_returning + insert_returning_bound + placeholders + typeless_placeholders + join_optimizer +/); __PACKAGE__->mk_group_accessors( dbms_capability => map { "_supports_$_" } @capabilities ); __PACKAGE__->mk_group_accessors( use_dbms_capability => map { "_use_$_" } (@capabilities ) ); @@ -588,8 +595,18 @@ sub connect_info { my @args = @{ $info->{arguments} }; - $self->_dbi_connect_info([@args, - %attrs && !(ref $args[0] eq 'CODE') ? \%attrs : ()]); + if (keys %attrs and ref $args[0] ne 'CODE') { + carp + 'You provided explicit AutoCommit => 0 in your connection_info. ' + . 'This is almost universally a bad idea (see the footnotes of ' + . 'DBIx::Class::Storage::DBI for more info). If you still want to ' + . 'do this you can set $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK} to disable ' + . 'this warning.' + if ! $attrs{AutoCommit} and ! $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK}; + + push @args, \%attrs if keys %attrs; + } + $self->_dbi_connect_info(\@args); # FIXME - dirty: # save attributes them in a separate accessor so they are always @@ -659,11 +676,12 @@ sub _normalize_connect_info { return \%info; } -sub _default_dbi_connect_attributes { - return { +sub _default_dbi_connect_attributes () { + +{ AutoCommit => 1, - RaiseError => 1, PrintError => 0, + RaiseError => 1, + ShowErrorStatement => 1, }; } @@ -772,7 +790,7 @@ sub txn_do { local $self->{_in_dbh_do} = 1; my @result; - my $want_array = wantarray; + my $want = wantarray; my $tried = 0; while(1) { @@ -784,10 +802,10 @@ sub txn_do { try { $self->txn_begin; my $txn_start_depth = $self->transaction_depth; - if($want_array) { + if($want) { @result = $coderef->(@$args); } - elsif(defined $want_array) { + elsif(defined $want) { $result[0] = $coderef->(@$args); } else { @@ -806,7 +824,7 @@ sub txn_do { $exception = $_; }; - if(! defined $exception) { return $want_array ? @result : $result[0] } + if(! defined $exception) { return wantarray ? @result : $result[0] } if($self->transaction_depth > 1 || $tried++ || $self->connected) { my $rollback_exception; @@ -1250,6 +1268,27 @@ sub _connect { unless ($self->unsafe) { + $self->throw_exception( + 'Refusing clobbering of {HandleError} installed on externally supplied ' + ."DBI handle $dbh. Either remove the handler or use the 'unsafe' attribute." + ) if $dbh->{HandleError} and ref $dbh->{HandleError} ne '__DBIC__DBH__ERROR__HANDLER__'; + + # Default via _default_dbi_connect_attributes is 1, hence it was an explicit + # request, or an external handle. Complain and set anyway + unless ($dbh->{RaiseError}) { + carp( ref $info[0] eq 'CODE' + + ? "The 'RaiseError' of the externally supplied DBI handle is set to false. " + ."DBIx::Class will toggle it back to true, unless the 'unsafe' connect " + .'attribute has been supplied' + + : 'RaiseError => 0 supplied in your connection_info, without an explicit ' + .'unsafe => 1. Toggling RaiseError back to true' + ); + + $dbh->{RaiseError} = 1; + } + # this odd anonymous coderef dereference is in fact really # necessary to avoid the unwanted effect described in perl5 # RT#75792 @@ -1257,7 +1296,9 @@ sub _connect { my $weak_self = $_[0]; weaken $weak_self; - $_[1]->{HandleError} = sub { + # the coderef is blessed so we can distinguish it from externally + # supplied handles (which must be preserved) + $_[1]->{HandleError} = bless sub { if ($weak_self) { $weak_self->throw_exception("DBI Exception: $_[0]"); } @@ -1266,12 +1307,8 @@ sub _connect { # the scope of DBIC croak ("DBI Exception (unhandled by DBIC, ::Schema GCed): $_[0]"); } - }; + }, '__DBIC__DBH__ERROR__HANDLER__'; }->($self, $dbh); - - $dbh->{ShowErrorStatement} = 1; - $dbh->{RaiseError} = 1; - $dbh->{PrintError} = 0; } } catch { @@ -1413,7 +1450,10 @@ sub _dbh_begin_work { sub txn_commit { my $self = shift; - if ($self->{transaction_depth} == 1) { + if (! $self->_dbh) { + $self->throw_exception('cannot COMMIT on a disconnected handle'); + } + elsif ($self->{transaction_depth} == 1) { $self->debugobj->txn_commit() if ($self->debug); $self->_dbh_commit; @@ -1425,6 +1465,17 @@ sub txn_commit { $self->svp_release if $self->auto_savepoint; } + elsif (! $self->_dbh->FETCH('AutoCommit') ) { + + carp "Storage transaction_depth $self->{transaction_depth} does not match " + ."false AutoCommit of $self->{_dbh}, attempting COMMIT anyway"; + + $self->debugobj->txn_commit() + if ($self->debug); + $self->_dbh_commit; + $self->{transaction_depth} = 0 + if $self->_dbh_autocommit; + } else { $self->throw_exception( 'Refusing to commit without a started transaction' ); } @@ -1554,10 +1605,21 @@ sub _dbh_execute { foreach my $data (@data) { my $ref = ref $data; - $data = $ref && $ref ne 'ARRAY' ? ''.$data : $data; # stringify args (except arrayrefs) - $sth->bind_param($placeholder_index, $data, $attributes); - $placeholder_index++; + if ($ref and overload::Method($data, '""') ) { + $data = "$data"; + } + elsif ($ref eq 'SCALAR') { # any scalarrefs are assumed to be bind_inouts + $sth->bind_param_inout( + $placeholder_index++, + $data, + $self->_max_column_bytesize($ident, $column_name), + $attributes + ); + next; + } + + $sth->bind_param($placeholder_index++, $data, $attributes); } } @@ -1616,19 +1678,19 @@ sub insert { # list of primary keys we try to fetch from the database # both not-exsists and scalarrefs are considered my %fetch_pks; - %fetch_pks = ( map - { $_ => scalar keys %fetch_pks } # so we can preserve order for prettyness - grep - { ! exists $to_insert->{$_} or ref $to_insert->{$_} eq 'SCALAR' } - $source->primary_columns - ); + for ($source->primary_columns) { + $fetch_pks{$_} = scalar keys %fetch_pks # so we can preserve order for prettyness + if ! exists $to_insert->{$_} or ref $to_insert->{$_} eq 'SCALAR'; + } - my $sqla_opts; + my ($sqla_opts, @ir_container); if ($self->_use_insert_returning) { # retain order as declared in the resultsource for (sort { $fetch_pks{$a} <=> $fetch_pks{$b} } keys %fetch_pks ) { push @{$sqla_opts->{returning}}, $_; + $sqla_opts->{returning_container} = \@ir_container + if $self->_use_insert_returning_bound; } } @@ -1639,14 +1701,14 @@ sub insert { my %returned_cols; if (my $retlist = $sqla_opts->{returning}) { - my @ret_vals = try { + @ir_container = try { local $SIG{__WARN__} = sub {}; my @r = $sth->fetchrow_array; $sth->finish; @r; - }; + } unless @ir_container; - @returned_cols{@$retlist} = @ret_vals if @ret_vals; + @returned_cols{@$retlist} = @ir_container if @ir_container; } return { %$prefetched_values, %returned_cols }; @@ -1797,6 +1859,14 @@ sub _execute_array { $err = shift; }; + # Not all DBDs are create equal. Some throw on error, some return + # an undef $rv, and some set $sth->err - try whatever we can + $err = ($sth->errstr || 'UNKNOWN ERROR ($sth->errstr is unset)') if ( + ! defined $err + and + ( !defined $rv or $sth->err ) + ); + # Statement must finish even if there was an exception. try { $sth->finish @@ -1805,9 +1875,6 @@ sub _execute_array { $err = shift unless defined $err }; - $err = $sth->errstr - if (! defined $err and $sth->err); - if (defined $err) { my $i = 0; ++$i while $i <= $#$tuple_status && !ref $tuple_status->[$i]; @@ -2007,7 +2074,7 @@ sub _select_args { from => $ident, where => $where, $rs_alias && $alias2source->{$rs_alias} - ? ( _rsroot_source_handle => $alias2source->{$rs_alias}->handle ) + ? ( _rsroot_rsrc => $alias2source->{$rs_alias} ) : () , }; @@ -2069,9 +2136,7 @@ sub _select_args { && @{$attrs->{group_by}} && - $attrs->{_prefetch_select} - && - @{$attrs->{_prefetch_select}} + $attrs->{_prefetch_selector_range} ) ) { ($ident, $select, $where, $attrs) @@ -2641,8 +2706,7 @@ sub deployment_statements { ); my @ret; - my $wa = wantarray; - if ($wa) { + if (wantarray) { @ret = $tr->translate; } else { @@ -2652,7 +2716,7 @@ sub deployment_statements { $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error) unless (@ret && defined $ret[0]); - return $wa ? @ret : $ret[0]; + return wantarray ? @ret : $ret[0]; } sub deploy { @@ -2777,6 +2841,55 @@ sub relname_to_table_alias { return $alias; } +# The size in bytes to use for DBI's ->bind_param_inout, this is the generic +# version and it may be necessary to amend or override it for a specific storage +# if such binds are necessary. +sub _max_column_bytesize { + my ($self, $source, $col) = @_; + + my $inf = $source->column_info($col); + return $inf->{_max_bytesize} ||= do { + + my $max_size; + + if (my $data_type = $inf->{data_type}) { + $data_type = lc($data_type); + + # String/sized-binary types + if ($data_type =~ /^(?:l?(?:var)?char(?:acter)?(?:\s*varying)? + |(?:var)?binary(?:\s*varying)?|raw)\b/x + ) { + $max_size = $inf->{size}; + } + # Other charset/unicode types, assume scale of 4 + elsif ($data_type =~ /^(?:national\s*character(?:\s*varying)?|nchar + |univarchar + |nvarchar)\b/x + ) { + $max_size = $inf->{size} * 4 if $inf->{size}; + } + # Blob types + elsif ($self->_is_lob_type($data_type)) { + # default to longreadlen + } + else { + $max_size = 100; # for all other (numeric?) datatypes + } + } + + $max_size ||= $self->_get_dbh->{LongReadLen} || 8000; + }; +} + +# Determine if a data_type is some type of BLOB +sub _is_lob_type { + my ($self, $data_type) = @_; + $data_type && ($data_type =~ /(?:lob|bfile|text|image|bytea|memo)/i + || $data_type =~ /^long(?:\s*(?:raw|bit\s*varying|varbit|binary + |varchar|character\s*varying|nvarchar + |national\s*character\s*varying))?$/xi); +} + 1; =head1 USAGE NOTES