From: Justin Guenther <jguenther@cpan.org>
Date: Fri, 19 May 2006 20:50:55 +0000 (+0000)
Subject: added ensure_class_loaded method to Componentized, which should fix problems with... 
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c037c03aa6089d35c8a62ce5e1ed8b19e765c8bc;p=dbsrgits%2FDBIx-Class-Historic.git

added ensure_class_loaded method to Componentized, which should fix problems with nonexistent classes referenced in relationships going undetected
---

diff --git a/lib/DBIx/Class/CDBICompat/HasA.pm b/lib/DBIx/Class/CDBICompat/HasA.pm
index 6930f3b..647674f 100644
--- a/lib/DBIx/Class/CDBICompat/HasA.pm
+++ b/lib/DBIx/Class/CDBICompat/HasA.pm
@@ -7,7 +7,7 @@ use warnings;
 sub has_a {
   my ($self, $col, $f_class, %args) = @_;
   $self->throw_exception( "No such column ${col}" ) unless $self->has_column($col);
-  eval "require $f_class";
+  $self->ensure_class_loaded($f_class);
   if ($args{'inflate'} || $args{'deflate'}) { # Non-database has_a
     if (!ref $args{'inflate'}) {
       my $meth = $args{'inflate'};
diff --git a/lib/DBIx/Class/Componentised.pm b/lib/DBIx/Class/Componentised.pm
index 560c374..e23a0b4 100644
--- a/lib/DBIx/Class/Componentised.pm
+++ b/lib/DBIx/Class/Componentised.pm
@@ -5,6 +5,7 @@ use strict;
 use warnings;
 
 use Class::C3;
+use Class::Inspector;
 
 sub inject_base {
   my ($class, $target, @to_inject) = @_;
@@ -41,10 +42,20 @@ sub load_own_components {
 sub _load_components {
   my ($class, @comp) = @_;
   foreach my $comp (@comp) {
-    eval "use $comp";
-    die $@ if $@;
+    $class->ensure_class_loaded($comp);
   }
   $class->inject_base($class => @comp);
 }
 
+# TODO: handle ->has_many('rel', 'Class'...) instead of
+#              ->has_many('rel', 'Some::Schema::Class'...)
+sub ensure_class_loaded {
+  my ($class, $f_class) = @_;
+  eval "require $f_class";
+  my $err = $@;
+  Class::Inspector->loaded($f_class)
+      or die $err || "require $f_class was successful but the package".
+                     "is not defined";
+}
+
 1;
diff --git a/lib/DBIx/Class/Relationship/BelongsTo.pm b/lib/DBIx/Class/Relationship/BelongsTo.pm
index 535fa75..8c8ceaa 100644
--- a/lib/DBIx/Class/Relationship/BelongsTo.pm
+++ b/lib/DBIx/Class/Relationship/BelongsTo.pm
@@ -5,11 +5,7 @@ use warnings;
 
 sub belongs_to {
   my ($class, $rel, $f_class, $cond, $attrs) = @_;
-  eval "require $f_class";
-  if ($@) {
-    $class->throw_exception($@) unless $@ =~ /Can't locate/;
-  }
-  
+  $class->ensure_class_loaded($f_class);
   # no join condition or just a column name
   if (!ref $cond) {
     my %f_primaries = map { $_ => 1 } eval { $f_class->primary_columns };
diff --git a/lib/DBIx/Class/Relationship/HasMany.pm b/lib/DBIx/Class/Relationship/HasMany.pm
index a709d6a..aa46486 100644
--- a/lib/DBIx/Class/Relationship/HasMany.pm
+++ b/lib/DBIx/Class/Relationship/HasMany.pm
@@ -6,11 +6,8 @@ use warnings;
 
 sub has_many {
   my ($class, $rel, $f_class, $cond, $attrs) = @_;
-    
-  eval "require $f_class";
-  if ($@) {
-    $class->throw_exception($@) unless $@ =~ /Can't locate/;
-  }
+
+  $class->ensure_class_loaded($f_class);
 
   unless (ref $cond) {
     my ($pri, $too_many) = $class->primary_columns;
diff --git a/lib/DBIx/Class/Relationship/HasOne.pm b/lib/DBIx/Class/Relationship/HasOne.pm
index 4efbec0..aa94a08 100644
--- a/lib/DBIx/Class/Relationship/HasOne.pm
+++ b/lib/DBIx/Class/Relationship/HasOne.pm
@@ -14,11 +14,7 @@ sub has_one {
 
 sub _has_one {
   my ($class, $join_type, $rel, $f_class, $cond, $attrs) = @_;
-  eval "require $f_class";
-  if ($@) {
-    $class->throw_exception($@) unless $@ =~ /Can't locate/;
-  }
-
+  $class->ensure_class_loaded($f_class);
   unless (ref $cond) {
     my ($pri, $too_many) = $class->primary_columns;
     $class->throw_exception( "might_have/has_one can only infer join for a single primary key; ${class} has more" )
diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm
index 7b4c48c..eb58dd5 100644
--- a/lib/DBIx/Class/ResultSource.pm
+++ b/lib/DBIx/Class/ResultSource.pm
@@ -456,10 +456,7 @@ sub add_relationship {
 
   my $f_source = $self->schema->source($f_source_name);
   unless ($f_source) {
-    eval "require $f_source_name;";
-    if ($@) {
-      die $@ unless $@ =~ /Can't locate/;
-    }
+    $self->ensure_class_loaded($f_source_name);
     $f_source = $f_source_name->result_source;
     #my $s_class = ref($self->schema);
     #$f_source_name =~ m/^${s_class}::(.*)$/;
diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm
index c1ea074..98387b4 100644
--- a/lib/DBIx/Class/Schema.pm
+++ b/lib/DBIx/Class/Schema.pm
@@ -263,13 +263,7 @@ sub load_classes {
     foreach my $prefix (keys %comps_for) {
       foreach my $comp (@{$comps_for{$prefix}||[]}) {
         my $comp_class = "${prefix}::${comp}";
-        eval "use $comp_class"; # If it fails, assume the user fixed it
-        if ($@) {
-          $comp_class =~ s/::/\//g;
-          die $@ unless $@ =~ /Can't locate.+$comp_class\.pm\sin\s\@INC/;
-          warn $@ if $@;
-        }
-
+        $class->ensure_class_loaded($comp_class);
         $comp_class->source_name($comp) unless $comp_class->source_name;
 
         push(@to_register, [ $comp_class->source_name, $comp_class ]);
diff --git a/t/basicrels/30ensure_class_loaded.t b/t/basicrels/30ensure_class_loaded.t
new file mode 100644
index 0000000..67f2d6c
--- /dev/null
+++ b/t/basicrels/30ensure_class_loaded.t
@@ -0,0 +1,7 @@
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::BasicRels;
+
+require "t/run/30ensure_class_loaded.tl";
+run_tests(DBICTest->schema);
diff --git a/t/helperrels/30ensure_class_loaded.t b/t/helperrels/30ensure_class_loaded.t
new file mode 100644
index 0000000..6edbe80
--- /dev/null
+++ b/t/helperrels/30ensure_class_loaded.t
@@ -0,0 +1,7 @@
+use Test::More;
+use lib qw(t/lib);
+use DBICTest;
+use DBICTest::HelperRels;
+
+require "t/run/30ensure_class_loaded.tl";
+run_tests(DBICTest->schema);
diff --git a/t/lib/DBICTest/FakeComponent.pm b/t/lib/DBICTest/FakeComponent.pm
new file mode 100644
index 0000000..5fe3b66
--- /dev/null
+++ b/t/lib/DBICTest/FakeComponent.pm
@@ -0,0 +1,7 @@
+#   belongs to t/run/30ensure_class_loaded.tl
+package # hide from PAUSE 
+    DBICTest::FakeComponent;
+use warnings;
+use strict;
+
+1;
diff --git a/t/lib/DBICTest/Schema/TreeLike.pm b/t/lib/DBICTest/Schema/TreeLike.pm
index 9fde9f3..1eca3e1 100644
--- a/t/lib/DBICTest/Schema/TreeLike.pm
+++ b/t/lib/DBICTest/Schema/TreeLike.pm
@@ -14,7 +14,7 @@ __PACKAGE__->add_columns(
  },
 );
 __PACKAGE__->set_primary_key(qw/id/);
-__PACKAGE__->belongs_to('parent', 'TreeLike',
+__PACKAGE__->belongs_to('parent', 'DBICTest::Schema::TreeLike',
                           { 'foreign.id' => 'self.parent' });
 
 1;
diff --git a/t/run/30ensure_class_loaded.tl b/t/run/30ensure_class_loaded.tl
new file mode 100644
index 0000000..8602565
--- /dev/null
+++ b/t/run/30ensure_class_loaded.tl
@@ -0,0 +1,40 @@
+use Class::Inspector;
+
+BEGIN {
+  package TestPackage::A;
+  sub some_method {}
+}
+
+sub run_tests {
+
+my $schema = shift;
+plan tests => 6;
+
+ok(Class::Inspector->loaded('TestPackage::A'),
+   'anon. package exists');
+eval {
+  $schema->ensure_class_loaded('TestPackage::A');
+};
+
+ok(!$@, 'ensure_class_loaded detected an anon. class');
+
+eval {
+  $schema->ensure_class_loaded('FakePackage::B');
+};
+
+like($@, qr/Can't locate/,
+     'ensure_class_loaded threw exception for nonexistent class');
+
+ok(!Class::Inspector->loaded('DBICTest::FakeComponent'),
+   'DBICTest::FakeComponent not loaded yet');
+
+eval {
+  $schema->ensure_class_loaded('DBICTest::FakeComponent');
+};
+
+ok(!$@, 'ensure_class_loaded detected an existing but non-loaded class');
+ok(Class::Inspector->loaded('DBICTest::FakeComponent'),
+   'DBICTest::FakeComponent now loaded');
+}
+
+1;