From: Brandon L. Black Date: Mon, 31 Jul 2006 20:31:20 +0000 (+0000) Subject: Merge 'trunk' into 'DBIx-Class-current' X-Git-Tag: v0.08010~43^2~37 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a9196897efe0c699d743adcf41ba5ebcdaf30931;hp=c531250af90355104b6323c78e389ca55504b73d;p=dbsrgits%2FDBIx-Class.git Merge 'trunk' into 'DBIx-Class-current' r11259@evoc8 (orig r2634): ningu | 2006-07-27 01:22:57 -0500 add result_class to ResultSourceProxy; move _ident_cond into CDBI code, not needed elsewhere r11260@evoc8 (orig r2635): ningu | 2006-07-27 01:32:47 -0500 small cleanup to ResultSourceProxy r11261@evoc8 (orig r2636): castaway | 2006-07-27 02:13:53 -0500 Add some new docs r11262@evoc8 (orig r2637): castaway | 2006-07-27 02:28:11 -0500 Documentation improvements r13028@evoc8 (orig r2641): dwc | 2006-07-27 22:19:58 -0500 Add previous changes for 0.07001 r13029@evoc8 (orig r2642): dwc | 2006-07-27 22:30:28 -0500 Remove anonymous blesses to avoid major speed hit on Fedora Core 5, or 'the anti-dead-rat fix' r13030@evoc8 (orig r2643): dwc | 2006-07-27 23:14:05 -0500 Pass attrs to find from update_or_create (reported by Nathan Kurz) r13031@evoc8 (orig r2644): dwc | 2006-07-27 23:20:15 -0500 Typo in scalar ref example r13032@evoc8 (orig r2645): dwc | 2006-07-27 23:25:35 -0500 Add missing quote to example. I looked over this last night, but I guess my eyes aren't working as well anymore. r13033@evoc8 (orig r2646): dwc | 2006-07-27 23:55:37 -0500 Minor test cleanup (I think I'm losing my mind) r13092@evoc8 (orig r2650): blblack | 2006-07-31 15:31:05 -0500 added Cwd 3.19 + Alg::C3 0.02 to requirements --- diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index b6a089c..8e0c929 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -13,7 +13,7 @@ sub component_base_class { 'DBIx::Class' } # i.e. first release of 0.XX *must* be 0.XX000. This avoids fBSD ports # brain damage and presumably various other packaging systems too -$VERSION = '0.07000'; +$VERSION = '0.07999_01'; sub MODIFY_CODE_ATTRIBUTES { my ($class,$code,@attrs) = @_; diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm index 659948f..f498490 100644 --- a/lib/DBIx/Class/ResultSource.pm +++ b/lib/DBIx/Class/ResultSource.pm @@ -12,7 +12,7 @@ __PACKAGE__->load_components(qw/AccessorGroup/); __PACKAGE__->mk_group_accessors('simple' => qw/_ordered_columns _columns _primaries _unique_constraints name resultset_attributes - schema from _relationships source_name/); + schema from _relationships column_info_from_storage source_name/); __PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class result_class/); @@ -184,6 +184,7 @@ sub column_info { unless exists $self->_columns->{$column}; #warn $self->{_columns_info_loaded}, "\n"; if ( ! $self->_columns->{$column}{data_type} + and $self->column_info_from_storage and ! $self->{_columns_info_loaded} and $self->schema and $self->storage ) { @@ -204,6 +205,15 @@ sub column_info { return $self->_columns->{$column}; } +=head2 load_column_info_from_storage + +Enables the on-demand automatic loading of the above column +metadata from storage as neccesary. + +=cut + +sub load_column_info_from_storage { shift->column_info_from_storage(1) } + =head2 columns my @column_names = $obj->columns; diff --git a/lib/DBIx/Class/ResultSourceProxy.pm b/lib/DBIx/Class/ResultSourceProxy.pm index a668164..c1d6164 100644 --- a/lib/DBIx/Class/ResultSourceProxy.pm +++ b/lib/DBIx/Class/ResultSourceProxy.pm @@ -34,6 +34,10 @@ sub column_info { shift->result_source_instance->column_info(@_); } +sub load_column_info_from_storage { + shift->result_source_instance->load_column_info_from_storage; +} + sub columns { shift->result_source_instance->columns(@_); } diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index d35b211..3641f3c 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -12,6 +12,7 @@ __PACKAGE__->mk_classdata('class_mappings' => {}); __PACKAGE__->mk_classdata('source_registrations' => {}); __PACKAGE__->mk_classdata('storage_type' => '::DBI'); __PACKAGE__->mk_classdata('storage'); +__PACKAGE__->mk_classdata('exception_action'); =head1 NAME @@ -452,7 +453,7 @@ sub connection { $self->throw_exception( "No arguments to load_classes and couldn't load ${storage_class} ($@)" ) if $@; - my $storage = $storage_class->new; + my $storage = $storage_class->new($self); $storage->connect_info(\@info); $self->storage($storage); return $self; @@ -633,6 +634,7 @@ sub clone { my $new = $source->new($source); $clone->register_source($moniker => $new); } + $clone->storage->set_schema($clone) if $clone->storage; return $clone; } @@ -672,6 +674,38 @@ sub populate { return @created; } +=head2 exception_action + +=over 4 + +=item Arguments: $code_reference + +=back + +If C is set for this class/object, L +will prefer to call this code reference with the exception as an argument, +rather than its normal action. + +Your subroutine should probably just wrap the error in the exception +object/class of your choosing and rethrow. If, against all sage advice, +you'd like your C to suppress a particular exception +completely, simply have it return true. + +Example: + + package My::Schema; + use base qw/DBIx::Class::Schema/; + use My::ExceptionClass; + __PACKAGE__->exception_action(sub { My::ExceptionClass->throw(@_) }); + __PACKAGE__->load_classes; + + # or: + my $schema_obj = My::Schema->connect( .... ); + $schema_obj->exception_action(sub { My::ExceptionClass->throw(@_) }); + + # suppress all exceptions, like a moron: + $schema_obj->exception_action(sub { 1 }); + =head2 throw_exception =over 4 @@ -681,13 +715,14 @@ sub populate { =back Throws an exception. Defaults to using L to report errors from -user's perspective. +user's perspective. See L for details on overriding +this method's behavior. =cut sub throw_exception { - my ($self) = shift; - croak @_; + my $self = shift; + croak @_ if !$self->exception_action || !$self->exception_action->(@_); } =head2 deploy (EXPERIMENTAL) diff --git a/lib/DBIx/Class/Storage.pm b/lib/DBIx/Class/Storage.pm index 735006c..2efc930 100644 --- a/lib/DBIx/Class/Storage.pm +++ b/lib/DBIx/Class/Storage.pm @@ -5,6 +5,7 @@ use strict; use warnings; sub new { die "Virtual method!" } +sub set_schema { die "Virtual method!" } sub debug { die "Virtual method!" } sub debugcb { die "Virtual method!" } sub debugfh { die "Virtual method!" } diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm index 5984c94..22aa2c1 100644 --- a/lib/DBIx/Class/Storage/DBI.pm +++ b/lib/DBIx/Class/Storage/DBI.pm @@ -10,6 +10,7 @@ use SQL::Abstract::Limit; use DBIx::Class::Storage::DBI::Cursor; use DBIx::Class::Storage::Statistics; use IO::File; +use Scalar::Util qw/weaken/; use Carp::Clan qw/DBIx::Class/; BEGIN { @@ -256,7 +257,7 @@ __PACKAGE__->load_components(qw/AccessorGroup/); __PACKAGE__->mk_group_accessors('simple' => qw/_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid _conn_tid - debug debugobj cursor on_connect_do transaction_depth/); + debug debugobj cursor on_connect_do transaction_depth schema/); =head1 NAME @@ -272,12 +273,16 @@ This class represents the connection to the database =head2 new +Constructor. Only argument is the schema which instantiated us. + =cut sub new { + my ($self, $schema) = @_; + my $new = {}; bless $new, (ref $_[0] || $_[0]); - + $new->set_schema($schema); $new->cursor("DBIx::Class::Storage::DBI::Cursor"); $new->transaction_depth(0); @@ -300,6 +305,20 @@ sub new { return $new; } +=head2 set_schema + +Used to reset the schema class or object which owns this +storage object, such as after a C. + +=cut + +sub set_schema { + my ($self, $schema) = @_; + $self->schema($schema); + weaken($self->{schema}) if ref $self->{schema}; +} + + =head2 throw_exception Throws an exception - croaks. @@ -307,8 +326,10 @@ Throws an exception - croaks. =cut sub throw_exception { - my ($self, $msg) = @_; - croak($msg); + my $self = shift; + + $self->schema->throw_exception(@_) if $self->schema; + croak @_; } =head2 connect_info @@ -369,6 +390,12 @@ Every time C is invoked, any previous settings for these options will be cleared before setting the new ones, regardless of whether any options are specified in the new C. +Important note: DBIC expects the returned database handle provided by +a subref argument to have RaiseError set on it. If it doesn't, things +might not work very well, YMMV. If you don't use a subref, DBIC will +force this setting for you anyways. Setting HandleError to anything +other than simple exception object wrapper might cause problems too. + Examples: # Simple SQLite connection @@ -464,6 +491,54 @@ sub debugcb { } } +=head2 dbh_do + +Execute the given subref with the underlying database handle as its +first argument, using the new exception-based connection management. +Example: + + my @stuff = $schema->storage->dbh_do( + sub { + shift->selectrow_array("SELECT * FROM foo") + } + ); + +=cut + +sub dbh_do { + my ($self, $todo) = @_; + + my @result; + my $want_array = wantarray; + + eval { + $self->_verify_pid if $self->_dbh; + $self->_populate_dbh if !$self->_dbh; + my $dbh = $self->_dbh; + if($want_array) { + @result = $todo->($dbh); + } + elsif(defined $want_array) { + $result[0] = $todo->($dbh); + } + else { + $todo->($dbh); + } + }; + + if($@) { + my $exception = $@; + $self->connected + ? $self->throw_exception($exception) + : $self->_populate_dbh; + + my $dbh = $self->_dbh; + return $todo->($dbh); + } + + return $want_array ? @result : $result[0]; +} + =head2 disconnect Disconnect the L handle, performing a rollback first if the @@ -488,15 +563,15 @@ is connected. =cut -sub connected { my ($self) = @_; +sub connected { + my ($self) = @_; if(my $dbh = $self->_dbh) { if(defined $self->_conn_tid && $self->_conn_tid != threads->tid) { return $self->_dbh(undef); } - elsif($self->_conn_pid != $$) { - $self->_dbh->{InactiveDestroy} = 1; - return $self->_dbh(undef); + else { + $self->_verify_pid; } return ($dbh->FETCH('Active') && $dbh->ping); } @@ -504,6 +579,19 @@ sub connected { my ($self) = @_; return 0; } +# handle pid changes correctly +# NOTE: assumes $self->_dbh is a valid $dbh +sub _verify_pid { + my ($self) = @_; + + return if $self->_conn_pid == $$; + + $self->_dbh->{InactiveDestroy} = 1; + $self->_dbh(undef); + + return; +} + =head2 ensure_connected Check whether the database handle is connected - if not then make a @@ -556,32 +644,30 @@ sub sql_maker { sub connect_info { my ($self, $info_arg) = @_; - if($info_arg) { - # 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({}); - - my $info = [ @$info_arg ]; # copy because we can alter it - my $last_info = $info->[-1]; - if(ref $last_info eq 'HASH') { - if(my $on_connect_do = delete $last_info->{on_connect_do}) { - $self->on_connect_do($on_connect_do); - } - for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) { - if(my $opt_val = delete $last_info->{$sql_maker_opt}) { - $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val; - } - } + return $self->_connect_info if !$info_arg; + + # 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({}); - # Get rid of any trailing empty hashref - pop(@$info) if !keys %$last_info; + my $info = [ @$info_arg ]; # copy because we can alter it + my $last_info = $info->[-1]; + if(ref $last_info eq 'HASH') { + if(my $on_connect_do = delete $last_info->{on_connect_do}) { + $self->on_connect_do($on_connect_do); + } + for my $sql_maker_opt (qw/limit_dialect quote_char name_sep/) { + if(my $opt_val = delete $last_info->{$sql_maker_opt}) { + $self->_sql_maker_opts->{$sql_maker_opt} = $opt_val; + } } - $self->_connect_info($info); + # Get rid of any trailing empty hashref + pop(@$info) if !keys %$last_info; } - $self->_connect_info; + $self->_connect_info($info); } sub _populate_dbh { @@ -622,9 +708,14 @@ sub _connect { } eval { - $dbh = ref $info[0] eq 'CODE' - ? &{$info[0]} - : DBI->connect(@info); + if(ref $info[0] eq 'CODE') { + $dbh = &{$info[0]} + } + else { + $dbh = DBI->connect(@info); + $dbh->{RaiseError} = 1; + $dbh->{PrintError} = 0; + } }; $DBI::connect_via = $old_connect_via if $old_connect_via; @@ -648,12 +739,14 @@ an entire code block to be executed transactionally. sub txn_begin { my $self = shift; if ($self->{transaction_depth}++ == 0) { - my $dbh = $self->dbh; - if ($dbh->{AutoCommit}) { - $self->debugobj->txn_begin() - if ($self->debug); - $dbh->begin_work; - } + $self->dbh_do(sub { + my $dbh = shift; + if ($dbh->{AutoCommit}) { + $self->debugobj->txn_begin() + if ($self->debug); + $dbh->begin_work; + } + }); } } @@ -665,21 +758,23 @@ Issues a commit against the current dbh. sub txn_commit { my $self = shift; - my $dbh = $self->dbh; - if ($self->{transaction_depth} == 0) { - unless ($dbh->{AutoCommit}) { - $self->debugobj->txn_commit() - if ($self->debug); - $dbh->commit; + $self->dbh_do(sub { + my $dbh = shift; + if ($self->{transaction_depth} == 0) { + unless ($dbh->{AutoCommit}) { + $self->debugobj->txn_commit() + if ($self->debug); + $dbh->commit; + } } - } - else { - if (--$self->{transaction_depth} == 0) { - $self->debugobj->txn_commit() - if ($self->debug); - $dbh->commit; + else { + if (--$self->{transaction_depth} == 0) { + $self->debugobj->txn_commit() + if ($self->debug); + $dbh->commit; + } } - } + }); } =head2 txn_rollback @@ -694,24 +789,26 @@ sub txn_rollback { my $self = shift; eval { - my $dbh = $self->dbh; - if ($self->{transaction_depth} == 0) { - unless ($dbh->{AutoCommit}) { - $self->debugobj->txn_rollback() - if ($self->debug); - $dbh->rollback; - } - } - else { - if (--$self->{transaction_depth} == 0) { - $self->debugobj->txn_rollback() - if ($self->debug); - $dbh->rollback; + $self->dbh_do(sub { + my $dbh = shift; + if ($self->{transaction_depth} == 0) { + unless ($dbh->{AutoCommit}) { + $self->debugobj->txn_rollback() + if ($self->debug); + $dbh->rollback; + } } else { - die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new; + if (--$self->{transaction_depth} == 0) { + $self->debugobj->txn_rollback() + if ($self->debug); + $dbh->rollback; + } + else { + die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new; + } } - } + }); }; if ($@) { @@ -838,7 +935,7 @@ Returns a L sth (statement handle) for the supplied SQL. sub sth { my ($self, $sql) = @_; # 3 is the if_active parameter which avoids active sth re-use - return $self->dbh->prepare_cached($sql, {}, 3); + return $self->dbh_do(sub { shift->prepare_cached($sql, {}, 3) }); } =head2 columns_info_for @@ -850,62 +947,56 @@ Returns database type info for a given table columns. sub columns_info_for { my ($self, $table) = @_; - my $dbh = $self->dbh; + $self->dbh_do(sub { + my $dbh = shift; + + if ($dbh->can('column_info')) { + my %result; + eval { + my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table); + my $sth = $dbh->column_info( undef,$schema, $tab, '%' ); + $sth->execute(); + while ( my $info = $sth->fetchrow_hashref() ){ + my %column_info; + $column_info{data_type} = $info->{TYPE_NAME}; + $column_info{size} = $info->{COLUMN_SIZE}; + $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0; + $column_info{default_value} = $info->{COLUMN_DEF}; + my $col_name = $info->{COLUMN_NAME}; + $col_name =~ s/^\"(.*)\"$/$1/; + + $result{$col_name} = \%column_info; + } + }; + return \%result if !$@; + } - if ($dbh->can('column_info')) { my %result; - local $dbh->{RaiseError} = 1; - local $dbh->{PrintError} = 0; - eval { - my ($schema,$tab) = $table =~ /^(.+?)\.(.+)$/ ? ($1,$2) : (undef,$table); - my $sth = $dbh->column_info( undef,$schema, $tab, '%' ); - $sth->execute(); - - # Some error occured or there is no information: - if($sth->rows <1) { - die "column_info returned no rows for $schema, $tab"; + my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0"); + $sth->execute; + my @columns = @{$sth->{NAME_lc}}; + for my $i ( 0 .. $#columns ){ + my %column_info; + my $type_num = $sth->{TYPE}->[$i]; + 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; } + $column_info{data_type} = $type_name ? $type_name : $type_num; + $column_info{size} = $sth->{PRECISION}->[$i]; + $column_info{is_nullable} = $sth->{NULLABLE}->[$i] ? 1 : 0; - while ( my $info = $sth->fetchrow_hashref() ){ - my %column_info; - $column_info{data_type} = $info->{TYPE_NAME}; - $column_info{size} = $info->{COLUMN_SIZE}; - $column_info{is_nullable} = $info->{NULLABLE} ? 1 : 0; - $column_info{default_value} = $info->{COLUMN_DEF}; - my $col_name = $info->{COLUMN_NAME}; - $col_name =~ s/^\"(.*)\"$/$1/; - - $result{$col_name} = \%column_info; + if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) { + $column_info{data_type} = $1; + $column_info{size} = $2; } - }; - return \%result if !$@; - } - my %result; - my $sth = $dbh->prepare("SELECT * FROM $table WHERE 1=0"); - $sth->execute; - my @columns = @{$sth->{NAME_lc}}; - for my $i ( 0 .. $#columns ){ - my %column_info; - my $type_num = $sth->{TYPE}->[$i]; - 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; + $result{$columns[$i]} = \%column_info; } - $column_info{data_type} = $type_name ? $type_name : $type_num; - $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; - } - - $result{$columns[$i]} = \%column_info; - } - - return \%result; + return \%result; + }); } =head2 last_insert_id @@ -917,8 +1008,7 @@ Return the row id of the last insert. sub last_insert_id { my ($self, $row) = @_; - return $self->dbh->func('last_insert_rowid'); - + $self->dbh_do(sub { shift->func('last_insert_rowid') }); } =head2 sqlt_type @@ -927,7 +1017,7 @@ Returns the database driver name. =cut -sub sqlt_type { shift->dbh->{Driver}->{Name} } +sub sqlt_type { shift->dbh_do(sub { shift->{Driver}->{Name} }) } =head2 create_ddl_dir (EXPERIMENTAL) @@ -1057,7 +1147,7 @@ sub deploy { next if($_ =~ /^COMMIT/m); next if $_ =~ /^\s+$/; # skip whitespace only $self->debugobj->query_start($_) if $self->debug; - $self->dbh->do($_) or warn "SQL was:\n $_"; + $self->dbh->do($_) or warn "SQL was:\n $_"; # XXX exceptions? $self->debugobj->query_end($_) if $self->debug; } } @@ -1097,7 +1187,13 @@ sub build_datetime_parser { return $type; } -sub DESTROY { shift->disconnect } +sub DESTROY { + my $self = shift; + return if !$self->_dbh; + + $self->_verify_pid; + $self->_dbh(undef); +} 1; diff --git a/lib/DBIx/Class/Storage/DBI/DB2.pm b/lib/DBIx/Class/Storage/DBI/DB2.pm index 8e867e0..ebe1067 100644 --- a/lib/DBIx/Class/Storage/DBI/DB2.pm +++ b/lib/DBIx/Class/Storage/DBI/DB2.pm @@ -11,8 +11,7 @@ sub last_insert_id { my ($self) = @_; - my $dbh = $self->_dbh; - my $sth = $dbh->prepare_cached("VALUES(IDENTITY_VAL_LOCAL())", {}, 3); + my $sth = $self->dbh_do(sub { shift->prepare_cached("VALUES(IDENTITY_VAL_LOCAL())", {}, 3) }); $sth->execute(); my @res = $sth->fetchrow_array(); diff --git a/lib/DBIx/Class/Storage/DBI/MSSQL.pm b/lib/DBIx/Class/Storage/DBI/MSSQL.pm index e355ce9..6634c59 100644 --- a/lib/DBIx/Class/Storage/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Storage/DBI/MSSQL.pm @@ -6,7 +6,9 @@ use warnings; use base qw/DBIx::Class::Storage::DBI/; sub last_insert_id { - my( $id ) = $_[0]->_dbh->selectrow_array('SELECT @@IDENTITY' ); + my $self = shift; + my ($id) = + $self->dbh_do( sub { shift->selectrow_array('SELECT @@IDENTITY' ) } ); return $id; } diff --git a/lib/DBIx/Class/Storage/DBI/NoBindVars.pm b/lib/DBIx/Class/Storage/DBI/NoBindVars.pm index 73c7b43..b8684fd 100644 --- a/lib/DBIx/Class/Storage/DBI/NoBindVars.pm +++ b/lib/DBIx/Class/Storage/DBI/NoBindVars.pm @@ -15,7 +15,7 @@ sub _execute { } while(my $bvar = shift @bind) { - $bvar = $self->dbh->quote($bvar); + $bvar = $self->_dbh->quote($bvar); $sql =~ s/\?/$bvar/; } diff --git a/lib/DBIx/Class/Storage/DBI/ODBC.pm b/lib/DBIx/Class/Storage/DBI/ODBC.pm index f33100c..42466ef 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC.pm @@ -7,7 +7,7 @@ use base qw/DBIx::Class::Storage::DBI/; sub _rebless { my ($self) = @_; - my $dbh = $self->_dbh; + my $dbh = $self->dbh; my $dbtype = eval { $dbh->get_info(17) }; unless ( $@ ) { # Translate the backend name into a perl identifier diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/DB2_400_SQL.pm b/lib/DBIx/Class/Storage/DBI/ODBC/DB2_400_SQL.pm index c39a622..e84c087 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/DB2_400_SQL.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/DB2_400_SQL.pm @@ -8,28 +8,29 @@ sub last_insert_id { my ($self) = @_; - my $dbh = $self->_dbh; + $self->dbh_do(sub { + my $dbh = shift; - # get the schema/table separator: - # '.' when SQL naming is active - # '/' when system naming is active - my $sep = $dbh->get_info(41); - my $sth = $dbh->prepare_cached( - "SELECT IDENTITY_VAL_LOCAL() FROM SYSIBM${sep}SYSDUMMY1", {}, 3); - $sth->execute(); + # get the schema/table separator: + # '.' when SQL naming is active + # '/' when system naming is active + my $sep = $dbh->get_info(41); + my $sth = $dbh->prepare_cached( + "SELECT IDENTITY_VAL_LOCAL() FROM SYSIBM${sep}SYSDUMMY1", {}, 3); + $sth->execute(); - my @res = $sth->fetchrow_array(); + my @res = $sth->fetchrow_array(); - return @res ? $res[0] : undef; + return @res ? $res[0] : undef; + }); } sub _sql_maker_opts { my ($self) = @_; - return { - limit_dialect => 'FetchFirst', - name_sep => $self->_dbh->get_info(41) - }; + $self->dbh_do(sub { + { limit_dialect => 'FetchFirst', name_sep => shift->get_info(41) } + }); } 1; diff --git a/lib/DBIx/Class/Storage/DBI/Oracle.pm b/lib/DBIx/Class/Storage/DBI/Oracle.pm index d5b605f..94df0e6 100644 --- a/lib/DBIx/Class/Storage/DBI/Oracle.pm +++ b/lib/DBIx/Class/Storage/DBI/Oracle.pm @@ -13,7 +13,7 @@ sub last_insert_id { my ($self,$source,$col) = @_; my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col)); my $sql = "SELECT " . $seq . ".currval FROM DUAL"; - my ($id) = $self->_dbh->selectrow_array($sql); + my ($id) = $self->dbh_do(sub { shift->selectrow_array($sql) }); return $id; } @@ -21,21 +21,24 @@ sub get_autoinc_seq { my ($self,$source,$col) = @_; # look up the correct sequence automatically - my $dbh = $self->_dbh; my $sql = q{ SELECT trigger_body FROM ALL_TRIGGERS t WHERE t.table_name = ? AND t.triggering_event = 'INSERT' AND t.status = 'ENABLED' }; - # trigger_body is a LONG - $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024); - my $sth = $dbh->prepare($sql); - $sth->execute( uc($source->name) ); - while (my ($insert_trigger) = $sth->fetchrow_array) { - return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here??? - } - croak "Unable to find a sequence INSERT trigger on table '" . $source->name . "'."; + + $self->dbh_do(sub { + my $dbh = shift; + # trigger_body is a LONG + $dbh->{LongReadLen} = 64 * 1024 if ($dbh->{LongReadLen} < 64 * 1024); + my $sth = $dbh->prepare($sql); + $sth->execute( uc($source->name) ); + while (my ($insert_trigger) = $sth->fetchrow_array) { + return uc($1) if $insert_trigger =~ m!(\w+)\.nextval!i; # col name goes here??? + } + croak "Unable to find a sequence INSERT trigger on table '" . $source->name . "'."; + }); } sub columns_info_for { diff --git a/lib/DBIx/Class/Storage/DBI/Pg.pm b/lib/DBIx/Class/Storage/DBI/Pg.pm index e211c05..f17831c 100644 --- a/lib/DBIx/Class/Storage/DBI/Pg.pm +++ b/lib/DBIx/Class/Storage/DBI/Pg.pm @@ -16,25 +16,29 @@ warn "DBD::Pg 1.49 is strongly recommended" sub last_insert_id { my ($self,$source,$col) = @_; my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col)); - $self->_dbh->last_insert_id(undef,undef,undef,undef, {sequence => $seq}); + $self->dbh_do(sub { shift->last_insert_id(undef,undef,undef,undef, {sequence => $seq}) } ); } sub get_autoinc_seq { my ($self,$source,$col) = @_; my @pri = $source->primary_columns; - my $dbh = $self->_dbh; my ($schema,$table) = $source->name =~ /^(.+)\.(.+)$/ ? ($1,$2) : (undef,$source->name); - while (my $col = shift @pri) { - my $info = $dbh->column_info(undef,$schema,$table,$col)->fetchrow_hashref; - if (defined $info->{COLUMN_DEF} and $info->{COLUMN_DEF} =~ - /^nextval\(+'([^']+)'::(?:text|regclass)\)/) - { - my $seq = $1; - return $seq =~ /\./ ? $seq : $info->{TABLE_SCHEM} . "." . $seq; # may need to strip quotes -- see if this works + + $self->dbh_do(sub { + my $dbh = shift; + while (my $col = shift @pri) { + my $info = $dbh->column_info(undef,$schema,$table,$col)->fetchrow_hashref; + if (defined $info->{COLUMN_DEF} and $info->{COLUMN_DEF} =~ + /^nextval\(+'([^']+)'::(?:text|regclass)\)/) + { + my $seq = $1; + return $seq =~ /\./ ? $seq : $info->{TABLE_SCHEM} . "." . $seq; # may need to strip quotes -- see if this works + } } - } + return; + }); } sub sqlt_type { diff --git a/lib/DBIx/Class/Storage/DBI/SQLite.pm b/lib/DBIx/Class/Storage/DBI/SQLite.pm index 091b5e7..ccf82d5 100644 --- a/lib/DBIx/Class/Storage/DBI/SQLite.pm +++ b/lib/DBIx/Class/Storage/DBI/SQLite.pm @@ -6,7 +6,7 @@ use warnings; use base qw/DBIx::Class::Storage::DBI::MultiDistinctEmulation/; sub last_insert_id { - return $_[0]->dbh->func('last_insert_rowid'); + shift->dbh_do(sub { shift->func('last_insert_rowid') }); } 1; diff --git a/lib/DBIx/Class/Storage/DBI/mysql.pm b/lib/DBIx/Class/Storage/DBI/mysql.pm index 8c14b1b..2f1114b 100644 --- a/lib/DBIx/Class/Storage/DBI/mysql.pm +++ b/lib/DBIx/Class/Storage/DBI/mysql.pm @@ -8,7 +8,7 @@ use base qw/DBIx::Class::Storage::DBI/; # __PACKAGE__->load_components(qw/PK::Auto/); sub last_insert_id { - return $_[0]->_dbh->{mysql_insertid}; + return shift->dbh_do(sub { shift->{mysql_insertid} } ); } sub sqlt_type { diff --git a/t/19quotes.t b/t/19quotes.t index ad44bcb..65a7f3f 100644 --- a/t/19quotes.t +++ b/t/19quotes.t @@ -28,10 +28,8 @@ cmp_ok( $rs->count, '==', 1, "join with fields quoted"); $rs = DBICTest::CD->search({}, { 'order_by' => 'year DESC'}); { - my $warnings = ''; - local $SIG{__WARN__} = sub { $warnings .= $_[0] }; - my $first = eval{ $rs->first() }; - like( $warnings, qr/ORDER BY terms/, "Problem with ORDER BY quotes" ); + eval{ $rs->first() }; + like( $@, qr/ORDER BY terms/, "Problem with ORDER BY quotes" ); } my $order = 'year DESC'; diff --git a/t/19quotes_newstyle.t b/t/19quotes_newstyle.t index 65cd3aa..5bb0bc3 100644 --- a/t/19quotes_newstyle.t +++ b/t/19quotes_newstyle.t @@ -29,10 +29,8 @@ cmp_ok( $rs->count, '==', 1, "join with fields quoted"); $rs = DBICTest::CD->search({}, { 'order_by' => 'year DESC'}); { - my $warnings = ''; - local $SIG{__WARN__} = sub { $warnings .= $_[0] }; - my $first = eval{ $rs->first() }; - like( $warnings, qr/ORDER BY terms/, "Problem with ORDER BY quotes" ); + eval{ $rs->first() }; + like( $@, qr/ORDER BY terms/, "Problem with ORDER BY quotes" ); } my $order = 'year DESC'; diff --git a/t/33storage_reconnect.t b/t/33storage_reconnect.t new file mode 100644 index 0000000..6e82b13 --- /dev/null +++ b/t/33storage_reconnect.t @@ -0,0 +1,26 @@ +use strict; +use warnings; + +use Test::More; +use lib qw(t/lib); +use DBICTest; + +plan tests => 2; + +# Set up the "usual" sqlite for DBICTest +my $schema = DBICTest->init_schema; + +# Make sure we're connected by doing something +my @art = $schema->resultset("Artist")->search({ }, { order_by => 'name DESC'}); +cmp_ok(@art, '==', 3, "Three artists returned"); + +# Disconnect the dbh, and be sneaky about it +$schema->storage->_dbh->disconnect; + +# Try the operation again - What should happen here is: +# 1. S::DBI blindly attempts the SELECT, which throws an exception +# 2. It catches the exception, checks ->{Active}/->ping, sees the disconnected state... +# 3. Reconnects, and retries the operation +# 4. Success! +my @art_two = $schema->resultset("Artist")->search({ }, { order_by => 'name DESC'}); +cmp_ok(@art_two, '==', 3, "Three artists returned"); diff --git a/t/34exception_action.t b/t/34exception_action.t new file mode 100644 index 0000000..dd54be1 --- /dev/null +++ b/t/34exception_action.t @@ -0,0 +1,64 @@ +use strict; +use warnings; + +use Test::More; +use lib qw(t/lib); +use DBICTest; + +plan tests => 6; + +# Set up the "usual" sqlite for DBICTest +my $schema = DBICTest->init_schema; + +# This is how we're generating exceptions in the rest of these tests, +# which might need updating at some future time to be some other +# exception-generating statement: + +sub throwex { $schema->resultset("Artist")->search(1,1,1); } +my $ex_regex = qr/Odd number of arguments to search/; + +# Basic check, normal exception +eval { throwex }; +like($@, $ex_regex); + +# Now lets rethrow via exception_action +$schema->exception_action(sub { die @_ }); +eval { throwex }; +like($@, $ex_regex); + +# Now lets suppress the error +$schema->exception_action(sub { 1 }); +eval { throwex }; +ok(!$@, "Suppress exception"); + +# Now lets fall through and let croak take back over +$schema->exception_action(sub { return }); +eval { throwex }; +like($@, $ex_regex); + +# Whacky useless exception class +{ + package DBICTest::Exception; + use overload '""' => \&stringify, fallback => 1; + sub new { + my $class = shift; + bless { msg => shift }, $class; + } + sub throw { + my $self = shift; + die $self if ref $self eq __PACKAGE__; + die $self->new(shift); + } + sub stringify { + "DBICTest::Exception is handling this: " . shift->{msg}; + } +} + +# Try the exception class +$schema->exception_action(sub { DBICTest::Exception->throw(@_) }); +eval { throwex }; +like($@, qr/DBICTest::Exception is handling this: $ex_regex/); + +# While we're at it, lets throw a custom exception through Storage::DBI +eval { DBICTest->schema->storage->throw_exception('floob') }; +like($@, qr/DBICTest::Exception is handling this: floob/); diff --git a/t/60core.t b/t/60core.t index aae959e..a468515 100644 --- a/t/60core.t +++ b/t/60core.t @@ -277,6 +277,7 @@ ok(!$@, "stringify to false value doesn't cause error"); # test column_info { $schema->source("Artist")->{_columns}{'artistid'} = {}; + $schema->source("Artist")->load_column_info_from_storage; my $typeinfo = $schema->source("Artist")->column_info('artistid'); is($typeinfo->{data_type}, 'INTEGER', 'column_info ok'); diff --git a/t/72pg.t b/t/72pg.t index f0bb3f8..f393a9a 100644 --- a/t/72pg.t +++ b/t/72pg.t @@ -15,6 +15,7 @@ use DBICTest; __PACKAGE__->load_components(qw/PK::Auto Core/); __PACKAGE__->table('casecheck'); __PACKAGE__->add_columns(qw/id name NAME uc_name/); + __PACKAGE__->load_column_info_from_storage; __PACKAGE__->set_primary_key('id'); }