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' =>
qw/_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid _conn_tid
- cursor on_connect_do transaction_depth/
+ disable_sth_caching cursor on_connect_do transaction_depth/
);
BEGIN {
$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;
+ if(ref($self) && $dbhname && $dbhname eq 'DB2') {
+ return 'RowNumberOver';
+ }
+
$self->{_cached_syntax} ||= $self->SUPER::_find_syntax($syntax);
}
if (ref $cond eq 'HASH') {
my %j;
for (keys %$cond) {
- my $x = '= '.$self->_quote($cond->{$_}); $j{$_} = \$x;
+ my $v = $cond->{$_};
+ if (ref $v) {
+ # XXX no throw_exception() in this package and croak() fails with strange results
+ Carp::croak(ref($v) . qq{ reference arguments are not supported in JOINS - try using \"..." instead'})
+ if ref($v) ne 'SCALAR';
+ $j{$_} = $v;
+ }
+ else {
+ my $x = '= '.$self->_quote($v); $j{$_} = \$x;
+ }
};
- return $self->_recurse_where(\%j);
+ return scalar($self->_recurse_where(\%j));
} elsif (ref $cond eq 'ARRAY') {
return join(' OR ', map { $self->_join_condition($_) } @$cond);
} else {
$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;
}
be executed immediately after making the connection to the database
every time we [re-]connect.
+=item disable_sth_caching
+
+If set to a true value, this option will disable the caching of
+statement handles via L<DBI/prepare_cached>.
+
=item limit_dialect
Sets the limit dialect. This is useful for JDBC-bridge among others
quote_char => q{`},
name_sep => q{@},
on_connect_do => ['SET search_path TO myschema,otherschema,public'],
+ disable_sth_caching => 1,
},
]
);
my $info = [ @$info_arg ]; # copy because we can alter it
my $last_info = $info->[-1];
if(ref $last_info eq 'HASH') {
- if(my $on_connect_do = delete $last_info->{on_connect_do}) {
- $self->on_connect_do($on_connect_do);
+ for my $storage_opt (qw/on_connect_do disable_sth_caching/) {
+ if(my $value = delete $last_info->{$storage_opt}) {
+ $self->$storage_opt($value);
+ }
}
for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
if(my $opt_val = delete $last_info->{$sql_maker_opt}) {
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;
}
sub _sql_maker_args {
my ($self) = @_;
- return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
+ return ( bindtype=>'columns', limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
}
sub sql_maker {
$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;
+ unshift(@bind,
+ map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
+ if $extra_bind;
+ @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
+
+ return ($sql, @bind);
+}
+
+sub _execute {
+ my ($self, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
+
+ my ($sql, @bind) = $self->sql_maker->$op($ident, @args);
+ unshift(@bind,
+ map { ref $_ eq 'ARRAY' ? $_ : [ '!!dummy', $_ ] } @$extra_bind)
+ if $extra_bind;
if ($self->debug) {
- my @debug_bind = map { defined $_ ? qq{'$_'} : q{'NULL'} } @bind;
+ my @debug_bind =
+ map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
$self->debugobj->query_start($sql, @debug_bind);
}
my $sth = eval { $self->sth($sql,$op) };
'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(@bind) };
+
+ $rv = eval {
+
+ my $placeholder_index = 1;
+ foreach my $bound (@bind) {
+
+ my $attributes = {};
+ my($column_name, $data) = @$bound;
+
+ if( $bind_attributes ) {
+ $attributes = $bind_attributes->{$column_name}
+ if defined $bind_attributes->{$column_name};
+ }
+
+ $data = ref $data ? ''.$data : $data; # stringify args
+
+ $sth->bind_param($placeholder_index, $data, $attributes);
+ $placeholder_index++;
+ }
+ $sth->execute;
+ };
+
if ($@ || !$rv) {
$self->throw_exception("Error executing '$sql': ".($@ || $sth->errstr));
}
$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);
+ my @debug_bind =
+ map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @bind;
+ $self->debugobj->query_end($sql, @debug_bind);
}
return (wantarray ? ($rv, $sth, @bind) : $rv);
}
sub insert {
- my ($self, $ident, $to_insert) = @_;
+ my ($self, $source, $to_insert) = @_;
+
+ my $ident = $source->from;
+ my $bind_attributes;
+ foreach my $column ($source->columns) {
+
+ my $data_type = $source->column_info($column)->{data_type} || '';
+ $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
+ if $data_type;
+ }
+
$self->throw_exception(
"Couldn't insert ".join(', ',
map "$_ => $to_insert->{$_}", keys %$to_insert
)." into ${ident}"
- ) unless ($self->_execute('insert' => [], $ident, $to_insert));
+ ) unless ($self->_execute('insert' => [], $ident, $bind_attributes, $to_insert));
return $to_insert;
}
+## Still not quite perfect, and EXPERIMENTAL
+## Currently it is assumed that all values passed will be "normal", i.e. not
+## scalar refs, or at least, all the same type as the first set, the statement is
+## only prepped once.
+sub insert_bulk {
+ my ($self, $source, $cols, $data) = @_;
+ my %colvalues;
+ my $table = $source->from;
+ @colvalues{@$cols} = (0..$#$cols);
+ my ($sql, @bind) = $self->sql_maker->insert($table, \%colvalues);
+
+ if ($self->debug) {
+ my @debug_bind = map { defined $_->[1] ? qq{$_->[1]} : q{'NULL'} } @bind;
+ $self->debugobj->query_start($sql, @debug_bind);
+ }
+ my $sth = $self->sth($sql);
+
+# @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
+
+ my $rv;
+
+ ## This must be an arrayref, else nothing works!
+
+ my $tuple_status = [];
+
+ ##use Data::Dumper;
+ ##print STDERR Dumper( $data, $sql, [@bind] );
+
+ if ($sth) {
+
+ my $time = time();
+
+ #$rv = eval {
+ #
+ # $sth->execute_array({
+
+ # ArrayTupleFetch => sub {
+
+ # my $values = shift @$data;
+ # return if !$values;
+ # return [ @{$values}[@bind] ];
+ # },
+
+ # ArrayTupleStatus => $tuple_status,
+ # })
+ #};
+
+ ## Get the bind_attributes, if any exist
+
+ my $bind_attributes;
+ foreach my $column ($source->columns) {
+
+ my $data_type = $source->column_info($column)->{data_type} || '';
+
+ $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
+ if $data_type;
+ }
+
+ ## Bind the values and execute
+
+ $rv = eval {
+
+ my $placeholder_index = 1;
+
+ foreach my $bound (@bind) {
+
+ my $attributes = {};
+ my ($column_name, $data_index) = @$bound;
+
+ if( $bind_attributes ) {
+ $attributes = $bind_attributes->{$column_name}
+ if defined $bind_attributes->{$column_name};
+ }
+
+ my @data = map { $_->[$data_index] } @$data;
+
+ $sth->bind_param_array( $placeholder_index, [@data], $attributes );
+ $placeholder_index++;
+ }
+ $sth->execute_array( {ArrayTupleStatus => $tuple_status} );
+
+ };
+
+#print STDERR Dumper($tuple_status);
+#print STDERR "RV: $rv\n";
+
+ if ($@ || !defined $rv) {
+ my $errors = '';
+ foreach my $tuple (@$tuple_status)
+ {
+ $errors .= "\n" . $tuple->[1] if(ref $tuple);
+ }
+ $self->throw_exception("Error executing '$sql': ".($@ || $errors));
+ }
+ } 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' => [], @_);
+ my $self = shift @_;
+ my $source = shift @_;
+
+ my $bind_attributes;
+ foreach my $column ($source->columns) {
+
+ my $data_type = $source->column_info($column)->{data_type} || '';
+ $bind_attributes->{$column} = $self->bind_attribute_by_data_type($data_type)
+ if $data_type;
+ }
+
+ my $ident = $source->from;
+ return $self->_execute('update' => [], $ident, $bind_attributes, @_);
}
+
sub delete {
- return shift->_execute('delete' => [], @_);
+ my $self = shift @_;
+ my $source = shift @_;
+
+ my $bind_attrs = {}; ## If ever it's needed...
+ my $ident = $source->from;
+
+ return $self->_execute('delete' => [], $ident, $bind_attrs, @_);
}
sub _select {
($order ? (order_by => $order) : ())
};
}
- my @args = ('select', $attrs->{bind}, $ident, $select, $condition, $order);
+ my $bind_attrs = {}; ## Future support
+ my @args = ('select', $attrs->{bind}, $ident, $bind_attrs, $select, $condition, $order);
if ($attrs->{software_limit} ||
$self->sql_maker->_default_limit_syntax eq "GenericSubQ") {
$attrs->{software_limit} = 1;
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);
+ my $sth = $self->disable_sth_caching
+ ? $dbh->prepare($sql)
+ : $dbh->prepare_cached($sql, {}, 3);
+
+ $self->throw_exception(
+ 'no sth generated via sql (' . ($@ || $dbh->errstr) . "): $sql"
+ ) if !$sth;
+
+ $sth;
}
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 bind_attribute_by_data_type
+
+Given a datatype from column info, returns a database specific bind attribute for
+$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.
+
+=cut
+
+sub bind_attribute_by_data_type {
+ return;
+}
=head2 create_ddl_dir (EXPERIMENTAL)
=over 4
-=item Arguments: $schema \@databases, $version, $directory, $sqlt_args
+=item Arguments: $schema \@databases, $version, $directory, $preversion, $sqlt_args
=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
sub create_ddl_dir
{
- my ($self, $schema, $databases, $version, $dir, $sqltargs) = @_;
+ my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
if(!$dir || !-d $dir)
{
$sqltargs = { ( add_drop_table => 1 ), %{$sqltargs || {}} };
eval "use SQL::Translator";
- $self->throw_exception("Can't deploy without SQL::Translator: $@") if $@;
+ $self->throw_exception("Can't create a ddl file without SQL::Translator: $@") if $@;
- my $sqlt = SQL::Translator->new($sqltargs);
+ my $sqlt = SQL::Translator->new({
+# debug => 1,
+ add_drop_table => 1,
+ });
foreach my $db (@$databases)
{
$sqlt->reset();
$sqlt->parser('SQL::Translator::Parser::DBIx::Class');
# $sqlt->parser_args({'DBIx::Class' => $schema);
+ $sqlt = $self->configure_sqlt($sqlt, $db);
$sqlt->data($schema);
$sqlt->producer($db);
my $filename = $schema->ddl_filename($db, $dir, $version);
if(-e $filename)
{
- $self->throw_exception("$filename already exists, skipping $db");
+ warn("$filename already exists, skipping $db");
next;
}
- open($file, ">$filename")
- or $self->throw_exception("Can't open $filename for writing ($!)");
+
my $output = $sqlt->translate;
-#use Data::Dumper;
-# print join(":", keys %{$schema->source_registrations});
-# print Dumper($sqlt->schema);
if(!$output)
{
- $self->throw_exception("Failed to translate to $db. (" . $sqlt->error . ")");
+ warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
next;
}
+ if(!open($file, ">$filename"))
+ {
+ $self->throw_exception("Can't open $filename for writing ($!)");
+ next;
+ }
print $file $output;
close($file);
+
+ if($preversion)
+ {
+ eval "use SQL::Translator::Diff";
+ if($@)
+ {
+ warn("Can't diff versions without SQL::Translator::Diff: $@");
+ next;
+ }
+
+ my $prefilename = $schema->ddl_filename($db, $dir, $preversion);
+# print "Previous version $prefilename\n";
+ if(!-e $prefilename)
+ {
+ warn("No previous schema file found ($prefilename)");
+ next;
+ }
+ #### We need to reparse the SQLite file we just wrote, so that
+ ## Diff doesnt get all confoosed, and Diff is *very* confused.
+ ## FIXME: rip Diff to pieces!
+# my $target_schema = $sqlt->schema;
+# unless ( $target_schema->name ) {
+# $target_schema->name( $filename );
+# }
+ my @input;
+ push @input, {file => $prefilename, parser => $db};
+ push @input, {file => $filename, parser => $db};
+ my ( $source_schema, $source_db, $target_schema, $target_db ) = map {
+ my $file = $_->{'file'};
+ my $parser = $_->{'parser'};
+
+ my $t = SQL::Translator->new;
+ $t->debug( 0 );
+ $t->trace( 0 );
+ $t->parser( $parser ) or die $t->error;
+ my $out = $t->translate( $file ) or die $t->error;
+ my $schema = $t->schema;
+ unless ( $schema->name ) {
+ $schema->name( $file );
+ }
+ ($schema, $parser);
+ } @input;
+
+ my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
+ $target_schema, $db,
+ {}
+ );
+ my $difffile = $schema->ddl_filename($db, $dir, $version, $preversion);
+ print STDERR "Diff: $difffile: $db, $dir, $version, $preversion \n";
+ if(-e $difffile)
+ {
+ warn("$difffile already exists, skipping");
+ next;
+ }
+ if(!open $file, ">$difffile")
+ {
+ $self->throw_exception("Can't write to $difffile ($!)");
+ next;
+ }
+ print $file $diff;
+ close($file);
+ }
}
+}
+sub configure_sqlt() {
+ my $self = shift;
+ my $tr = shift;
+ my $db = shift || $self->sqlt_type;
+ if ($db eq 'PostgreSQL') {
+ $tr->quote_table_names(0);
+ $tr->quote_field_names(0);
+ }
+ return $tr;
}
=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
$type ||= $self->sqlt_type;
$version ||= $schema->VERSION || '1.x';
$dir ||= './';
+ my $filename = $schema->ddl_filename($type, $dir, $version);
+ if(-f $filename)
+ {
+ my $file;
+ open($file, "<$filename")
+ or $self->throw_exception("Can't open $filename ($!)");
+ my @rows = <$file>;
+ close($file);
+ return join('', @rows);
+ }
+
eval "use SQL::Translator";
if(!$@)
{
$self->throw_exception($@) if $@;
eval "use SQL::Translator::Producer::${type};";
$self->throw_exception($@) if $@;
+
+ # sources needs to be a parser arg, but for simplicty allow at top level
+ # coming in
+ $sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
+ if exists $sqltargs->{sources};
+
my $tr = SQL::Translator->new(%$sqltargs);
SQL::Translator::Parser::DBIx::Class::parse( $tr, $schema );
return "SQL::Translator::Producer::${type}"->can('produce')->($tr);
}
- my $filename = $schema->ddl_filename($type, $dir, $version);
- if(!-f $filename)
- {
-# $schema->create_ddl_dir([ $type ], $version, $dir, $sqltargs);
- $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
- return;
- }
- my $file;
- open($file, "<$filename")
- or $self->throw_exception("Can't open $filename ($!)");
- my @rows = <$file>;
- close($file);
+ $self->throw_exception("No SQL::Translator, and no Schema file found, aborting deploy");
+ return;
- return join('', @rows);
-
}
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
-