Module::Find is a real dep in Build.PL

[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Schema.pm

diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm
index 98cfd48..d81320e 100644 (file)
--- a/lib/DBIx/Class/Schema.pm
+++ b/lib/DBIx/Class/Schema.pm
@@ -5,6 +5,7 @@ use warnings;
 
 use Carp::Clan qw/^DBIx::Class/;
 use Scalar::Util qw/weaken/;
+require Module::Find;
 
 use base qw/DBIx::Class/;
 
@@ -12,6 +13,7 @@ __PACKAGE__->mk_classdata('class_mappings' => {});
 __PACKAGE__->mk_classdata('source_registrations' => {});
 __PACKAGE__->mk_classdata('storage_type' => '::DBI');
 __PACKAGE__->mk_classdata('storage');
+__PACKAGE__->mk_classdata('exception_action');
 
 =head1 NAME
 
@@ -247,10 +249,6 @@ sub load_classes {
       }
     }
   } 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;
@@ -306,8 +304,6 @@ 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<+>.
 
-This method requires L<Module::Find> to be installed on the system.
-
 Example:
 
   # load My::Schema::ResultSource::CD, My::Schema::ResultSource::Artist,
@@ -350,9 +346,6 @@ sub load_namespaces {
     $_ = $class . '::' . $_ if !s/^\+//;
   }
 
-  eval "require Module::Find";
-  $class->throw_exception("Couldn't load Module::Find ($@)") if $@;
-
   my %sources = map { (substr($_, length "${resultsource_namespace}::"), $_) }
       Module::Find::findallmod($resultsource_namespace);
 
@@ -392,6 +385,19 @@ sub load_namespaces {
            . "that you had already set '$source' to use '$rs_set' instead";
       }
 
+      my $r_class = delete $results{$source};
+      if($r_class) {
+        my $r_set = $source_class->result_class;
+        if(!$r_set || $r_set eq $sources{$source}) {
+          $class->ensure_class_loaded($r_class);
+          $source_class->result_class($r_class);
+        }
+        else {
+          warn "We found Result class '$r_class' for '$source', but it seems "
+             . "that you had already set '$source' to use '$r_set' instead";
+        }
+      }
+
       push(@to_register, [ $source_class->source_name, $source_class ]);
     }
   }
@@ -401,29 +407,14 @@ sub load_namespaces {
       . 'corresponding ResultSource';
   }
 
-  Class::C3->reinitialize;
-  $class->register_class(@$_) for (@to_register);
-
-  foreach my $source (keys %sources) {
-    my $r_class = delete $results{$source};
-    if($r_class) {
-      my $r_set = $class->source($source)->result_class;
-      if(!$r_set || $r_set eq $sources{$source}) {
-        $class->ensure_class_loaded($r_class);
-        $class->source($source)->result_class($r_class);
-      }
-      else {
-        warn "We found Result class '$r_class' for '$source', but it seems "
-           . "that you had already set '$source' to use '$r_set' instead";
-      }
-    }
-  }
-
   foreach (sort keys %results) {
     warn "load_namespaces found Result class $_ with no "
       . 'corresponding ResultSource';
   }
 
+  Class::C3->reinitialize;
+  $class->register_class(@$_) for (@to_register);
+
   return;
 }
 
@@ -601,7 +592,7 @@ sub connection {
   $self->throw_exception(
     "No arguments to load_classes and couldn't load ${storage_class} ($@)"
   ) if $@;
-  my $storage = $storage_class->new;
+  my $storage = $storage_class->new($self);
   $storage->connect_info(\@info);
   $self->storage($storage);
   return $self;
@@ -780,6 +771,7 @@ sub clone {
     my $new = $source->new($source);
     $clone->register_source($moniker => $new);
   }
+  $clone->storage->set_schema($clone) if $clone->storage;
   return $clone;
 }
 
@@ -819,6 +811,38 @@ sub populate {
   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
@@ -828,13 +852,14 @@ sub populate {
 =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)