use Sub::Name 'subname';
use Context::Preserve 'preserve_context';
use Try::Tiny;
-use overload ();
use Data::Compare (); # no imports!!! guard against insane architecture
+use DBIx::Class::_Util qw(is_plain_value is_literal_value);
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
- deployment_statements
+ 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
_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/;
+ no strict 'refs';
+ no warnings 'redefine';
*{__PACKAGE__ ."::$meth"} = subname $meth => sub {
if (
# only fire when invoked on an instance, a valid class-based invocation
and
! $_[0]->{_in_determine_driver}
and
- ($_[0]->_dbi_connect_info||[])->[0]
+ # if this is a known *setter* - just set it, no need to connect
+ # and determine the driver
+ ! ( $storage_accessor_idx->{$meth} and @_ > 1 )
+ 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;
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]
);
$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} || {} },
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
#
DBIx::Class::Storage::BlockRunner->new(
storage => $self,
- run_code => sub { $self->$run_target ($self->_get_dbh, @$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 {
return $self->_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;
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
+ $self->_sql_maker(undef); # this may also end up being different
- $self->_dbh($self->_connect(@info));
+ $self->_dbh($self->_connect);
$self->_conn_pid($$) unless DBIx::Class::_ENV_::BROKEN_FORK; # on win32 these are in fact threads
require DBI::Const::GetInfoReturn;
my $self = shift;
- $self->ensure_connected;
+
+ my $drv;
+ 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 => 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/
$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) {
}
}
+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)
+ ($drv) = ($self->_dbi_connect_info->[0] || '') =~ /^dbi:([^:]+):/i;
+ $drv ||= $ENV{DBI_DRIVER};
+ }
+
+ return $drv;
+}
+
sub _determine_connector_driver {
my ($self, $conn) = @_;
}
sub _connect {
- my ($self, @info) = @_;
+ my $self = shift;
+
+ my $info = $self->_dbi_connect_info;
$self->throw_exception("You did not provide any connection_info")
- if ( ! defined $info[0] and ! $ENV{DBI_DSN} and ! $ENV{DBI_DRIVER} );
+ unless defined $info->[0];
my ($old_connect_via, $dbh);
local $DBI::connect_via = 'connect' if $INC{'Apache/DBI.pm'} && $ENV{MOD_PERL};
+ # 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__';
+ };
+
try {
- if(ref $info[0] eq 'CODE') {
- $dbh = $info[0]->();
+ if(ref $info->[0] eq 'CODE') {
+ $dbh = $info->[0]->();
}
else {
require DBI;
- $dbh = DBI->connect(@info);
+ $dbh = DBI->connect(@$info);
}
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"
+ ref $info->[0] eq 'CODE'
+ ? "Connection coderef $info->[0] returned a"
: 'DBI->connect($schema->storage->connect_info) resulted in a'
) unless $dbh->FETCH('Active');
# 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 {
};
$self->_dbh_autocommit($dbh->{AutoCommit});
- $dbh;
+ return $dbh;
}
sub txn_begin {
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}) {
my $resolved =
( ref $_ ne 'ARRAY' or @$_ != 2 ) ? [ {}, $_ ]
: ( ! defined $_->[0] ) ? [ {}, $_->[1] ]
- : (ref $_->[0] eq 'HASH') ? [ (exists $_->[0]{dbd_attrs} or $_->[0]{sqlt_datatype})
- ? $_->[0]
- : $resolve_bindinfo->($_->[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] }
and
length ref $resolved->[1]
and
- ! overload::Method($resolved->[1], '""')
+ ! is_plain_value $resolved->[1]
) {
require Data::Dumper;
local $Data::Dumper::Maxdepth = 1;
);
}
else {
- # FIXME SUBOPTIMAL - most likely this is not necessary at all
- # confirm with dbi-dev whether explicit stringification is needed
- my $v = ( length ref $bind->[$i][1] and overload::Method($bind->[$i][1], '""') )
- ? "$bind->[$i][1]"
- : $bind->[$i][1]
- ;
$sth->bind_param(
$i + 1,
- $v,
+ $bind->[$i][1],
$bind_attrs->[$i],
);
}
(
! 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(
}
# 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 (
+ defined $to_insert->{$col} and ! 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 (
my @col_range = (0..$#$cols);
- # FIXME SUBOPTIMAL - most likely this is not necessary at all
- # confirm with dbi-dev whether explicit stringification is needed
- #
- # 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 ( length ref $data->[$r][$c] and overload::Method($data->[$r][$c], '""') );
- }
- }
-
my $colinfos = $source->columns_info($cols);
local $self->{_autoinc_supplied_for_op} =
}
}
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') ) {
+ if (is_literal_value($val)) {
$bad_slice_report_cref->("Literal SQL found where a plain bind value is expected", $row_idx, $col_idx);
}
}
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 {
+ ! 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]
+
+ } map { $_->[0] } @$proto_bind ];
};
my $tuple_status = [];
# soooooo much better now. But that is also another
# battle...
#return (
- # 'select', @{$orig_attrs->{_sqlmaker_select_args}}
- #) if $orig_attrs->{_sqlmaker_select_args};
+ # '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 = $self->_resolve_ident_sources ($ident);
my ($prefetch_needs_subquery, @limit_args);
if ( $attrs->{_grouped_by_distinct} and $attrs->{collapse} ) {
- # we already know there is a valid group_by and we know it is intended
- # to be based *only* on the main result columns
+ # 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;
}
@{$attrs->{group_by}}
and
my $grp_aliases = try { # try{} because $attrs->{from} may be unreadable
- $self->_resolve_aliastypes_from_select_args( $attrs->{from}, undef, undef, { group_by => $attrs->{group_by} } )
+ $self->_resolve_aliastypes_from_select_args({ from => $attrs->{from}, group_by => $attrs->{group_by} })
}
) {
# no aliases other than our own in group_by
}
if ($prefetch_needs_subquery) {
- ($ident, $select, $where, $attrs) =
- $self->_adjust_select_args_for_complex_prefetch ($ident, $select, $where, $attrs);
+ $attrs = $self->_adjust_select_args_for_complex_prefetch ($attrs);
}
elsif (! $attrs->{software_limit} ) {
push @limit_args, (
if (
! $prefetch_needs_subquery # already pruned
and
- ref $ident
+ ref $attrs->{from}
and
- reftype $ident eq 'ARRAY'
+ reftype $attrs->{from} eq 'ARRAY'
and
- @$ident != 1
+ @{$attrs->{from}} != 1
) {
- ($ident, $attrs->{_aliastypes}) = $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
+ # 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', @{ $orig_attrs->{_sqlmaker_select_args} = [
- $ident, $select, $where, $attrs, @limit_args
- ]} );
+ return ( 'select', @{$attrs}{qw(from select where)}, $attrs, @limit_args );
}
# Returns a counting SELECT for a simple count