From: Rafael Kitover <rkitover@cpan.org>
Date: Tue, 9 Feb 2010 23:39:39 +0000 (-0500)
Subject: refactor the classname checking code
X-Git-Tag: 0.05002~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8048320ca00e5e1104bf8ea4b3bf74ba5d5cb7fa;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

refactor the classname checking code
---

diff --git a/lib/DBIx/Class/Schema/Loader.pm b/lib/DBIx/Class/Schema/Loader.pm
index 6d9c568..8073fe8 100644
--- a/lib/DBIx/Class/Schema/Loader.pm
+++ b/lib/DBIx/Class/Schema/Loader.pm
@@ -143,45 +143,11 @@ sub loader_options {
     my $self = shift;
 
     my %args = (ref $_[0] eq 'HASH') ? %{$_[0]} : @_;
-    $self->_validate_loader_options(\%args);
     $self->_loader_args(\%args);
 
     $self;
 }
 
-sub _validate_loader_options {
-    my $self = shift;
-    my $args = shift;
-    
-    my @class_keys = qw(
-        schema_base_class result_base_class additional_base_classes
-        left_base_classes additional_classes components resultset_components
-    );
-    foreach my $k ( grep { exists $args->{$_} } @class_keys ) {
-        my @classes = ref( $args->{$k} ) eq 'ARRAY' ? @{ $args->{$k} } : $args->{$k};
-        foreach my $c (@classes) {
-
-            # components default to being under the DBIx::Class namespace unless they
-            # are preceeded with a '+'
-            if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
-                $c = 'DBIx::Class::' . $c;
-            }
-
-            # 1 == installed, 0 == not installed, undef == invalid classname
-            my $installed = Class::Inspector->installed($c);
-            if ( defined($installed) ) {
-                if ( $installed == 0 ) {
-                    croak qq/$c, as specified in the loader option "$k", is not installed/;
-                }
-            } else {
-                croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
-            }
-        }
-    }
-
-    return;
-}
-
 sub _invoke_loader {
     my $self = shift;
     my $class = ref $self || $self;
diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index d915653..cf22900 100644
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -14,6 +14,7 @@ use Digest::MD5 qw//;
 use Lingua::EN::Inflect::Number qw//;
 use File::Temp qw//;
 use Class::Unload;
+use Class::Inspector ();
 require DBIx::Class;
 
 our $VERSION = '0.05001';
@@ -386,7 +387,12 @@ can also be found via standard L<DBIx::Class::Schema> methods somehow.
 
 =cut
 
-use constant CURRENT_V => 'v5';
+use constant CURRENT_V  => 'v5';
+
+use constant CLASS_ARGS => qw(
+    schema_base_class result_base_class additional_base_classes
+    left_base_classes additional_classes components resultset_components
+);
 
 # ensure that a peice of object data is a valid arrayref, creating
 # an empty one or encapsulating whatever's there.
@@ -421,6 +427,8 @@ sub new {
                                resultset_components
                               /);
 
+    $self->_validate_class_args;
+
     push(@{$self->{components}}, 'ResultSetManager')
         if @{$self->{resultset_components}};
 
@@ -596,6 +604,34 @@ EOF
     close $fh;
 }
 
+sub _validate_class_args {
+    my $self = shift;
+    my $args = shift;
+    
+    foreach my $k (CLASS_ARGS) {
+        next unless $self->$k;
+
+        my @classes = ref $self->$k eq 'ARRAY' ? @{ $self->$k } : $self->$k;
+        foreach my $c (@classes) {
+            # components default to being under the DBIx::Class namespace unless they
+            # are preceeded with a '+'
+            if ( $k =~ m/components$/ && $c !~ s/^\+// ) {
+                $c = 'DBIx::Class::' . $c;
+            }
+
+            # 1 == installed, 0 == not installed, undef == invalid classname
+            my $installed = Class::Inspector->installed($c);
+            if ( defined($installed) ) {
+                if ( $installed == 0 ) {
+                    croak qq/$c, as specified in the loader option "$k", is not installed/;
+                }
+            } else {
+                croak qq/$c, as specified in the loader option "$k", is an invalid class name/;
+            }
+        }
+    }
+}
+
 sub _find_file_in_inc {
     my ($self, $file) = @_;
 
diff --git a/t/23dumpmore.t b/t/23dumpmore.t
index 47dbfc5..9f31abd 100644
--- a/t/23dumpmore.t
+++ b/t/23dumpmore.t
@@ -26,7 +26,7 @@ sub dump_directly {
     $schema_class->storage->disconnect if !$err && $schema_class->storage;
     undef *{$schema_class};
 
-    is($err, $tdata{error});
+    check_error($err, $tdata{error});
 
     return @warns;
 }
@@ -45,17 +45,40 @@ sub dump_dbicdump {
 
     # make sure our current @INC gets used by dbicdump
     use Config;
-    local $ENV{PERL5LIB} = join $Config{path_sep}, @INC, $ENV{PERL5LIB};
+    local $ENV{PERL5LIB} = join $Config{path_sep}, @INC, ($ENV{PERL5LIB} || '');
 
     my ($in, $out, $err);
     my $pid = open3($in, $out, $err, @cmd);
 
-    my @warns = <$out>;
+    my @out = <$out>;
     waitpid($pid, 0);
 
+    my ($error, @warns);
+
+    if ($? >> 8 != 0) {
+        $error = $out[0];
+        check_error($error, $tdata{error});
+    }
+    else {
+        @warns = @out;
+    }
+
     return @warns;
 }
 
+sub check_error {
+    my ($got, $expected) = @_;
+
+    return unless $got && $expected;
+
+    if (ref $expected eq 'Regexp') {
+        like $got, $expected, 'error matches expected pattern';
+        return;
+    }
+
+    is $got, $expected, 'error matches';
+}
+
 sub do_dump_test {
     my %tdata = @_;
     
@@ -75,6 +98,7 @@ sub test_dumps {
     my $schema_class = $tdata{classname};
     my $check_warns = $tdata{warnings};
     is(@warns, @$check_warns, "$schema_class warning count");
+
     for(my $i = 0; $i <= $#$check_warns; $i++) {
         like($warns[$i], $check_warns->[$i], "$schema_class warning $i");
     }
@@ -372,18 +396,15 @@ do_dump_test(
         ],
     },
 );
-eval {
-    do_dump_test(
-        classname => 'DBICTest::DumpMore::1',
-        options   => {
-            use_namespaces    => 1,
-            result_base_class => 'My::MissingResultBaseClass',
-        },
-    );
-};
-ok($@, "exception thrown on bad result_base_class");
-like($@, qr/My::MissingResultBaseClass.*is not installed/, "user-friend error message on missing result_base_class" );
 
+do_dump_test(
+    classname => 'DBICTest::DumpMore::1',
+    options   => {
+        use_namespaces    => 1,
+        result_base_class => 'My::MissingResultBaseClass',
+    },
+    error => qr/My::MissingResultBaseClass.*is not installed/,
+);
 
 done_testing;