X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema.pm;h=3c2df0a05d826105185643903238451394f3a5ac;hb=3b80fa31b60050d4c8df91457ba6fd51b579a7a6;hp=b493d6cb3cd7736fe19d52dbf648fbc79a0f5e07;hpb=fd323bf1046faa7de5a8c985268d80ec5b703361;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm
index b493d6c..3c2df0a 100644
--- a/lib/DBIx/Class/Schema.pm
+++ b/lib/DBIx/Class/Schema.pm
@@ -4,12 +4,11 @@ use strict;
 use warnings;
 
 use DBIx::Class::Exception;
-use Carp::Clan qw/^DBIx::Class/;
+use Carp::Clan qw/^DBIx::Class|^Try::Tiny/;
 use Try::Tiny;
-use Scalar::Util ();
-use File::Spec;
-use Sub::Name ();
-use Module::Find();
+use Scalar::Util 'weaken';
+use Sub::Name 'subname';
+use B 'svref_2object';
 use namespace::clean;
 
 use base qw/DBIx::Class/;
@@ -167,6 +166,7 @@ sub _findallmod {
   my $proto = shift;
   my $ns = shift || ref $proto || $proto;
 
+  require Module::Find;
   my @mods = Module::Find::findallmod($ns);
 
   # try to untaint module names. mods where this fails
@@ -238,12 +238,14 @@ sub load_namespaces {
 
   my @to_register;
   {
-    no warnings 'redefine';
-    local *Class::C3::reinitialize = sub { };
-    use warnings 'redefine';
+    no warnings qw/redefine/;
+    local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
+    use warnings qw/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 {
 
@@ -291,7 +293,8 @@ sub load_namespaces {
       . 'corresponding Result class';
   }
 
-  Class::C3->reinitialize;
+  Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
+
   $class->register_class(@$_) for (@to_register);
 
   return;
@@ -374,7 +377,9 @@ sub load_classes {
   my @to_register;
   {
     no warnings qw/redefine/;
-    local *Class::C3::reinitialize = sub { };
+    local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
+    use warnings qw/redefine/;
+
     foreach my $prefix (keys %comps_for) {
       foreach my $comp (@{$comps_for{$prefix}||[]}) {
         my $comp_class = "${prefix}::${comp}";
@@ -391,7 +396,7 @@ sub load_classes {
       }
     }
   }
-  Class::C3->reinitialize;
+  Class::C3->reinitialize if DBIx::Class::_ENV_::OLD_MRO;
 
   foreach my $to (@to_register) {
     $class->register_class(@$to);
@@ -437,14 +442,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:
 
@@ -458,9 +462,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
@@ -587,7 +588,13 @@ source name.
 =cut
 
 sub source {
-  my ($self, $moniker) = @_;
+  my $self = shift;
+
+  $self->throw_exception("source() expects a source name")
+    unless @_;
+
+  my $moniker = shift;
+
   my $sreg = $self->source_registrations;
   return $sreg->{$moniker} if exists $sreg->{$moniker};
 
@@ -901,7 +908,10 @@ sub compose_namespace {
   my $schema = $self->clone;
   {
     no warnings qw/redefine/;
-#    local *Class::C3::reinitialize = sub { };
+    local *Class::C3::reinitialize = sub { } if DBIx::Class::_ENV_::OLD_MRO;
+    use warnings qw/redefine/;
+
+    no strict qw/refs/;
     foreach my $moniker ($schema->sources) {
       my $source = $schema->source($moniker);
       my $target_class = "${target}::${moniker}";
@@ -909,17 +919,23 @@ 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);
     }
   }
-#  Class::C3->reinitialize();
+  Class::C3->reinitialize() if DBIx::Class::_ENV_::OLD_MRO;
   {
     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(@_) };
     }
   }
@@ -1030,11 +1046,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
@@ -1153,6 +1187,8 @@ format.
 sub ddl_filename {
   my ($self, $type, $version, $dir, $preversion) = @_;
 
+  require File::Spec;
+
   my $filename = ref($self);
   $filename =~ s/::/-/g;
   $filename = File::Spec->catfile($dir, "$filename-$version-$type.sql");
@@ -1172,18 +1208,20 @@ reference to any schema, so are rather useless.
 sub thaw {
   my ($self, $obj) = @_;
   local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
+  require Storable;
   return Storable::thaw($obj);
 }
 
 =head2 freeze
 
-This doesn't actually do anything more than call L<Storable/freeze>, it is just
+This doesn't actually do anything more than call L<Storable/nfreeze>, it is just
 provided here for symmetry.
 
 =cut
 
 sub freeze {
-  return Storable::freeze($_[1]);
+  require Storable;
+  return Storable::nfreeze($_[1]);
 }
 
 =head2 dclone
@@ -1205,6 +1243,7 @@ objects so their references to the schema object
 sub dclone {
   my ($self, $obj) = @_;
   local $DBIx::Class::ResultSourceHandle::thaw_schema = $self;
+  require Storable;
   return Storable::dclone($obj);
 }
 
@@ -1323,7 +1362,7 @@ sub _register_source {
 
   $source = $source->new({ %$source, source_name => $moniker });
   $source->schema($self);
-  Scalar::Util::weaken($source->{schema}) if ref($self);
+  weaken $source->{schema} if ref($self);
 
   my $rs_class = $source->result_class;
 
@@ -1348,6 +1387,43 @@ sub _register_source {
   $self->class_mappings(\%map);
 }
 
+{
+  my $global_phase_destroy;
+
+  # SpeedyCGI runs END blocks every cycle but keeps object instances
+  # hence we have to disable the globaldestroy hatch, and rely on the
+  # eval trap below (which appears to work, but is risky done so late)
+  END { $global_phase_destroy = 1 unless $CGI::SpeedyCGI::i_am_speedy }
+
+  sub DESTROY {
+    return if $global_phase_destroy;
+
+    my $self = shift;
+    my $srcs = $self->source_registrations;
+
+    for my $moniker (keys %$srcs) {
+      # find first source that is not about to be GCed (someone other than $self
+      # holds a reference to it) and reattach to it, weakening our own link
+      #
+      # during global destruction (if we have not yet bailed out) this will throw
+      # which will serve as a signal to not try doing anything else
+      if (ref $srcs->{$moniker} and svref_2object($srcs->{$moniker})->REFCNT > 1) {
+        local $@;
+        eval {
+          $srcs->{$moniker}->schema($self);
+          1;
+        } or do {
+          $global_phase_destroy = 1;
+          last;
+        };
+
+        weaken $srcs->{$moniker};
+        last;
+      }
+    }
+  }
+}
+
 sub _unregister_source {
     my ($self, $moniker) = @_;
     my %reg = %{$self->source_registrations};
@@ -1431,7 +1507,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);