__PACKAGE__->mk_classdata('source_registrations' => {});
__PACKAGE__->mk_classdata('storage_type' => '::DBI');
__PACKAGE__->mk_classdata('storage');
+__PACKAGE__->mk_classdata('exception_action');
=head1 NAME
$target_class => $source->result_class, ($base ? $base : ())
);
$source->result_class($target_class);
+ $target_class->result_source_instance($source)
+ if $target_class->can('result_source_instance');
}
}
Class::C3->reinitialize();
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.
-
-=cut
-
-sub txn_begin { shift->storage->txn_begin }
+=head2 txn_do
-=head2 txn_commit
+=over 4
-Commits the current transaction. Equivalent to calling
-$schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
-for more information.
+=item Arguments: C<$coderef>, @coderef_args?
-=cut
+=item Return Value: The return value of $coderef
-sub txn_commit { shift->storage->txn_commit }
+=back
-=head2 txn_rollback
+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.
-Rolls back the current transaction. Equivalent to calling
-$schema->storage->txn_rollback. See
-L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
+This interface is preferred over using the individual methods L</txn_begin>,
+L</txn_commit>, and L</txn_rollback> below.
=cut
-sub txn_rollback { shift->storage->txn_rollback }
-
-=head2 txn_do
+sub txn_do {
+ my $self = shift;
-=over 4
+ $self->storage or $self->throw_exception
+ ('txn_do called on $schema without storage');
-=item Arguments: C<$coderef>, @coderef_args?
+ $self->storage->txn_do(@_);
+}
-=item Return Value: The return value of $coderef
+=head2 txn_begin
-=back
+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.
-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.
+=cut
-For example,
+sub txn_begin {
+ my $self = shift;
- my $author_rs = $schema->resultset('Author')->find(1);
- my @titles = qw/Night Day It/;
+ $self->storage or $self->throw_exception
+ ('txn_begin called on $schema without storage');
- my $coderef = sub {
- # If any one of these fails, the entire transaction fails
- $author_rs->create_related('books', {
- title => $_
- }) foreach (@titles);
+ $self->storage->txn_begin;
+}
- return $author->books;
- };
+=head2 txn_commit
- my $rs;
- eval {
- $rs = $schema->txn_do($coderef);
- };
+Commits the current transaction. Equivalent to calling
+$schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
+for more information.
- if ($@) { # Transaction failed
- die "something terrible has happened!" #
- if ($@ =~ /Rollback failed/); # Rollback failed
+=cut
- deal_with_failed_transaction();
- }
+sub txn_commit {
+ my $self = shift;
-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.
+ $self->storage or $self->throw_exception
+ ('txn_commit called on $schema without storage');
-=cut
+ $self->storage->txn_commit;
+}
-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;
- };
+=head2 txn_rollback
- if ($@) {
- my $error = $@;
+Rolls back the current transaction. Equivalent to calling
+$schema->storage->txn_rollback. See
+L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
- eval {
- $self->txn_rollback;
- };
+=cut
- 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/;
+sub txn_rollback {
+ my $self = shift;
- $self->throw_exception(
- "Transaction aborted: $error. Rollback failed: ${rollback_error}"
- );
- } else {
- $self->throw_exception($error); # txn failed but rollback succeeded
- }
- }
+ $self->storage or $self->throw_exception
+ ('txn_rollback called on $schema without storage');
- return $wantarray ? @return_values : $return_value;
+ $self->storage->txn_rollback;
}
=head2 clone
sub clone {
my ($self) = @_;
- my $clone = bless({ (ref $self ? %$self : ()) }, ref $self || $self);
+ my $clone = { (ref $self ? %$self : ()) };
+ bless $clone, (ref $self || $self);
+
foreach my $moniker ($self->sources) {
my $source = $self->source($moniker);
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)
=over 4
-=item Arguments: $sqlt_args
+=item Arguments: $sqlt_args, $dir
=back
Note that this feature is currently EXPERIMENTAL and may not work correctly
across all databases, or fully handle complex relationships.
+See L<SQL::Translator/METHODS> for a list of values for C<$sqlt_args>. The most
+common value for this would be C<< { add_drop_table => 1, } >> to have the SQL
+produced include a DROP TABLE statement for each table created.
+
=cut
sub deploy {
- my ($self, $sqltargs) = @_;
+ my ($self, $sqltargs, $dir) = @_;
$self->throw_exception("Can't deploy without storage") unless $self->storage;
- $self->storage->deploy($self, undef, $sqltargs);
+ $self->storage->deploy($self, undef, $sqltargs, $dir);
}
=head2 create_ddl_dir (EXPERIMENTAL)
=cut
-sub create_ddl_dir
-{
+sub create_ddl_dir {
my $self = shift;
$self->throw_exception("Can't create_ddl_dir without storage") unless $self->storage;
=cut
-sub ddl_filename
-{
+sub ddl_filename {
my ($self, $type, $dir, $version) = @_;
my $filename = ref($self);
- $filename =~ s/^.*:://;
+ $filename =~ s/::/-/;
$filename = "$dir$filename-$version-$type.sql";
return $filename;
You may distribute this code under the same terms as Perl itself.
=cut
-
projects / dbsrgits/DBIx-Class.git / blobdiff