use DBIx::Class::Storage::DBI::Cursor;
use Scalar::Util qw/refaddr weaken reftype blessed/;
use List::Util qw/first/;
-use Data::Dumper::Concise 'Dumper';
use Sub::Name 'subname';
use Try::Tiny;
-use File::Path 'make_path';
+use overload ();
use namespace::clean;
# default cursor class, overridable in connect_info attributes
__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
-__PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class sql_limit_dialect/);
+__PACKAGE__->mk_group_accessors('inherited' => qw/
+ sql_maker_class sql_limit_dialect sql_quote_char sql_name_sep
+/);
+
+__PACKAGE__->sql_name_sep('.');
+
__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker');
__PACKAGE__->mk_group_accessors('simple' => qw/
# 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 ) );
# some databases spew warnings on implicit disconnect
local $SIG{__WARN__} = sub {};
$self->_dbh(undef);
+
+ # this op is necessary, since the very last perl runtime statement
+ # triggers a global destruction shootout, and the $SIG localization
+ # may very well be destroyed before perl actually gets to do the
+ # $dbh undef
+ 1;
}
# handle pid changes correctly - do not destroy parent's connection
default L</sql_limit_dialect> setting of the storage (if any). For a list
of available limit dialects see L<DBIx::Class::SQLMaker::LimitDialects>.
+=item quote_names
+
+When true automatically sets L</quote_char> and L</name_sep> to the characters
+appropriate for your particular RDBMS. This option is preferred over specifying
+L</quote_char> directly.
+
=item quote_char
Specifies what characters to use to quote table and column names.
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
delete @attrs{@storage_opts} if @storage_opts;
my @sql_maker_opts = grep exists $attrs{$_},
- qw/limit_dialect quote_char name_sep/;
+ qw/limit_dialect quote_char name_sep quote_names/;
@{ $info{sql_maker_options} }{@sql_maker_opts} =
delete @attrs{@sql_maker_opts} if @sql_maker_opts;
return \%info;
}
-sub _default_dbi_connect_attributes {
- return {
+sub _default_dbi_connect_attributes () {
+ +{
AutoCommit => 1,
- RaiseError => 1,
PrintError => 0,
+ RaiseError => 1,
+ ShowErrorStatement => 1,
};
}
local $self->{_in_dbh_do} = 1;
my @result;
- my $want_array = wantarray;
+ my $want = wantarray;
my $tried = 0;
while(1) {
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 {
$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;
"Your storage class ($s_class) does not set sql_limit_dialect and you "
. 'have not supplied an explicit limit_dialect in your connection_info. '
. 'DBIC will attempt to use the GenericSubQ dialect, which works on most '
- . 'databases but can be (and often is) painfully slow.'
+ . 'databases but can be (and often is) painfully slow. '
+ . "Please file an RT ticket against '$s_class' ."
);
'GenericSubQ';
}
;
+ my ($quote_char, $name_sep);
+
+ if ($opts{quote_names}) {
+ $quote_char = (delete $opts{quote_char}) || $self->sql_quote_char || do {
+ my $s_class = (ref $self) || $self;
+ carp (
+ "You requested 'quote_names' but your storage class ($s_class) does "
+ . 'not explicitly define a default sql_quote_char and you have not '
+ . 'supplied a quote_char as part of your connection_info. DBIC will '
+ .q{default to the ANSI SQL standard quote '"', which works most of }
+ . "the time. Please file an RT ticket against '$s_class'."
+ );
+
+ '"'; # RV
+ };
+
+ $name_sep = (delete $opts{name_sep}) || $self->sql_name_sep;
+ }
+
$self->_sql_maker($sql_maker_class->new(
bindtype=>'columns',
array_datatypes => 1,
limit_dialect => $dialect,
- name_sep => '.',
+ ($quote_char ? (quote_char => $quote_char) : ()),
+ name_sep => ($name_sep || '.'),
%opts,
));
}
}
sub _get_server_version {
- shift->_get_dbh->get_info(18);
+ shift->_dbh_get_info(18);
+}
+
+sub _dbh_get_info {
+ my ($self, $info) = @_;
+
+ return try { $self->_get_dbh->get_info($info) } || undef;
}
sub _determine_driver {
$self->_driver_determined(1);
+ Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
+
$self->_init; # run driver-specific initializations
$self->_run_connection_actions
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
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]");
}
# 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 {
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;
$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' );
}
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);
}
}
$self->dbh_do('_dbh_execute', @_); # retry over disconnects
}
-sub insert {
+sub _prefetch_autovalues {
my ($self, $source, $to_insert) = @_;
my $colinfo = $source->columns_info;
- # mix with auto-nextval marked values (a bit of a speed hit, but
- # no saner way to handle this yet)
- my $auto_nextvals = {} ;
+ my %values;
for my $col (keys %$colinfo) {
if (
$colinfo->{$col}{auto_nextval}
ref $to_insert->{$col} eq 'SCALAR'
)
) {
- $auto_nextvals->{$col} = $self->_sequence_fetch(
- 'nextval',
+ $values{$col} = $self->_sequence_fetch(
+ 'NEXTVAL',
( $colinfo->{$col}{sequence} ||=
$self->_dbh_get_autoinc_seq($self->_get_dbh, $source, $col)
),
}
}
+ \%values;
+}
+
+sub insert {
+ my ($self, $source, $to_insert) = @_;
+
+ my $prefetched_values = $self->_prefetch_autovalues($source, $to_insert);
+
# fuse the values
- $to_insert = { %$to_insert, %$auto_nextvals };
+ $to_insert = { %$to_insert, %$prefetched_values };
# 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;
}
}
my ($rv, $sth) = $self->_execute('insert' => [], $source, $bind_attributes, $to_insert, $sqla_opts);
- my %returned_cols = %$auto_nextvals;
+ 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 \%returned_cols;
+ return { %$prefetched_values, %returned_cols };
}
$msg,
$cols->[$col_idx],
do {
+ require Data::Dumper::Concise;
local $Data::Dumper::Maxdepth = 1; # don't dump objects, if any
- Dumper {
+ Data::Dumper::Concise::Dumper ({
map { $cols->[$_] => $data->[$slice_idx][$_] } (0 .. $#$cols)
- },
+ }),
}
);
};
$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
$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];
$self->throw_exception("Unexpected populate error: $err")
if ($i > $#$tuple_status);
+ require Data::Dumper::Concise;
$self->throw_exception(sprintf "%s for populate slice:\n%s",
($tuple_status->[$i][1] || $err),
- Dumper { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) },
+ Data::Dumper::Concise::Dumper( { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) } ),
);
}
from => $ident,
where => $where,
$rs_alias && $alias2source->{$rs_alias}
- ? ( _rsroot_source_handle => $alias2source->{$rs_alias}->handle )
+ ? ( _rsroot_rsrc => $alias2source->{$rs_alias} )
: ()
,
};
&&
@{$attrs->{group_by}}
&&
- $attrs->{_prefetch_select}
- &&
- @{$attrs->{_prefetch_select}}
+ $attrs->{_prefetch_selector_range}
)
) {
($ident, $select, $where, $attrs)
# XXX You would think RaiseError would make this impossible,
# but apparently that's not true :(
- $self->throw_exception($dbh->errstr) if !$sth;
+ $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;
}
} else {
-d $dir
or
- make_path ("$dir") # make_path does not like objects (i.e. Path::Class::Dir)
+ (require File::Path and File::Path::make_path ("$dir")) # make_path does not like objects (i.e. Path::Class::Dir)
or
$self->throw_exception(
- "Failed to create '$dir': " . ($! || $@ || 'error unknow')
+ "Failed to create '$dir': " . ($! || $@ || 'error unknown')
);
}
my $filename = $schema->ddl_filename($type, $version, $dir);
if(-f $filename)
{
+ # FIXME replace this block when a proper sane sql parser is available
my $file;
open($file, "<$filename")
or $self->throw_exception("Can't open $filename ($!)");
);
my @ret;
- my $wa = wantarray;
- if ($wa) {
+ if (wantarray) {
@ret = $tr->translate;
}
else {
$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];
}
+# FIXME deploy() currently does not accurately report sql errors
+# Will always return true while errors are warned
sub deploy {
my ($self, $schema, $type, $sqltargs, $dir) = @_;
my $deploy = sub {
my $line = shift;
- return if($line =~ /^--/);
return if(!$line);
+ return if($line =~ /^--/);
# next if($line =~ /^DROP/m);
return if($line =~ /^BEGIN TRANSACTION/m);
return if($line =~ /^COMMIT/m);
}
}
elsif (@statements == 1) {
- foreach my $line ( split(";\n", $statements[0])) {
+ # split on single line comments and end of statements
+ foreach my $line ( split(/\s*--.*\n|;\n/, $statements[0])) {
$deploy->( $line );
}
}
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
+# FIXME: these regexes are expensive, result of these checks should be cached in
+# the column_info .
+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))?\z/xi);
+}
+
+sub _is_binary_lob_type {
+ my ($self, $data_type) = @_;
+ $data_type && ($data_type =~ /blob|bfile|image|bytea/i
+ || $data_type =~ /^long(?:\s+(?:raw|bit\s*varying|varbit|binary))?\z/xi);
+}
+
+sub _is_text_lob_type {
+ my ($self, $data_type) = @_;
+ $data_type && ($data_type =~ /^(?:clob|memo)\z/i
+ || $data_type =~ /^long(?:\s+(?:varchar|character\s*varying|nvarchar
+ |national\s*character\s*varying))\z/xi);
+}
+
1;
=head1 USAGE NOTES
projects / dbsrgits/DBIx-Class.git / blobdiff