Fix load_namespaces fail when classes tinker with $_
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Schema.pm
index 2e8f982..348edeb 100644 (file)
@@ -4,11 +4,14 @@ use strict;
 use warnings;
 
 use DBIx::Class::Exception;
-use Carp::Clan qw/^DBIx::Class/;
-use Scalar::Util qw/weaken/;
+use Carp::Clan qw/^DBIx::Class|^Try::Tiny/;
+use Try::Tiny;
+use Scalar::Util 'weaken';
 use File::Spec;
-use Sub::Name ();
+use Sub::Name 'subname';
 use Module::Find();
+use Storable();
+use namespace::clean;
 
 use base qw/DBIx::Class/;
 
@@ -82,7 +85,7 @@ particular which module inherits off which.
 
 With no arguments, this method uses L<Module::Find> to load all your
 Result classes from a sub-namespace F<Result> under your Schema class'
-namespace. Eg. With a Schema of I<MyDB::Schema> all files in
+namespace, i.e. with a Schema of I<MyDB::Schema> all files in
 I<MyDB::Schema::Result> are assumed to be Result classes.
 
 It also finds all ResultSet classes in the namespace F<ResultSet> and
@@ -98,7 +101,7 @@ are no matching Result classes like this:
 If a Result class is found to already have a ResultSet class set using
 L</resultset_class> to some other class, you will be warned like this:
 
-  We found ResultSet class '$rs_class' for '$result', but it seems 
+  We found ResultSet class '$rs_class' for '$result', but it seems
   that you had already set '$result' to use '$rs_set' instead
 
 Both of the sub-namespaces are configurable if you don't like the defaults,
