__PACKAGE__->mk_group_accessors('simple' =>
qw/_connect_info _dbi_connect_info _dbh _sql_maker _sql_maker_opts
- _conn_pid _conn_tid disable_sth_caching cursor on_connect_do
- transaction_depth unsafe/
+ _conn_pid _conn_tid disable_sth_caching on_connect_do
+ on_disconnect_do transaction_depth unsafe _dbh_autocommit/
);
+__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::Cursor');
+
+__PACKAGE__->mk_group_accessors('inherited' => qw/sql_maker_class/);
+__PACKAGE__->sql_maker_class('DBIC::SQL::Abstract');
+
BEGIN {
package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
my ($sql, @ret) = $self->SUPER::select(
$table, $self->_recurse_fields($fields), $where, $order, @rest
);
+ $sql .=
+ $self->{for} ?
+ (
+ $self->{for} eq 'update' ? ' FOR UPDATE' :
+ $self->{for} eq 'shared' ? ' FOR SHARE' :
+ ''
+ ) :
+ ''
+ ;
return wantarray ? ($sql, @ret, @{$self->{having_bind}}) : $sql;
}
return $$fields if $ref eq 'SCALAR';
if ($ref eq 'ARRAY') {
- return join(', ', map {
+ return join(', ', map {
$self->_recurse_fields($_)
- .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
- ? ' AS col'.$self->{rownum_hack_count}++
- : '')
+ .(exists $self->{rownum_hack_count} && !($params && $params->{no_rownum_hack})
+ ? ' AS col'.$self->{rownum_hack_count}++
+ : '')
} @$fields);
} elsif ($ref eq 'HASH') {
foreach my $func (keys %$fields) {
if (ref $_[0] eq 'HASH') {
if (defined $_[0]->{group_by}) {
$ret = $self->_sqlcase(' group by ')
- .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
+ .$self->_recurse_fields($_[0]->{group_by}, { no_rownum_hack => 1 });
}
if (defined $_[0]->{having}) {
my $frag;
sub new {
my $new = shift->next::method(@_);
- $new->cursor("DBIx::Class::Storage::DBI::Cursor");
$new->transaction_depth(0);
$new->_sql_maker_opts({});
$new->{_in_dbh_do} = 0;
=item on_connect_do
-This can be set to an arrayref of literal sql statements, which will
-be executed immediately after making the connection to the database
-every time we [re-]connect.
+Specifies things to do immediately after connecting or re-connecting to
+the database. Its value may contain:
+
+=over
+
+=item an array reference
+
+This contains SQL statements to execute in order. Each element contains
+a string or a code reference that returns a string.
+
+=item a code reference
+
+This contains some code to execute. Unlike code references within an
+array reference, its return value is ignored.
+
+=back
+
+=item on_disconnect_do
+
+Takes arguments in the same form as L<on_connect_do> and executes them
+immediately before disconnecting from the database.
+
+Note, this only runs if you explicitly call L<disconnect> on the
+storage object.
=item disable_sth_caching
my $last_info = $dbi_info->[-1];
if(ref $last_info eq 'HASH') {
- for my $storage_opt (qw/on_connect_do disable_sth_caching unsafe/) {
+ $last_info = { %$last_info }; # so delete is non-destructive
+ my @storage_option = qw(
+ on_connect_do on_disconnect_do disable_sth_caching unsafe cursor_class
+ );
+ for my $storage_opt (@storage_option) {
if(my $value = delete $last_info->{$storage_opt}) {
$self->$storage_opt($value);
}
$self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
}
}
+ # re-insert modified hashref
+ $dbi_info->[-1] = $last_info;
# Get rid of any trailing empty hashref
pop(@$dbi_info) if !keys %$last_info;
ref $coderef eq 'CODE' or $self->throw_exception
('$coderef must be a CODE reference');
+ return $coderef->(@_) if $self->{transaction_depth};
+
local $self->{_in_dbh_do} = 1;
my @result;
my ($self) = @_;
if( $self->connected ) {
- $self->_dbh->rollback unless $self->_dbh->{AutoCommit};
+ my $connection_do = $self->on_disconnect_do;
+ $self->_do_connection_actions($connection_do) if ref($connection_do);
+
+ $self->_dbh->rollback unless $self->_dbh_autocommit;
$self->_dbh->disconnect;
$self->_dbh(undef);
$self->{_dbh_gen}++;
}
else {
$self->_verify_pid;
+ return 0 if !$self->_dbh;
}
return ($dbh->FETCH('Active') && $dbh->ping);
}
sub _verify_pid {
my ($self) = @_;
- return if $self->_conn_pid == $$;
+ return if defined $self->_conn_pid && $self->_conn_pid == $$;
$self->_dbh->{InactiveDestroy} = 1;
$self->_dbh(undef);
sub sql_maker {
my ($self) = @_;
unless ($self->_sql_maker) {
- $self->_sql_maker(new DBIC::SQL::Abstract( $self->_sql_maker_args ));
+ my $sql_maker_class = $self->sql_maker_class;
+ $self->_sql_maker($sql_maker_class->new( $self->_sql_maker_args ));
}
return $self->_sql_maker;
}
# Always set the transaction depth on connect, since
# there is no transaction in progress by definition
- $self->{transaction_depth} = $self->_dbh->{AutoCommit} ? 0 : 1;
+ $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
if(ref $self eq 'DBIx::Class::Storage::DBI') {
my $driver = $self->_dbh->{Driver}->{Name};
}
}
- # if on-connect sql statements are given execute them
- foreach my $sql_statement (@{$self->on_connect_do || []}) {
- $self->debugobj->query_start($sql_statement) if $self->debug();
- $self->_dbh->do($sql_statement);
- $self->debugobj->query_end($sql_statement) if $self->debug();
- }
+ my $connection_do = $self->on_connect_do;
+ $self->_do_connection_actions($connection_do) if ref($connection_do);
$self->_conn_pid($$);
$self->_conn_tid(threads->tid) if $INC{'threads.pm'};
}
+sub _do_connection_actions {
+ my $self = shift;
+ my $connection_do = shift;
+
+ if (ref $connection_do eq 'ARRAY') {
+ $self->_do_query($_) foreach @$connection_do;
+ }
+ elsif (ref $connection_do eq 'CODE') {
+ $connection_do->();
+ }
+
+ return $self;
+}
+
+sub _do_query {
+ my ($self, $action) = @_;
+
+ if (ref $action eq 'CODE') {
+ $action = $action->($self);
+ $self->_do_query($_) foreach @$action;
+ }
+ else {
+ my @to_run = (ref $action eq 'ARRAY') ? (@$action) : ($action);
+ $self->_query_start(@to_run);
+ $self->_dbh->do(@to_run);
+ $self->_query_end(@to_run);
+ }
+
+ return $self;
+}
+
sub _connect {
my ($self, @info) = @_;
$dbh = DBI->connect(@info);
}
- if(!$self->unsafe) {
+ if($dbh && !$self->unsafe) {
my $weak_self = $self;
weaken($weak_self);
$dbh->{HandleError} = sub {
$self->throw_exception("DBI Connection failed: " . ($@||$DBI::errstr))
if !$dbh || $@;
+ $self->_dbh_autocommit($dbh->{AutoCommit});
+
$dbh;
}
sub txn_begin {
my $self = shift;
$self->ensure_connected();
- if($self->{transaction_depth}++ == 0) {
+ if($self->{transaction_depth} == 0) {
$self->debugobj->txn_begin()
if $self->debug;
# this isn't ->_dbh-> because
# for AutoCommit users
$self->dbh->begin_work;
}
+ $self->{transaction_depth}++;
}
sub txn_commit {
if ($self->debug);
$dbh->commit;
$self->{transaction_depth} = 0
- if $dbh->{AutoCommit};
+ if $self->_dbh_autocommit;
}
elsif($self->{transaction_depth} > 1) {
$self->{transaction_depth}--
sub txn_rollback {
my $self = shift;
my $dbh = $self->_dbh;
- my $autocommit;
eval {
- $autocommit = $dbh->{AutoCommit};
if ($self->{transaction_depth} == 1) {
$self->debugobj->txn_rollback()
if ($self->debug);
- $dbh->rollback;
$self->{transaction_depth} = 0
- if $autocommit;
+ if $self->_dbh_autocommit;
+ $dbh->rollback;
}
elsif($self->{transaction_depth} > 1) {
$self->{transaction_depth}--;
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} = $autocommit ? 0 : 1;
+ $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
$self->throw_exception($error);
}
}
return ($sql, \@bind);
}
+sub _fix_bind_params {
+ my ($self, @bind) = @_;
+
+ ### Turn @bind from something like this:
+ ### ( [ "artist", 1 ], [ "cdid", 1, 3 ] )
+ ### to this:
+ ### ( "'1'", "'1'", "'3'" )
+ return
+ map {
+ if ( defined( $_ && $_->[1] ) ) {
+ map { qq{'$_'}; } @{$_}[ 1 .. $#$_ ];
+ }
+ else { q{'NULL'}; }
+ } @bind;
+}
+
+sub _query_start {
+ my ( $self, $sql, @bind ) = @_;
+
+ if ( $self->debug ) {
+ @bind = $self->_fix_bind_params(@bind);
+ $self->debugobj->query_start( $sql, @bind );
+ }
+}
+
+sub _query_end {
+ my ( $self, $sql, @bind ) = @_;
+
+ if ( $self->debug ) {
+ @bind = $self->_fix_bind_params(@bind);
+ $self->debugobj->query_end( $sql, @bind );
+ }
+}
+
sub _dbh_execute {
my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
my ($sql, $bind) = $self->_prep_for_execute($op, $extra_bind, $ident, \@args);
- if ($self->debug) {
- my @debug_bind =
- map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @$bind;
- $self->debugobj->query_start($sql, @debug_bind);
- }
+ $self->_query_start( $sql, @$bind );
my $sth = $self->sth($sql,$op);
my $rv = $sth->execute();
$self->throw_exception($sth->errstr) if !$rv;
- if ($self->debug) {
- my @debug_bind =
- map { defined ($_ && $_->[1]) ? qq{'$_->[1]'} : q{'NULL'} } @$bind;
- $self->debugobj->query_end($sql, @debug_bind);
- }
+ $self->_query_end( $sql, @$bind );
return (wantarray ? ($rv, $sth, @$bind) : $rv);
}
@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);
- }
+ $self->_query_start( $sql, @bind );
my $sth = $self->sth($sql);
# @bind = map { ref $_ ? ''.$_ : $_ } @bind; # stringify args
my $rv = $sth->execute_array({ArrayTupleStatus => $tuple_status});
$self->throw_exception($sth->errstr) if !$rv;
- if ($self->debug) {
- my @debug_bind = map { defined $_ ? qq{`$_'} : q{`NULL'} } @bind;
- $self->debugobj->query_end($sql, @debug_bind);
- }
+ $self->_query_end( $sql, @bind );
return (wantarray ? ($rv, $sth, @bind) : $rv);
}
sub _select {
my ($self, $ident, $select, $condition, $attrs) = @_;
my $order = $attrs->{order_by};
+
if (ref $condition eq 'SCALAR') {
$order = $1 if $$condition =~ s/ORDER BY (.*)$//i;
}
+
+ my $for = delete $attrs->{for};
+ my $sql_maker = $self->sql_maker;
+ local $sql_maker->{for} = $for;
+
if (exists $attrs->{group_by} || $attrs->{having}) {
$order = {
group_by => $attrs->{group_by},
if (defined($attrs->{rows}) && !($attrs->{rows} > 0));
push @args, $attrs->{rows}, $attrs->{offset};
}
+
return $self->_execute(@args);
}
sub select {
my $self = shift;
my ($ident, $select, $condition, $attrs) = @_;
- return $self->cursor->new($self, \@_, $attrs);
+ return $self->cursor_class->new($self, \@_, $attrs);
}
sub select_single {
return;
}
-=head2 create_ddl_dir (EXPERIMENTAL)
+=head2 create_ddl_dir
=over 4
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
-across all databases, or fully handle complex relationships.
-
=cut
sub create_ddl_dir
if !$self->_check_sqlt_version;
my $sqlt = SQL::Translator->new({
-# debug => 1,
add_drop_table => 1,
});
+
+ $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
+ my $sqlt_schema = $sqlt->translate({ data => $schema }) or die $sqlt->error;
+
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->{schema} = $sqlt_schema;
$sqlt->producer($db);
my $file;
if(-e $filename)
{
warn("$filename already exists, skipping $db");
- next;
- }
-
- my $output = $sqlt->translate;
- if(!$output)
- {
- warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
- next;
- }
- if(!open($file, ">$filename"))
- {
- $self->throw_exception("Can't open $filename for writing ($!)");
+ next unless ($preversion);
+ } else {
+ my $output = $sqlt->translate;
+ if(!$output)
+ {
+ warn("Failed to translate to $db, skipping. (" . $sqlt->error . ")");
next;
- }
- print $file $output;
- close($file);
-
+ }
+ if(!open($file, ">$filename"))
+ {
+ $self->throw_exception("Can't open $filename for writing ($!)");
+ next;
+ }
+ print $file $output;
+ close($file);
+ }
if($preversion)
{
require SQL::Translator::Diff;
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 $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;
+ }
+
+ my $source_schema;
+ {
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 );
+ $t->parser( $db ) or die $t->error;
+ my $out = $t->translate( $prefilename ) or die $t->error;
+ $source_schema = $t->schema;
+ unless ( $source_schema->name ) {
+ $source_schema->name( $prefilename );
}
- ($schema, $parser);
- } @input;
+ }
+
+ # The "new" style of producers have sane normalization and can support
+ # diffing a SQL file against a DBIC->SQLT schema. Old style ones don't
+ # And we have to diff parsed SQL against parsed SQL.
+ my $dest_schema = $sqlt_schema;
+
+ unless ( "SQL::Translator::Producers::$db"->can('preprocess_schema') ) {
+ my $t = SQL::Translator->new;
+ $t->debug( 0 );
+ $t->trace( 0 );
+ $t->parser( $db ) or die $t->error;
+ my $out = $t->translate( $filename ) or die $t->error;
+ $dest_schema = $t->schema;
+ $dest_schema->name( $filename )
+ unless $dest_schema->name;
+ }
my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
- $target_schema, $db,
+ $dest_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 if($line =~ /^BEGIN TRANSACTION/m);
next if($line =~ /^COMMIT/m);
next if $line =~ /^\s+$/; # skip whitespace only
- $self->debugobj->query_start($line) if $self->debug;
+ $self->_query_start($line);
eval {
$self->dbh->do($line); # shouldn't be using ->dbh ?
};
if ($@) {
warn qq{$@ (running "${line}")};
}
- $self->debugobj->query_end($line) if $self->debug;
+ $self->_query_end($line);
}
}
}
sub datetime_parser {
my $self = shift;
- return $self->{datetime_parser} ||= $self->build_datetime_parser(@_);
+ return $self->{datetime_parser} ||= do {
+ $self->ensure_connected;
+ $self->build_datetime_parser(@_);
+ };
}
=head2 datetime_parser_type
my $_check_sqlt_message; # private
sub _check_sqlt_version {
return $_check_sqlt_version if defined $_check_sqlt_version;
- eval 'use SQL::Translator 0.08';
- $_check_sqlt_message = $@ ? $@ : '';
- $_check_sqlt_version = $@ ? 0 : 1;
+ eval 'use SQL::Translator "0.08"';
+ $_check_sqlt_message = $@ || '';
+ $_check_sqlt_version = !$@;
}
sub _check_sqlt_message {
projects / dbsrgits/DBIx-Class.git / blobdiff