use mro 'c3';
use DBIx::Class::Carp;
-use DBIx::Class::Exception;
use Scalar::Util qw/refaddr weaken reftype blessed/;
-use List::Util qw/first/;
-use Sub::Name 'subname';
use Context::Preserve 'preserve_context';
-use Try::Tiny;
-use overload ();
-use Data::Compare (); # no imports!!! guard against insane architecture
-use DBI::Const::GetInfoType (); # no import of retarded global hash
+use SQL::Abstract qw(is_plain_value is_literal_value);
+use DBIx::Class::_Util qw(
+ quote_sub perlstring serialize dump_value
+ dbic_internal_try dbic_internal_catch
+ detected_reinvoked_destructor scope_guard
+ mkdir_p
+);
use namespace::clean;
# default cursor class, overridable in connect_info attributes
__PACKAGE__->sql_name_sep('.');
__PACKAGE__->mk_group_accessors('simple' => qw/
- _connect_info _dbi_connect_info _dbic_connect_attributes _driver_determined
+ _connect_info _dbic_connect_attributes _driver_determined
_dbh _dbh_details _conn_pid _sql_maker _sql_maker_opts _dbh_autocommit
_perform_autoinc_retrieval _autoinc_supplied_for_op
/);
sub _determine_supports_join_optimizer { 1 };
# Each of these methods need _determine_driver called before itself
-# in order to function reliably. This is a purely DRY optimization
+# in order to function reliably. We also need to separate accessors
+# from plain old method calls, since an accessor called as a setter
+# does *not* need the driver determination loop fired (and in fact
+# can produce hard to find bugs, like e.g. losing on_connect_*
+# semantics on fresh connections)
#
-# get_(use)_dbms_capability need to be called on the correct Storage
-# class, as _use_X may be hardcoded class-wide, and _supports_X calls
-# _determine_supports_X which obv. needs a correct driver as well
-my @rdbms_specific_methods = qw/
+# The construct below is simply a parameterized around()
+my $storage_accessor_idx = { map { $_ => 1 } qw(
sqlt_type
+ datetime_parser_type
+
sql_maker
+ cursor_class
+)};
+for my $meth (keys %$storage_accessor_idx, qw(
+ deployment_statements
+
build_datetime_parser
- datetime_parser_type
txn_begin
+
insert
- insert_bulk
update
delete
select
select_single
+
+ _insert_bulk
+
with_deferred_fk_checks
get_use_dbms_capability
_server_info
_get_server_version
-/;
-
-for my $meth (@rdbms_specific_methods) {
+)) {
my $orig = __PACKAGE__->can ($meth)
or die "$meth is not a ::Storage::DBI method!";
- no strict qw/refs/;
- no warnings qw/redefine/;
- *{__PACKAGE__ ."::$meth"} = subname $meth => sub {
+ my $possibly_a_setter = $storage_accessor_idx->{$meth} ? 1 : 0;
+
+ quote_sub
+ __PACKAGE__ ."::$meth", sprintf( <<'EOC', $possibly_a_setter, perlstring $meth ), { '$orig' => \$orig };
+
if (
+ # if this is an actual *setter* - just set it, no need to connect
+ # and determine the driver
+ !( %1$s and @_ > 1 )
+ and
# only fire when invoked on an instance, a valid class-based invocation
# would e.g. be setting a default for an inherited accessor
ref $_[0]
and
- ! $_[0]->_driver_determined
+ ! $_[0]->{_driver_determined}
and
! $_[0]->{_in_determine_driver}
+ and
+ # Only try to determine stuff if we have *something* that either is or can
+ # provide a DSN. Allows for bare $schema's generated with a plain ->connect()
+ # to still be marginally useful
+ $_[0]->_dbi_connect_info->[0]
) {
$_[0]->_determine_driver;
- # This for some reason crashes and burns on perl 5.8.1
- # IFF the method ends up throwing an exception
- #goto $_[0]->can ($meth);
+ # work around http://rt.perl.org/rt3/Public/Bug/Display.html?id=35878
+ goto $_[0]->can(%2$s) unless DBIx::Class::_ENV_::BROKEN_GOTO;
- my $cref = $_[0]->can ($meth);
+ my $cref = $_[0]->can(%2$s);
goto $cref;
}
goto $orig;
- };
+EOC
}
=head1 NAME
$new->_sql_maker_opts({});
$new->_dbh_details({});
$new->{_in_do_block} = 0;
- $new->{_dbh_gen} = 0;
# read below to see what this does
$new->_arm_global_destructor;
my %seek_and_destroy;
sub _arm_global_destructor {
+
+ # quick "garbage collection" pass - prevents the registry
+ # from slowly growing with a bunch of undef-valued keys
+ defined $seek_and_destroy{$_} or delete $seek_and_destroy{$_}
+ for keys %seek_and_destroy;
+
weaken (
$seek_and_destroy{ refaddr($_[0]) } = $_[0]
);
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
END {
- local $?; # just in case the DBI destructor changes it somehow
- # destroy just the object if not native to this process
- $_->_verify_pid for (grep
- { defined $_ }
- values %seek_and_destroy
- );
+ if(
+ ! DBIx::Class::_ENV_::BROKEN_FORK
+ and
+ my @instances = grep { defined $_ } values %seek_and_destroy
+ ) {
+ local $?; # just in case the DBI destructor changes it somehow
+
+ # disarm the handle if not native to this process (see comment on top)
+ $_->_verify_pid for @instances;
+ }
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
- sub CLONE {
+ sub DBIx::Class::__DBI_Storage_iThreads_handler__::CLONE {
# As per DBI's recommendation, DBIC disconnects all handles as
# soon as possible (DBIC will reconnect only on demand from within
# the thread)
my @instances = grep { defined $_ } values %seek_and_destroy;
+ %seek_and_destroy = ();
+
for (@instances) {
- $_->{_dbh_gen}++; # so that existing cursors will drop as well
$_->_dbh(undef);
+ $_->disconnect;
- $_->transaction_depth(0);
- $_->savepoints([]);
+ # properly renumber existing refs
+ $_->_arm_global_destructor
}
- # properly renumber all existing refs
- %seek_and_destroy = ();
- $_->_arm_global_destructor for @instances;
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
}
sub DESTROY {
- my $self = shift;
+ return if &detected_reinvoked_destructor;
+
+ $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
# some databases spew warnings on implicit disconnect
- $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
+ return unless defined $_[0]->_dbh;
+
local $SIG{__WARN__} = sub {};
- $self->_dbh(undef);
+ $_[0]->_dbh(undef);
+ # not calling ->disconnect here - we are being destroyed - nothing to reset
- # this op is necessary, since the very last perl runtime statement
- # triggers a global destruction shootout, and the $SIG localization
- # may very well be destroyed before perl actually gets to do the
- # $dbh undef
- 1;
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
# handle pid changes correctly - do not destroy parent's connection
sub _verify_pid {
- my $self = shift;
- my $pid = $self->_conn_pid;
- if( defined $pid and $pid != $$ and my $dbh = $self->_dbh ) {
+ my $pid = $_[0]->_conn_pid;
+
+ if( defined $pid and $pid != $$ and my $dbh = $_[0]->_dbh ) {
$dbh->{InactiveDestroy} = 1;
- $self->{_dbh_gen}++;
- $self->_dbh(undef);
- $self->transaction_depth(0);
- $self->savepoints([]);
+ $_[0]->_dbh(undef);
+ $_[0]->disconnect;
}
- return;
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
=head2 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} };
if (keys %attrs and ref $args[0] ne 'CODE') {
- carp
+ carp_unique (
'You provided explicit AutoCommit => 0 in your connection_info. '
. 'This is almost universally a bad idea (see the footnotes of '
. 'DBIx::Class::Storage::DBI for more info). If you still want to '
. 'do this you can set $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK} to disable '
. 'this warning.'
- if ! $attrs{AutoCommit} and ! $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK};
+ ) if ! $attrs{AutoCommit} and ! $ENV{DBIC_UNSAFE_AUTOCOMMIT_OK};
push @args, \%attrs if keys %attrs;
}
+
+ # this is the authoritative "always an arrayref" thing fed to DBI->connect
+ # OR a single-element coderef-based $dbh factory
$self->_dbi_connect_info(\@args);
+ # extract the individual storage options
+ for my $storage_opt (keys %{ $info->{storage_options} }) {
+ my $value = $info->{storage_options}{$storage_opt};
+
+ $self->$storage_opt($value);
+ }
+
+ # Extract the individual sqlmaker options
+ #
+ # 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;
+ }
+
# FIXME - dirty:
- # save attributes them in a separate accessor so they are always
+ # save attributes 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 _dbi_connect_info {
+ my $self = shift;
+
+ return $self->{_dbi_connect_info} = $_[0]
+ if @_;
+
+ my $conninfo = $self->{_dbi_connect_info} || [];
+
+ # last ditch effort to grab a DSN
+ if ( ! defined $conninfo->[0] and $ENV{DBI_DSN} ) {
+ my @new_conninfo = @$conninfo;
+ $new_conninfo[0] = $ENV{DBI_DSN};
+ $conninfo = \@new_conninfo;
+ }
+
+ return $conninfo;
+}
+
+
sub _normalize_connect_info {
my ($self, $info_arg) = @_;
my %info;
sub dbh_do {
my $self = shift;
- my $run_target = shift;
+ my $run_target = shift; # either a coderef or a method name
# short circuit when we know there is no need for a runner
#
- # FIXME - asumption may be wrong
+ # FIXME - assumption may be wrong
# the rationale for the txn_depth check is that if this block is a part
# of a larger transaction, everything up to that point is screwed anyway
return $self->$run_target($self->_get_dbh, @_)
if $self->{_in_do_block} or $self->transaction_depth;
- my $cref = (ref $run_target eq 'CODE')
- ? $run_target
- : $self->can($run_target) || $self->throw_exception(sprintf (
- 'Can\'t locate object method "%s" via package "%s"',
- $run_target,
- (ref $self || $self),
- ))
- ;
-
# take a ref instead of a copy, to preserve @_ aliasing
# semantics within the coderef, but only if needed
# (pseudoforking doesn't like this trick much)
my $args = @_ ? \@_ : [];
- unshift @$args, $self, $self->_get_dbh;
DBIx::Class::Storage::BlockRunner->new(
storage => $self,
- run_code => $cref,
- run_args => $args,
wrap_txn => 0,
- retry_handler => sub { ! ( $_[0]->retried_count or $_[0]->storage->connected ) },
- )->run;
+ retry_handler => sub {
+ $_[0]->failed_attempt_count == 1
+ and
+ ! $_[0]->storage->connected
+ },
+ )->run(sub {
+ $self->$run_target ($self->_get_dbh, @$args )
+ });
}
sub txn_do {
=cut
sub disconnect {
- my ($self) = @_;
+ my $self = shift;
- if( $self->_dbh ) {
- my @actions;
+ # this physical disconnect below might very well throw
+ # in order to unambiguously reset the state - do the cleanup in guard
- push @actions, ( $self->on_disconnect_call || () );
- push @actions, $self->_parse_connect_do ('on_disconnect_do');
+ my $g = scope_guard {
- $self->_do_connection_actions(disconnect_call_ => $_) for @actions;
+ defined( $self->_dbh )
+ and dbic_internal_try { $self->_dbh->disconnect };
+
+ $self->_dbh(undef);
+ $self->_dbh_details({});
+ $self->transaction_depth(undef);
+ $self->_dbh_autocommit(undef);
+ $self->savepoints([]);
+
+ # FIXME - this needs reenabling with the proper "no reset on same DSN" check
+ #$self->_sql_maker(undef); # this may also end up being different
+ };
+
+ if( $self->_dbh ) {
+
+ $self->_do_connection_actions(disconnect_call_ => $_) for (
+ ( $self->on_disconnect_call || () ),
+ $self->_parse_connect_do ('on_disconnect_do')
+ );
# stops the "implicit rollback on disconnect" warning
$self->_exec_txn_rollback unless $self->_dbh_autocommit;
-
- %{ $self->_dbh->{CachedKids} } = ();
- $self->_dbh->disconnect;
- $self->_dbh(undef);
- $self->{_dbh_gen}++;
}
+
+ # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage
+ # collected before leaving this scope. Depending on the code above, this
+ # may very well be just a preventive measure guarding future modifications
+ undef;
}
=head2 with_deferred_fk_checks
# Storage subclasses should override this
sub with_deferred_fk_checks {
- my ($self, $sub) = @_;
- $sub->();
+ #my ($self, $sub) = @_;
+ $_[1]->();
}
=head2 connected
=cut
sub connected {
- my $self = shift;
- return 0 unless $self->_seems_connected;
+ return 0 unless $_[0]->_seems_connected;
#be on the safe side
- local $self->_dbh->{RaiseError} = 1;
+ local $_[0]->_dbh->{RaiseError} = 1;
- return $self->_ping;
+ return $_[0]->_ping;
}
sub _seems_connected {
- my $self = shift;
+ $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
- $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
+ $_[0]->_dbh
+ and
+ $_[0]->_dbh->FETCH('Active')
+ and
+ return 1;
- my $dbh = $self->_dbh
- or return 0;
-
- return $dbh->FETCH('Active');
+ # explicitly reset all state
+ $_[0]->disconnect;
+ return 0;
}
sub _ping {
- my $self = shift;
-
- my $dbh = $self->_dbh or return 0;
-
- return $dbh->ping;
+ ($_[0]->_dbh || return 0)->ping;
}
sub ensure_connected {
- my ($self) = @_;
-
- unless ($self->connected) {
- $self->_populate_dbh;
- }
+ $_[0]->connected || ( $_[0]->_populate_dbh && 1 );
}
=head2 dbh
=cut
sub dbh {
- my ($self) = @_;
-
- if (not $self->_dbh) {
- $self->_populate_dbh;
- } else {
- $self->ensure_connected;
- }
- return $self->_dbh;
+ # maybe save a ping call
+ $_[0]->_dbh
+ ? ( $_[0]->ensure_connected and $_[0]->_dbh )
+ : $_[0]->_populate_dbh
+ ;
}
# this is the internal "get dbh or connect (don't check)" method
sub _get_dbh {
- my $self = shift;
- $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
- $self->_populate_dbh unless $self->_dbh;
- return $self->_dbh;
+ $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
+ $_[0]->_dbh || $_[0]->_populate_dbh;
}
+# *DELIBERATELY* not a setter (for the time being)
+# Too intertwined with everything else for any kind of sanity
sub sql_maker {
- my ($self) = @_;
+ my $self = shift;
+
+ $self->throw_exception('sql_maker() is not a setter method') if @_;
+
unless ($self->_sql_maker) {
my $sql_maker_class = $self->sql_maker_class;
||
do {
my $s_class = (ref $self) || $self;
- carp (
+ carp_unique (
"Your storage class ($s_class) does not set sql_limit_dialect and you "
. 'have not supplied an explicit limit_dialect in your connection_info. '
. 'DBIC will attempt to use the GenericSubQ dialect, which works on most '
. 'databases but can be (and often is) painfully slow. '
- . "Please file an RT ticket against '$s_class' ."
- );
+ . "Please file an RT ticket against '$s_class'"
+ ) if $self->_dbi_connect_info->[0];
'GenericSubQ';
}
if ($opts{quote_names}) {
$quote_char = (delete $opts{quote_char}) || $self->sql_quote_char || do {
my $s_class = (ref $self) || $self;
- carp (
+ carp_unique (
"You requested 'quote_names' but your storage class ($s_class) does "
. 'not explicitly define a default sql_quote_char and you have not '
. 'supplied a quote_char as part of your connection_info. DBIC will '
sub _init {}
sub _populate_dbh {
- my ($self) = @_;
- my @info = @{$self->_dbi_connect_info || []};
- $self->_dbh(undef); # in case ->connected failed we might get sent here
- $self->_dbh_details({}); # reset everything we know
+ # reset internal states
+ # also in case ->connected failed we might get sent here
+ $_[0]->disconnect;
- $self->_dbh($self->_connect(@info));
+ $_[0]->_dbh($_[0]->_connect);
- $self->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads
+ $_[0]->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads
- $self->_determine_driver;
+ $_[0]->_determine_driver;
# Always set the transaction depth on connect, since
# there is no transaction in progress by definition
- $self->{transaction_depth} = $self->_dbh_autocommit ? 0 : 1;
+ $_[0]->transaction_depth( $_[0]->_dbh_autocommit ? 0 : 1 );
+
+ $_[0]->_run_connection_actions unless $_[0]->{_in_determine_driver};
- $self->_run_connection_actions unless $self->{_in_determine_driver};
+ $_[0]->_dbh;
}
sub _run_connection_actions {
- my $self = shift;
- my @actions;
- push @actions, ( $self->on_connect_call || () );
- push @actions, $self->_parse_connect_do ('on_connect_do');
-
- $self->_do_connection_actions(connect_call_ => $_) for @actions;
+ $_[0]->_do_connection_actions(connect_call_ => $_) for (
+ ( $_[0]->on_connect_call || () ),
+ $_[0]->_parse_connect_do ('on_connect_do'),
+ );
}
sub _server_info {
my $self = shift;
- my $info;
- unless ($info = $self->_dbh_details->{info}) {
+ # FIXME - ideally this needs to be an ||= assignment, and the final
+ # assignment at the end of this do{} should be gone entirely. However
+ # this confuses CXSA: https://rt.cpan.org/Ticket/Display.html?id=103296
+ $self->_dbh_details->{info} || do {
+
+ # this guarantees that problematic conninfo won't be hidden
+ # by the try{} below
+ $self->ensure_connected;
- $info = {};
+ my $info = {};
- my $server_version = try {
+ my $server_version = dbic_internal_try {
$self->_get_server_version
- } catch {
+ } dbic_internal_catch {
# driver determination *may* use this codepath
# in which case we must rethrow
$self->throw_exception($_) if $self->{_in_determine_driver};
}
$self->_dbh_details->{info} = $info;
- }
-
- return $info;
+ };
}
sub _get_server_version {
my ($self, $info) = @_;
if ($info =~ /[^0-9]/) {
+ require DBI::Const::GetInfoType;
$info = $DBI::Const::GetInfoType::GetInfoType{$info};
$self->throw_exception("Info type '$_[1]' not provided by DBI::Const::GetInfoType")
unless defined $info;
}
- return $self->_get_dbh->get_info($info);
+ $self->_get_dbh->get_info($info);
}
sub _describe_connection {
require DBI::Const::GetInfoReturn;
my $self = shift;
- $self->ensure_connected;
+
+ my $drv;
+ dbic_internal_try {
+ $drv = $self->_extract_driver_from_connect_info;
+ $self->ensure_connected;
+ };
+
+ $drv = "DBD::$drv" if $drv;
my $res = {
DBIC_DSN => $self->_dbi_connect_info->[0],
DBI_VER => DBI->VERSION,
DBIC_VER => DBIx::Class->VERSION,
DBIC_DRIVER => ref $self,
+ $drv ? (
+ DBD => $drv,
+ DBD_VER => dbic_internal_try { $drv->VERSION },
+ ) : (),
};
+ # try to grab data even if we never managed to connect
+ # will cover us in cases of an oddly broken half-connect
for my $inf (
#keys %DBI::Const::GetInfoType::GetInfoType,
qw/
SQL_TXN_ISOLATION_OPTION
/
) {
- my $v = $self->_dbh_get_info($inf);
+ # some drivers barf on things they do not know about instead
+ # of returning undef
+ my $v = dbic_internal_try { $self->_dbh_get_info($inf) };
next unless defined $v;
#my $key = sprintf( '%s(%s)', $inf, $DBI::Const::GetInfoType::GetInfoType{$inf} );
if ((not $self->_driver_determined) && (not $self->{_in_determine_driver})) {
my $started_connected = 0;
- local $self->{_in_determine_driver} = 1;
+
+ local $self->{_in_determine_driver} = 1
+ unless $self->{_in_determine_driver};
if (ref($self) eq __PACKAGE__) {
my $driver;
$started_connected = 1;
}
else {
- # if connect_info is a CODEREF, we have no choice but to connect
- if (ref $self->_dbi_connect_info->[0] &&
- reftype $self->_dbi_connect_info->[0] eq 'CODE') {
- $self->_populate_dbh;
- $driver = $self->_dbh->{Driver}{Name};
- }
- else {
- # try to use dsn to not require being connected, the driver may still
- # force a connection in _rebless to determine version
- # (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};
- }
+ $driver = $self->_extract_driver_from_connect_info;
}
if ($driver) {
my $storage_class = "DBIx::Class::Storage::DBI::${driver}";
if ($self->load_optional_class($storage_class)) {
- mro::set_mro($storage_class, 'c3');
+
+ no strict 'refs';
+ mro::set_mro($storage_class, 'c3') if
+ (
+ ${"${storage_class}::__INITIAL_MRO_UPON_DBIC_LOAD__"}
+ ||= mro::get_mro($storage_class)
+ )
+ ne
+ 'c3'
+ ;
+
bless $self, $storage_class;
$self->_rebless();
}
"Your storage subclass @{[ ref $self ]} provides (or inherits) the method "
. 'source_bind_attributes() for which support has been removed as of Jan 2013. '
. 'If you are not sure how to proceed please contact the development team via '
- . 'http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class.pm#GETTING_HELP/SUPPORT'
+ . DBIx::Class::_ENV_::HELP_URL
);
}
}
}
+sub _extract_driver_from_connect_info {
+ my $self = shift;
+
+ my $drv;
+
+ # if connect_info is a CODEREF, we have no choice but to connect
+ if (
+ ref $self->_dbi_connect_info->[0]
+ and
+ reftype $self->_dbi_connect_info->[0] eq 'CODE'
+ ) {
+ $self->_populate_dbh;
+ $drv = $self->_dbh->{Driver}{Name};
+ }
+ else {
+ # try to use dsn to not require being connected, the driver may still
+ # force a connection later in _rebless to determine version
+ # (dsn may not be supplied at all if all we do is make a mock-schema)
+ #
+ # Use the same regex as the one used by DBI itself (even if the use of
+ # \w is odd given unicode):
+ # https://metacpan.org/source/TIMB/DBI-1.634/DBI.pm#L621
+ #
+ # DO NOT use https://metacpan.org/source/TIMB/DBI-1.634/DBI.pm#L559-566
+ # as there is a long-standing precedent of not loading DBI.pm until the
+ # very moment we are actually connecting
+ #
+ ($drv) = ($self->_dbi_connect_info->[0] || '') =~ /^dbi:(\w*)/i;
+ $drv ||= $ENV{DBI_DRIVER};
+ }
+
+ return $drv;
+}
+
sub _determine_connector_driver {
my ($self, $conn) = @_;
- my $dbtype = $self->_dbh_get_info('SQL_DBMS_NAME');
+ my $dbtype = $self->_get_rdbms_name;
if (not $dbtype) {
$self->_warn_undetermined_driver(
}
}
+sub _get_rdbms_name { shift->_dbh_get_info('SQL_DBMS_NAME') }
+
sub _warn_undetermined_driver {
my ($self, $msg) = @_;
- require Data::Dumper::Concise;
-
carp_once ($msg . ' While we will attempt to continue anyway, the results '
. 'are likely to be underwhelming. Please upgrade DBIC, and if this message '
. "does not go away, file a bugreport including the following info:\n"
- . Data::Dumper::Concise::Dumper($self->_describe_connection)
+ . dump_value $self->_describe_connection
);
}
sub _do_connection_actions {
- my $self = shift;
- my $method_prefix = shift;
- my $call = shift;
-
- if (not ref($call)) {
- my $method = $method_prefix . $call;
- $self->$method(@_);
- } elsif (ref($call) eq 'CODE') {
- $self->$call(@_);
- } elsif (ref($call) eq 'ARRAY') {
- if (ref($call->[0]) ne 'ARRAY') {
- $self->_do_connection_actions($method_prefix, $_) for @$call;
- } else {
- $self->_do_connection_actions($method_prefix, @$_) for @$call;
+ my ($self, $method_prefix, $call, @args) = @_;
+
+ dbic_internal_try {
+ if (not ref($call)) {
+ my $method = $method_prefix . $call;
+ $self->$method(@args);
+ }
+ elsif (ref($call) eq 'CODE') {
+ $self->$call(@args);
+ }
+ elsif (ref($call) eq 'ARRAY') {
+ if (ref($call->[0]) ne 'ARRAY') {
+ $self->_do_connection_actions($method_prefix, $_) for @$call;
+ }
+ else {
+ $self->_do_connection_actions($method_prefix, @$_) for @$call;
+ }
+ }
+ else {
+ $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref($call)) );
}
- } else {
- $self->throw_exception (sprintf ("Don't know how to process conection actions of type '%s'", ref($call)) );
}
+ dbic_internal_catch {
+ if ( $method_prefix =~ /^connect/ ) {
+ # this is an on_connect cycle - we can't just throw while leaving
+ # a handle in an undefined state in our storage object
+ # kill it with fire and rethrow
+ $self->_dbh(undef);
+ $self->disconnect; # the $dbh is gone, but we still need to reset the rest
+ $self->throw_exception( $_[0] );
+ }
+ else {
+ carp "Disconnect action failed: $_[0]";
+ }
+ };
return $self;
}
$self->_do_query(@_);
}
-# override in db-specific backend when necessary
+=head2 connect_call_datetime_setup
+
+A no-op stub method, provided so that one can always safely supply the
+L<connection option|/DBIx::Class specific connection attributes>
+
+ on_connect_call => 'datetime_setup'
+
+This way one does not need to know in advance whether the underlying
+storage requires any sort of hand-holding when dealing with calendar
+data.
+
+=cut
+
sub connect_call_datetime_setup { 1 }
sub _do_query {
}
sub _connect {
- my ($self, @info) = @_;
+ my $self = shift;
- $self->throw_exception("You failed to provide any connection info")
- if !@info;
+ my $info = $self->_dbi_connect_info;
+
+ $self->throw_exception("You did not provide any connection_info")
+ unless defined $info->[0];
my ($old_connect_via, $dbh);
local $DBI::connect_via = 'connect' if $INC{'Apache/DBI.pm'} && $ENV{MOD_PERL};
- try {
- if(ref $info[0] eq 'CODE') {
- $dbh = $info[0]->();
+ # this odd anonymous coderef dereference is in fact really
+ # necessary to avoid the unwanted effect described in perl5
+ # RT#75792
+ #
+ # in addition the coderef itself can't reside inside the try{} block below
+ # as it somehow triggers a leak under perl -d
+ my $dbh_error_handler_installer = sub {
+ weaken (my $weak_self = $_[0]);
+
+ # the coderef is blessed so we can distinguish it from externally
+ # supplied handles (which must be preserved)
+ $_[1]->{HandleError} = bless sub {
+ if ($weak_self) {
+ $weak_self->throw_exception("DBI Exception: $_[0]");
+ }
+ else {
+ # the handler may be invoked by something totally out of
+ # the scope of DBIC
+ DBIx::Class::Exception->throw("DBI Exception (unhandled by DBIC, ::Schema GCed): $_[0]");
+ }
+ }, '__DBIC__DBH__ERROR__HANDLER__';
+ };
+
+ dbic_internal_try {
+ if(ref $info->[0] eq 'CODE') {
+ $dbh = $info->[0]->();
}
else {
require DBI;
- $dbh = DBI->connect(@info);
+ $dbh = DBI->connect(@$info);
}
- if (!$dbh) {
- die $DBI::errstr;
- }
+ die $DBI::errstr unless $dbh;
+ die sprintf ("%s fresh DBI handle with a *false* 'Active' attribute. "
+ . 'This handle is disconnected as far as DBIC is concerned, and we can '
+ . 'not continue',
+ ref $info->[0] eq 'CODE'
+ ? "Connection coderef $info->[0] returned a"
+ : 'DBI->connect($schema->storage->connect_info) resulted in a'
+ ) unless $dbh->FETCH('Active');
+
+ # sanity checks unless asked otherwise
unless ($self->unsafe) {
$self->throw_exception(
# Default via _default_dbi_connect_attributes is 1, hence it was an explicit
# request, or an external handle. Complain and set anyway
unless ($dbh->{RaiseError}) {
- carp( ref $info[0] eq 'CODE'
+ carp( ref $info->[0] eq 'CODE'
? "The 'RaiseError' of the externally supplied DBI handle is set to false. "
."DBIx::Class will toggle it back to true, unless the 'unsafe' connect "
$dbh->{RaiseError} = 1;
}
- # this odd anonymous coderef dereference is in fact really
- # necessary to avoid the unwanted effect described in perl5
- # RT#75792
- sub {
- my $weak_self = $_[0];
- weaken $weak_self;
-
- # the coderef is blessed so we can distinguish it from externally
- # supplied handles (which must be preserved)
- $_[1]->{HandleError} = bless sub {
- if ($weak_self) {
- $weak_self->throw_exception("DBI Exception: $_[0]");
- }
- else {
- # the handler may be invoked by something totally out of
- # the scope of DBIC
- DBIx::Class::Exception->throw("DBI Exception (unhandled by DBIC, ::Schema GCed): $_[0]");
- }
- }, '__DBIC__DBH__ERROR__HANDLER__';
- }->($self, $dbh);
+ $dbh_error_handler_installer->($self, $dbh);
}
}
- catch {
+ dbic_internal_catch {
$self->throw_exception("DBI Connection failed: $_")
};
$self->_dbh_autocommit($dbh->{AutoCommit});
- $dbh;
+ return $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), need a full-fledged connection check
- if (! defined $self->_dbh_autocommit) {
- $self->ensure_connected;
+ if (! defined $_[0]->_dbh_autocommit) {
+ $_[0]->ensure_connected;
}
# Otherwise simply connect or re-connect on pid changes
else {
- $self->_get_dbh;
+ $_[0]->_get_dbh;
}
- $self->next::method(@_);
+ shift->next::method(@_);
}
sub _exec_txn_begin {
sub txn_commit {
my $self = shift;
- $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
$self->throw_exception("Unable to txn_commit() on a disconnected storage")
- unless $self->_dbh;
+ unless $self->_seems_connected;
# esoteric case for folks using external $dbh handles
if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) {
sub txn_rollback {
my $self = shift;
- $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
- $self->throw_exception("Unable to txn_rollback() on a disconnected storage")
- unless $self->_dbh;
+ # do a minimal connectivity check due to weird shit like
+ # https://rt.cpan.org/Public/Bug/Display.html?id=62370
+ $self->throw_exception("lost connection to storage")
+ unless $self->_seems_connected;
# esoteric case for folks using external $dbh handles
if (! $self->transaction_depth and ! $self->_dbh->FETCH('AutoCommit') ) {
shift->_dbh->rollback;
}
-# generate some identical methods
-for my $meth (qw/svp_begin svp_release svp_rollback/) {
- no strict qw/refs/;
- *{__PACKAGE__ ."::$meth"} = subname $meth => sub {
- my $self = shift;
- $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK;
- $self->throw_exception("Unable to $meth() on a disconnected storage")
- unless $self->_dbh;
- $self->next::method(@_);
- };
-}
+# generate the DBI-specific stubs, which then fallback to ::Storage proper
+quote_sub __PACKAGE__ . "::$_" => sprintf (<<'EOS', $_) for qw(svp_begin svp_release svp_rollback);
+ $_[0]->throw_exception('Unable to %s() on a disconnected storage')
+ unless $_[0]->_seems_connected;
+ shift->next::method(@_);
+EOS
# 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
$colinfos = $ident->columns_info;
}
- my ($sql, @bind) = $self->sql_maker->$op( ($from || $ident), @$args );
+ my ($sql, $bind);
+ ($sql, @$bind) = $self->sql_maker->$op( ($from || $ident), @$args );
+
+ $bind = $self->_resolve_bindattrs(
+ $ident, [ @{$args->[2]{bind}||[]}, @$bind ], $colinfos
+ );
if (
! $ENV{DBIC_DT_SEARCH_OK}
and
$op eq 'select'
and
- first { blessed($_->[1]) && $_->[1]->isa('DateTime') } @bind
+ grep {
+ defined blessed($_->[1])
+ and
+ $_->[1]->isa('DateTime')
+ } @$bind
) {
carp_unique 'DateTime objects passed to search() are not supported '
. 'properly (InflateColumn::DateTime formats and settings are not '
- . 'respected.) See "Formatting DateTime objects in queries" in '
- . 'DBIx::Class::Manual::Cookbook. To disable this warning for good '
+ . 'respected.) See ".. format a DateTime object for searching?" in '
+ . 'DBIx::Class::Manual::FAQ. To disable this warning for good '
. 'set $ENV{DBIC_DT_SEARCH_OK} to true'
}
- return( $sql, $self->_resolve_bindattrs(
- $ident, [ @{$args->[2]{bind}||[]}, @bind ], $colinfos
- ));
+ return( $sql, $bind );
}
sub _resolve_bindattrs {
my ($self, $ident, $bind, $colinfos) = @_;
- $colinfos ||= {};
-
my $resolve_bindinfo = sub {
#my $infohash = shift;
- %$colinfos = %{ $self->_resolve_column_info($ident) }
- unless keys %$colinfos;
+ $colinfos ||= { %{ $self->_resolve_column_info($ident) } };
my $ret;
if (my $col = $_[0]->{dbic_colname}) {
};
return [ map {
- if (ref $_ ne 'ARRAY') {
- [{}, $_]
- }
- elsif (! defined $_->[0]) {
- [{}, $_->[1]]
- }
- elsif (ref $_->[0] eq 'HASH') {
- [
- ($_->[0]{dbd_attrs} or $_->[0]{sqlt_datatype}) ? $_->[0] : $resolve_bindinfo->($_->[0]),
- $_->[1]
- ]
- }
- elsif (ref $_->[0] eq 'SCALAR') {
- [ { sqlt_datatype => ${$_->[0]} }, $_->[1] ]
- }
- else {
- [ $resolve_bindinfo->({ dbic_colname => $_->[0] }), $_->[1] ]
- }
+ ( ref $_ ne 'ARRAY' or @$_ != 2 ) ? [ {}, $_ ]
+ : ( ! defined $_->[0] ) ? [ {}, $_->[1] ]
+ : (ref $_->[0] eq 'HASH') ? [(
+ ! keys %{$_->[0]}
+ or
+ exists $_->[0]{dbd_attrs}
+ or
+ $_->[0]{sqlt_datatype}
+ ) ? $_->[0]
+ : $resolve_bindinfo->($_->[0])
+ , $_->[1]
+ ]
+ : (ref $_->[0] eq 'SCALAR') ? [ { sqlt_datatype => ${$_->[0]} }, $_->[1] ]
+ : [ $resolve_bindinfo->(
+ { dbic_colname => $_->[0] }
+ ), $_->[1] ]
} @$bind ];
}
map {
defined( $_ && $_->[1] )
- ? qq{'$_->[1]'}
+ ? sprintf( "'%s'", "$_->[1]" ) # because overload
: q{NULL}
} @{$_[1] || []};
}
}
sub _dbi_attrs_for_bind {
- my ($self, $ident, $bind) = @_;
+ #my ($self, $ident, $bind) = @_;
- my @attrs;
+ return [ map {
- for (map { $_->[0] } @$bind) {
- push @attrs, do {
- if (exists $_->{dbd_attrs}) {
- $_->{dbd_attrs}
- }
- elsif($_->{sqlt_datatype}) {
- # cache the result in the dbh_details hash, as it can not change unless
- # we connect to something else
- my $cache = $self->_dbh_details->{_datatype_map_cache} ||= {};
- if (not exists $cache->{$_->{sqlt_datatype}}) {
- $cache->{$_->{sqlt_datatype}} = $self->bind_attribute_by_data_type($_->{sqlt_datatype}) || undef;
- }
- $cache->{$_->{sqlt_datatype}};
- }
- else {
- undef; # always push something at this position
- }
- }
- }
+ exists $_->{dbd_attrs} ? $_->{dbd_attrs}
+
+ : ! $_->{sqlt_datatype} ? undef
+
+ : do {
+
+ # cache the result in the dbh_details hash, as it (usually) can not change
+ # unless we connect to something else
+ # FIXME: for the time being Oracle is an exception, pending a rewrite of
+ # the LOB storage
+ my $cache = $_[0]->_dbh_details->{_datatype_map_cache} ||= {};
+
+ $cache->{$_->{sqlt_datatype}} = $_[0]->bind_attribute_by_data_type($_->{sqlt_datatype})
+ if ! exists $cache->{$_->{sqlt_datatype}};
+
+ $cache->{$_->{sqlt_datatype}};
- return \@attrs;
+ } } map { $_->[0] } @{$_[2]} ];
}
sub _execute {
my ($sql, $bind) = $self->_prep_for_execute($op, $ident, \@args);
- shift->dbh_do( # retry over disconnects
- '_dbh_execute',
+ # not even a PID check - we do not care about the state of the _dbh.
+ # All we need is to get the appropriate drivers loaded if they aren't
+ # already so that the assumption in ad7c50fc26e holds
+ $self->_populate_dbh unless $self->_dbh;
+
+ $self->dbh_do( _dbh_execute => # retry over disconnects
$sql,
$bind,
- $ident,
+ $self->_dbi_attrs_for_bind($ident, $bind),
);
}
sub _dbh_execute {
- my ($self, undef, $sql, $bind, $ident) = @_;
+ my ($self, $dbh, $sql, $bind, $bind_attrs) = @_;
$self->_query_start( $sql, $bind );
- my $bind_attrs = $self->_dbi_attrs_for_bind($ident, $bind);
+ my $sth = $self->_bind_sth_params(
+ $self->_prepare_sth($dbh, $sql),
+ $bind,
+ $bind_attrs,
+ );
+
+ # Can this fail without throwing an exception anyways???
+ my $rv = $sth->execute();
+ $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 );
+
+ return (wantarray ? ($rv, $sth, @$bind) : $rv);
+}
+
+sub _prepare_sth {
+ my ($self, $dbh, $sql) = @_;
+
+ # 3 is the if_active parameter which avoids active sth re-use
+ my $sth = $self->disable_sth_caching
+ ? $dbh->prepare($sql)
+ : $dbh->prepare_cached($sql, {}, 3);
+
+ # XXX You would think RaiseError would make this impossible,
+ # but apparently that's not true :(
+ $self->throw_exception(
+ $dbh->errstr
+ ||
+ sprintf( "\$dbh->prepare() of '%s' through %s failed *silently* without "
+ .'an exception and/or setting $dbh->errstr',
+ length ($sql) > 20
+ ? substr($sql, 0, 20) . '...'
+ : $sql
+ ,
+ 'DBD::' . $dbh->{Driver}{Name},
+ )
+ ) if !$sth;
+
+ $sth;
+}
- my $sth = $self->_sth($sql);
+sub _bind_sth_params {
+ my ($self, $sth, $bind, $bind_attrs) = @_;
for my $i (0 .. $#$bind) {
if (ref $bind->[$i][1] eq 'SCALAR') { # any scalarrefs are assumed to be bind_inouts
);
}
else {
+ # FIXME SUBOPTIMAL - DBI needs fixing to always stringify regardless of DBD
+ my $v = ( length ref $bind->[$i][1] and is_plain_value $bind->[$i][1] )
+ ? "$bind->[$i][1]"
+ : $bind->[$i][1]
+ ;
+
$sth->bind_param(
$i + 1,
- (ref $bind->[$i][1] and overload::Method($bind->[$i][1], '""'))
- ? "$bind->[$i][1]"
- : $bind->[$i][1]
- ,
+ # The temp-var is CRUCIAL - DO NOT REMOVE IT, breaks older DBD::SQLite RT#79576
+ $v,
$bind_attrs->[$i],
);
}
}
- # Can this fail without throwing an exception anyways???
- my $rv = $sth->execute();
- $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 );
-
- return (wantarray ? ($rv, $sth, @$bind) : $rv);
+ $sth;
}
sub _prefetch_autovalues {
(
! exists $to_insert->{$col}
or
- ref $to_insert->{$col} eq 'SCALAR'
- or
- (ref $to_insert->{$col} eq 'REF' and ref ${$to_insert->{$col}} eq 'ARRAY')
+ is_literal_value($to_insert->{$col})
)
) {
$values{$col} = $self->_sequence_fetch(
# they can be fused once again with the final return
$to_insert = { %$to_insert, %$prefetched_values };
- # FIXME - we seem to assume undef values as non-supplied. This is wrong.
- # Investigate what does it take to s/defined/exists/
my %pcols = map { $_ => 1 } $source->primary_columns;
+
my (%retrieve_cols, $autoinc_supplied, $retrieve_autoinc_col);
+
for my $col ($source->columns) {
+
+ # first autoinc wins - this is why ->columns() in-order iteration is important
+ #
+ # FIXME - there ought to be a sanity-check for multiple is_auto_increment settings
+ # or something...
+ #
if ($col_infos->{$col}{is_auto_increment}) {
+
+ # FIXME - we seem to assume undef values as non-supplied.
+ # This is wrong.
+ # Investigate what does it take to s/defined/exists/
+ # ( fails t/cdbi/copy.t amoong other things )
$autoinc_supplied ||= 1 if defined $to_insert->{$col};
+
$retrieve_autoinc_col ||= $col unless $autoinc_supplied;
}
# nothing to retrieve when explicit values are supplied
- next if (defined $to_insert->{$col} and ! (
- ref $to_insert->{$col} eq 'SCALAR'
- or
- (ref $to_insert->{$col} eq 'REF' and ref ${$to_insert->{$col}} eq 'ARRAY')
- ));
+ next if (
+ # FIXME - we seem to assume undef values as non-supplied.
+ # This is wrong.
+ # Investigate what does it take to s/defined/exists/
+ # ( fails t/cdbi/copy.t amoong other things )
+ defined $to_insert->{$col}
+ and
+ (
+ # not a ref - cheaper to check before a call to is_literal_value()
+ ! length ref $to_insert->{$col}
+ or
+ # not a literal we *MAY* need to pull out ( see check below )
+ ! is_literal_value( $to_insert->{$col} )
+ )
+ );
# the 'scalar keys' is a trick to preserve the ->columns declaration order
$retrieve_cols{$col} = scalar keys %retrieve_cols if (
);
};
+ # corner case of a non-supplied PK which is *not* declared as autoinc
+ if (
+ ! $autoinc_supplied
+ and
+ ! defined $retrieve_autoinc_col
+ and
+ # FIXME - first come-first serve, suboptimal...
+ ($retrieve_autoinc_col) = ( grep
+ {
+ $pcols{$_}
+ and
+ ! $col_infos->{$_}{retrieve_on_insert}
+ and
+ ! defined $col_infos->{$_}{is_auto_increment}
+ }
+ sort
+ { $retrieve_cols{$a} <=> $retrieve_cols{$b} }
+ keys %retrieve_cols
+ )
+ ) {
+ carp_unique(
+ "Missing value for primary key column '$retrieve_autoinc_col' on "
+ . "@{[ $source->source_name ]} - perhaps you forgot to set its "
+ . "'is_auto_increment' attribute during add_columns()? Treating "
+ . "'$retrieve_autoinc_col' implicitly as an autoinc, and attempting "
+ . 'value retrieval'
+ );
+ }
+
local $self->{_autoinc_supplied_for_op} = $autoinc_supplied;
local $self->{_perform_autoinc_retrieval} = $retrieve_autoinc_col;
my %returned_cols = %$to_insert;
if (my $retlist = $sqla_opts->{returning}) { # if IR is supported - we will get everything in one set
- @ir_container = try {
- local $SIG{__WARN__} = sub {};
- my @r = $sth->fetchrow_array;
- $sth->finish;
- @r;
- } unless @ir_container;
+
+ unless( @ir_container ) {
+ dbic_internal_try {
+
+ # FIXME - need to investigate why Caelum silenced this in 4d4dc518
+ local $SIG{__WARN__} = sub {};
+
+ @ir_container = $sth->fetchrow_array;
+ $sth->finish;
+
+ } dbic_internal_catch {
+ # Evict the $sth from the cache in case we got here, since the finish()
+ # is crucial, at least on older Firebirds, possibly on other engines too
+ #
+ # It would be too complex to make this a proper subclass override,
+ # and besides we already take the try{} penalty, adding a catch that
+ # triggers infrequently is a no-brainer
+ #
+ if( my $kids = $self->_dbh->{CachedKids} ) {
+ $kids->{$_} == $sth and delete $kids->{$_}
+ for keys %$kids
+ }
+ };
+ }
@returned_cols{@$retlist} = @ir_container if @ir_container;
}
unless (@pri_values == @missing_pri);
@returned_cols{@missing_pri} = @pri_values;
- delete $retrieve_cols{$_} for @missing_pri;
+ delete @retrieve_cols{@missing_pri};
}
# if there is more left to pull
}
sub insert_bulk {
- my ($self, $source, $cols, $data) = @_;
+ carp_unique(
+ 'insert_bulk() should have never been exposed as a public method and '
+ . 'calling it is depecated as of Aug 2014. If you believe having a genuine '
+ . 'use for this method please contact the development team via '
+ . DBIx::Class::_ENV_::HELP_URL
+ );
- my @col_range = (0..$#$cols);
+ return '0E0' unless @{$_[3]||[]};
- # FIXME - perhaps this is not even needed? does DBI stringify?
- #
- # forcibly stringify whatever is stringifiable
- # ResultSet::populate() hands us a copy - safe to mangle
- for my $r (0 .. $#$data) {
- for my $c (0 .. $#{$data->[$r]}) {
- $data->[$r][$c] = "$data->[$r][$c]"
- if ( ref $data->[$r][$c] and overload::Method($data->[$r][$c], '""') );
- }
- }
+ shift->_insert_bulk(@_);
+}
+
+sub _insert_bulk {
+ my ($self, $source, $cols, $data) = @_;
+
+ $self->throw_exception('Calling _insert_bulk without a dataset to process makes no sense')
+ unless @{$data||[]};
my $colinfos = $source->columns_info($cols);
local $self->{_autoinc_supplied_for_op} =
- (first { $_->{is_auto_increment} } values %$colinfos)
+ (grep { $_->{is_auto_increment} } values %$colinfos)
? 1
: 0
;
# can't just hand SQLA a set of some known "values" (e.g. hashrefs that
# can be later matched up by address), because we want to supply a real
# value on which perhaps e.g. datatype checks will be performed
- my ($proto_data, $value_type_by_col_idx);
- for my $i (@col_range) {
- my $colname = $cols->[$i];
- if (ref $data->[0][$i] eq 'SCALAR') {
+ my ($proto_data, $serialized_bind_type_by_col_idx);
+ for my $col_idx (0..$#$cols) {
+ my $colname = $cols->[$col_idx];
+ if (ref $data->[0][$col_idx] eq 'SCALAR') {
# no bind value at all - no type
- $proto_data->{$colname} = $data->[0][$i];
+ $proto_data->{$colname} = $data->[0][$col_idx];
}
- elsif (ref $data->[0][$i] eq 'REF' and ref ${$data->[0][$i]} eq 'ARRAY' ) {
+ elsif (ref $data->[0][$col_idx] eq 'REF' and ref ${$data->[0][$col_idx]} eq 'ARRAY' ) {
# repack, so we don't end up mangling the original \[]
- my ($sql, @bind) = @${$data->[0][$i]};
+ my ($sql, @bind) = @${$data->[0][$col_idx]};
# normalization of user supplied stuff
my $resolved_bind = $self->_resolve_bindattrs(
# store value-less (attrs only) bind info - we will be comparing all
# supplied binds against this for sanity
- $value_type_by_col_idx->{$i} = [ map { $_->[0] } @$resolved_bind ];
+ $serialized_bind_type_by_col_idx->{$col_idx} = serialize [ map { $_->[0] } @$resolved_bind ];
$proto_data->{$colname} = \[ $sql, map { [
# inject slice order to use for $proto_bind construction
- { %{$resolved_bind->[$_][0]}, _bind_data_slice_idx => $i, _literal_bind_subindex => $_+1 }
+ { %{$resolved_bind->[$_][0]}, _bind_data_slice_idx => $col_idx, _literal_bind_subindex => $_+1 }
=>
$resolved_bind->[$_][1]
] } (0 .. $#bind)
];
}
else {
- $value_type_by_col_idx->{$i} = undef;
+ $serialized_bind_type_by_col_idx->{$col_idx} = undef;
$proto_data->{$colname} = \[ '?', [
- { dbic_colname => $colname, _bind_data_slice_idx => $i }
+ { dbic_colname => $colname, _bind_data_slice_idx => $col_idx }
=>
- $data->[0][$i]
+ $data->[0][$col_idx]
] ];
}
}
[ $proto_data ],
);
- if (! @$proto_bind and keys %$value_type_by_col_idx) {
+ if (! @$proto_bind and keys %$serialized_bind_type_by_col_idx) {
# if the bindlist is empty and we had some dynamic binds, this means the
# storage ate them away (e.g. the NoBindVars component) and interpolated
# them directly into the SQL. This obviously can't be good for multi-inserts
- $self->throw_exception('Cannot insert_bulk without support for placeholders');
+ $self->throw_exception('Unable to invoke fast-path insert without storage placeholder support');
}
# sanity checks
$msg,
$cols->[$c_idx],
do {
- require Data::Dumper::Concise;
local $Data::Dumper::Maxdepth = 5;
- Data::Dumper::Concise::Dumper ({
+ dump_value {
map { $cols->[$_] =>
$data->[$r_idx][$_]
- } @col_range
- }),
+ } 0..$#$cols
+ };
}
);
};
- for my $col_idx (@col_range) {
+ for my $col_idx (0..$#$cols) {
my $reference_val = $data->[0][$col_idx];
for my $row_idx (1..$#$data) { # we are comparing against what we got from [0] above, hence start from 1
my $val = $data->[$row_idx][$col_idx];
- if (! exists $value_type_by_col_idx->{$col_idx}) { # literal no binds
+ if (! exists $serialized_bind_type_by_col_idx->{$col_idx}) { # literal no binds
if (ref $val ne 'SCALAR') {
$bad_slice_report_cref->(
"Incorrect value (expecting SCALAR-ref \\'$$reference_val')",
);
}
}
- elsif (! defined $value_type_by_col_idx->{$col_idx} ) { # regular non-literal value
- if (ref $val eq 'SCALAR' or (ref $val eq 'REF' and ref $$val eq 'ARRAY') ) {
+ elsif (! defined $serialized_bind_type_by_col_idx->{$col_idx} ) { # regular non-literal value
+ if (is_literal_value($val)) {
$bad_slice_report_cref->("Literal SQL found where a plain bind value is expected", $row_idx, $col_idx);
}
}
}
# need to check the bind attrs - a bind will happen only once for
# the entire dataset, so any changes further down will be ignored.
- elsif (! Data::Compare::Compare(
- $value_type_by_col_idx->{$col_idx},
- [
+ elsif (
+ $serialized_bind_type_by_col_idx->{$col_idx}
+ ne
+ serialize [
map
{ $_->[0] }
@{$self->_resolve_bindattrs(
$source, [ @{$$val}[1 .. $#$$val] ], $colinfos,
)}
- ],
- )) {
+ ]
+ ) {
$bad_slice_report_cref->(
'Differing bind attributes on literal/bind values not supported',
$row_idx,
# scope guard
my $guard = $self->txn_scope_guard;
- $self->_query_start( $sql, @$proto_bind ? [[undef => '__BULK_INSERT__' ]] : () );
- my $sth = $self->_sth($sql);
+ $self->_query_start( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () );
+ my $sth = $self->_prepare_sth($self->_dbh, $sql);
my $rv = do {
if (@$proto_bind) {
# proto bind contains the information on which pieces of $data to pull
}
};
- $self->_query_end( $sql, @$proto_bind ? [[ undef => '__BULK_INSERT__' ]] : () );
+ $self->_query_end( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () );
$guard->commit;
sub _dbh_execute_for_fetch {
my ($self, $source, $sth, $proto_bind, $cols, $data) = @_;
- my @idx_range = ( 0 .. $#$proto_bind );
-
# If we have any bind attributes to take care of, we will bind the
# proto-bind data (which will never be used by execute_for_fetch)
# However since column bindtypes are "sticky", this is sufficient
# to get the DBD to apply the bindtype to all values later on
-
my $bind_attrs = $self->_dbi_attrs_for_bind($source, $proto_bind);
- for my $i (@idx_range) {
+ for my $i (0 .. $#$proto_bind) {
$sth->bind_param (
$i+1, # DBI bind indexes are 1-based
$proto_bind->[$i][1],
my $fetch_tuple = sub {
return undef if ++$fetch_row_idx > $#$data;
- return [ map { defined $_->{_literal_bind_subindex}
- ? ${ $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]}
- ->[ $_->{_literal_bind_subindex} ]
- ->[1]
- : $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]
- } map { $_->[0] } @$proto_bind];
+ return [ map {
+ my $v = ! defined $_->{_literal_bind_subindex}
+
+ ? $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]
+
+ # There are no attributes to resolve here - we already did everything
+ # when we constructed proto_bind. However we still want to sanity-check
+ # what the user supplied, so pass stuff through to the resolver *anyway*
+ : $self->_resolve_bindattrs (
+ undef, # a fake rsrc
+ [ ${ $data->[ $fetch_row_idx ]->[ $_->{_bind_data_slice_idx} ]}->[ $_->{_literal_bind_subindex} ] ],
+ {}, # a fake column_info bag
+ )->[0][1]
+ ;
+
+ # FIXME SUBOPTIMAL - DBI needs fixing to always stringify regardless of DBD
+ # For the time being forcibly stringify whatever is stringifiable
+ my $vref;
+
+ ( !length ref $v or ! ($vref = is_plain_value $v) ) ? $v
+ : defined blessed( $$vref ) ? "$$vref"
+ : $$vref
+ ;
+ } map { $_->[0] } @$proto_bind ];
};
my $tuple_status = [];
my ($rv, $err);
- try {
+ dbic_internal_try {
$rv = $sth->execute_for_fetch(
$fetch_tuple,
$tuple_status,
);
}
- catch {
+ dbic_internal_catch {
$err = shift;
};
);
# Statement must finish even if there was an exception.
- try {
+ dbic_internal_try {
$sth->finish
}
- catch {
+ dbic_internal_catch {
$err = shift unless defined $err
};
$self->throw_exception("Unexpected populate error: $err")
if ($i > $#$tuple_status);
- require Data::Dumper::Concise;
$self->throw_exception(sprintf "execute_for_fetch() aborted with '%s' at populate slice:\n%s",
($tuple_status->[$i][1] || $err),
- Data::Dumper::Concise::Dumper( { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) } ),
+ dump_value { map { $cols->[$_] => $data->[$i][$_] } (0 .. $#$cols) },
);
}
my ($self, $sth, $count) = @_;
my $err;
- try {
+ dbic_internal_try {
my $dbh = $self->_get_dbh;
local $dbh->{RaiseError} = 1;
local $dbh->{PrintError} = 0;
$sth->execute foreach 1..$count;
}
- catch {
+ dbic_internal_catch {
$err = shift;
};
# Make sure statement is finished even if there was an exception.
- try {
+ dbic_internal_try {
$sth->finish
}
- catch {
+ dbic_internal_catch {
$err = shift unless defined $err;
};
$self->_select_args(@_);
# my ($sql, $prepared_bind) = $self->_gen_sql_bind($op, $ident, [ $select, $cond, $rs_attrs, $rows, $offset ]);
- my ($sql, $prepared_bind) = $self->_gen_sql_bind($op, $ident, \@args);
- $prepared_bind ||= [];
+ my ($sql, $bind) = $self->_gen_sql_bind($op, $ident, \@args);
- return wantarray
- ? ($sql, $prepared_bind)
- : \[ "($sql)", @$prepared_bind ]
- ;
+ # reuse the bind arrayref
+ unshift @{$bind}, "($sql)";
+ \$bind;
}
sub _select_args {
- my ($self, $ident, $select, $where, $attrs) = @_;
+ my ($self, $ident, $select, $where, $orig_attrs) = @_;
+
+ # FIXME - that kind of caching would be nice to have
+ # however currently we *may* pass the same $orig_attrs
+ # with different ident/select/where
+ # the whole interface needs to be rethought, since it
+ # was centered around the flawed SQLA API. We can do
+ # soooooo much better now. But that is also another
+ # battle...
+ #return (
+ # 'select', $orig_attrs->{!args_as_stored_at_the_end_of_this_method!}
+ #) if $orig_attrs->{!args_as_stored_at_the_end_of_this_method!};
my $sql_maker = $self->sql_maker;
- my ($alias2source, $rs_alias) = $self->_resolve_ident_sources ($ident);
- $attrs = {
- %$attrs,
+ my $attrs = {
+ %$orig_attrs,
select => $select,
from => $ident,
where => $where,
- $rs_alias && $alias2source->{$rs_alias}
- ? ( _rsroot_rsrc => $alias2source->{$rs_alias} )
- : ()
- ,
};
- # Sanity check the attributes (SQLMaker does it too, but
- # in case of a software_limit we'll never reach there)
- if (defined $attrs->{offset}) {
- $self->throw_exception('A supplied offset attribute must be a non-negative integer')
- if ( $attrs->{offset} =~ /\D/ or $attrs->{offset} < 0 );
- }
+ # MySQL actually recommends this approach. I cringe.
+ $attrs->{rows} ||= $sql_maker->__max_int
+ if $attrs->{offset};
- if (defined $attrs->{rows}) {
- $self->throw_exception("The rows attribute must be a positive integer if present")
- if ( $attrs->{rows} =~ /\D/ or $attrs->{rows} <= 0 );
+ # see if we will need to tear the prefetch apart to satisfy group_by == select
+ # this is *extremely tricky* to get right, I am still not sure I did
+ #
+ my ($prefetch_needs_subquery, @limit_args);
+
+ if ( $attrs->{_grouped_by_distinct} and $attrs->{collapse} ) {
+ # we already know there is a valid group_by (we made it) and we know it is
+ # intended to be based *only* on non-multi stuff
+ # short circuit the group_by parsing below
+ $prefetch_needs_subquery = 1;
+ }
+ elsif (
+ # The rationale is that even if we do *not* have collapse, we still
+ # need to wrap the core grouped select/group_by in a subquery
+ # so that databases that care about group_by/select equivalence
+ # are happy (this includes MySQL in strict_mode)
+ # If any of the other joined tables are referenced in the group_by
+ # however - the user is on their own
+ ( $prefetch_needs_subquery or ! $attrs->{_simple_passthrough_construction} )
+ and
+ $attrs->{group_by}
+ and
+ @{$attrs->{group_by}}
+ and
+ my $grp_aliases = dbic_internal_try { # internal_try{} because $attrs->{from} may be unreadable
+ $self->_resolve_aliastypes_from_select_args({ from => $attrs->{from}, group_by => $attrs->{group_by} })
+ }
+ ) {
+ # no aliases other than our own in group_by
+ # if there are - do not allow subquery even if limit is present
+ $prefetch_needs_subquery = ! scalar grep { $_ ne $attrs->{alias} } keys %{ $grp_aliases->{grouping} || {} };
}
- elsif ($attrs->{offset}) {
- # MySQL actually recommends this approach. I cringe.
- $attrs->{rows} = $sql_maker->__max_int;
+ elsif ( $attrs->{rows} && $attrs->{collapse} ) {
+ # active collapse with a limit - that one is a no-brainer unless
+ # overruled by a group_by above
+ $prefetch_needs_subquery = 1;
}
- my @limit;
-
- # see if we need to tear the prefetch apart otherwise delegate the limiting to the
- # storage, unless software limit was requested
- if (
- #limited has_many
- ( $attrs->{rows} && keys %{$attrs->{collapse}} )
- ||
- # grouped prefetch (to satisfy group_by == select)
- ( $attrs->{group_by}
- &&
- @{$attrs->{group_by}}
- &&
- $attrs->{_prefetch_selector_range}
- )
- ) {
- ($ident, $select, $where, $attrs)
- = $self->_adjust_select_args_for_complex_prefetch ($ident, $select, $where, $attrs);
+ if ($prefetch_needs_subquery) {
+ $attrs = $self->_adjust_select_args_for_complex_prefetch ($attrs);
}
elsif (! $attrs->{software_limit} ) {
- push @limit, (
+ push @limit_args, (
$attrs->{rows} || (),
$attrs->{offset} || (),
);
# try to simplify the joinmap further (prune unreferenced type-single joins)
if (
- ref $ident
+ ! $prefetch_needs_subquery # already pruned
and
- reftype $ident eq 'ARRAY'
+ ref $attrs->{from}
and
- @$ident != 1
+ reftype $attrs->{from} eq 'ARRAY'
+ and
+ @{$attrs->{from}} != 1
) {
- $ident = $self->_prune_unused_joins ($ident, $select, $where, $attrs);
+ ($attrs->{from}, $attrs->{_aliastypes}) = $self->_prune_unused_joins ($attrs);
}
+ # FIXME this is a gross, inefficient, largely incorrect and fragile hack
+ # during the result inflation stage we *need* to know what was the aliastype
+ # map as sqla saw it when the final pieces of SQL were being assembled
+ # Originally we simply carried around the entirety of $attrs, but this
+ # resulted in resultsets that are being reused growing continuously, as
+ # the hash in question grew deeper and deeper.
+ # Instead hand-pick what to take with us here (we actually don't need much
+ # at this point just the map itself)
+ $orig_attrs->{_last_sqlmaker_alias_map} = $attrs->{_aliastypes};
+
###
- # This would be the point to deflate anything found in $where
+ # my $alias2source = $self->_resolve_ident_sources ($ident);
+ #
+ # This would be the point to deflate anything found in $attrs->{where}
# (and leave $attrs->{bind} intact). Problem is - inflators historically
# expect a result object. And all we have is a resultsource (it is trivial
# to extract deflator coderefs via $alias2source above).
# invoked, and that's just bad...
###
- return ('select', $ident, $select, $where, $attrs, @limit);
+ return ( 'select', @{$attrs}{qw(from select where)}, $attrs, @limit_args );
}
# Returns a counting SELECT for a simple count
=cut
-sub _dbh_sth {
- my ($self, $dbh, $sql) = @_;
-
- # 3 is the if_active parameter which avoids active sth re-use
- my $sth = $self->disable_sth_caching
- ? $dbh->prepare($sql)
- : $dbh->prepare_cached($sql, {}, 3);
-
- # XXX You would think RaiseError would make this impossible,
- # but apparently that's not true :(
- $self->throw_exception(
- $dbh->errstr
- ||
- sprintf( "\$dbh->prepare() of '%s' through %s failed *silently* without "
- .'an exception and/or setting $dbh->errstr',
- length ($sql) > 20
- ? substr($sql, 0, 20) . '...'
- : $sql
- ,
- 'DBD::' . $dbh->{Driver}{Name},
- )
- ) if !$sth;
-
- $sth;
-}
-
-sub sth {
- carp_unique 'sth was mistakenly marked/documented as public, stop calling it (will be removed before DBIC v0.09)';
- shift->_sth(@_);
-}
-
-sub _sth {
- my ($self, $sql) = @_;
- $self->dbh_do('_dbh_sth', $sql); # retry over disconnects
-}
-
sub _dbh_columns_info_for {
my ($self, $dbh, $table) = @_;
- if ($dbh->can('column_info')) {
- my %result;
- my $caught;
- try {
+ my %result;
+
+ if (! DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE and $dbh->can('column_info')) {
+ dbic_internal_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;
+ } dbic_internal_catch {
+ %result = ();
};
- return \%result if !$caught && scalar keys %result;
+
+ return \%result if keys %result;
}
- my %result;
my $sth = $dbh->prepare($self->sql_maker->select($table, undef, \'1 = 0'));
$sth->execute;
- my @columns = @{$sth->{NAME_lc}};
- for my $i ( 0 .. $#columns ){
- my %column_info;
- $column_info{data_type} = $sth->{TYPE}->[$i];
- $column_info{size} = $sth->{PRECISION}->[$i];
- $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0;
-
- if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
- $column_info{data_type} = $1;
- $column_info{size} = $2;
+
+### The acrobatics with lc names is necessary to support both the legacy
+### API that used NAME_lc exclusively, *AND* at the same time work properly
+### with column names differing in cas eonly (thanks pg!)
+
+ my ($columns, $seen_lcs);
+
+ ++$seen_lcs->{lc($_)} and $columns->{$_} = {
+ idx => scalar keys %$columns,
+ name => $_,
+ lc_name => lc($_),
+ } for @{$sth->{NAME}};
+
+ $seen_lcs->{$_->{lc_name}} == 1
+ and
+ $_->{name} = $_->{lc_name}
+ for values %$columns;
+
+ for ( values %$columns ) {
+ my $inf = {
+ data_type => $sth->{TYPE}->[$_->{idx}],
+ size => $sth->{PRECISION}->[$_->{idx}],
+ is_nullable => $sth->{NULLABLE}->[$_->{idx}] ? 1 : 0,
+ };
+
+ if ($inf->{data_type} =~ m/^(.*?)\((.*?)\)$/) {
+ @{$inf}{qw( data_type size)} = ($1, $2);
}
- $result{$columns[$i]} = \%column_info;
+ $result{$_->{name}} = $inf;
}
+
$sth->finish;
- foreach my $col (keys %result) {
- my $colinfo = $result{$col};
- my $type_num = $colinfo->{data_type};
- my $type_name;
- if(defined $type_num && $dbh->can('type_info')) {
- my $type_info = $dbh->type_info($type_num);
- $type_name = $type_info->{TYPE_NAME} if $type_info;
- $colinfo->{data_type} = $type_name if $type_name;
+ if ($dbh->can('type_info')) {
+ for my $inf (values %result) {
+ next if ! defined $inf->{data_type};
+
+ $inf->{data_type} = (
+ (
+ (
+ $dbh->type_info( $inf->{data_type} )
+ ||
+ next
+ )
+ ||
+ next
+ )->{TYPE_NAME}
+ ||
+ next
+ );
+
+ # FIXME - this may be an artifact of the DBD::Pg implmentation alone
+ # needs more testing in the future...
+ $inf->{size} -= 4 if (
+ ( $inf->{size}||0 > 4 )
+ and
+ $inf->{data_type} =~ qr/^text$/i
+ );
}
+
}
return \%result;
sub _dbh_last_insert_id {
my ($self, $dbh, $source, $col) = @_;
- my $id = try { $dbh->last_insert_id (undef, undef, $source->name, $col) };
+ my $id = dbic_internal_try { $dbh->last_insert_id (undef, undef, $source->name, $col) };
return $id if defined $id;
# some drivers provide a $dbh attribute (e.g. Sybase and $dbh->{syb_dynamic_supported})
# but it is inaccurate more often than not
- return try {
+ ( dbic_internal_try {
local $dbh->{PrintError} = 0;
local $dbh->{RaiseError} = 1;
$dbh->do('select ?', {}, 1);
1;
- }
- catch {
- 0;
- };
+ } )
+ ? 1
+ : 0
+ ;
}
# Check if placeholders bound to non-string types throw exceptions
my $self = shift;
my $dbh = $self->_get_dbh;
- return try {
+ ( dbic_internal_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;
- };
+ } )
+ ? 1
+ : 0
+ ;
}
=head2 sqlt_type
See L<SQL::Translator/METHODS> for a list of values for C<\%sqlt_args>.
The most common value for this would be C<< { add_drop_table => 1 } >>
to have the SQL produced include a C<DROP TABLE> statement for each table
-created. For quoting purposes supply C<quote_table_names> and
-C<quote_field_names>.
+created. For quoting purposes supply C<quote_identifiers>.
If no arguments are passed, then the following default values are assumed:
sub create_ddl_dir {
my ($self, $schema, $databases, $version, $dir, $preversion, $sqltargs) = @_;
- unless ($dir) {
+ require DBIx::Class::Optional::Dependencies;
+ if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')) {
+ $self->throw_exception("Can't create a ddl file without $missing");
+ }
+
+ if (!$dir) {
carp "No directory given, using ./\n";
$dir = './';
- } else {
- -d $dir
- or
- (require File::Path and File::Path::mkpath (["$dir"])) # mkpath does not like objects (i.e. Path::Class::Dir)
- or
- $self->throw_exception(
- "Failed to create '$dir': " . ($! || $@ || 'error unknown')
- );
}
-
- $self->throw_exception ("Directory '$dir' does not exist\n") unless(-d $dir);
+ else {
+ mkdir_p( $dir ) unless -d $dir;
+ }
$databases ||= ['MySQL', 'SQLite', 'PostgreSQL'];
$databases = [ $databases ] if(ref($databases) ne 'ARRAY');
add_drop_table => 1,
ignore_constraint_names => 1,
ignore_index_names => 1,
+ quote_identifiers => $self->sql_maker->_quoting_enabled,
%{$sqltargs || {}}
};
- 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 );
$sqlt->parser('SQL::Translator::Parser::DBIx::Class');
unless $dest_schema->name;
}
- my $diff = SQL::Translator::Diff::schema_diff($source_schema, $db,
- $dest_schema, $db,
- $sqltargs
- );
+ my $diff = do {
+ # FIXME - this is a terrible workaround for
+ # https://github.com/dbsrgits/sql-translator/commit/2d23c1e
+ # Fixing it in this sloppy manner so that we don't hve to
+ # lockstep an SQLT release as well. Needs to be removed at
+ # some point, and SQLT dep bumped
+ local $SQL::Translator::Producer::SQLite::NO_QUOTES
+ if $SQL::Translator::Producer::SQLite::NO_QUOTES;
+
+ SQL::Translator::Diff::schema_diff($source_schema, $db,
+ $dest_schema, $db,
+ $sqltargs
+ );
+ };
+
if(!open $file, ">$difffile") {
$self->throw_exception("Can't write to $difffile ($!)");
next;
=back
-Returns the statements used by L</deploy> and L<DBIx::Class::Schema/deploy>.
+Returns the statements used by L<DBIx::Class::Storage/deploy>
+and L<DBIx::Class::Schema/deploy>.
The L<SQL::Translator> (not L<DBI>) database driver name can be explicitly
provided in C<$type>, otherwise the result of L</sqlt_type> is used as default.
sub deployment_statements {
my ($self, $schema, $type, $version, $dir, $sqltargs) = @_;
+
+ $self->throw_exception(
+ 'Calling deployment_statements() in void context makes no sense'
+ ) unless defined wantarray;
+
$type ||= $self->sqlt_type;
$version ||= $schema->schema_version || '1.x';
$dir ||= './';
return join('', @rows);
}
- 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') );
+ require DBIx::Class::Optional::Dependencies;
+ if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy') ) {
+ $self->throw_exception("Can't deploy without a pregenerated 'ddl_dir' directory or $missing");
}
- # sources needs to be a parser arg, but for simplicty allow at top level
+ # sources needs to be a parser arg, but for simplicity allow at top level
# coming in
$sqltargs->{parser_args}{sources} = delete $sqltargs->{sources}
if exists $sqltargs->{sources};
+ $sqltargs->{quote_identifiers} = $self->sql_maker->_quoting_enabled
+ unless exists $sqltargs->{quote_identifiers};
+
my $tr = SQL::Translator->new(
producer => "SQL::Translator::Producer::${type}",
%$sqltargs,
return if($line =~ /^COMMIT/m);
return if $line =~ /^\s+$/; # skip whitespace only
$self->_query_start($line);
- try {
+ dbic_internal_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 {
+ } dbic_internal_catch {
carp qq{$_ (running "${line}")};
};
$self->_query_end($line);
cases if you choose the C<< AutoCommit => 0 >> path, just as you would
be with raw DBI.
+=head1 FURTHER QUESTIONS?
-=head1 AUTHOR AND CONTRIBUTORS
+Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
-See L<AUTHOR|DBIx::Class/AUTHOR> and L<CONTRIBUTORS|DBIx::Class/CONTRIBUTORS> in DBIx::Class
+=head1 COPYRIGHT AND LICENSE
-=head1 LICENSE
-
-You may distribute this code under the same terms as Perl itself.
-
-=cut
+This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
+by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
+redistribute it and/or modify it under the same terms as the
+L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.
projects / dbsrgits/DBIx-Class.git / blobdiff