Revision history for DBIx::Class
+0.07000 2006-07-23 02:30:00
- supress warnings for possibly non-unique queries, since
_is_unique_query doesn't infer properly in all cases
- skip empty queries to eliminate spurious warnings on ->deploy
- nuke ResultSource caching of ->resultset for consistency reasons
- fix for -and conditions when updating or deleting on a ResultSet
-0.06001 2006-04-08 21:48:43
- - minor fix to update in case of undefined rels
- - fixes for cascade delete
- - substantial improvements and fixes to deploy
+0.06001
- Added fix for quoting with single table
- Substantial fixes and improvements to deploy
- slice now uses search directly
# 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.06999_07';
+$VERSION = '0.07999_01';
sub MODIFY_CODE_ATTRIBUTES {
my ($class,$code,@attrs) = @_;
=item .. create a database to use?
First, choose a database. For testing/experimenting, we reccommend
-L<DBD::SQLite>, which is a self-contained small database. (i.e. all
-you need to do is to install the DBD from CPAN, and it's usable).
+L<DBD::SQLite>, which is a self-contained small database (i.e. all you
+need to do is to install L<DBD::SQLite> from CPAN, and it's usable).
Next, spend some time defining which data you need to store, and how
it relates to the other data you have. For some help on normalisation,
=item .. use DBIx::Class with L<Catalyst>?
-Install L<Catalyst::Model::DBIC::Schema> from CPAN. See it's
+Install L<Catalyst::Model::DBIC::Schema> from CPAN. See its
documentation, or below, for further details.
=item .. set up my DBIx::Class classes automatically from my database?
-Install L<DBIx::Class::Schema::Loader> from CPAN, and read it's documentation.
+Install L<DBIx::Class::Schema::Loader> from CPAN, and read its documentation.
=item .. set up my DBIx::Class classes manually?
-Look at the L<DBIx::Class::Manual::Example>, come back here if you get lost.
+Look at the L<DBIx::Class::Manual::Example> and come back here if you get lost.
=item .. create my database tables from my DBIx::Class schema?
=item .. tell DBIx::Class about relationships between my tables?
-There are a vareity of relationship types that come pre-defined for you to use. These are all listed in L<DBIx::Class::Relationship>. If you need a non-standard type, or more information, look in L<DBIx::Class::Relationship::Base>.
+There are a vareity of relationship types that come pre-defined for
+you to use. These are all listed in L<DBIx::Class::Relationship>. If
+you need a non-standard type, or more information, look in
+L<DBIx::Class::Relationship::Base>.
=item .. define a one-to-many relationship?
-This is called a C<has_many> relationship on the one side, and a C<belongs_to> relationship on the many side. Currently these need to be set up individually on each side. See L<DBIx::Class::Relationship> for details.
+This is called a C<has_many> relationship on the one side, and a
+C<belongs_to> relationship on the many side. Currently these need to
+be set up individually on each side. See L<DBIx::Class::Relationship>
+for details.
=item .. define a relationship where this table contains another table's primary key? (foreign key)
-Create a C<belongs_to> relationship for the field containing the foreign key. L<DBIx::Class::Relationship/belongs_to>.
+Create a C<belongs_to> relationship for the field containing the
+foreign key. See L<DBIx::Class::Relationship/belongs_to>.
=item .. define a foreign key relationship where the key field may contain NULL?
-Just create a C<belongs_to> relationship, as above. If
-the column is NULL then the inflation to the foreign object will not
-happen. This has a side effect of not always fetching all the relevant
-data, if you use a nullable foreign-key relationship in a JOIN, then
-you probably want to set the join_type to 'left'.
+Just create a C<belongs_to> relationship, as above. If the column is
+NULL then the inflation to the foreign object will not happen. This
+has a side effect of not always fetching all the relevant data, if you
+use a nullable foreign-key relationship in a JOIN, then you probably
+want to set the C<join_type> to C<left>.
=item .. define a relationship where the key consists of more than one column?
By default, DBIx::Class cascades deletes and updates across
C<has_many> relationships. If your database already does this (and
-probably better), turn it off by supplying C<< cascade_delete => 0 >> in
-the relationship attributes. See L<DBIx::Class::Relationship::Base>.
+that is probably better), turn it off by supplying C<< cascade_delete => 0 >>
+in the relationship attributes. See L<DBIx::Class::Relationship::Base>.
=item .. use a relationship?
-Use it's name. An accessor is created using the name. See examples in L<DBIx::Class::Manual::Cookbook/Using relationships>.
+Use its name. An accessor is created using the name. See examples in
+L<DBIx::Class::Manual::Cookbook/Using relationships>.
=back
=item .. search for data?
Create a C<$schema> object, as mentioned above in ".. connect to my
-database". Find the
-L<ResultSet|DBIx::Class::Manual::Glossary/ResultSet> that you want
-to search in, and call C<search> on it. See
+database". Find the L<ResultSet|DBIx::Class::Manual::Glossary/ResultSet>
+that you want to search in, and call C<search> on it. See
L<DBIx::Class::ResultSet/search>.
=item .. search using database functions?
=item .. sort the results of my search?
-Supply a list of columns you want to sort by, to the C<order_by>
-attribute, see L<DBIx::Class::ResultSet/order_by>.
+Supply a list of columns you want to sort by to the C<order_by>
+attribute. See L<DBIx::Class::ResultSet/order_by>.
=item .. sort my results based on fields I've aliased using C<as>?
You don't. You'll need to supply the same functions/expressions to
-C<order_by>, as you did to C<select>.
+C<order_by>, as you did to C<select>.
-To get "fieldname AS alias" in your SQL, you'll need to supply a literal chunk of SQL in your C<select> attribute, such as:
+To get "fieldname AS alias" in your SQL, you'll need to supply a
+literal chunk of SQL in your C<select> attribute, such as:
->search({}, { select => [ \'now() AS currenttime'] })
Currently, L<DBIx::Class> can only create join conditions using
equality, so you're probably better off creating a C<view> in your
-database, and using that as your source. A C<view> is a stored SQL query,
-which can be accessed similarly to a table, see your database
+database, and using that as your source. A C<view> is a stored SQL
+query, which can be accessed similarly to a table, see your database
documentation for details.
=item .. search using greater-than or less-than and database functions?
=item .. find more help on constructing searches?
Behind the scenes, DBIx::Class uses L<SQL::Abstract> to help construct
-it's SQL searches. So if you fail to find help in the
+its SQL searches. So if you fail to find help in the
L<DBIx::Class::Manual::Cookbook>, try looking in the SQL::Abstract
documentation.
=item How do I use DBIx::Class objects in my TT templates?
-Like normal objects, mostly. However you need to watch out for TTs
-calling methods in list context, this means that when calling
-relationship accessors you will not get resultsets, but a list of all
-the related objects.
+Like normal objects, mostly. However you need to watch out for TT
+calling methods in list context. When calling relationship accessors
+you will not get resultsets, but a list of all the related objects.
+
+Starting with version 0.07, you can use L<DBIx::Class::ResultSet/search_rs>
+to work around this issue.
=item See the SQL statements my code is producing?
if you create a resultset using C<search> in scalar context, no query
is executed. You can create further resultset refinements by calling
search again or relationship accessors. The SQL query is only run when
-you ask the resultset for an actual Row object.
+you ask the resultset for an actual row object.
=back
my $collapse = $attrs->{collapse} || {};
if (my $prefetch = delete $attrs->{prefetch}) {
+ $prefetch = $self->_merge_attr({}, $prefetch);
my @pre_order;
+ my $seen = $attrs->{seen_join} || {};
foreach my $p (ref $prefetch eq 'ARRAY' ? @$prefetch : ($prefetch)) {
# bring joins back to level of current class
my @prefetch = $source->resolve_prefetch(
- $p, $alias, { %{$attrs->{seen_join}||{}} }, \@pre_order, $collapse
+ $p, $alias, $seen, \@pre_order, $collapse
);
push(@{$attrs->{select}}, map { $_->[0] } @prefetch);
push(@{$attrs->{as}}, map { $_->[1] } @prefetch);
my $info;
my $lc_info;
# eval for the case of storage without table
- eval { $info = $self->storage->columns_info_for( $self->from, keys %{$self->_columns} ) };
+ eval { $info = $self->storage->columns_info_for( $self->from ) };
unless ($@) {
for my $realcol ( keys %{$info} ) {
$lc_info->{lc $realcol} = $info->{$realcol};
__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 $new = bless({}, ref $_[0] || $_[0]);
+ my ($self, $schema) = @_;
+
+ my $new = bless({}, ref $self || $self);
+
+ $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;
- my $old_raise_err = $dbh->{RaiseError};
- my $old_print_err = $dbh->{PrintError};
- $dbh->{RaiseError} = 1;
- $dbh->{PrintError} = 0;
- 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;
+ 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;
}
- };
- $dbh->{RaiseError} = $old_raise_err;
- $dbh->{PrintError} = $old_print_err;
- return \%result if !$@;
- }
+ $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;
- 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;
- }
- $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;
+ }
- if ($column_info{data_type} =~ m/^(.*?)\((.*?)\)$/) {
- $column_info{data_type} = $1;
- $column_info{size} = $2;
+ $result{$columns[$i]} = \%column_info;
}
- $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 {
+ my ($self, $table) = @_;
+
+ $self->next::method($self, uc($table));
+}
+
+
1;
=head1 NAME
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/);
use Data::Dumper;
my $schema = DBICTest->init_schema();
-plan tests => 18;
+plan tests => 19;
my @rs1a_results = $schema->resultset("Artist")->search_related('cds', {title => 'Forkful of bees'}, {order_by => 'title'});
is($rs1a_results[0]->title, 'Forkful of bees', "bare field conditions okay after search related");
is(scalar(@{$merge_rs_2->{attrs}->{join}}), 1, 'only one join kept when inherited');
my $merge_rs_2_cd = $merge_rs_2->next;
+eval {
+
+ my @rs_with_prefetch = $schema->resultset('TreeLike')
+ ->search(
+ {'me.id' => 1},
+ {
+ prefetch => [ 'parent', { 'children' => 'parent' } ],
+ });
+
+};
+
+ok(!$@, "pathological prefetch ok");
+
1;
--
-- Created by SQL::Translator::Producer::SQLite
--- Created on Thu Jun 6 23:36:19 2006
+-- Created on Sun Jul 23 00:23:30 2006
--
BEGIN TRANSACTION;
);
--
+-- Table: liner_notes
+--
+CREATE TABLE liner_notes (
+ liner_id INTEGER PRIMARY KEY NOT NULL,
+ notes varchar(100) NOT NULL
+);
+
+--
-- Table: cd_to_producer
--
CREATE TABLE cd_to_producer (
);
--
--- Table: liner_notes
---
-CREATE TABLE liner_notes (
- liner_id INTEGER PRIMARY KEY NOT NULL,
- notes varchar(100) NOT NULL
-);
-
---
-- Table: artist
--
CREATE TABLE artist (
);
--
+-- Table: twokeytreelike
+--
+CREATE TABLE twokeytreelike (
+ id1 integer NOT NULL,
+ id2 integer NOT NULL,
+ parent1 integer NOT NULL,
+ parent2 integer NOT NULL,
+ name varchar(100) NOT NULL,
+ PRIMARY KEY (id1, id2)
+);
+
+--
-- Table: fourkeys_to_twokeys
--
CREATE TABLE fourkeys_to_twokeys (
);
--
--- Table: twokeytreelike
---
-CREATE TABLE twokeytreelike (
- id1 integer NOT NULL,
- id2 integer NOT NULL,
- parent1 integer NOT NULL,
- parent2 integer NOT NULL,
- name varchar(100) NOT NULL,
- PRIMARY KEY (id1, id2)
-);
-
---
-- Table: self_ref_alias
--
CREATE TABLE self_ref_alias (
);
--
--- Table: treelike
---
-CREATE TABLE treelike (
- id INTEGER PRIMARY KEY NOT NULL,
- parent integer NOT NULL,
- name varchar(100) NOT NULL
-);
-
---
-- Table: self_ref
--
CREATE TABLE self_ref (
);
--
+-- Table: treelike
+--
+CREATE TABLE treelike (
+ id INTEGER PRIMARY KEY NOT NULL,
+ parent integer NOT NULL,
+ name varchar(100) NOT NULL
+);
+
+--
-- Table: event
--
CREATE TABLE event (
projects / dbsrgits/DBIx-Class.git / commitdiff