X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=99a895e8e92527ac2d2babde5336a08ac202718a;hb=c6ec79000b160e7491d9ab9d95d6e69c473b0862;hp=570cf2b32230f5ac20523c39586fb677d4b6d702;hpb=560978e22520434c67eebb2de72f0e571e47ee40;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 570cf2b..99a895e 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -9,13 +9,14 @@ use mro 'c3'; use DBIx::Class::Carp; 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 @@ -33,7 +34,7 @@ __PACKAGE__->datetime_parser_type('DateTime::Format::MySQL'); # historic default __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 /); @@ -80,24 +81,35 @@ __PACKAGE__->_use_join_optimizer (1); 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 @@ -105,37 +117,45 @@ my @rdbms_specific_methods = qw/ _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 @@ -195,22 +215,42 @@ sub new { 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) @@ -219,44 +259,52 @@ sub new { for (@instances) { $_->_dbh(undef); - - $_->transaction_depth(0); - $_->savepoints([]); + $_->disconnect; # properly renumber existing refs $_->_arm_global_destructor } + + # 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(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 @@ -601,23 +649,6 @@ sub 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} || {} }, @@ -626,26 +657,68 @@ sub connect_info { 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; @@ -781,11 +854,11 @@ Example: 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, @_) @@ -798,10 +871,15 @@ sub dbh_do { 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 { @@ -817,23 +895,41 @@ database is not in C mode. =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 + + my $g = scope_guard { + + 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([]); - push @actions, ( $self->on_disconnect_call || () ); - push @actions, $self->_parse_connect_do ('on_disconnect_do'); + # FIXME - this needs reenabling with the proper "no reset on same DSN" check + #$self->_sql_maker(undef); # this may also end up being different + }; - $self->_do_connection_actions(disconnect_call_ => $_) for @actions; + 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); } + + # 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 @@ -853,8 +949,8 @@ in MySQL's case disabled entirely. # Storage subclasses should override this sub with_deferred_fk_checks { - my ($self, $sub) = @_; - $sub->(); + #my ($self, $sub) = @_; + $_[1]->(); } =head2 connected @@ -874,40 +970,34 @@ answering, etc.) This method is used internally by L. =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; - - $self->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; + $_[0]->_verify_pid unless DBIx::Class::_ENV_::BROKEN_FORK; - my $dbh = $self->_dbh - or return 0; + $_[0]->_dbh + and + $_[0]->_dbh->FETCH('Active') + and + return 1; - 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 @@ -921,26 +1011,26 @@ instead. =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; @@ -952,13 +1042,13 @@ sub sql_maker { || 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'; } @@ -969,7 +1059,7 @@ sub sql_maker { 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 ' @@ -1000,33 +1090,32 @@ sub _rebless {} 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 ); - $self->_run_connection_actions unless $self->{_in_determine_driver}; + $_[0]->_run_connection_actions unless $_[0]->{_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'), + ); } @@ -1071,14 +1160,20 @@ sub get_dbms_capability { 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 { - $info = {}; + # this guarantees that problematic conninfo won't be hidden + # by the try{} below + $self->ensure_connected; - my $server_version = try { + my $info = {}; + + 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}; @@ -1111,9 +1206,7 @@ sub _server_info { } $self->_dbh_details->{info} = $info; - } - - return $info; + }; } sub _get_server_version { @@ -1124,27 +1217,41 @@ sub _dbh_get_info { 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/ @@ -1180,7 +1287,7 @@ sub _describe_connection { ) { # some drivers barf on things they do not know about instead # of returning undef - my $v = try { $self->_dbh_get_info($inf) }; + 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} ); @@ -1196,7 +1303,9 @@ sub _determine_driver { 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; @@ -1205,26 +1314,23 @@ sub _determine_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(); } @@ -1252,7 +1358,7 @@ sub _determine_driver { "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 ); } @@ -1263,10 +1369,44 @@ sub _determine_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) + # + # 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( @@ -1293,37 +1433,54 @@ sub _determine_connector_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; } @@ -1338,7 +1495,19 @@ sub disconnect_call_do_sql { $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 + + 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 { @@ -1369,22 +1538,47 @@ sub _do_query { } sub _connect { - my ($self, @info) = @_; + my $self = shift; + + my $info = $self->_dbi_connect_info; - $self->throw_exception("You failed to provide any connection info") - if !@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); } die $DBI::errstr unless $dbh; @@ -1392,8 +1586,8 @@ sub _connect { 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'); @@ -1408,7 +1602,7 @@ sub _connect { # 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 " @@ -1421,50 +1615,29 @@ sub _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 { @@ -1485,9 +1658,8 @@ 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') ) { @@ -1516,9 +1688,10 @@ sub _exec_txn_commit { 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') ) { @@ -1544,17 +1717,12 @@ sub _exec_txn_rollback { 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 @@ -1573,37 +1741,41 @@ sub _gen_sql_bind { $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}) { @@ -1620,24 +1792,22 @@ sub _resolve_bindattrs { }; 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 ]; } @@ -1651,7 +1821,7 @@ sub _format_for_trace { map { defined( $_ && $_->[1] ) - ? qq{'$_->[1]'} + ? sprintf( "'%s'", "$_->[1]" ) # because overload : q{NULL} } @{$_[1] || []}; } @@ -1671,31 +1841,28 @@ sub _query_end { } 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}}; - return \@attrs; + $cache->{$_->{sqlt_datatype}}; + + } } map { $_->[0] } @{$_[2]} ]; } sub _execute { @@ -1776,14 +1943,15 @@ sub _bind_sth_params { ); } 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], '""') ) + # 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, + # The temp-var is CRUCIAL - DO NOT REMOVE IT, breaks older DBD::SQLite RT#79576 $v, $bind_attrs->[$i], ); @@ -1804,9 +1972,7 @@ 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( @@ -1832,22 +1998,44 @@ sub insert { # 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 ( @@ -1857,6 +2045,35 @@ sub insert { ); }; + # 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; @@ -1874,12 +2091,30 @@ sub insert { 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; } @@ -1896,7 +2131,7 @@ sub insert { 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 @@ -1923,26 +2158,28 @@ sub insert { } 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 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], '""') ); - } - } + 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 ; @@ -1968,17 +2205,17 @@ sub insert_bulk { # 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( @@ -1987,23 +2224,23 @@ sub insert_bulk { # 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] ] ]; } } @@ -2014,11 +2251,11 @@ sub insert_bulk { [ $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 @@ -2031,24 +2268,23 @@ sub insert_bulk { $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')", @@ -2064,8 +2300,8 @@ sub insert_bulk { ); } } - 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); } } @@ -2092,16 +2328,17 @@ sub insert_bulk { } # 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, @@ -2118,7 +2355,7 @@ sub insert_bulk { # scope guard my $guard = $self->txn_scope_guard; - $self->_query_start( $sql, @$proto_bind ? [[undef => '__BULK_INSERT__' ]] : () ); + $self->_query_start( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () ); my $sth = $self->_prepare_sth($self->_dbh, $sql); my $rv = do { if (@$proto_bind) { @@ -2132,7 +2369,7 @@ sub insert_bulk { } }; - $self->_query_end( $sql, @$proto_bind ? [[ undef => '__BULK_INSERT__' ]] : () ); + $self->_query_end( $sql, @$proto_bind ? [[ {} => '__BULK_INSERT__' ]] : () ); $guard->commit; @@ -2146,16 +2383,13 @@ sub insert_bulk { 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], @@ -2175,23 +2409,41 @@ sub _dbh_execute_for_fetch { 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; }; @@ -2204,10 +2456,10 @@ sub _dbh_execute_for_fetch { ); # Statement must finish even if there was an exception. - try { + dbic_internal_try { $sth->finish } - catch { + dbic_internal_catch { $err = shift unless defined $err }; @@ -2218,10 +2470,9 @@ sub _dbh_execute_for_fetch { $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) }, ); } @@ -2232,22 +2483,22 @@ sub _dbh_execute_inserts_with_no_binds { 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; }; @@ -2293,40 +2544,31 @@ sub _select_args_to_query { } 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 = $self->_resolve_ident_sources ($ident); - $attrs = { - %$attrs, + my $attrs = { + %$orig_attrs, select => $select, from => $ident, where => $where, - - # limit dialects use this stuff - # yes, some CDBICompat crap does not supply an {alias} >.< - ( $attrs->{alias} and $alias2source->{$attrs->{alias}} ) - ? ( _rsroot_rsrc => $alias2source->{$attrs->{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 ); - } - - 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 ); - } - elsif ($attrs->{offset}) { - # MySQL actually recommends this approach. I cringe. - $attrs->{rows} = $sql_maker->__max_int; - } + # MySQL actually recommends this approach. I cringe. + $attrs->{rows} ||= $sql_maker->__max_int + if $attrs->{offset}; # 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 @@ -2334,8 +2576,8 @@ sub _select_args { 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; } @@ -2346,14 +2588,14 @@ sub _select_args { # 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->{_related_results_construction} ) + ( $prefetch_needs_subquery or ! $attrs->{_simple_passthrough_construction} ) and $attrs->{group_by} and @{$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} } ) + 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 @@ -2367,8 +2609,7 @@ sub _select_args { } 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, ( @@ -2381,17 +2622,29 @@ sub _select_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 = $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). @@ -2400,7 +2653,7 @@ sub _select_args { # invoked, and that's just bad... ### - return ('select', $ident, $select, $where, $attrs, @limit_args); + return ( 'select', @{$attrs}{qw(from select where)}, $attrs, @limit_args ); } # Returns a counting SELECT for a simple count @@ -2455,10 +2708,10 @@ see L. 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(); @@ -2473,40 +2726,76 @@ sub _dbh_columns_info_for { $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; @@ -2526,7 +2815,7 @@ Return the row id of the last insert. 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; @@ -2577,15 +2866,15 @@ sub _determine_supports_placeholders { # 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 @@ -2594,16 +2883,16 @@ sub _determine_supports_typeless_placeholders { 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 @@ -2713,20 +3002,18 @@ them. 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'); @@ -2738,13 +3025,10 @@ sub create_ddl_dir { 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'); @@ -2832,10 +3116,21 @@ sub create_ddl_dir { 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; @@ -2853,7 +3148,8 @@ sub create_ddl_dir { =back -Returns the statements used by L and L. +Returns the statements used by L +and L. The L (not L) database driver name can be explicitly provided in C<$type>, otherwise the result of L is used as default. @@ -2871,6 +3167,11 @@ See L for a list of values for C<$sqlt_args>. 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 ||= './'; @@ -2886,15 +3187,19 @@ sub deployment_statements { 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, @@ -2923,11 +3228,11 @@ sub deploy { 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); @@ -3127,13 +3432,13 @@ transactions. You're on your own for handling all sorts of exceptional cases if you choose the C<< AutoCommit => 0 >> path, just as you would be with raw DBI. +=head1 FURTHER QUESTIONS? -=head1 AUTHOR AND CONTRIBUTORS - -See L and L in DBIx::Class +Check the list of L. -=head1 LICENSE +=head1 COPYRIGHT AND LICENSE -You may distribute this code under the same terms as Perl itself. - -=cut +This module is free software L +by the L. You can +redistribute it and/or modify it under the same terms as the +L.