X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI.pm;h=9da3bd9bacd10f3027b390670f9fd91231031aa7;hb=7648acb5dd1f2f281ca84e2152efe314bcbf2c70;hp=7c7c5c23c3c0428d3c7a26112145115929b137b2;hpb=729656c504e5ca25cfebfbbbce69bb1e74268ef6;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 7c7c5c2..9da3bd9 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -9,11 +9,15 @@ use mro 'c3'; use DBIx::Class::Carp; use Scalar::Util qw/refaddr weaken reftype blessed/; -use List::Util qw/first/; use Context::Preserve 'preserve_context'; use Try::Tiny; use SQL::Abstract qw(is_plain_value is_literal_value); -use DBIx::Class::_Util qw(quote_sub perlstring serialize detected_reinvoked_destructor scope_guard); +use DBIx::Class::_Util qw( + quote_sub perlstring serialize dump_value + dbic_internal_try + detected_reinvoked_destructor scope_guard + mkdir_p +); use namespace::clean; # default cursor class, overridable in connect_info attributes @@ -221,6 +225,11 @@ sub new { 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 { @@ -235,9 +244,14 @@ sub new { # 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) @@ -251,6 +265,11 @@ sub new { # 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; } } @@ -266,11 +285,10 @@ sub DESTROY { $_[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 @@ -284,7 +302,10 @@ sub _verify_pid { $_[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 @@ -881,6 +902,10 @@ sub disconnect { # 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); @@ -891,7 +916,7 @@ sub disconnect { #$self->_sql_maker(undef); # this may also end up being different }; - if( my $dbh = $self->_dbh ) { + if( $self->_dbh ) { $self->_do_connection_actions(disconnect_call_ => $_) for ( ( $self->on_disconnect_call || () ), @@ -900,11 +925,12 @@ sub disconnect { # stops the "implicit rollback on disconnect" warning $self->_exec_txn_rollback unless $self->_dbh_autocommit; - - %{ $dbh->{CachedKids} } = (); - - $dbh->disconnect; } + + # 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 @@ -1146,7 +1172,7 @@ sub _server_info { my $info = {}; - my $server_version = try { + my $server_version = dbic_internal_try { $self->_get_server_version } catch { # driver determination *may* use this codepath @@ -1207,7 +1233,7 @@ sub _describe_connection { my $self = shift; my $drv; - try { + dbic_internal_try { $drv = $self->_extract_driver_from_connect_info; $self->ensure_connected; }; @@ -1221,7 +1247,7 @@ sub _describe_connection { DBIC_DRIVER => ref $self, $drv ? ( DBD => $drv, - DBD_VER => try { $drv->VERSION }, + DBD_VER => dbic_internal_try { $drv->VERSION }, ) : (), }; @@ -1262,7 +1288,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} ); @@ -1278,7 +1304,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; @@ -1293,7 +1321,17 @@ sub _determine_driver { 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(); } @@ -1350,7 +1388,16 @@ sub _extract_driver_from_connect_info { # 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; + # + # 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}; } @@ -1392,19 +1439,17 @@ 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, $method_prefix, $call, @args) = @_; - try { + dbic_internal_try { if (not ref($call)) { my $method = $method_prefix . $call; $self->$method(@args); @@ -1528,7 +1573,7 @@ sub _connect { }, '__DBIC__DBH__ERROR__HANDLER__'; }; - try { + dbic_internal_try { if(ref $info->[0] eq 'CODE') { $dbh = $info->[0]->(); } @@ -1709,7 +1754,7 @@ sub _gen_sql_bind { and $op eq 'select' and - first { + grep { length ref $_->[1] and blessed($_->[1]) @@ -1779,7 +1824,7 @@ sub _format_for_trace { map { defined( $_ && $_->[1] ) - ? qq{'$_->[1]'} + ? sprintf( "'%s'", "$_->[1]" ) # because overload : q{NULL} } @{$_[1] || []}; } @@ -1998,7 +2043,7 @@ sub insert { if (my $retlist = $sqla_opts->{returning}) { # if IR is supported - we will get everything in one set unless( @ir_container ) { - try { + dbic_internal_try { # FIXME - need to investigate why Caelum silenced this in 4d4dc518 local $SIG{__WARN__} = sub {}; @@ -2173,13 +2218,12 @@ 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][$_] } 0..$#$cols - }), + }; } ); }; @@ -2343,7 +2387,7 @@ sub _dbh_execute_for_fetch { my $tuple_status = []; my ($rv, $err); - try { + dbic_internal_try { $rv = $sth->execute_for_fetch( $fetch_tuple, $tuple_status, @@ -2362,7 +2406,7 @@ sub _dbh_execute_for_fetch { ); # Statement must finish even if there was an exception. - try { + dbic_internal_try { $sth->finish } catch { @@ -2376,10 +2420,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) }, ); } @@ -2390,7 +2433,7 @@ 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; @@ -2402,7 +2445,7 @@ sub _dbh_execute_inserts_with_no_binds { }; # Make sure statement is finished even if there was an exception. - try { + dbic_internal_try { $sth->finish } catch { @@ -2501,7 +2544,7 @@ sub _select_args { and @{$attrs->{group_by}} and - my $grp_aliases = try { # try{} because $attrs->{from} may be unreadable + 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} }) } ) { @@ -2618,7 +2661,7 @@ sub _dbh_columns_info_for { my %result; if (! DBIx::Class::_ENV_::STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE and $dbh->can('column_info')) { - try { + dbic_internal_try { my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table); my $sth = $dbh->column_info( undef,$schema, $tab, '%' ); $sth->execute(); @@ -2722,7 +2765,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; @@ -2773,15 +2816,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 @@ -2790,16 +2833,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 @@ -2909,20 +2952,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'); @@ -2938,10 +2979,6 @@ sub create_ddl_dir { %{$sqltargs || {}} }; - if (my $missing = DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')) { - $self->throw_exception("Can't create a ddl file without $missing"); - } - my $sqlt = SQL::Translator->new( $sqltargs ); $sqlt->parser('SQL::Translator::Parser::DBIx::Class'); @@ -3080,6 +3117,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 ||= './'; @@ -3095,6 +3137,7 @@ sub deployment_statements { return join('', @rows); } + 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"); } @@ -3135,7 +3178,7 @@ 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) });