From: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
Date: Mon, 29 Jul 2013 19:35:52 +0000 (+0100)
Subject: Allow matching all the moniker parts in constraint/exclude
X-Git-Tag: 0.07036_01~1
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=b187901e0210a67eb8c62404316df5136dd71e14;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

Allow matching all the moniker parts in constraint/exclude
---

diff --git a/Changes b/Changes
index e10eb1b..8a365f7 100644
--- a/Changes
+++ b/Changes
@@ -7,6 +7,7 @@ Revision history for Perl extension DBIx::Class::Schema::Loader
         - Allow specifying the separator when joining database, schema
           and table names to form a moniker
         - Allow using all the moniker parts in hashref moniker_map
+        - Allow matching all the moniker parts in constraint/exclude
 
 0.07036  2013-07-08
         - Fix stray comma in Pg on_delete/on_update => CASCADE (RT#84706)
diff --git a/lib/DBIx/Class/Schema/Loader/DBI.pm b/lib/DBIx/Class/Schema/Loader/DBI.pm
index d3ce9b7..f2bbc14 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI.pm
@@ -194,6 +194,40 @@ sub _tables_list {
     return $self->_filter_tables(\@tables, $opts);
 }
 
+sub _recurse_constraint {
+    my ($constraint, @parts) = @_;
+
+    my $name = shift @parts;
+
+    # If there are any parts left, the constraint must be an arrayref
+    croak "depth of constraint/exclude array does not match length of moniker_parts"
+        unless !!@parts == !!(ref $constraint eq 'ARRAY');
+
+    # if ths is the last part, use the constraint directly
+    return $name =~ $constraint unless @parts;
+
+    # recurse into the first matching subconstraint
+    foreach (@{$constraint}) {
+        my ($re, $sub) = @{$_};
+        return _recurse_constraint($sub, @parts)
+            if $name =~ $re;
+    }
+    return 0;
+}
+
+sub _check_constraint {
+    my ($include, $constraint, @tables) = @_;
+
+    return @tables unless defined $constraint;
+
+    return grep { !$include xor _recurse_constraint($constraint, @{$_}) } @tables
+        if ref $constraint eq 'ARRAY';
+
+    return grep { !$include xor /$constraint/ } @tables;
+}
+
+
+
 # apply constraint/exclude and ignore bad tables and views
 sub _filter_tables {
     my ($self, $tables, $opts) = @_;
@@ -202,11 +236,8 @@ sub _filter_tables {
     my @filtered_tables;
 
     $opts ||= {};
-    my $constraint   = $opts->{constraint};
-    my $exclude      = $opts->{exclude};
-
-    @tables = grep { /$constraint/ } @tables if defined $constraint;
-    @tables = grep { ! /$exclude/  } @tables if defined $exclude;
+    @tables = _check_constraint(1, $opts->{constraint}, @tables);
+    @tables = _check_constraint(0, $opts->{exclude}, @tables);
 
     TABLE: for my $table (@tables) {
         try {
diff --git a/t/23dumpmore.t b/t/23dumpmore.t
index bebd4b4..07b1bc1 100644
--- a/t/23dumpmore.t
+++ b/t/23dumpmore.t
@@ -372,7 +372,7 @@ $t->dump_test(
   },
 );
 
-# test moniker_part_separator + moniker_map
+# test moniker_part_separator + moniker_map + recursive constraints
 $t->dump_test(
   classname => 'DBICTest::DumpMore::1',
   options => {
@@ -383,7 +383,9 @@ $t->dump_test(
     use_namespaces => 1,
     moniker_map => {
         my_schema => { foo => "MySchema::Floop" },
-    }
+    },
+    constraint => [ [ qr/my_schema/ => qr/foo|bar/ ] ],
+    exclude => [ [ qr/my_schema/ => qr/bar/ ] ],
   },
   warnings => [
     qr/^db_schema is not supported on SQLite/,
@@ -392,7 +394,11 @@ $t->dump_test(
     'Result/MySchema/Floop' => [
       qr/^package DBICTest::DumpMore::1::Result::MySchema::Floop;$/m,
       qr/^\Q__PACKAGE__->table("my_schema.foo");\E/m,
-      # the has_many relname should not have the schema in it!
+    ],
+  },
+  neg_regexes => {
+    'Result/MySchema/Floop' => [
+      # the bar table should not be loaded, so no relationship should exist
       qr/^__PACKAGE__->has_many\(\n  "bars"/m,
     ],
   },
diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm
index 1425e2f..c80c52c 100644
--- a/t/lib/dbixcsl_common_tests.pm
+++ b/t/lib/dbixcsl_common_tests.pm
@@ -212,7 +212,7 @@ my (@statements, @statements_reltests, @statements_advanced,
 
 sub CONSTRAINT {
     my $self = shift;
-return qr/^(?:\S+\.)?(?:(?:$self->{vendor}|extra)[_-]?)?loader[_-]?test[0-9]+(?!.*_)/i;
+return qr/^(?:(?:$self->{vendor}|extra)[_-]?)?loader[_-]?test[0-9]+(?!.*_)/i;
 }
 
 sub setup_schema {