@@ -241,7 +244,9 @@ sub load_namespaces {
     use warnings 'redefine';
 
     # ensure classes are loaded and attached in inheritance order
-    $class->ensure_class_loaded($_) foreach(values %results);
+    for my $res (values %results) {
+      $class->ensure_class_loaded($res);
+    }
     my %inh_idx;
     my @subclass_last = sort {
 
@@ -271,6 +276,10 @@ sub load_namespaces {
       }
       elsif($rs_class ||= $default_resultset_class) {
         $class->ensure_class_loaded($rs_class);
+        if(!$rs_class->isa("DBIx::Class::ResultSet")) {
+            carp "load_namespaces found ResultSet class $rs_class that does not subclass DBIx::Class::ResultSet";
+        }
+
         $class->_ns_get_rsrc_instance ($result_class)->resultset_class($rs_class);
       }
 
@@ -315,7 +324,7 @@ need to add C<no warnings 'qw';> before your load_classes call.
 If any classes found do not appear to be Result class files, you will
 get the following warning:
 
-   Failed to load $comp_class. Can't find source_name method. Is 
+   Failed to load $comp_class. Can't find source_name method. Is
    $comp_class really a full DBIC result class? Fix it, move it elsewhere,
    or make your load_classes call more specific.
 
@@ -431,14 +440,13 @@ L<DBIx::Class::Storage::DBI::Replicated> for an example of this.
 
 =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 L<DBIx::Class::Exception/throw>.
+When L</throw_exception> is invoked and L</exception_action> is set to a code
+reference, this reference will be called instead of
+L<DBIx::Class::Exception/throw>, with the exception message passed as the only
+argument.
 
-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.
+Your custom throw code B<must> rethrow the exception, as L</throw_exception> is
+an integral part of DBIC's internal execution control flow.
 
 Example:
 
@@ -452,9 +460,6 @@ Example:
    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 stacktrace
 
 =over 4
@@ -475,11 +480,11 @@ is true.
 
 =back
 
-An optional sub which you can declare in your own Schema class that will get 
+An optional sub which you can declare in your own Schema class that will get
 passed the L<SQL::Translator::Schema> object when you deploy the schema via
 L</create_ddl_dir> or L</deploy>.
 
-For an example of what you can do with this, see 
+For an example of what you can do with this, see
 L<DBIx::Class::Manual::Cookbook/Adding Indexes And Functions To Your SQL>.
 
 Note that sqlt_deploy_hook is called by L</deployment_statements>, which in turn
@@ -651,7 +656,7 @@ sub txn_do {
 
 =head2 txn_scope_guard
 
-Runs C<txn_scope_guard> on the schema's storage. See 
+Runs C<txn_scope_guard> on the schema's storage. See
 L<DBIx::Class::Storage/txn_scope_guard>.
 
 =cut
@@ -669,7 +674,7 @@ sub txn_scope_guard {
 
 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.
+L<DBIx::Class::Storage/"txn_begin"> for more information.
 
 =cut
 
@@ -685,7 +690,7 @@ sub txn_begin {
 =head2 txn_commit
 
 Commits the current transaction. Equivalent to calling
-$schema->storage->txn_commit. See L<DBIx::Class::Storage::DBI/"txn_commit">
+$schema->storage->txn_commit. See L<DBIx::Class::Storage/"txn_commit">
 for more information.
 
 =cut
@@ -703,7 +708,7 @@ sub txn_commit {
 
 Rolls back the current transaction. Equivalent to calling
 $schema->storage->txn_rollback. See
-L<DBIx::Class::Storage::DBI/"txn_rollback"> for more information.
+L<DBIx::Class::Storage/"txn_rollback"> for more information.
 
 =cut
 
@@ -737,7 +742,7 @@ found in L<DBIx::Class::Storage::DBI>.
 
 Pass this method a resultsource name, and an arrayref of
 arrayrefs. The arrayrefs should contain a list of column names,
-followed by one or many sets of matching data for the given columns. 
+followed by one or many sets of matching data for the given columns.
 
 In void context, C<insert_bulk> in L<DBIx::Class::Storage::DBI> is used
 to insert the data, as this is a fast method. However, insert_bulk currently
@@ -748,7 +753,7 @@ Otherwise, each set of data is inserted into the database using
 L<DBIx::Class::ResultSet/create>, and a arrayref of the resulting row
 objects is returned.
 
-i.e.,
+e.g.
 
   $schema->populate('Artist', [
     [ qw/artistid name/ ],
@@ -757,16 +762,16 @@ i.e.,
     ...
   ]);
 
-Since wantarray context is basically the same as looping over $rs->create(...) 
+Since wantarray context is basically the same as looping over $rs->create(...)
 you won't see any performance benefits and in this case the method is more for
 convenience. Void context sends the column information directly to storage
-using <DBI>s bulk insert method. So the performance will be much better for 
+using <DBI>s bulk insert method. So the performance will be much better for
 storages that support this method.
 
-Because of this difference in the way void context inserts rows into your 
+Because of this difference in the way void context inserts rows into your
 database you need to note how this will effect any loaded components that
-override or augment insert.  For example if you are using a component such 
-as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use 
+override or augment insert.  For example if you are using a component such
+as L<DBIx::Class::UUIDColumns> to populate your primary keys you MUST use
 wantarray context if you want the PKs automatically created.
 
 =cut
@@ -780,7 +785,7 @@ sub populate {
         $rs->populate($data);
     }
   } else {
-      $self->throw_exception("$name is not a resultset"); 
+      $self->throw_exception("$name is not a resultset");
   }
 }
 
@@ -808,15 +813,19 @@ sub connection {
   my ($self, @info) = @_;
   return $self if !@info && $self->storage;
 
-  my ($storage_class, $args) = ref $self->storage_type ? 
+  my ($storage_class, $args) = ref $self->storage_type ?
     ($self->_normalize_storage_type($self->storage_type),{}) : ($self->storage_type, {});
 
   $storage_class = 'DBIx::Class::Storage'.$storage_class
     if $storage_class =~ m/^::/;
-  eval { $self->ensure_class_loaded ($storage_class) };
-  $self->throw_exception(
-    "No arguments to load_classes and couldn't load ${storage_class} ($@)"
-  ) if $@;
+  try {
+    $self->ensure_class_loaded ($storage_class);
+  }
+  catch {
+    $self->throw_exception(
+      "No arguments to load_classes and couldn't load ${storage_class} ($_)"
+    );
+  };
   my $storage = $storage_class->new($self=>$args);
   $storage->connect_info(\@info);
   $self->storage($storage);
@@ -851,7 +860,7 @@ attached to the current schema.
 
 It also attaches a corresponding L<DBIx::Class::ResultSource> object to the
 new $schema object. If C<$additional_base_class> is given, the new composed
-classes will inherit from first the corresponding classe from the current
+classes will inherit from first the corresponding class from the current
 schema then the base class.
 
 For example, for a schema with My::Schema::CD and My::Schema::Artist classes,
@@ -891,6 +900,7 @@ sub compose_namespace {
   my $schema = $self->clone;
   {
     no warnings qw/redefine/;
+    no strict qw/refs/;
 #    local *Class::C3::reinitialize = sub { };
     foreach my $moniker ($schema->sources) {
       my $source = $schema->source($moniker);
@@ -899,8 +909,14 @@ sub compose_namespace {
         $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');
+      if ($target_class->can('result_source_instance')) {
+
+        # since the newly created classes are registered only with
+        # the instance of $schema, it should be safe to weaken
+        # the ref (it will GC when $schema is destroyed)
+        $target_class->result_source_instance($source);
+        weaken ${"${target_class}::__cag_result_source_instance"};
+      }
      $schema->register_source($moniker, $source);
     }
   }
@@ -909,7 +925,7 @@ sub compose_namespace {
     no strict 'refs';
     no warnings 'redefine';
     foreach my $meth (qw/class source resultset/) {
-      *{"${target}::${meth}"} = Sub::Name::subname "${target}::${meth}" =>
+      *{"${target}::${meth}"} = subname "${target}::${meth}" =>
         sub { shift->schema->$meth(@_) };
     }
   }
@@ -925,9 +941,9 @@ sub setup_connection_class {
 
 =head2 svp_begin
 
-Creates a new savepoint (does nothing outside a transaction). 
+Creates a new savepoint (does nothing outside a transaction).
 Equivalent to calling $schema->storage->svp_begin.  See
-L<DBIx::Class::Storage::DBI/"svp_begin"> for more information.
+L<DBIx::Class::Storage/"svp_begin"> for more information.
 
 =cut
 
@@ -942,9 +958,9 @@ sub svp_begin {
 
 =head2 svp_release
 
-Releases a savepoint (does nothing outside a transaction). 
+Releases a savepoint (does nothing outside a transaction).
 Equivalent to calling $schema->storage->svp_release.  See
-L<DBIx::Class::Storage::DBI/"svp_release"> for more information.
+L<DBIx::Class::Storage/"svp_release"> for more information.
 
 =cut
 
@@ -959,9 +975,9 @@ sub svp_release {
 
 =head2 svp_rollback
 
-Rollback to a savepoint (does nothing outside a transaction). 
+Rollback to a savepoint (does nothing outside a transaction).
 Equivalent to calling $schema->storage->svp_rollback.  See
-L<DBIx::Class::Storage::DBI/"svp_rollback"> for more information.
+L<DBIx::Class::Storage/"svp_rollback"> for more information.
 
 =cut
 
@@ -1020,11 +1036,29 @@ default behavior will provide a detailed stack trace.
 
 =cut
 
+my $false_exception_action_warned;
 sub throw_exception {
   my $self = shift;
 
-  DBIx::Class::Exception->throw($_[0], $self->stacktrace)
-    if !$self->exception_action || !$self->exception_action->(@_);
+  if (my $act = $self->exception_action) {
+    if ($act->(@_)) {
+      DBIx::Class::Exception->throw(
+          "Invocation of the exception_action handler installed on $self did *not*"
+        .' result in an exception. DBIx::Class is unable to function without a reliable'
+        .' exception mechanism, ensure that exception_action does not hide exceptions'
+        ." (original error: $_[0])"
+      );
+    }
+    elsif(! $false_exception_action_warned++) {
+      carp (
+          "The exception_action handler installed on $self returned false instead"
+        .' of throwing an exception. This behavior has been deprecated, adjust your'
+        .' handler to always rethrow the supplied error.'
+      );
+    }
+  }
+
+  DBIx::Class::Exception->throw($_[0], $self->stacktrace);
 }
 
 =head2 deploy
@@ -1043,8 +1077,8 @@ to have the SQL produced include a C<DROP TABLE> statement for each table
 created. For quoting purposes supply C<quote_table_names> and
 C<quote_field_names>.
 
-Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash 
-ref or an array ref, containing a list of source to deploy. If present, then 
+Additionally, the DBIx::Class parser accepts a C<sources> parameter as a hash
+ref or an array ref, containing a list of source to deploy. If present, then
 only the sources listed will get deployed. Furthermore, you can use the
 C<add_fk_index> parser parameter to prevent the parser from creating an index for each
 FK.
@@ -1083,7 +1117,7 @@ sub deployment_statements {
   $self->storage->deployment_statements($self, @_);
 }
 
-=head2 create_ddl_dir (EXPERIMENTAL)
+=head2 create_ddl_dir
 
 =over 4
 
@@ -1091,7 +1125,7 @@ sub deployment_statements {
 
 =back
 
-A convenient shortcut to 
+A convenient shortcut to
 C<< $self->storage->create_ddl_dir($self, @args) >>.
 
 Creates an SQL file based on the Schema, for each of the specified
@@ -1132,7 +1166,7 @@ format.
     my $filename = $table->ddl_filename($type, $dir, $version, $preversion)
 
  In recent versions variables $dir and $version were reversed in order to
- bring the signature in line with other Schema/Storage methods. If you 
+ bring the signature in line with other Schema/Storage methods. If you
  really need to maintain backward compatibility, you can do the following
  in any overriding methods:
 
@@ -1153,9 +1187,9 @@ sub ddl_filename {
 
 =head2 thaw
 
-Provided as the recommended way of thawing schema objects. You can call 
+Provided as the recommended way of thawing schema objects. You can call
 C<Storable::thaw> directly if you wish, but the thawed objects will not have a
-reference to any schema, so are rather useless
+reference to any schema, so are rather useless.
 
 =cut
 
@@ -1167,8 +1201,8 @@ sub thaw {
 
 =head2 freeze
 
-This doesn't actualy do anything more than call L<Storable/freeze>, it is just
-provided here for symetry.
+This doesn't actually do anything more than call L<Storable/freeze>, it is just
+provided here for symmetry.
 
 =cut
 
@@ -1186,9 +1220,9 @@ sub freeze {
 
 =back
 
-Recommended way of dcloning objects. If a L<DBIx::Class::Row> object is passed
-its references to the schema object (which itself is B<not> cloned)
-are properly maintained.
+Recommended way of dcloning L<DBIx::Class::Row> and L<DBIx::Class::ResultSet>
+objects so their references to the schema object
+(which itself is B<not> cloned) are properly maintained.
 
 =cut
 
@@ -1230,7 +1264,7 @@ sub schema_version {
 
 =back
 
-This method is called by L</load_namespaces> and L</load_classes> to install the found classes into your Schema. You should be using those instead of this one. 
+This method is called by L</load_namespaces> and L</load_classes> to install the found classes into your Schema. You should be using those instead of this one.
 
 You will only need this method if you have your Result classes in
 files which are not named after the packages (or all in the same
@@ -1269,6 +1303,24 @@ sub register_source {
   $self->_register_source(@_);
 }
 
+=head2 unregister_source
+
+=over 4
+
+=item Arguments: $moniker
+
+=back
+
+Removes the L<DBIx::Class::ResultSource> from the schema for the given moniker.
+
+=cut
+
+sub unregister_source {
+  my $self = shift;
+
+  $self->_unregister_source(@_);
+}
+
 =head2 register_extra_source
 
 =over 4
@@ -1277,7 +1329,7 @@ sub register_source {
 
 =back
 
-As L</register_source> but should be used if the result class already 
+As L</register_source> but should be used if the result class already
 has a source and you want to register an extra one.
 
 =cut
@@ -1295,7 +1347,7 @@ sub _register_source {
 
   $source = $source->new({ %$source, source_name => $moniker });
   $source->schema($self);
-  weaken($source->{schema}) if ref($self);
+  weaken $source->{schema} if ref($self);
 
   my $rs_class = $source->result_class;
 
@@ -1322,7 +1374,7 @@ sub _register_source {
 
 sub _unregister_source {
     my ($self, $moniker) = @_;
-    my %reg = %{$self->source_registrations}; 
+    my %reg = %{$self->source_registrations};
 
     my $source = delete $reg{$moniker};
     $self->source_registrations(\%reg);
@@ -1378,10 +1430,13 @@ more information.
       unless ($INC{"DBIx/Class/CDBICompat.pm"} || $warn++);
 
     my $base = 'DBIx::Class::ResultSetProxy';
-    eval "require ${base};";
-    $self->throw_exception
-      ("No arguments to load_classes and couldn't load ${base} ($@)")
-        if $@;
+    try {
+      eval "require ${base};"
+    }
+    catch {
+      $self->throw_exception
+        ("No arguments to load_classes and couldn't load ${base} ($_)")
+    };
 
     if ($self eq $target) {
       # Pathological case, largely caused by the docs on early C::M::DBIC::Plain
@@ -1400,7 +1455,7 @@ more information.
     {
       no strict 'refs';
       my $name = join '::', $target, 'schema';
-      *$name = Sub::Name::subname $name, sub { $schema };
+      *$name = subname $name, sub { $schema };
     }
 
     $schema->connection(@info);