Revision history for DBIx::Class
+ - added DBIx::Class::Schema::load_namespaces, alternative to
+ load_classes
+ - added source_info method for source-level metadata (kinda like
+ column_info)
+ - Some of ::Storage::DBI's code/docs moved to ::Storage
+ - DBIx::Class::Schema::txn_do code moved to ::Storage
+ - Storage::DBI now uses exceptions instead of ->ping/->{Active} checks
+ - Storage exceptions are thrown via the schema class's throw_exception
+ - DBIx::Class::Schema::throw_exception's behavior can be modified via
+ ->exception_action
+ - columns_info_for is deprecated, and no longer runs automatically.
+ You can make it work like before via
+ __PACKAGE__->load_column_info_from_storage for now
+
0.07002
- cleared up Relationship docs, and fixed some typos
- use ref instead of eval to check limit syntax (to avoid issues with
# 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.07001';
+$VERSION = '0.07999_01';
sub MODIFY_CODE_ATTRIBUTES {
my ($class,$code,@attrs) = @_;
use Class::C3;
use Class::Inspector;
-use Carp::Clan qw/DBIx::Class/;
+use Carp::Clan qw/^DBIx::Class/;
sub inject_base {
my ($class, $target, @to_inject) = @_;
=head2 Transactions
As of version 0.04001, there is improved transaction support in
-L<DBIx::Class::Storage::DBI> and L<DBIx::Class::Schema>. Here is an
+L<DBIx::Class::Storage> and L<DBIx::Class::Schema>. Here is an
example of the recommended way to use it:
my $genus = $schema->resultset('Genus')->find(12);
=head2 Profiling
-When you enable L<DBIx::Class::Storage::DBI>'s debugging it prints the SQL
+When you enable L<DBIx::Class::Storage>'s debugging it prints the SQL
executed as well as notifications of query completion and transaction
begin/commit. If you'd like to profile the SQL you can subclass the
L<DBIx::Class::Storage::Statistics> class and write your own profiling
=item L<DBIx::Class::Row> - Dealing with actual data.
+=item L<DBIx::Class::Storage> - Basic Storage stuff.
+
=item L<DBIx::Class::Storage::DBI> - Storage using L<DBI> and L<SQL::Abstract>.
=back
=item See the SQL statements my code is producing?
-Turn on debugging! See L<DBIx::Class::Storage::DBI> for details of how
+Turn on debugging! See L<DBIx::Class::Storage> for details of how
to turn on debugging in the environment, pass your own filehandle to
save debug to, or create your own callback.
through directly to SQL, so you can give e.g. C<year DESC> for a
descending order on the column `year'.
-Please note that if you have quoting enabled (see
-L<DBIx::Class::Storage/quote_char>) you will need to do C<\'year DESC' > to
+Please note that if you have C<quote_char> enabled (see
+L<DBIx::Class::Storage::DBI/connect_info>) you will need to do C<\'year DESC' > to
specify an order. (The scalar ref causes it to be passed as raw sql to the DB,
so you will need to manually quote things as appropriate.)
__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
+ source_info/);
__PACKAGE__->mk_group_accessors('component_class' => qw/resultset_class
result_class/);
=pod
+=head2 source_info
+
+Stores a hashref of per-source metadata. No specific key names
+have yet been standardized, the examples below are purely hypothetical
+and don't actually accomplish anything on their own:
+
+ __PACKAGE__->source_info({
+ "_tablespace" => 'fast_disk_array_3',
+ "_engine" => 'InnoDB',
+ });
+
=head2 add_columns
$table->add_columns(qw/col1 col2 col3/);
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. This is *deprecated*, and
+should not be used. It will be removed before 1.0.
+
+=cut
+
+sub load_column_info_from_storage { shift->column_info_from_storage(1) }
+
=head2 columns
my @column_names = $obj->columns;
use DBIx::Class::ResultSet;
-use Carp qw/croak/;
-
use base qw/DBIx::Class/;
__PACKAGE__->load_components(qw/ResultSource/);
sub resultset_class { shift->result_source_instance->resultset_class(@_) }
sub result_class { shift->result_source_instance->result_class(@_) }
sub source_name { shift->result_source_instance->source_name(@_) }
+sub source_info { shift->result_source_instance->source_info(@_) }
sub resultset_attributes {
shift->result_source_instance->resultset_attributes(@_);
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(@_);
}
use Carp::Clan qw/^DBIx::Class/;
use Scalar::Util qw/weaken/;
+require Module::Find;
use base qw/DBIx::Class/;
__PACKAGE__->mk_classdata('source_registrations' => {});
__PACKAGE__->mk_classdata('storage_type' => '::DBI');
__PACKAGE__->mk_classdata('storage');
+__PACKAGE__->mk_classdata('exception_action');
=head1 NAME
}
}
} else {
- eval "require Module::Find;";
- $class->throw_exception(
- "No arguments to load_classes and couldn't load Module::Find ($@)"
- ) if $@;
my @comp = map { substr $_, length "${class}::" }
Module::Find::findallmod($class);
$comps_for{$class} = \@comp;
}
}
+=head2 load_namespaces
+
+=over 4
+
+=item Arguments: %options?
+
+=back
+
+This is an alternative to L</load_classes> above which assumes an alternative
+layout for automatic class loading. It assumes that all result
+classes are underneath a sub-namespace of the schema called C<Result>, any
+corresponding ResultSet classes are underneath a sub-namespace of the schema
+called C<ResultSet>.
+
+Both of the sub-namespaces are configurable if you don't like the defaults,
+via the options C<result_namespace> and C<resultset_namespace>.
+
+If (and only if) you specify the option C<default_resultset_class>, any found
+Result classes for which we do not find a corresponding
+ResultSet class will have their C<resultset_class> set to
+C<default_resultset_class>.
+
+C<load_namespaces> takes care of calling C<resultset_class> for you where
+neccessary if you didn't do it for yourself.
+
+All of the namespace and classname options to this method are relative to
+the schema classname by default. To specify a fully-qualified name, prefix
+it with a literal C<+>.
+
+Examples:
+
+ # load My::Schema::Result::CD, My::Schema::Result::Artist,
+ # My::Schema::ResultSet::CD, etc...
+ My::Schema->load_namespaces;
+
+ # Override everything to use ugly names.
+ # In this example, if there is a My::Schema::Res::Foo, but no matching
+ # My::Schema::RSets::Foo, then Foo will have its
+ # resultset_class set to My::Schema::RSetBase
+ My::Schema->load_namespaces(
+ result_namespace => 'Res',
+ resultset_namespace => 'RSets',
+ default_resultset_class => 'RSetBase',
+ );
+
+ # Put things in other namespaces
+ My::Schema->load_namespaces(
+ result_namespace => '+Some::Place::Results',
+ resultset_namespace => '+Another::Place::RSets',
+ );
+
+If you'd like to use multiple namespaces of each type, simply use an arrayref
+of namespaces for that option. In the case that the same result
+(or resultset) class exists in multiple namespaces, the latter entries in
+your list of namespaces will override earlier ones.
+
+ My::Schema->load_namespaces(
+ # My::Schema::Results_C::Foo takes precedence over My::Schema::Results_B::Foo :
+ result_namespace => [ 'Results_A', 'Results_B', 'Results_C' ],
+ resultset_namespace => [ '+Some::Place::RSets', 'RSets' ],
+ );
+
+=cut
+
+# Pre-pends our classname to the given relative classname or
+# class namespace, unless there is a '+' prefix, which will
+# be stripped.
+sub _expand_relative_name {
+ my ($class, $name) = @_;
+ return if !$name;
+ $name = $class . '::' . $name if ! ($name =~ s/^\+//);
+ return $name;
+}
+
+# returns a hash of $shortname => $fullname for every package
+# found in the given namespaces ($shortname is with the $fullname's
+# namespace stripped off)
+sub _map_namespaces {
+ my ($class, @namespaces) = @_;
+
+ my @results_hash;
+ foreach my $namespace (@namespaces) {
+ push(
+ @results_hash,
+ map { (substr($_, length "${namespace}::"), $_) }
+ Module::Find::findallmod($namespace)
+ );
+ }
+
+ @results_hash;
+}
+
+sub load_namespaces {
+ my ($class, %args) = @_;
+
+ my $result_namespace = delete $args{result_namespace} || 'Result';
+ my $resultset_namespace = delete $args{resultset_namespace} || 'ResultSet';
+ my $default_resultset_class = delete $args{default_resultset_class};
+
+ $class->throw_exception('load_namespaces: unknown option(s): '
+ . join(q{,}, map { qq{'$_'} } keys %args))
+ if scalar keys %args;
+
+ $default_resultset_class
+ = $class->_expand_relative_name($default_resultset_class);
+
+ for my $arg ($result_namespace, $resultset_namespace) {
+ $arg = [ $arg ] if !ref($arg) && $arg;
+
+ $class->throw_exception('load_namespaces: namespace arguments must be '
+ . 'a simple string or an arrayref')
+ if ref($arg) ne 'ARRAY';
+
+ $_ = $class->_expand_relative_name($_) for (@$arg);
+ }
+
+ my %results = $class->_map_namespaces(@$result_namespace);
+ my %resultsets = $class->_map_namespaces(@$resultset_namespace);
+
+ my @to_register;
+ {
+ no warnings 'redefine';
+ local *Class::C3::reinitialize = sub { };
+ use warnings 'redefine';
+
+ foreach my $result (keys %results) {
+ my $result_class = $results{$result};
+ $class->ensure_class_loaded($result_class);
+ $result_class->source_name($result) unless $result_class->source_name;
+
+ my $rs_class = delete $resultsets{$result};
+ my $rs_set = $result_class->resultset_class;
+ if($rs_set && $rs_set ne 'DBIx::Class::ResultSet') {
+ if($rs_class && $rs_class ne $rs_set) {
+ warn "We found ResultSet class '$rs_class' for '$result', but it seems "
+ . "that you had already set '$result' to use '$rs_set' instead";
+ }
+ }
+ elsif($rs_class ||= $default_resultset_class) {
+ $class->ensure_class_loaded($rs_class);
+ $result_class->resultset_class($rs_class);
+ }
+
+ push(@to_register, [ $result_class->source_name, $result_class ]);
+ }
+ }
+
+ foreach (sort keys %resultsets) {
+ warn "load_namespaces found ResultSet class $_ with no "
+ . 'corresponding Result class';
+ }
+
+ Class::C3->reinitialize;
+ $class->register_class(@$_) for (@to_register);
+
+ return;
+}
+
=head2 compose_connection
=over 4
Instantiates a new Storage object of type
L<DBIx::Class::Schema/"storage_type"> and passes the arguments to
-$storage->connect_info. Sets the connection in-place on the schema. See
-L<DBIx::Class::Storage::DBI/"connect_info"> for more information.
+$storage->connect_info. Sets the connection in-place on the schema.
+
+See L<DBIx::Class::Storage::DBI/"connect_info"> for DBI-specific syntax,
+or L<DBIx::Class::Storage> in general.
=cut
$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;
sub connect { shift->clone->connection(@_) }
-=head2 txn_begin
-
-Begins a transaction (does nothing if AutoCommit is off). Equivalent to
-calling $schema->storage->txn_begin. See
-L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
+=head2 txn_do
-=cut
+=over 4
-sub txn_begin { shift->storage->txn_begin }
+=item Arguments: C<$coderef>, @coderef_args?
-=head2 txn_commit
+=item Return Value: The return value of $coderef
-Commits the current transaction. Equivalent to calling
-$schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
-for more information.
+=back
-=cut
+Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
+returning its result (if any). Equivalent to calling $schema->storage->txn_do.
+See L<DBIx::Class::Storage/"txn_do"> for more information.
-sub txn_commit { shift->storage->txn_commit }
+This interface is preferred over using the individual methods L</txn_begin>,
+L</txn_commit>, and L</txn_rollback> below.
-=head2 txn_rollback
+=cut
-Rolls back the current transaction. Equivalent to calling
-$schema->storage->txn_rollback. See
-L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
+sub txn_do {
+ my $self = shift;
-=cut
+ $self->storage or $self->throw_exception
+ ('txn_do called on $schema without storage');
-sub txn_rollback { shift->storage->txn_rollback }
+ $self->storage->txn_do(@_);
+}
-=head2 txn_do
+=head2 txn_begin
-=over 4
+Begins a transaction (does nothing if AutoCommit is off). Equivalent to
+calling $schema->storage->txn_begin. See
+L<DBIx::Class::Storage::DBI/"txn_begin"> for more information.
-=item Arguments: C<$coderef>, @coderef_args?
+=cut
-=item Return Value: The return value of $coderef
+sub txn_begin {
+ my $self = shift;
-=back
+ $self->storage or $self->throw_exception
+ ('txn_begin called on $schema without storage');
-Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
-returning its result (if any). If an exception is caught, a rollback is issued
-and the exception is rethrown. If the rollback fails, (i.e. throws an
-exception) an exception is thrown that includes a "Rollback failed" message.
+ $self->storage->txn_begin;
+}
-For example,
+=head2 txn_commit
- my $author_rs = $schema->resultset('Author')->find(1);
- my @titles = qw/Night Day It/;
+Commits the current transaction. Equivalent to calling
+$schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
+for more information.
- my $coderef = sub {
- # If any one of these fails, the entire transaction fails
- $author_rs->create_related('books', {
- title => $_
- }) foreach (@titles);
+=cut
- return $author->books;
- };
+sub txn_commit {
+ my $self = shift;
- my $rs;
- eval {
- $rs = $schema->txn_do($coderef);
- };
+ $self->storage or $self->throw_exception
+ ('txn_commit called on $schema without storage');
- if ($@) { # Transaction failed
- die "something terrible has happened!" #
- if ($@ =~ /Rollback failed/); # Rollback failed
+ $self->storage->txn_commit;
+}
- deal_with_failed_transaction();
- }
+=head2 txn_rollback
-In a nested transaction (calling txn_do() from within a txn_do() coderef) only
-the outermost transaction will issue a L<DBIx::Class::Schema/"txn_commit"> on
-the Schema's storage, and txn_do() can be called in void, scalar and list
-context and it will behave as expected.
+Rolls back the current transaction. Equivalent to calling
+$schema->storage->txn_rollback. See
+L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
=cut
-sub txn_do {
- my ($self, $coderef, @args) = @_;
+sub txn_rollback {
+ my $self = shift;
$self->storage or $self->throw_exception
- ('txn_do called on $schema without storage');
- ref $coderef eq 'CODE' or $self->throw_exception
- ('$coderef must be a CODE reference');
-
- my (@return_values, $return_value);
-
- $self->txn_begin; # If this throws an exception, no rollback is needed
-
- my $wantarray = wantarray; # Need to save this since the context
- # inside the eval{} block is independent
- # of the context that called txn_do()
- eval {
-
- # Need to differentiate between scalar/list context to allow for
- # returning a list in scalar context to get the size of the list
- if ($wantarray) {
- # list context
- @return_values = $coderef->(@args);
- } elsif (defined $wantarray) {
- # scalar context
- $return_value = $coderef->(@args);
- } else {
- # void context
- $coderef->(@args);
- }
- $self->txn_commit;
- };
-
- if ($@) {
- my $error = $@;
-
- eval {
- $self->txn_rollback;
- };
+ ('txn_rollback called on $schema without storage');
- if ($@) {
- my $rollback_error = $@;
- my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
- $self->throw_exception($error) # propagate nested rollback
- if $rollback_error =~ /$exception_class/;
-
- $self->throw_exception(
- "Transaction aborted: $error. Rollback failed: ${rollback_error}"
- );
- } else {
- $self->throw_exception($error); # txn failed but rollback succeeded
- }
- }
-
- return $wantarray ? @return_values : $return_value;
+ $self->storage->txn_rollback;
}
=head2 clone
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)
-package # hide from PAUSE
- DBIx::Class::Storage;
+package DBIx::Class::Storage;
use strict;
use warnings;
-sub new { die "Virtual method!" }
-sub debug { die "Virtual method!" }
-sub debugcb { die "Virtual method!" }
-sub debugfh { die "Virtual method!" }
-sub debugobj { die "Virtual method!" }
-sub cursor { die "Virtual method!" }
-sub disconnect { die "Virtual method!" }
+use base qw/DBIx::Class/;
+
+use Scalar::Util qw/weaken/;
+use Carp::Clan qw/^DBIx::Class/;
+
+__PACKAGE__->load_components(qw/AccessorGroup/);
+__PACKAGE__->mk_group_accessors('simple' => qw/debug debugobj schema/);
+
+package # Hide from PAUSE
+ DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION;
+
+use overload '"' => sub {
+ 'DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION'
+};
+
+sub new {
+ my $class = shift;
+ my $self = {};
+ return bless $self, $class;
+}
+
+package DBIx::Class::Storage;
+
+=head1 NAME
+
+DBIx::Class::Storage - Generic Storage Handler
+
+=head1 DESCRIPTION
+
+A base implementation of common Storage methods. For specific
+information about L<DBI>-based storage, see L<DBIx::Class::Storage::DBI>.
+
+=head1 METHODS
+
+=head2 new
+
+Arguments: $schema
+
+Instantiates the Storage object.
+
+=cut
+
+sub new {
+ my ($self, $schema) = @_;
+
+ $self = ref $self if ref $self;
+
+ my $new = {};
+ bless $new, $self;
+
+ $new->set_schema($schema);
+ $new->debugobj(new DBIx::Class::Storage::Statistics());
+
+ my $fh;
+
+ my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
+ || $ENV{DBIC_TRACE};
+
+ if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
+ $fh = IO::File->new($1, 'w')
+ or $new->throw_exception("Cannot open trace file $1");
+ } else {
+ $fh = IO::File->new('>&STDERR');
+ }
+
+ $new->debugfh($fh);
+ $new->debug(1) if $debug_env;
+
+ $new;
+}
+
+=head2 set_schema
+
+Used to reset the schema class or object which owns this
+storage object, such as during L<DBIx::Class::Schema/clone>.
+
+=cut
+
+sub set_schema {
+ my ($self, $schema) = @_;
+ $self->schema($schema);
+ weaken($self->{schema}) if ref $self->{schema};
+}
+
+=head2 connected
+
+Returns true if we have an open storage connection, false
+if it is not (yet) open.
+
+=cut
+
sub connected { die "Virtual method!" }
+
+=head2 disconnect
+
+Closes any open storage connection unconditionally.
+
+=cut
+
+sub disconnect { die "Virtual method!" }
+
+=head2 ensure_connected
+
+Initiate a connection to the storage if one isn't already open.
+
+=cut
+
sub ensure_connected { die "Virtual method!" }
-sub on_connect_do { die "Virtual method!" }
-sub connect_info { die "Virtual method!" }
-sub sql_maker { die "Virtual method!" }
+
+=head2 throw_exception
+
+Throws an exception - croaks.
+
+=cut
+
+sub throw_exception {
+ my $self = shift;
+
+ $self->schema->throw_exception(@_) if $self->schema;
+ croak @_;
+}
+
+=head2 txn_do
+
+=over 4
+
+=item Arguments: C<$coderef>, @coderef_args?
+
+=item Return Value: The return value of $coderef
+
+=back
+
+Executes C<$coderef> with (optional) arguments C<@coderef_args> atomically,
+returning its result (if any). If an exception is caught, a rollback is issued
+and the exception is rethrown. If the rollback fails, (i.e. throws an
+exception) an exception is thrown that includes a "Rollback failed" message.
+
+For example,
+
+ my $author_rs = $schema->resultset('Author')->find(1);
+ my @titles = qw/Night Day It/;
+
+ my $coderef = sub {
+ # If any one of these fails, the entire transaction fails
+ $author_rs->create_related('books', {
+ title => $_
+ }) foreach (@titles);
+
+ return $author->books;
+ };
+
+ my $rs;
+ eval {
+ $rs = $schema->txn_do($coderef);
+ };
+
+ if ($@) { # Transaction failed
+ die "something terrible has happened!" #
+ if ($@ =~ /Rollback failed/); # Rollback failed
+
+ deal_with_failed_transaction();
+ }
+
+In a nested transaction (calling txn_do() from within a txn_do() coderef) only
+the outermost transaction will issue a L</txn_commit>, and txn_do() can be
+called in void, scalar and list context and it will behave as expected.
+
+=cut
+
+sub txn_do {
+ my ($self, $coderef, @args) = @_;
+
+ ref $coderef eq 'CODE' or $self->throw_exception
+ ('$coderef must be a CODE reference');
+
+ my (@return_values, $return_value);
+
+ $self->txn_begin; # If this throws an exception, no rollback is needed
+
+ my $wantarray = wantarray; # Need to save this since the context
+ # inside the eval{} block is independent
+ # of the context that called txn_do()
+ eval {
+
+ # Need to differentiate between scalar/list context to allow for
+ # returning a list in scalar context to get the size of the list
+ if ($wantarray) {
+ # list context
+ @return_values = $coderef->(@args);
+ } elsif (defined $wantarray) {
+ # scalar context
+ $return_value = $coderef->(@args);
+ } else {
+ # void context
+ $coderef->(@args);
+ }
+ $self->txn_commit;
+ };
+
+ if ($@) {
+ my $error = $@;
+
+ eval {
+ $self->txn_rollback;
+ };
+
+ if ($@) {
+ my $rollback_error = $@;
+ my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
+ $self->throw_exception($error) # propagate nested rollback
+ if $rollback_error =~ /$exception_class/;
+
+ $self->throw_exception(
+ "Transaction aborted: $error. Rollback failed: ${rollback_error}"
+ );
+ } else {
+ $self->throw_exception($error); # txn failed but rollback succeeded
+ }
+ }
+
+ return $wantarray ? @return_values : $return_value;
+}
+
+=head2 txn_begin
+
+Starts a transaction.
+
+See the preferred L</txn_do> method, which allows for
+an entire code block to be executed transactionally.
+
+=cut
+
sub txn_begin { die "Virtual method!" }
+
+=head2 txn_commit
+
+Issues a commit of the current transaction.
+
+=cut
+
sub txn_commit { die "Virtual method!" }
+
+=head2 txn_rollback
+
+Issues a rollback of the current transaction. A nested rollback will
+throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
+which allows the rollback to propagate to the outermost transaction.
+
+=cut
+
sub txn_rollback { die "Virtual method!" }
+
+=head2 sql_maker
+
+Returns a C<sql_maker> object - normally an object of class
+C<DBIC::SQL::Abstract>.
+
+=cut
+
+sub sql_maker { die "Virtual method!" }
+
+=head2 debug
+
+Causes trace information to be emitted on the C<debugobj> object.
+(or C<STDERR> if C<debugobj> has not specifically been set).
+
+This is the equivalent to setting L</DBIC_TRACE> in your
+shell environment.
+
+=head2 debugfh
+
+Set or retrieve the filehandle used for trace/debug output. This should be
+an IO::Handle compatible ojbect (only the C<print> method is used. Initially
+set to be STDERR - although see information on the
+L<DBIC_TRACE> environment variable.
+
+=cut
+
+sub debugfh {
+ my $self = shift;
+
+ if ($self->debugobj->can('debugfh')) {
+ return $self->debugobj->debugfh(@_);
+ }
+}
+
+=head2 debugobj
+
+Sets or retrieves the object used for metric collection. Defaults to an instance
+of L<DBIx::Class::Storage::Statistics> that is compatible with the original
+method of using a coderef as a callback. See the aforementioned Statistics
+class for more information.
+
+=head2 debugcb
+
+Sets a callback to be executed each time a statement is run; takes a sub
+reference. Callback is executed as $sub->($op, $info) where $op is
+SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
+
+See L<debugobj> for a better way.
+
+=cut
+
+sub debugcb {
+ my $self = shift;
+
+ if ($self->debugobj->can('callback')) {
+ return $self->debugobj->callback(@_);
+ }
+}
+
+=head2 cursor
+
+The cursor class for this Storage object.
+
+=cut
+
+sub cursor { die "Virtual method!" }
+
+=head2 deploy
+
+Deploy the tables to storage (CREATE TABLE and friends in a SQL-based
+Storage class). This would normally be called through
+L<DBIx::Class::Schema/deploy>.
+
+=cut
+
+sub deploy { die "Virtual method!" }
+
+=head2 connect_info
+
+The arguments of C<connect_info> are always a single array reference,
+and are Storage-handler specific.
+
+This is normally accessed via L<DBIx::Class::Schema/connection>, which
+encapsulates its argument list in an arrayref before calling
+C<connect_info> here.
+
+=cut
+
+sub connect_info { die "Virtual method!" }
+
+=head2 select
+
+Handle a select statement.
+
+=cut
+
+sub select { die "Virtual method!" }
+
+=head2 insert
+
+Handle an insert statement.
+
+=cut
+
sub insert { die "Virtual method!" }
+
+=head2 update
+
+Handle an update statement.
+
+=cut
+
sub update { die "Virtual method!" }
+
+=head2 delete
+
+Handle a delete statement.
+
+=cut
+
sub delete { die "Virtual method!" }
-sub select { die "Virtual method!" }
+
+=head2 select_single
+
+Performs a select, fetch and return of data - handles a single row
+only.
+
+=cut
+
sub select_single { die "Virtual method!" }
+
+=head2 columns_info_for
+
+Returns metadata for the given source's columns. This
+is *deprecated*, and will be removed before 1.0. You should
+be specifying the metadata yourself if you need it.
+
+=cut
+
sub columns_info_for { die "Virtual method!" }
+=head1 ENVIRONMENT VARIABLES
-package DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION;
+=head2 DBIC_TRACE
-use overload '"' => sub {
- 'DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION'
-};
+If C<DBIC_TRACE> is set then trace information
+is produced (as when the L<debug> method is set).
-sub new {
- my $class = shift;
- my $self = {};
- return bless $self, $class;
-}
+If the value is of the form C<1=/path/name> then the trace output is
+written to the file C</path/name>.
+
+This environment variable is checked when the storage object is first
+created (when you call connect on your schema). So, run-time changes
+to this environment variable will not take effect unless you also
+re-connect on your schema.
+
+=head2 DBIX_CLASS_STORAGE_DBI_DEBUG
+
+Old name for DBIC_TRACE
+
+=head1 AUTHORS
+
+Matt S. Trout <mst@shadowcatsystems.co.uk>
+
+Andy Grundman <andy@hybridized.org>
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
1;
use DBIx::Class::Storage::DBI::Cursor;
use DBIx::Class::Storage::Statistics;
use IO::File;
-use Carp::Clan qw/DBIx::Class/;
+
+__PACKAGE__->mk_group_accessors(
+ 'simple' =>
+ qw/_connect_info _dbh _sql_maker _sql_maker_opts _conn_pid _conn_tid
+ cursor on_connect_do transaction_depth/
+);
+
BEGIN {
package DBIC::SQL::Abstract; # Would merge upstream, but nate doesn't reply :(
} # End of BEGIN block
-use base qw/DBIx::Class/;
-
-__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/);
-
=head1 NAME
DBIx::Class::Storage::DBI - DBI storage handler
=head1 DESCRIPTION
-This class represents the connection to the database
+This class represents the connection to an RDBMS via L<DBI>. See
+L<DBIx::Class::Storage> for general information. This pod only
+documents DBI-specific methods and behaviors.
=head1 METHODS
-=head2 new
-
=cut
sub new {
- my $new = {};
- bless $new, (ref $_[0] || $_[0]);
+ my $new = shift->next::method(@_);
$new->cursor("DBIx::Class::Storage::DBI::Cursor");
$new->transaction_depth(0);
-
- $new->debugobj(new DBIx::Class::Storage::Statistics());
-
- my $fh;
-
- my $debug_env = $ENV{DBIX_CLASS_STORAGE_DBI_DEBUG}
- || $ENV{DBIC_TRACE};
-
- if (defined($debug_env) && ($debug_env =~ /=(.+)$/)) {
- $fh = IO::File->new($1, 'w')
- or $new->throw_exception("Cannot open trace file $1");
- } else {
- $fh = IO::File->new('>&STDERR');
- }
- $new->debugfh($fh);
- $new->debug(1) if $debug_env;
$new->_sql_maker_opts({});
- return $new;
-}
-
-=head2 throw_exception
-
-Throws an exception - croaks.
-
-=cut
-sub throw_exception {
- my ($self, $msg) = @_;
- croak($msg);
+ $new;
}
=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
]
);
+=cut
+
+sub connect_info {
+ my ($self, $info_arg) = @_;
+
+ 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({});
+
+ 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;
+ }
+ }
+
+ # Get rid of any trailing empty hashref
+ pop(@$info) if !keys %$last_info;
+ }
+
+ $self->_connect_info($info);
+}
+
=head2 on_connect_do
This method is deprecated in favor of setting via L</connect_info>.
-=head2 debug
+=head2 dbh_do
+
+Arguments: $subref, @extra_coderef_args?
-Causes SQL trace information to be emitted on the C<debugobj> object.
-(or C<STDERR> if C<debugobj> has not specifically been set).
+Execute the given subref with the underlying database handle as its
+first argument, using the new exception-based connection management.
-This is the equivalent to setting L</DBIC_TRACE> in your
-shell environment.
+Any additional arguments will be passed verbatim to the called subref
+as arguments 2 and onwards.
-=head2 debugfh
+Example:
-Set or retrieve the filehandle used for trace/debug output. This should be
-an IO::Handle compatible ojbect (only the C<print> method is used. Initially
-set to be STDERR - although see information on the
-L<DBIC_TRACE> environment variable.
+ my @stuff = $schema->storage->dbh_do(
+ sub {
+ my $dbh = shift;
+ my $cols = join(q{, }, @_);
+ shift->selectrow_array("SELECT $cols FROM foo")
+ },
+ @column_list
+ );
=cut
-sub debugfh {
- my $self = shift;
+sub dbh_do {
+ my $self = shift;
+ my $coderef = shift;
- if ($self->debugobj->can('debugfh')) {
- return $self->debugobj->debugfh(@_);
+ return $coderef->($self->_dbh, @_) if $self->{_in_txn_do};
+
+ ref $coderef eq 'CODE' or $self->throw_exception
+ ('$coderef must be a CODE reference');
+
+ my @result;
+ my $want_array = wantarray;
+
+ eval {
+ $self->_verify_pid if $self->_dbh;
+ $self->_populate_dbh if !$self->_dbh;
+ if($want_array) {
+ @result = $coderef->($self->_dbh, @_);
+ }
+ elsif(defined $want_array) {
+ $result[0] = $coderef->($self->_dbh, @_);
}
+ else {
+ $coderef->($self->_dbh, @_);
+ }
+ };
+
+ my $exception = $@;
+ if(!$exception) { return $want_array ? @result : $result[0] }
+
+ $self->throw_exception($exception) if $self->connected;
+
+ # We were not connected - reconnect and retry, but let any
+ # exception fall right through this time
+ $self->_populate_dbh;
+ $coderef->($self->_dbh, @_);
}
-=head2 debugobj
+# This is basically a blend of dbh_do above and DBIx::Class::Storage::txn_do.
+# It also informs dbh_do to bypass itself while under the direction of txn_do,
+# via $self->{_in_txn_do} (this saves some redundant eval and errorcheck, etc)
+sub txn_do {
+ my $self = shift;
+ my $coderef = shift;
-Sets or retrieves the object used for metric collection. Defaults to an instance
-of L<DBIx::Class::Storage::Statistics> that is campatible with the original
-method of using a coderef as a callback. See the aforementioned Statistics
-class for more information.
+ ref $coderef eq 'CODE' or $self->throw_exception
+ ('$coderef must be a CODE reference');
-=head2 debugcb
+ local $self->{_in_txn_do} = 1;
-Sets a callback to be executed each time a statement is run; takes a sub
-reference. Callback is executed as $sub->($op, $info) where $op is
-SELECT/INSERT/UPDATE/DELETE and $info is what would normally be printed.
+ my $tried = 0;
-See L<debugobj> for a better way.
+ my @result;
+ my $want_array = wantarray;
-=cut
+ START_TXN: eval {
+ $self->_verify_pid if $self->_dbh;
+ $self->_populate_dbh if !$self->_dbh;
-sub debugcb {
- my $self = shift;
+ $self->txn_begin;
+ if($want_array) {
+ @result = $coderef->(@_);
+ }
+ elsif(defined $want_array) {
+ $result[0] = $coderef->(@_);
+ }
+ else {
+ $coderef->(@_);
+ }
+ $self->txn_commit;
+ };
- if ($self->debugobj->can('callback')) {
- return $self->debugobj->callback(@_);
+ my $exception = $@;
+ if(!$exception) { return $want_array ? @result : $result[0] }
+
+ if($tried++ > 0 || $self->connected) {
+ eval { $self->txn_rollback };
+ my $rollback_exception = $@;
+ if($rollback_exception) {
+ my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
+ $self->throw_exception($exception) # propagate nested rollback
+ if $rollback_exception =~ /$exception_class/;
+
+ $self->throw_exception(
+ "Transaction aborted: ${exception}. "
+ . "Rollback failed: ${rollback_exception}"
+ );
}
+ $self->throw_exception($exception)
+ }
+
+ # We were not connected, and was first try - reconnect and retry
+ # XXX I know, gotos are evil. If you can find a better way
+ # to write this that doesn't duplicate a lot of code/structure,
+ # and behaves identically, feel free...
+
+ $self->_populate_dbh;
+ goto START_TXN;
}
=head2 disconnect
-Disconnect the L<DBI> handle, performing a rollback first if the
+Our C<disconnect> method also performs a rollback first if the
database is not in C<AutoCommit> mode.
=cut
}
}
-=head2 connected
-
-Check if the L<DBI> handle is connected. Returns true if the handle
-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);
}
return 0;
}
-=head2 ensure_connected
+# handle pid changes correctly
+# NOTE: assumes $self->_dbh is a valid $dbh
+sub _verify_pid {
+ my ($self) = @_;
-Check whether the database handle is connected - if not then make a
-connection.
+ return if $self->_conn_pid == $$;
-=cut
+ $self->_dbh->{InactiveDestroy} = 1;
+ $self->_dbh(undef);
+
+ return;
+}
sub ensure_connected {
my ($self) = @_;
return ( limit_dialect => $self->dbh, %{$self->_sql_maker_opts} );
}
-=head2 sql_maker
-
-Returns a C<sql_maker> object - normally an object of class
-C<DBIC::SQL::Abstract>.
-
-=cut
-
sub sql_maker {
my ($self) = @_;
unless ($self->_sql_maker) {
return $self->_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;
- }
- }
-
- # Get rid of any trailing empty hashref
- pop(@$info) if !keys %$last_info;
- }
-
- $self->_connect_info($info);
- }
-
- $self->_connect_info;
-}
-
sub _populate_dbh {
my ($self) = @_;
my @info = @{$self->_connect_info || []};
}
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;
$dbh;
}
-=head2 txn_begin
-
-Calls begin_work on the current dbh.
-
-See L<DBIx::Class::Schema> for the txn_do() method, which allows for
-an entire code block to be executed transactionally.
-
-=cut
+sub __txn_begin {
+ my ($dbh, $self) = @_;
+ if ($dbh->{AutoCommit}) {
+ $self->debugobj->txn_begin()
+ if ($self->debug);
+ $dbh->begin_work;
+ }
+}
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(\&__txn_begin, $self)
+ if $self->{transaction_depth}++ == 0;
}
-=head2 txn_commit
-
-Issues a commit against the current dbh.
-
-=cut
-
-sub txn_commit {
- my $self = shift;
- my $dbh = $self->dbh;
+sub __txn_commit {
+ my ($dbh, $self) = @_;
if ($self->{transaction_depth} == 0) {
unless ($dbh->{AutoCommit}) {
$self->debugobj->txn_commit()
}
}
-=head2 txn_rollback
-
-Issues a rollback against the current dbh. A nested rollback will
-throw a L<DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION> exception,
-which allows the rollback to propagate to the outermost transaction.
-
-=cut
-
-sub txn_rollback {
+sub txn_commit {
my $self = shift;
+ $self->dbh_do(\&__txn_commit, $self);
+}
- eval {
- my $dbh = $self->dbh;
- if ($self->{transaction_depth} == 0) {
- unless ($dbh->{AutoCommit}) {
- $self->debugobj->txn_rollback()
- if ($self->debug);
- $dbh->rollback;
- }
+sub __txn_rollback {
+ my ($dbh, $self) = @_;
+ 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;
}
else {
- if (--$self->{transaction_depth} == 0) {
- $self->debugobj->txn_rollback()
- if ($self->debug);
- $dbh->rollback;
- }
- else {
- die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
- }
+ die DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION->new;
}
- };
+ }
+}
+sub txn_rollback {
+ my $self = shift;
+ eval { $self->dbh_do(\&__txn_rollback, $self) };
if ($@) {
my $error = $@;
my $exception_class = "DBIx::Class::Storage::NESTED_ROLLBACK_EXCEPTION";
return $self->cursor->new($self, \@_, $attrs);
}
-=head2 select_single
-
-Performs a select, fetch and return of data - handles a single row
-only.
-
-=cut
-
-# Need to call finish() to work round broken DBDs
-
sub select_single {
my $self = shift;
my ($rv, $sth, @bind) = $self->_select(@_);
my @row = $sth->fetchrow_array;
+ # Need to call finish() to work round broken DBDs
$sth->finish();
return @row;
}
=cut
-sub sth {
- my ($self, $sql) = @_;
+sub __sth {
+ my ($dbh, $sql) = @_;
# 3 is the if_active parameter which avoids active sth re-use
- return $self->dbh->prepare_cached($sql, {}, 3);
+ $dbh->prepare_cached($sql, {}, 3);
}
-=head2 columns_info_for
-
-Returns database type info for a given table column.
-
-=cut
+sub sth {
+ my ($self, $sql) = @_;
+ $self->dbh_do(\&__sth, $sql);
+}
-sub columns_info_for {
- my ($self, $table) = @_;
- my $dbh = $self->dbh;
+sub __columns_info_for {
+ my ($dbh, $self, $table) = @_;
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();
-
while ( my $info = $sth->fetchrow_hashref() ){
my %column_info;
$column_info{data_type} = $info->{TYPE_NAME};
return \%result;
}
+sub columns_info_for {
+ my ($self, $table) = @_;
+ $self->dbh_do(\&__columns_info_for, $self, $table);
+}
+
=head2 last_insert_id
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
=cut
-sub sqlt_type { shift->dbh->{Driver}->{Name} }
+sub sqlt_type { shift->dbh_do(sub { shift->{Driver}->{Name} }) }
=head2 create_ddl_dir (EXPERIMENTAL)
}
-=head2 deploy
-
-Sends the appropriate statements to create or modify tables to the
-db. This would normally be called through
-L<DBIx::Class::Schema/deploy>.
-
-=cut
-
sub deploy {
my ($self, $schema, $type, $sqltargs, $dir) = @_;
foreach my $statement ( $self->deployment_statements($schema, $type, undef, $dir, { no_comments => 1, %{ $sqltargs || {} } } ) ) {
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;
}
}
}
sub DESTROY {
- # NOTE: if there's a merge conflict here when -current is pushed
- # back to trunk, take -current's version and ignore this trunk one :)
my $self = shift;
-
- if($self->_dbh && $self->_conn_pid != $$) {
- $self->_dbh->{InactiveDestroy} = 1;
- }
-
+ return if !$self->_dbh;
+ $self->_verify_pid;
$self->_dbh(undef);
}
=back
-=head1 ENVIRONMENT VARIABLES
-
-=head2 DBIC_TRACE
-
-If C<DBIC_TRACE> is set then SQL trace information
-is produced (as when the L<debug> method is set).
-
-If the value is of the form C<1=/path/name> then the trace output is
-written to the file C</path/name>.
-
-This environment variable is checked when the storage object is first
-created (when you call connect on your schema). So, run-time changes
-to this environment variable will not take effect unless you also
-re-connect on your schema.
-
-=head2 DBIX_CLASS_STORAGE_DBI_DEBUG
-
-Old name for DBIC_TRACE
-
=head1 AUTHORS
Matt S. Trout <mst@shadowcatsystems.co.uk>
{
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;
use strict;
use warnings;
-use Carp qw/croak/;
+use Carp::Clan qw/^DBIx::Class/;
use base qw/DBIx::Class::Storage::DBI::MultiDistinctEmulation/;
# __PACKAGE__->load_components(qw/PK::Auto/);
+sub _ora_last_insert_id {
+ my ($dbh, $sql) = @_;
+ $dbh->selectrow_array($sql);
+}
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 $sql = 'SELECT ' . $seq . '.currval FROM DUAL';
+ my ($id) = $self->dbh_do(\&_ora_last_insert_id($sql));
return $id;
}
+sub _ora_get_autoinc_seq {
+ my ($dbh, $source, $sql) = @_;
+
+ # 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 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(\&_ora_get_autoinc_seq, $source, $sql);
}
sub columns_info_for {
warn "DBD::Pg 1.49 is strongly recommended"
if ($DBD::Pg::VERSION < 1.49);
+sub _pg_last_insert_id {
+ my ($dbh, $seq) = @_;
+ $dbh->last_insert_id(undef,undef,undef,undef, {sequence => $seq});
+}
+
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(\&_pg_last_insert_id, $seq);
+}
+
+sub _pg_get_autoinc_seq {
+ my ($dbh, $schema, $table, @pri) = @_;
+
+ 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;
+ # may need to strip quotes -- see if this works
+ return $seq =~ /\./ ? $seq : $info->{TABLE_SCHEM} . "." . $seq;
+ }
+ }
+ return;
}
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(\&_pg_get_autoinc_seq, $schema, $table, @pri);
}
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 {
package DBIx::Class::Storage::Statistics;
use strict;
+use warnings;
use base qw/DBIx::Class::AccessorGroup Class::Data::Accessor/;
__PACKAGE__->mk_group_accessors(simple => qw/callback debugfh/);
'DBIx::Class::Relationship::ProxyMethods' => { skip => 1 },
'DBIx::Class::ResultSetProxy' => { skip => 1 },
'DBIx::Class::ResultSourceProxy' => { skip => 1 },
- 'DBIx::Class::Storage' => { skip => 1 },
+ 'DBIx::Class::Storage::DBI' => { skip => 1 },
'DBIx::Class::Storage::DBI::DB2' => { skip => 1 },
'DBIx::Class::Storage::DBI::MSSQL' => { skip => 1 },
'DBIx::Class::Storage::DBI::MultiDistinctEmulation' => { skip => 1 },
$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/);
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+unshift(@INC, './t/lib');
+
+plan tests => 6;
+
+my $warnings;
+eval {
+ local $SIG{__WARN__} = sub { $warnings .= shift };
+ package DBICNSTest;
+ use base qw/DBIx::Class::Schema/;
+ __PACKAGE__->load_namespaces;
+};
+ok(!$@) or diag $@;
+like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
+
+my $source_a = DBICNSTest->source('A');
+isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
+my $rset_a = DBICNSTest->resultset('A');
+isa_ok($rset_a, 'DBICNSTest::ResultSet::A');
+
+my $source_b = DBICNSTest->source('B');
+isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
+my $rset_b = DBICNSTest->resultset('B');
+isa_ok($rset_b, 'DBIx::Class::ResultSet');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+unshift(@INC, './t/lib');
+
+plan tests => 6;
+
+my $warnings;
+eval {
+ local $SIG{__WARN__} = sub { $warnings .= shift };
+ package DBICNSTest;
+ use base qw/DBIx::Class::Schema/;
+ __PACKAGE__->load_namespaces(
+ result_namespace => 'Rslt',
+ resultset_namespace => 'RSet',
+ );
+};
+ok(!$@) or diag $@;
+like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
+
+my $source_a = DBICNSTest->source('A');
+isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
+my $rset_a = DBICNSTest->resultset('A');
+isa_ok($rset_a, 'DBICNSTest::RSet::A');
+
+my $source_b = DBICNSTest->source('B');
+isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
+my $rset_b = DBICNSTest->resultset('B');
+isa_ok($rset_b, 'DBIx::Class::ResultSet');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+unshift(@INC, './t/lib');
+
+plan tests => 7;
+
+my $warnings;
+eval {
+ local $SIG{__WARN__} = sub { $warnings .= shift };
+ package DBICNSTestOther;
+ use base qw/DBIx::Class::Schema/;
+ __PACKAGE__->load_namespaces(
+ result_namespace => [ '+DBICNSTest::Rslt', '+DBICNSTest::OtherRslt' ],
+ resultset_namespace => '+DBICNSTest::RSet',
+ );
+};
+ok(!$@) or diag $@;
+like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
+
+my $source_a = DBICNSTestOther->source('A');
+isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
+my $rset_a = DBICNSTestOther->resultset('A');
+isa_ok($rset_a, 'DBICNSTest::RSet::A');
+
+my $source_b = DBICNSTestOther->source('B');
+isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
+my $rset_b = DBICNSTestOther->resultset('B');
+isa_ok($rset_b, 'DBIx::Class::ResultSet');
+
+my $source_d = DBICNSTestOther->source('D');
+isa_ok($source_d, 'DBIx::Class::ResultSource::Table');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+unshift(@INC, './t/lib');
+
+plan tests => 6;
+
+my $warnings;
+eval {
+ local $SIG{__WARN__} = sub { $warnings .= shift };
+ package DBICNSTest;
+ use base qw/DBIx::Class::Schema/;
+ __PACKAGE__->load_namespaces( default_resultset_class => 'RSBase' );
+};
+ok(!$@) or diag $@;
+like($warnings, qr/load_namespaces found ResultSet class C with no corresponding Result class/);
+
+my $source_a = DBICNSTest->source('A');
+isa_ok($source_a, 'DBIx::Class::ResultSource::Table');
+my $rset_a = DBICNSTest->resultset('A');
+isa_ok($rset_a, 'DBICNSTest::ResultSet::A');
+
+my $source_b = DBICNSTest->source('B');
+isa_ok($source_b, 'DBIx::Class::ResultSource::Table');
+my $rset_b = DBICNSTest->resultset('B');
+isa_ok($rset_b, 'DBICNSTest::RSBase');
my $schema = DBICTest->init_schema();
-plan tests => 63;
+plan tests => 64;
# figure out if we've got a version of sqlite that is older than 3.2.6, in
# which case COUNT(DISTINCT()) doesn't work
# 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');
ok($schema->source("Artist")->{_columns_info_loaded} == 1, 'Columns info flag set');
}
+# test source_info
+{
+ my $expected = {
+ "source_info_key_A" => "source_info_value_A",
+ "source_info_key_B" => "source_info_value_B",
+ "source_info_key_C" => "source_info_value_C",
+ };
+
+ my $sinfo = $schema->source("Artist")->source_info;
+
+ is_deeply($sinfo, $expected, 'source_info data works');
+}
+
# test remove_columns
{
is_deeply([$schema->source('CD')->columns], [qw/cdid artist title year/]);
__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');
}
# Force txn_rollback() to throw an exception
no warnings 'redefine';
no strict 'refs';
- local *{"DBIx::Class::Schema::txn_rollback"} = sub{die 'FAILED'};
+ local *{"DBIx::Class::Storage::DBI::SQLite::txn_rollback"} = sub{die 'FAILED'};
eval {
$schema->txn_do($fail_code, $artist);
--- /dev/null
+package DBICNSTest::OtherRslt::D;
+use base qw/DBIx::Class/;
+__PACKAGE__->load_components(qw/PK::Auto Core/);
+__PACKAGE__->table('d');
+__PACKAGE__->add_columns('d');
+1;
--- /dev/null
+package DBICNSTest::RSBase;
+use base qw/DBIx::Class::ResultSet/;
+1;
--- /dev/null
+package DBICNSTest::RSet::A;
+use base qw/DBIx::Class::ResultSet/;
+1;
--- /dev/null
+package DBICNSTest::RSet::C;
+use base qw/DBIx::Class::ResultSet/;
+1;
--- /dev/null
+package DBICNSTest::Result::A;
+use base qw/DBIx::Class/;
+__PACKAGE__->load_components(qw/PK::Auto Core/);
+__PACKAGE__->table('a');
+__PACKAGE__->add_columns('a');
+1;
--- /dev/null
+package DBICNSTest::Result::B;
+use base qw/DBIx::Class/;
+__PACKAGE__->load_components(qw/PK::Auto Core/);
+__PACKAGE__->table('b');
+__PACKAGE__->add_columns('b');
+1;
--- /dev/null
+package DBICNSTest::ResultSet::A;
+use base qw/DBIx::Class::ResultSet/;
+1;
--- /dev/null
+package DBICNSTest::ResultSet::C;
+use base qw/DBIx::Class::ResultSet/;
+1;
--- /dev/null
+package DBICNSTest::Rslt::A;
+use base qw/DBIx::Class/;
+__PACKAGE__->load_components(qw/PK::Auto Core/);
+__PACKAGE__->table('a');
+__PACKAGE__->add_columns('a');
+1;
--- /dev/null
+package DBICNSTest::Rslt::B;
+use base qw/DBIx::Class/;
+__PACKAGE__->load_components(qw/PK::Auto Core/);
+__PACKAGE__->table('b');
+__PACKAGE__->add_columns('b');
+1;
use base 'DBIx::Class::Core';
__PACKAGE__->table('artist');
+__PACKAGE__->source_info({
+ "source_info_key_A" => "source_info_value_A",
+ "source_info_key_B" => "source_info_value_B",
+ "source_info_key_C" => "source_info_value_C",
+});
__PACKAGE__->add_columns(
'artistid' => {
data_type => 'integer',
projects / dbsrgits/DBIx-Class.git / commitdiff