use Data::Dumper::Concise();
use Sub::Name ();
-# 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/
# 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
build_datetime_parser
datetime_parser_type
=cut
sub connect_info {
- my ($self, $info_arg) = @_;
+ my ($self, $info) = @_;
- return $self->_connect_info if !$info_arg;
+ return $self->_connect_info if !$info;
- my @args = @$info_arg; # take a shallow copy for further mutilation
- $self->_connect_info([@args]); # copy for _connect_info
+ $self->_connect_info($info); # copy for _connect_info
+
+ $info = $self->_normalize_connect_info($info)
+ if ref $info eq 'ARRAY';
+
+ for my $storage_opt (keys %{ $info->{storage_options} }) {
+ my $value = $info->{storage_options}{$storage_opt};
+
+ $self->$storage_opt($value);
+ }
+
+ # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
+ # the new set of options
+ $self->_sql_maker(undef);
+ $self->_sql_maker_opts({});
+
+ for my $sql_maker_opt (keys %{ $info->{sql_maker_options} }) {
+ my $value = $info->{sql_maker_options}{$sql_maker_opt};
+
+ $self->_sql_maker_opts->{$sql_maker_opt} = $value;
+ }
+
+ my %attrs = (
+ %{ $self->_default_dbi_connect_attributes || {} },
+ %{ $info->{attributes} || {} },
+ );
+
+ my @args = @{ $info->{arguments} };
+
+ $self->_dbi_connect_info([@args,
+ %attrs && !(ref $args[0] eq 'CODE') ? \%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];
}
- # Kill sql_maker/_sql_maker_opts, so we get a fresh one with only
- # the new set of options
- $self->_sql_maker(undef);
- $self->_sql_maker_opts({});
+ $info{arguments} = \@args;
- if(keys %attrs) {
- for my $storage_opt (@storage_options, 'cursor_class') { # @storage_options is declared at the top of the module
- if(my $value = delete $attrs{$storage_opt}) {
- $self->$storage_opt($value);
- }
- }
- for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) {
- if(my $opt_val = delete $attrs{$sql_maker_opt}) {
- $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val;
- }
- }
- }
+ my @storage_opts = grep exists $attrs{$_},
+ @storage_options, 'cursor_class';
- if (ref $args[0] eq 'CODE') {
- # _connect() never looks past $args[0] in this case
- %attrs = ()
- } else {
- %attrs = (
- %{ $self->_default_dbi_connect_attributes || {} },
- %attrs,
- );
- }
+ @{ $info{storage_options} }{@storage_opts} =
+ delete @attrs{@storage_opts} if @storage_opts;
+
+ my @sql_maker_opts = grep exists $attrs{$_},
+ qw/limit_dialect quote_char name_sep/;
+
+ @{ $info{sql_maker_options} }{@sql_maker_opts} =
+ delete @attrs{@sql_maker_opts} if @sql_maker_opts;
+
+ $info{attributes} = \%attrs if %attrs;
- $self->_dbi_connect_info([@args, keys %attrs ? \%attrs : ()]);
- $self->_connect_info;
+ return \%info;
}
sub _default_dbi_connect_attributes {
eval {
if(ref $info[0] eq 'CODE') {
- $dbh = &{$info[0]}
+ $dbh = $info[0]->();
}
else {
$dbh = DBI->connect(@info);
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 _sth_bind_param {
- my ($self, $sth, $placeholder_index, $data, $attributes) = @_;
-
- $sth->bind_param($placeholder_index, $data, $attributes);
-}
-
sub _dbh_execute {
my ($self, $dbh, $op, $extra_bind, $ident, $bind_attributes, @args) = @_;
my $ref = ref $data;
$data = $ref && $ref ne 'ARRAY' ? ''.$data : $data; # stringify args (except arrayrefs)
- $self->_sth_bind_param($sth, $placeholder_index, $data, $attributes);
+ $sth->bind_param($placeholder_index, $data, $attributes);
$placeholder_index++;
}
}
return $updated_cols;
}
-## 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.
);
}
+ # 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 unless $self->{transaction_depth} != 0;
+
$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 if $guard;
+
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 = [];
}),
);
}
-
- $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 $dbh = $self->_get_dbh;
local $dbh->{RaiseError} = 1;
$self->throw_exception($exception) if $exception;
- $guard->commit if $guard;
-
return $count;
}
sub update {
- my ($self, $source, @args) = @_;
+ my ($self, $source, @args) = @_;
my $bind_attrs = $self->source_bind_attributes($source);
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 (
select => $select,
from => $ident,
where => $where,
- $rs_alias
+ $rs_alias && $alias2source->{$rs_alias}
? ( _source_handle => $alias2source->{$rs_alias}->handle )
: ()
,
&&
(ref $ident eq 'ARRAY' && @$ident > 1) # indicates a join
&&
- scalar $sql_maker->_order_by_chunks ($attrs->{order_by})
+ scalar $self->_parse_order_by ($attrs->{order_by})
) {
# the RNO limit dialect above mangles the SQL such that the join gets lost
# wrap a subquery here
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
=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 = eval { $dbh->last_insert_id (undef, undef, $source->name, $col) };
+
+ return $id if defined $id;
-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
+ 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 {
}
-=head2 create_ddl_dir (EXPERIMENTAL)
+=head2 create_ddl_dir
=over 4
{ ignore_constraint_names => 0, # ... other options }
-Note that this feature is currently EXPERIMENTAL and may not work correctly
-across all databases, or fully handle complex relationships.
-
-WARNING: Please check all SQL files created, before applying them.
+WARNING: You are strongly advised to check all SQL files created, before applying
+them.
=cut
%{$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
data => $schema,
);
- my $ret = $tr->translate
- or $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error);
+ my @ret;
+ my $wa = wantarray;
+ if ($wa) {
+ @ret = $tr->translate;
+ }
+ else {
+ $ret[0] = $tr->translate;
+ }
+
+ $self->throw_exception( 'Unable to produce deployment statements: ' . $tr->error)
+ unless (@ret && defined $ret[0]);
- return $ret;
+ return $wa ? @ret : $ret[0];
}
sub deploy {
return;
}
-# SQLT version handling
-{
- my $_sqlt_version_ok; # private
- my $_sqlt_version_error; # private
+=head2 relname_to_table_alias
- 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;
- }
+=over 4
- sub _sqlt_version_error {
- shift->_sqlt_version_ok unless defined $_sqlt_version_ok;
- return $_sqlt_version_error;
- }
+=item Arguments: $relname, $join_count
- sub _sqlt_minimum_version { $minimum_sqlt_version };
+=back
+
+L<DBIx::Class> uses L<DBIx::Class::Relationship> names as table aliases in
+queries.
+
+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">.
+
+=cut
+
+sub relname_to_table_alias {
+ my ($self, $relname, $join_count) = @_;
+
+ my $alias = ($join_count && $join_count > 1 ?
+ join('_', $relname, $join_count) : $relname);
+
+ return $alias;
}
sub DESTROY {
# some databases need this to stop spewing warnings
if (my $dbh = $self->_dbh) {
local $@;
- eval { $dbh->disconnect };
+ eval {
+ %{ $dbh->{CachedKids} } = ();
+ $dbh->disconnect;
+ };
}
$self->_dbh(undef);