# 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) = @_;
__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/);
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 )
{
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;
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(@_);
}
__PACKAGE__->mk_classdata('source_registrations' => {});
__PACKAGE__->mk_classdata('storage_type' => '::DBI');
__PACKAGE__->mk_classdata('storage');
+__PACKAGE__->mk_classdata('exception_action');
=head1 NAME
$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;
my $new = $source->new($source);
$clone->register_source($moniker => $new);
}
+ $clone->storage->set_schema($clone) if $clone->storage;
return $clone;
}
return @created;
}
+=head2 exception_action
+
+=over 4
+
+=item Arguments: $code_reference
+
+=back
+
+If C<exception_action> is set for this class/object, L</throw_exception>
+will prefer to call this code reference with the exception as an argument,
+rather than its normal <croak> 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<exception_action> 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
=back
Throws an exception. Defaults to using L<Carp::Clan> to report errors from
-user's perspective.
+user's perspective. See L</exception_action> 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)
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!" }
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 {
__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
=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);
return $new;
}
+=head2 set_schema
+
+Used to reset the schema class or object which owns this
+storage object, such as after a C<clone()>.
+
+=cut
+
+sub set_schema {
+ my ($self, $schema) = @_;
+ $self->schema($schema);
+ weaken($self->{schema}) if ref $self->{schema};
+}
+
+
=head2 throw_exception
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
these options will be cleared before setting the new ones, regardless of
whether any options are specified in the new C<connect_info>.
+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
}
}
+=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<DBI> handle, performing a rollback first if the
=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);
}
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
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 {
}
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;
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;
+ }
+ });
}
}
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
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 ($@) {
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
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
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
=cut
-sub sqlt_type { shift->dbh->{Driver}->{Name} }
+sub sqlt_type { shift->dbh_do(sub { shift->{Driver}->{Name} }) }
=head2 create_ddl_dir (EXPERIMENTAL)
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;
}
}
return $type;
}
-sub DESTROY { shift->disconnect }
+sub DESTROY {
+ my $self = shift;
+ return if !$self->_dbh;
+
+ $self->_verify_pid;
+ $self->_dbh(undef);
+}
1;
{
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();
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;
}
}
while(my $bvar = shift @bind) {
- $bvar = $self->dbh->quote($bvar);
+ $bvar = $self->_dbh->quote($bvar);
$sql =~ s/\?/$bvar/;
}
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
{
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;
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;
}
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 {
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 {
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;
# __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 {
$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';
$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';
--- /dev/null
+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");
--- /dev/null
+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/);
# 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');
__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');
}
projects / dbsrgits/DBIx-Class.git / commitdiff