use List::Util();
use Data::Dumper::Concise();
use Sub::Name ();
+use Try::Tiny;
+use File::Path ();
+use namespace::clean;
-# what version of sqlt do we require if deploy() without a ddl_dir is invoked
-# when changing also adjust the corresponding author_require in Makefile.PL
-my $minimum_sqlt_version = '0.11002';
-
-
-__PACKAGE__->mk_group_accessors('simple' =>
- qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid
- _conn_tid transaction_depth _dbh_autocommit _driver_determined savepoints/
-);
+__PACKAGE__->mk_group_accessors('simple' => qw/
+ _connect_info _dbi_connect_info _dbic_connect_attributes _driver_determined
+ _dbh _server_info_hash _conn_pid _conn_tid _sql_maker _sql_maker_opts
+ transaction_depth _dbh_autocommit savepoints
+/);
# the values for these accessors are picked out (and deleted) from
# the attribute hashref passed to connect_info
# 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/);
+__PACKAGE__->mk_group_accessors('inherited' => qw/
+ sql_maker_class
+ _supports_insert_returning
+/);
__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks');
-
# Each of these methods need _determine_driver called before itself
# in order to function reliably. This is a purely DRY optimization
my @rdbms_specific_methods = qw/
+ deployment_statements
sqlt_type
+ sql_maker
build_datetime_parser
datetime_parser_type
);
$schema->resultset('Book')->search({
- written_on => $schema->storage->datetime_parser(DateTime->now)
+ written_on => $schema->storage->datetime_parser->format_datetime(DateTime->now)
});
=head1 DESCRIPTION
$new->{_in_dbh_do} = 0;
$new->{_dbh_gen} = 0;
+ # read below to see what this does
+ $new->_arm_global_destructor;
+
$new;
}
+# This is hack to work around perl shooting stuff in random
+# order on exit(). If we do not walk the remaining storage
+# objects in an END block, there is a *small but real* chance
+# of a fork()ed child to kill the parent's shared DBI handle,
+# *before perl reaches the DESTROY in this package*
+# Yes, it is ugly and effective.
+{
+ my %seek_and_destroy;
+
+ sub _arm_global_destructor {
+ my $self = shift;
+ my $key = Scalar::Util::refaddr ($self);
+ $seek_and_destroy{$key} = $self;
+ Scalar::Util::weaken ($seek_and_destroy{$key});
+ }
+
+ END {
+ local $?; # just in case the DBI destructor changes it somehow
+
+ # destroy just the object if not native to this process/thread
+ $_->_preserve_foreign_dbh for (grep
+ { defined $_ }
+ values %seek_and_destroy
+ );
+ }
+}
+
+sub DESTROY {
+ my $self = shift;
+
+ # destroy just the object if not native to this process/thread
+ $self->_preserve_foreign_dbh;
+
+ # some databases need this to stop spewing warnings
+ if (my $dbh = $self->_dbh) {
+ try {
+ %{ $dbh->{CachedKids} } = ();
+ $dbh->disconnect;
+ };
+ }
+
+ $self->_dbh(undef);
+}
+
+sub _preserve_foreign_dbh {
+ my $self = shift;
+
+ return unless $self->_dbh;
+
+ $self->_verify_tid;
+
+ return unless $self->_dbh;
+
+ $self->_verify_pid;
+
+}
+
+# handle pid changes correctly - do not destroy parent's connection
+sub _verify_pid {
+ my $self = shift;
+
+ return if ( defined $self->_conn_pid and $self->_conn_pid == $$ );
+
+ $self->_dbh->{InactiveDestroy} = 1;
+ $self->_dbh(undef);
+ $self->{_dbh_gen}++;
+
+ return;
+}
+
+# very similar to above, but seems to FAIL if I set InactiveDestroy
+sub _verify_tid {
+ my $self = shift;
+
+ if ( ! defined $self->_conn_tid ) {
+ return; # no threads
+ }
+ elsif ( $self->_conn_tid == threads->tid ) {
+ return; # same thread
+ }
+
+ #$self->_dbh->{InactiveDestroy} = 1; # why does t/51threads.t fail...?
+ $self->_dbh(undef);
+ $self->{_dbh_gen}++;
+
+ return;
+}
+
+
=head2 connect_info
This method is normally called by L<DBIx::Class::Schema/connection>, which
In addition to the standard L<DBI|DBI/ATTRIBUTES_COMMON_TO_ALL_HANDLES>
L<connection|DBI/Database_Handle_Attributes> attributes, DBIx::Class recognizes
the following connection options. These options can be mixed in with your other
-L<DBI> connection attributes, or placed in a seperate hashref
+L<DBI> connection attributes, or placed in a separate hashref
(C<\%extra_attributes>) as shown above.
Every time C<connect_info> is invoked, any previous settings for
=item name_sep
This only needs to be used in conjunction with C<quote_char>, and is used to
-specify the charecter that seperates elements (schemas, tables, columns) from
+specify the character that separates elements (schemas, tables, columns) from
each other. In most cases this is simply a C<.>.
The consequences of not supplying this value is that L<SQL::Abstract>
$self->_dbi_connect_info([@args,
%attrs && !(ref $args[0] eq 'CODE') ? \%attrs : ()]);
+ # FIXME - dirty:
+ # save attributes them in a separate accessor so they are always
+ # introspectable, even in case of a CODE $dbhmaker
+ $self->_dbic_connect_attributes (\%attrs);
+
return $self->_connect_info;
}
sub _normalize_connect_info {
my ($self, $info_arg) = @_;
my %info;
-
+
my @args = @$info_arg; # take a shallow copy for further mutilation
# combine/pre-parse arguments depending on invocation style
@args = @args[0,1,2];
}
- $info{arguments} = \@args;
+ $info{arguments} = \@args;
my @storage_opts = grep exists $attrs{$_},
@storage_options, 'cursor_class';
my $dbh = $self->_get_dbh;
- return $self->$code($dbh, @_) if $self->{_in_dbh_do}
- || $self->{transaction_depth};
+ return $self->$code($dbh, @_)
+ if ( $self->{_in_dbh_do} || $self->{transaction_depth} );
local $self->{_in_dbh_do} = 1;
- my @result;
- my $want_array = wantarray;
+ my @args = @_;
+ return try {
+ $self->$code ($dbh, @args);
+ } catch {
+ $self->throw_exception($_) if $self->connected;
- eval {
+ # We were not connected - reconnect and retry, but let any
+ # exception fall right through this time
+ carp "Retrying $code after catching disconnected exception: $_"
+ if $ENV{DBIC_DBIRETRY_DEBUG};
- if($want_array) {
- @result = $self->$code($dbh, @_);
- }
- elsif(defined $want_array) {
- $result[0] = $self->$code($dbh, @_);
- }
- else {
- $self->$code($dbh, @_);
- }
+ $self->_populate_dbh;
+ $self->$code($self->_dbh, @args);
};
-
- # ->connected might unset $@ - copy
- my $exception = $@;
- if(!$exception) { return $want_array ? @result : $result[0] }
-
- $self->throw_exception($exception) if $self->connected;
-
- # We were not connected - reconnect and retry, but let any
- # exception fall right through this time
- carp "Retrying $code after catching disconnected exception: $exception"
- if $ENV{DBIC_DBIRETRY_DEBUG};
- $self->_populate_dbh;
- $self->$code($self->_dbh, @_);
}
# This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
my $tried = 0;
while(1) {
- eval {
+ my $exception;
+ my @args = @_;
+ try {
$self->_get_dbh;
$self->txn_begin;
if($want_array) {
- @result = $coderef->(@_);
+ @result = $coderef->(@args);
}
elsif(defined $want_array) {
- $result[0] = $coderef->(@_);
+ $result[0] = $coderef->(@args);
}
else {
- $coderef->(@_);
+ $coderef->(@args);
}
$self->txn_commit;
+ } catch {
+ $exception = $_;
};
- # ->connected might unset $@ - copy
- my $exception = $@;
- if(!$exception) { return $want_array ? @result : $result[0] }
+ if(! defined $exception) { return $want_array ? @result : $result[0] }
if($tried++ || $self->connected) {
- eval { $self->txn_rollback };
- my $rollback_exception = $@;
- if($rollback_exception) {
+ my $rollback_exception;
+ try { $self->txn_rollback } catch { $rollback_exception = shift };
+ if(defined $rollback_exception) {
my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
$self->throw_exception($exception) # propagate nested rollback
if $rollback_exception =~ /$exception_class/;
$self->_dbh_rollback unless $self->_dbh_autocommit;
+ %{ $self->_dbh->{CachedKids} } = ();
$self->_dbh->disconnect;
$self->_dbh(undef);
$self->{_dbh_gen}++;
=back
-Verifies that the the current database handle is active and ready to execute
-an SQL statement (i.e. the connection did not get stale, server is still
+Verifies that the current database handle is active and ready to execute
+an SQL statement (e.g. the connection did not get stale, server is still
answering, etc.) This method is used internally by L</dbh>.
=cut
sub _seems_connected {
my $self = shift;
+ $self->_preserve_foreign_dbh;
+
my $dbh = $self->_dbh
or return 0;
- if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
- $self->_dbh(undef);
- $self->{_dbh_gen}++;
- return 0;
- }
- else {
- $self->_verify_pid;
- return 0 if !$self->_dbh;
- }
-
return $dbh->FETCH('Active');
}
return $dbh->ping;
}
-# handle pid changes correctly
-# NOTE: assumes $self->_dbh is a valid $dbh
-sub _verify_pid {
- my ($self) = @_;
-
- return if defined $self->_conn_pid && $self->_conn_pid == $$;
-
- $self->_dbh->{InactiveDestroy} = 1;
- $self->_dbh(undef);
- $self->{_dbh_gen}++;
-
- return;
-}
-
sub ensure_connected {
my ($self) = @_;
Returns a C<$dbh> - a data base handle of class L<DBI>. The returned handle
is guaranteed to be healthy by implicitly calling L</connected>, and if
necessary performing a reconnection before returning. Keep in mind that this
-is very B<expensive> on some database engines. Consider using L<dbh_do>
+is very B<expensive> on some database engines. Consider using L</dbh_do>
instead.
=cut
# this is the internal "get dbh or connect (don't check)" method
sub _get_dbh {
my $self = shift;
- $self->_verify_pid if $self->_dbh;
+ $self->_preserve_foreign_dbh;
$self->_populate_dbh unless $self->_dbh;
return $self->_dbh;
}
my @info = @{$self->_dbi_connect_info || []};
$self->_dbh(undef); # in case ->connected failed we might get sent here
+ $self->_server_info_hash (undef);
$self->_dbh($self->_connect(@info));
$self->_conn_pid($$);
$self->_do_connection_actions(connect_call_ => $_) for @actions;
}
+sub _server_info {
+ my $self = shift;
+
+ unless ($self->_server_info_hash) {
+
+ my %info;
+
+ my $server_version = try { $self->_get_server_version };
+
+ if (defined $server_version) {
+ $info{dbms_version} = $server_version;
+
+ my ($numeric_version) = $server_version =~ /^([\d\.]+)/;
+ my @verparts = split (/\./, $numeric_version);
+ if (
+ @verparts
+ &&
+ $verparts[0] <= 999
+ ) {
+ # consider only up to 3 version parts, iff not more than 3 digits
+ my @use_parts;
+ while (@verparts && @use_parts < 3) {
+ my $p = shift @verparts;
+ last if $p > 999;
+ push @use_parts, $p;
+ }
+ push @use_parts, 0 while @use_parts < 3;
+
+ $info{normalized_dbms_version} = sprintf "%d.%03d%03d", @use_parts;
+ }
+ }
+
+ $self->_server_info_hash(\%info);
+ }
+
+ return $self->_server_info_hash
+}
+
+sub _get_server_version {
+ shift->_get_dbh->get_info(18);
+}
+
sub _determine_driver {
my ($self) = @_;
else {
# try to use dsn to not require being connected, the driver may still
# force a connection in _rebless to determine version
- ($driver) = $self->_dbi_connect_info->[0] =~ /dbi:([^:]+):/i;
+ # (dsn may not be supplied at all if all we do is make a mock-schema)
+ my $dsn = $self->_dbi_connect_info->[0] || $ENV{DBI_DSN} || '';
+ ($driver) = $dsn =~ /dbi:([^:]+):/i;
+ $driver ||= $ENV{DBI_DRIVER};
}
}
- my $storage_class = "DBIx::Class::Storage::DBI::${driver}";
- if ($self->load_optional_class($storage_class)) {
- mro::set_mro($storage_class, 'c3');
- bless $self, $storage_class;
- $self->_rebless();
+ if ($driver) {
+ my $storage_class = "DBIx::Class::Storage::DBI::${driver}";
+ if ($self->load_optional_class($storage_class)) {
+ mro::set_mro($storage_class, 'c3');
+ bless $self, $storage_class;
+ $self->_rebless();
+ }
}
}
$DBI::connect_via = 'connect';
}
- eval {
+ try {
if(ref $info[0] eq 'CODE') {
- $dbh = &{$info[0]}
+ $dbh = $info[0]->();
}
else {
$dbh = DBI->connect(@info);
}
- if($dbh && !$self->unsafe) {
+ if (!$dbh) {
+ die $DBI::errstr;
+ }
+
+ unless ($self->unsafe) {
my $weak_self = $self;
Scalar::Util::weaken($weak_self);
$dbh->{HandleError} = sub {
$dbh->{RaiseError} = 1;
$dbh->{PrintError} = 0;
}
+ }
+ catch {
+ $self->throw_exception("DBI Connection failed: $_")
+ }
+ finally {
+ $DBI::connect_via = $old_connect_via if $old_connect_via;
};
- $DBI::connect_via = $old_connect_via if $old_connect_via;
-
- $self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
- if !$dbh || $@;
-
$self->_dbh_autocommit($dbh->{AutoCommit});
-
$dbh;
}
sub txn_begin {
my $self = shift;
+
+ # this means we have not yet connected and do not know the AC status
+ # (e.g. coderef $dbh)
+ $self->ensure_connected if (! defined $self->_dbh_autocommit);
+
if($self->{transaction_depth} == 0) {
$self->debugobj->txn_begin()
if $self->debug;
sub txn_rollback {
my $self = shift;
my $dbh = $self->_dbh;
- eval {
+ try {
if ($self->{transaction_depth} == 1) {
$self->debugobj->txn_rollback()
if ($self->debug);
else {
die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
}
- };
- if ($@) {
- my $error = $@;
- my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
- $error =~ /$exception_class/ and $self->throw_exception($error);
- # ensure that a failed rollback resets the transaction depth
- $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
- $self->throw_exception($error);
}
+ catch {
+ my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
+
+ if ($_ !~ /$exception_class/) {
+ # ensure that a failed rollback resets the transaction depth
+ $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
+ }
+
+ $self->throw_exception($_)
+ };
}
sub _dbh_rollback {
# Can this fail without throwing an exception anyways???
my $rv = $sth->execute();
- $self->throw_exception($sth->errstr) if !$rv;
+ $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 );
$self->dbh_do('_dbh_execute', @_); # retry over disconnects
}
-sub insert {
+sub _prefetch_insert_auto_nextvals {
my ($self, $source, $to_insert) = @_;
- my $ident = $source->from;
- my $bind_attributes = $self->source_bind_attributes($source);
-
- my $updated_cols = {};
+ my $upd = {};
foreach my $col ( $source->columns ) {
if ( !defined $to_insert->{$col} ) {
my $col_info = $source->column_info($col);
if ( $col_info->{auto_nextval} ) {
- $updated_cols->{$col} = $to_insert->{$col} = $self->_sequence_fetch(
+ $upd->{$col} = $to_insert->{$col} = $self->_sequence_fetch(
'nextval',
- $col_info->{sequence} ||
- $self->_dbh_get_autoinc_seq($self->_get_dbh, $source)
+ $col_info->{sequence} ||=
+ $self->_dbh_get_autoinc_seq($self->_get_dbh, $source, $col)
);
}
}
}
- $self->_execute('insert' => [], $source, $bind_attributes, $to_insert);
+ return $upd;
+}
+
+sub insert {
+ my $self = shift;
+ my ($source, $to_insert, $opts) = @_;
+
+ my $updated_cols = $self->_prefetch_insert_auto_nextvals (@_);
+
+ my $bind_attributes = $self->source_bind_attributes($source);
+
+ my ($rv, $sth) = $self->_execute('insert' => [], $source, $bind_attributes, $to_insert, $opts);
+
+ if ($opts->{returning}) {
+ my @ret_cols = @{$opts->{returning}};
+
+ my @ret_vals = try {
+ local $SIG{__WARN__} = sub {};
+ my @r = $sth->fetchrow_array;
+ $sth->finish;
+ @r;
+ };
+
+ my %ret;
+ @ret{@ret_cols} = @ret_vals if (@ret_vals);
+
+ $updated_cols = {
+ %$updated_cols,
+ %ret,
+ };
+ }
return $updated_cols;
}
);
}
+ # neither _execute_array, nor _execute_inserts_with_no_binds are
+ # atomic (even if _execute _array is a single call). Thus a safety
+ # scope guard
+ my $guard = $self->txn_scope_guard;
+
$self->_query_start( $sql, ['__BULK__'] );
my $sth = $self->sth($sql);
-
my $rv = do {
if ($empty_bind) {
# bind_param_array doesn't work if there are no binds
$self->_query_end( $sql, ['__BULK__'] );
+ $guard->commit;
+
return (wantarray ? ($rv, $sth, @bind) : $rv);
}
sub _execute_array {
my ($self, $source, $sth, $bind, $cols, $data, @extra) = @_;
- my $guard = $self->txn_scope_guard unless $self->{transaction_depth} != 0;
-
## This must be an arrayref, else nothing works!
my $tuple_status = [];
my @data = map { $_->[$data_index] } @$data;
- $sth->bind_param_array( $placeholder_index, [@data], $attributes );
+ $sth->bind_param_array(
+ $placeholder_index,
+ [@data],
+ (%$attributes ? $attributes : ()),
+ );
$placeholder_index++;
}
- my $rv = eval {
- $self->_dbh_execute_array($sth, $tuple_status, @extra);
+ my ($rv, $err);
+ try {
+ $rv = $self->_dbh_execute_array($sth, $tuple_status, @extra);
+ }
+ catch {
+ $err = shift;
+ }
+ finally {
+ # Statement must finish even if there was an exception.
+ try {
+ $sth->finish
+ }
+ catch {
+ $err = shift unless defined $err
+ };
};
- my $err = $@ || $sth->errstr;
-# Statement must finish even if there was an exception.
- eval { $sth->finish };
- $err = $@ unless $err;
+ $err = $sth->errstr
+ if (! defined $err and $sth->err);
- if ($err) {
+ if (defined $err) {
my $i = 0;
++$i while $i <= $#$tuple_status && !ref $tuple_status->[$i];
);
}
- $guard->commit if $guard;
-
return $rv;
}
sub _dbh_execute_inserts_with_no_binds {
my ($self, $sth, $count) = @_;
- my $guard = $self->txn_scope_guard unless $self->{transaction_depth} != 0;
-
- eval {
+ my $err;
+ try {
my $dbh = $self->_get_dbh;
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
$sth->execute foreach 1..$count;
+ }
+ catch {
+ $err = shift;
+ }
+ finally {
+ # Make sure statement is finished even if there was an exception.
+ try {
+ $sth->finish
+ }
+ catch {
+ $err = shift unless defined $err;
+ };
};
- my $exception = $@;
-
-# Make sure statement is finished even if there was an exception.
- eval { $sth->finish };
- $exception = $@ unless $exception;
- $self->throw_exception($exception) if $exception;
-
- $guard->commit if $guard;
+ $self->throw_exception($err) if defined $err;
return $count;
}
sub update {
- my ($self, $source, @args) = @_;
+ my ($self, $source, @args) = @_;
my $bind_attrs = $self->source_bind_attributes($source);
my $rsrc = $rs->result_source;
# quick check if we got a sane rs on our hands
- my @pcols = $rsrc->primary_columns;
- unless (@pcols) {
- $self->throw_exception (
- sprintf (
- "You must declare primary key(s) on source '%s' (via set_primary_key) in order to update or delete complex resultsets",
- $rsrc->source_name || $rsrc->from
- )
- );
- }
+ my @pcols = $rsrc->_pri_cols;
my $sel = $rs->_resolved_attrs->{select};
$sel = [ $sel ] unless ref $sel eq 'ARRAY';
my ($rs, $op, $values) = @_;
my $rsrc = $rs->result_source;
- my @pcols = $rsrc->primary_columns;
+ my @pcols = $rsrc->_pri_cols;
my $guard = $self->txn_scope_guard;
my $row_cnt = '0E0';
my $subrs_cur = $rs->cursor;
- while (my @pks = $subrs_cur->next) {
+ my @all_pk = $subrs_cur->all;
+ for my $pks ( @all_pk) {
my $cond;
for my $i (0.. $#pcols) {
- $cond->{$pcols[$i]} = $pks[$i];
+ $cond->{$pcols[$i]} = $pks->[$i];
}
$self->$op (
sub _select {
my $self = shift;
-
- # localization is neccessary as
- # 1) there is no infrastructure to pass this around before SQLA2
- # 2) _select_args sets it and _prep_for_execute consumes it
- my $sql_maker = $self->sql_maker;
- local $sql_maker->{_dbic_rs_attrs};
-
- return $self->_execute($self->_select_args(@_));
+ $self->_execute($self->_select_args(@_));
}
sub _select_args_to_query {
my $self = shift;
- # localization is neccessary as
- # 1) there is no infrastructure to pass this around before SQLA2
- # 2) _select_args sets it and _prep_for_execute consumes it
- my $sql_maker = $self->sql_maker;
- local $sql_maker->{_dbic_rs_attrs};
-
- # my ($op, $bind, $ident, $bind_attrs, $select, $cond, $order, $rows, $offset)
+ # my ($op, $bind, $ident, $bind_attrs, $select, $cond, $rs_attrs, $rows, $offset)
# = $self->_select_args($ident, $select, $cond, $attrs);
my ($op, $bind, $ident, $bind_attrs, @args) =
$self->_select_args(@_);
- # my ($sql, $prepared_bind) = $self->_prep_for_execute($op, $bind, $ident, [ $select, $cond, $order, $rows, $offset ]);
+ # my ($sql, $prepared_bind) = $self->_prep_for_execute($op, $bind, $ident, [ $select, $cond, $rs_attrs, $rows, $offset ]);
my ($sql, $prepared_bind) = $self->_prep_for_execute($op, $bind, $ident, \@args);
$prepared_bind ||= [];
sub _select_args {
my ($self, $ident, $select, $where, $attrs) = @_;
+ my $sql_maker = $self->sql_maker;
my ($alias2source, $rs_alias) = $self->_resolve_ident_sources ($ident);
- my $sql_maker = $self->sql_maker;
- $sql_maker->{_dbic_rs_attrs} = {
+ $attrs = {
%$attrs,
select => $select,
from => $ident,
where => $where,
- $rs_alias
- ? ( _source_handle => $alias2source->{$rs_alias}->handle )
+ $rs_alias && $alias2source->{$rs_alias}
+ ? ( _rsroot_source_handle => $alias2source->{$rs_alias}->handle )
: ()
,
};
}
# adjust limits
- if (
- $attrs->{software_limit}
- ||
- $sql_maker->_default_limit_syntax eq "GenericSubQ"
- ) {
- $attrs->{software_limit} = 1;
- }
- else {
+ if (defined $attrs->{rows}) {
$self->throw_exception("rows attribute must be positive if present")
- if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
-
+ unless $attrs->{rows} > 0;
+ }
+ elsif (defined $attrs->{offset}) {
# MySQL actually recommends this approach. I cringe.
- $attrs->{rows} = 2**48 if not defined $attrs->{rows} and defined $attrs->{offset};
+ $attrs->{rows} = 2**32;
}
my @limit;
#limited has_many
( $attrs->{rows} && keys %{$attrs->{collapse}} )
||
- # limited prefetch with RNO subqueries
- (
- $attrs->{rows}
- &&
- $sql_maker->limit_dialect eq 'RowNumberOver'
- &&
- $attrs->{_prefetch_select}
- &&
- @{$attrs->{_prefetch_select}}
- )
- ||
- # grouped prefetch
+ # grouped prefetch (to satisfy group_by == select)
( $attrs->{group_by}
&&
@{$attrs->{group_by}}
($ident, $select, $where, $attrs)
= $self->_adjust_select_args_for_complex_prefetch ($ident, $select, $where, $attrs);
}
-
- elsif (
- ($attrs->{rows} || $attrs->{offset})
- &&
- $sql_maker->limit_dialect eq 'RowNumberOver'
- &&
- (ref $ident eq 'ARRAY' && @$ident > 1) # indicates a join
- &&
- scalar $sql_maker->_order_by_chunks ($attrs->{order_by})
- ) {
- # the RNO limit dialect above mangles the SQL such that the join gets lost
- # wrap a subquery here
-
- push @limit, delete @{$attrs}{qw/rows offset/};
-
- my $subq = $self->_select_args_to_query (
- $ident,
- $select,
- $where,
- $attrs,
- );
-
- $ident = {
- -alias => $attrs->{alias},
- -source_handle => $ident->[0]{-source_handle},
- $attrs->{alias} => $subq,
- };
-
- # all part of the subquery now
- delete @{$attrs}{qw/order_by group_by having/};
- $where = undef;
- }
-
elsif (! $attrs->{software_limit} ) {
push @limit, $attrs->{rows}, $attrs->{offset};
}
+ # try to simplify the joinmap further (prune unreferenced type-single joins)
+ $ident = $self->_prune_unused_joins ($ident, $select, $where, $attrs);
+
###
# This would be the point to deflate anything found in $where
# (and leave $attrs->{bind} intact). Problem is - inflators historically
# invoked, and that's just bad...
###
- my $order = { map
- { $attrs->{$_} ? ( $_ => $attrs->{$_} ) : () }
- (qw/order_by group_by having/ )
- };
-
- return ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $where, $order, @limit);
+ return ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $where, $attrs, @limit);
}
# Returns a counting SELECT for a simple count
return { count => '*' };
}
-# Returns a SELECT which will end up in the subselect
-# There may or may not be a group_by, as the subquery
-# might have been called to accomodate a limit
-#
-# Most databases would be happy with whatever ends up
-# here, but some choke in various ways.
-#
-sub _subq_count_select {
- my ($self, $source, $rs_attrs) = @_;
- return $rs_attrs->{group_by} if $rs_attrs->{group_by};
-
- my @pcols = map { join '.', $rs_attrs->{alias}, $_ } ($source->primary_columns);
- return @pcols ? \@pcols : [ 1 ];
-}
sub source_bind_attributes {
my ($self, $source) = @_;
if ($dbh->can('column_info')) {
my %result;
- eval {
+ my $caught;
+ try {
my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table);
my $sth = $dbh->column_info( undef,$schema, $tab, '%' );
$sth->execute();
$result{$col_name} = \%column_info;
}
+ } catch {
+ $caught = 1;
};
- return \%result if !$@ && scalar keys %result;
+ return \%result if !$caught && scalar keys %result;
}
my %result;
=cut
sub _dbh_last_insert_id {
- # All Storage's need to register their own _dbh_last_insert_id
- # the old SQLite-based method was highly inappropriate
+ my ($self, $dbh, $source, $col) = @_;
- my $self = shift;
- my $class = ref $self;
- $self->throw_exception (<<EOE);
+ my $id = try { $dbh->last_insert_id (undef, undef, $source->name, $col) };
-No _dbh_last_insert_id() method found in $class.
-Since the method of obtaining the autoincrement id of the last insert
-operation varies greatly between different databases, this method must be
-individually implemented for every storage class.
-EOE
+ return $id if defined $id;
+
+ my $class = ref $self;
+ $self->throw_exception ("No storage specific _dbh_last_insert_id() method implemented in $class, and the generic DBI::last_insert_id() failed");
}
sub last_insert_id {
# some drivers provide a $dbh attribute (e.g. Sybase and $dbh->{syb_dynamic_supported})
# but it is inaccurate more often than not
- eval {
+ return try {
local $dbh->{PrintError} = 0;
local $dbh->{RaiseError} = 1;
$dbh->do('select ?', {}, 1);
+ 1;
+ }
+ catch {
+ 0;
};
- return $@ ? 0 : 1;
}
# Check if placeholders bound to non-string types throw exceptions
my $self = shift;
my $dbh = $self->_get_dbh;
- eval {
+ return try {
local $dbh->{PrintError} = 0;
local $dbh->{RaiseError} = 1;
# this specifically tests a bind that is NOT a string
$dbh->do('select 1 where 1 = ?', {}, 1);
+ 1;
+ }
+ catch {
+ 0;
};
- return $@ ? 0 : 1;
}
=head2 sqlt_type
sub create_ddl_dir {
my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
- if(!$dir || !-d $dir) {
+ unless ($dir) {
carp "No directory given, using ./\n";
- $dir = "./";
+ $dir = './';
+ } else {
+ -d $dir or File::Path::mkpath($dir)
+ or $self->throw_exception("create_ddl_dir: $! creating dir '$dir'");
}
+
+ $self->throw_exception ("Directory '$dir' does not exist\n") unless(-d $dir);
+
$databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
$databases = [ $databases ] if(ref($databases) ne 'ARRAY');
%{$sqltargs || {}}
};
- $self->throw_exception("Can't create a ddl file without SQL::Translator: " . $self->_sqlt_version_error)
- if !$self->_sqlt_version_ok;
+ 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') );
+ }
my $sqlt = SQL::Translator->new( $sqltargs );
return join('', @rows);
}
- $self->throw_exception("Can't deploy without either SQL::Translator or a ddl_dir: " . $self->_sqlt_version_error )
- if !$self->_sqlt_version_ok;
+ 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') );
+ }
# sources needs to be a parser arg, but for simplicty allow at top level
# coming in
return if($line =~ /^COMMIT/m);
return if $line =~ /^\s+$/; # skip whitespace only
$self->_query_start($line);
- eval {
+ try {
# do a dbh_do cycle here, as we need some error checking in
# place (even though we will ignore errors)
$self->dbh_do (sub { $_[1]->do($line) });
+ } catch {
+ carp qq{$_ (running "${line}")};
};
- if ($@) {
- carp qq{$@ (running "${line}")};
- }
$self->_query_end($line);
};
- my @statements = $self->deployment_statements($schema, $type, undef, $dir, { %{ $sqltargs || {} }, no_comments => 1 } );
+ my @statements = $schema->deployment_statements($type, undef, $dir, { %{ $sqltargs || {} }, no_comments => 1 } );
if (@statements > 1) {
foreach my $statement (@statements) {
$deploy->( $statement );
return;
}
-# SQLT version handling
-{
- my $_sqlt_version_ok; # private
- my $_sqlt_version_error; # private
-
- sub _sqlt_version_ok {
- if (!defined $_sqlt_version_ok) {
- eval "use SQL::Translator $minimum_sqlt_version";
- if ($@) {
- $_sqlt_version_ok = 0;
- $_sqlt_version_error = $@;
- }
- else {
- $_sqlt_version_ok = 1;
- }
- }
- return $_sqlt_version_ok;
- }
-
- sub _sqlt_version_error {
- shift->_sqlt_version_ok unless defined $_sqlt_version_ok;
- return $_sqlt_version_error;
- }
-
- sub _sqlt_minimum_version { $minimum_sqlt_version };
-}
-
=head2 relname_to_table_alias
=over 4
This hook is to allow specific L<DBIx::Class::Storage> drivers to change the
way these aliases are named.
-The default behavior is C<"$relname_$join_count" if $join_count > 1>, otherwise
-C<"$relname">.
+The default behavior is C<< "$relname_$join_count" if $join_count > 1 >>,
+otherwise C<"$relname">.
=cut
return $alias;
}
-sub DESTROY {
- my $self = shift;
-
- $self->_verify_pid if $self->_dbh;
-
- # some databases need this to stop spewing warnings
- if (my $dbh = $self->_dbh) {
- local $@;
- eval { $dbh->disconnect };
- }
-
- $self->_dbh(undef);
-}
-
1;
=head1 USAGE NOTES