use DBIx::Class::Storage::DBI::Cursor;
use DBIx::Class::Storage::Statistics;
use IO::File;
-use Carp::Clan qw/DBIx::Class/;
__PACKAGE__->mk_group_accessors(
'simple' =>
$self;
}
+sub _RowNumberOver {
+ my ($self, $sql, $order, $rows, $offset ) = @_;
+
+ $offset += 1;
+ my $last = $rows + $offset;
+ my ( $order_by ) = $self->_order_by( $order );
+
+ $sql = <<"";
+SELECT * FROM
+(
+ SELECT Q1.*, ROW_NUMBER() OVER( ) AS ROW_NUM FROM (
+ $sql
+ $order_by
+ ) Q1
+) Q2
+WHERE ROW_NUM BETWEEN $offset AND $last
+
+ return $sql;
+}
+
+
# While we're at it, this should make LIMIT queries more efficient,
# without digging into things too deeply
+use Scalar::Util 'blessed';
sub _find_syntax {
my ($self, $syntax) = @_;
+ my $dbhname = blessed($syntax) ? $syntax->{Driver}{Name} : $syntax;
+# print STDERR "Found DBH $syntax >$dbhname< ", $syntax->{Driver}->{Name}, "\n";
+ if(ref($self) && $dbhname && $dbhname eq 'DB2') {
+ return 'RowNumberOver';
+ }
+
$self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
}
$new->cursor("DBIx::Class::Storage::DBI::Cursor");
$new->transaction_depth(0);
$new->_sql_maker_opts({});
+ $new->{_in_dbh_do} = 0;
+ $new->{_dbh_gen} = 0;
$new;
}
Arguments: $subref, @extra_coderef_args?
-Execute the given subref with the underlying database handle as its
-first argument, using the new exception-based connection management.
+Execute the given subref using the new exception-based connection management.
-Any additional arguments will be passed verbatim to the called subref
-as arguments 2 and onwards.
+The first two arguments will be the storage object that C<dbh_do> was called
+on and a database handle to use. Any additional arguments will be passed
+verbatim to the called subref as arguments 2 and onwards.
+
+Using this (instead of $self->_dbh or $self->dbh) ensures correct
+exception handling and reconnection (or failover in future subclasses).
+
+Your subref should have no side-effects outside of the database, as
+there is the potential for your subref to be partially double-executed
+if the database connection was stale/dysfunctional.
Example:
my @stuff = $schema->storage->dbh_do(
sub {
- my $dbh = shift;
- my $cols = join(q{, }, @_);
- shift->selectrow_array("SELECT $cols FROM foo")
+ my ($storage, $dbh, @cols) = @_;
+ my $cols = join(q{, }, @cols);
+ $dbh->selectrow_array("SELECT $cols FROM foo");
},
@column_list
);
sub dbh_do {
my $self = shift;
- my $todo = shift;
+ my $coderef = shift;
+
+ ref $coderef eq 'CODE' or $self->throw_exception
+ ('$coderef must be a CODE reference');
+
+ return $coderef->($self, $self->_dbh, @_) if $self->{_in_dbh_do};
+ local $self->{_in_dbh_do} = 1;
my @result;
my $want_array = wantarray;
eval {
$self->_verify_pid if $self->_dbh;
$self->_populate_dbh if !$self->_dbh;
- my $dbh = $self->_dbh;
if($want_array) {
- @result = $todo->($dbh, @_);
+ @result = $coderef->($self, $self->_dbh, @_);
}
elsif(defined $want_array) {
- $result[0] = $todo->($dbh, @_);
+ $result[0] = $coderef->($self, $self->_dbh, @_);
}
else {
- $todo->($dbh, @_);
+ $coderef->($self, $self->_dbh, @_);
}
};
- if($@) {
+ 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
+ $self->_populate_dbh;
+ $coderef->($self, $self->_dbh, @_);
+}
+
+# This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
+# It also informs dbh_do to bypass itself while under the direction of txn_do,
+# via $self->{_in_dbh_do} (this saves some redundant eval and errorcheck, etc)
+sub txn_do {
+ my $self = shift;
+ my $coderef = shift;
+
+ ref $coderef eq 'CODE' or $self->throw_exception
+ ('$coderef must be a CODE reference');
+
+ local $self->{_in_dbh_do} = 1;
+
+ my @result;
+ my $want_array = wantarray;
+
+ my $tried = 0;
+ while(1) {
+ eval {
+ $self->_verify_pid if $self->_dbh;
+ $self->_populate_dbh if !$self->_dbh;
+
+ $self->txn_begin;
+ if($want_array) {
+ @result = $coderef->(@_);
+ }
+ elsif(defined $want_array) {
+ $result[0] = $coderef->(@_);
+ }
+ else {
+ $coderef->(@_);
+ }
+ $self->txn_commit;
+ };
+
my $exception = $@;
- $self->connected
- ? $self->throw_exception($exception)
- : $self->_populate_dbh;
+ if(!$exception) { return $want_array ? @result : $result[0] }
+
+ if($tried++ > 0 || $self->connected) {
+ eval { $self->txn_rollback };
+ my $rollback_exception = $@;
+ if($rollback_exception) {
+ my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
+ $self->throw_exception($exception) # propagate nested rollback
+ if $rollback_exception =~ /$exception_class/;
+
+ $self->throw_exception(
+ "Transaction aborted: ${exception}. "
+ . "Rollback failed: ${rollback_exception}"
+ );
+ }
+ $self->throw_exception($exception)
+ }
- my $dbh = $self->_dbh;
- return $todo->($dbh, @_);
+ # We were not connected, and was first try - reconnect and retry
+ # via the while loop
+ $self->_populate_dbh;
}
-
- return $want_array ? @result : $result[0];
}
=head2 disconnect
$self->_dbh->rollback unless $self->_dbh->{AutoCommit};
$self->_dbh->disconnect;
$self->_dbh(undef);
+ $self->{_dbh_gen}++;
}
}
if(my $dbh = $self->_dbh) {
if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) {
- return $self->_dbh(undef);
+ $self->_dbh(undef);
+ $self->{_dbh_gen}++;
+ return;
}
else {
$self->_verify_pid;
$self->_dbh->{InactiveDestroy} = 1;
$self->_dbh(undef);
+ $self->{_dbh_gen}++;
return;
}
$dbh = DBI->connect(@info);
$dbh->{RaiseError} = 1;
$dbh->{PrintError} = 0;
+ $dbh->{PrintWarn} = 0;
}
};
$dbh;
}
-
-sub __txn_begin {
- my ($dbh, $self) = @_;
+sub _dbh_txn_begin {
+ my ($self, $dbh) = @_;
if ($dbh->{AutoCommit}) {
$self->debugobj->txn_begin()
if ($self->debug);
sub txn_begin {
my $self = shift;
- $self->dbh_do(\&__txn_begin, $self)
+ $self->dbh_do($self->can('_dbh_txn_begin'))
if $self->{transaction_depth}++ == 0;
}
-sub __txn_commit {
- my ($dbh, $self) = @_;
+sub _dbh_txn_commit {
+ my ($self, $dbh) = @_;
if ($self->{transaction_depth} == 0) {
unless ($dbh->{AutoCommit}) {
$self->debugobj->txn_commit()
sub txn_commit {
my $self = shift;
- $self->dbh_do(\&__txn_commit, $self);
+ $self->dbh_do($self->can('_dbh_txn_commit'));
}
-sub __txn_rollback {
- my ($dbh, $self) = @_;
+sub _dbh_txn_rollback {
+ my ($self, $dbh) = @_;
if ($self->{transaction_depth} == 0) {
unless ($dbh->{AutoCommit}) {
$self->debugobj->txn_rollback()
sub txn_rollback {
my $self = shift;
- eval { $self->dbh_do(\&__txn_rollback, $self) };
+
+ eval { $self->dbh_do($self->can('_dbh_txn_rollback')) };
if ($@) {
my $error = $@;
my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
}
}
-sub _execute {
+# This used to be the top-half of _execute. It was split out to make it
+# easier to override in NoBindVars without duping the rest. It takes up
+# all of _execute's args, and emits $sql, @bind.
+sub _prep_for_execute {
my ($self, $op, $extra_bind, $ident, @args) = @_;
+
my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
unshift(@bind, @$extra_bind) if $extra_bind;
+ @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
+
+ return ($sql, @bind);
+}
+
+sub _execute {
+ my $self = shift;
+
+ my ($sql, @bind) = $self->_prep_for_execute(@_);
+
if ($self->debug) {
my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
$self->debugobj->query_start($sql, @debug_bind);
}
- my $sth = eval { $self->sth($sql,$op) };
- if (!$sth || $@) {
- $self->throw_exception(
- 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
- );
- }
- @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
+ my $sth = $self->sth($sql);
+
my $rv;
if ($sth) {
my $time = time();
$self->throw_exception("'$sql' did not generate a statement.");
}
if ($self->debug) {
- my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
+ my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
$self->debugobj->query_end($sql, @debug_bind);
}
return (wantarray ? ($rv, $sth, @bind) : $rv);
return $to_insert;
}
+sub insert_bulk {
+ my ($self, $table, $cols, $data) = @_;
+ my ($sql, @bind) = $self->sql_maker->insert($table, @$data);
+
+ if ($self->debug) {
+ my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
+ $self->debugobj->query_start($sql, @debug_bind);
+ }
+ my $sth = eval { $self->sth($sql,'insert') };
+
+ if (!$sth || $@) {
+ $self->throw_exception(
+ 'no sth generated via sql (' . ($@ || $self->_dbh->errstr) . "): $sql"
+ );
+ }
+# @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
+
+ my $rv;
+ if ($sth) {
+ my $time = time();
+ $rv = eval { $sth->execute_array({ ArrayTupleFetch => sub { return shift @$data; }}) };
+
+ if ($@ || !$rv) {
+ $self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
+ }
+ } else {
+ $self->throw_exception("'$sql' did not generate a statement.");
+ }
+ if ($self->debug) {
+ my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
+ $self->debugobj->query_end($sql, @debug_bind);
+ }
+ return (wantarray ? ($rv, $sth, @bind) : $rv);
+}
+
sub update {
return shift->_execute('update' => [], @_);
}
return $self->_execute(@args);
}
+=head2 select
+
+=over 4
+
+=item Arguments: $ident, $select, $condition, $attrs
+
+=back
+
+Handle a SQL select statement.
+
+=cut
+
sub select {
my $self = shift;
my ($ident, $select, $condition, $attrs) = @_;
=head2 sth
+=over 4
+
+=item Arguments: $sql
+
+=back
+
Returns a L<DBI> sth (statement handle) for the supplied SQL.
=cut
-sub __sth {
- my ($dbh, $sql) = @_;
+sub _dbh_sth {
+ my ($self, $dbh, $sql) = @_;
# 3 is the if_active parameter which avoids active sth re-use
- $dbh->prepare_cached($sql, {}, 3);
+ $dbh->prepare_cached($sql, {}, 3) or
+ $self->throw_exception(
+ 'no sth generated via sql (' . ($@ || $dbh->errstr) . "): $sql"
+ );
}
sub sth {
my ($self, $sql) = @_;
- $self->dbh_do(\&__sth, $sql);
+ $self->dbh_do($self->can('_dbh_sth'), $sql);
}
-
-sub __columns_info_for {
- my ($dbh, $self, $table) = @_;
+sub _dbh_columns_info_for {
+ my ($self, $dbh, $table) = @_;
if ($dbh->can('column_info')) {
my %result;
$result{$col_name} = \%column_info;
}
};
- return \%result if !$@;
+ return \%result if !$@ && scalar keys %result;
}
my %result;
sub columns_info_for {
my ($self, $table) = @_;
- $self->dbh_do(\&__columns_info_for, $self, $table);
+ $self->dbh_do($self->can('_dbh_columns_info_for'), $table);
}
=head2 last_insert_id
=cut
+sub _dbh_last_insert_id {
+ my ($self, $dbh, $source, $col) = @_;
+ # XXX This is a SQLite-ism as a default... is there a DBI-generic way?
+ $dbh->func('last_insert_rowid');
+}
+
sub last_insert_id {
- my ($self, $row) = @_;
-
- $self->dbh_do(sub { shift->func('last_insert_rowid') });
+ my $self = shift;
+ $self->dbh_do($self->can('_dbh_last_insert_id'), @_);
}
=head2 sqlt_type
=cut
-sub sqlt_type { shift->dbh_do(sub { shift->{Driver}->{Name} }) }
+sub sqlt_type { shift->dbh->{Driver}->{Name} }
=head2 create_ddl_dir (EXPERIMENTAL)
=back
-Creates an SQL file based on the Schema, for each of the specified
+Creates a SQL file based on the Schema, for each of the specified
database types, in the given directory.
Note that this feature is currently EXPERIMENTAL and may not work correctly
=head2 deployment_statements
-Create the statements for L</deploy> and
-L<DBIx::Class::Schema/deploy>.
+=over 4
+
+=item Arguments: $schema, $type, $version, $directory, $sqlt_args
+
+=back
+
+Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
+The database driver name is given by C<$type>, though the value from
+L</sqlt_type> is used if it is not specified.
+
+C<$directory> is used to return statements from files in a previously created
+L</create_ddl_dir> directory and is optional. The filenames are constructed
+from L<DBIx::Class::Schema/ddl_filename>, the schema name and the C<$version>.
+
+If no C<$directory> is specified then the statements are constructed on the
+fly using L<SQL::Translator> and C<$version> is ignored.
+
+See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>.
=cut
}
sub deploy {
- my ($self, $schema, $type, $sqltargs) = @_;
- foreach my $statement ( $self->deployment_statements($schema, $type, undef, undef, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
+ my ($self, $schema, $type, $sqltargs, $dir) = @_;
+ foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
for ( split(";\n", $statement)) {
next if($_ =~ /^--/);
next if(!$_);
sub DESTROY {
my $self = shift;
return if !$self->_dbh;
-
$self->_verify_pid;
$self->_dbh(undef);
}
You may distribute this code under the same terms as Perl itself.
=cut
-