Allow overriding individual moniker parts

If there's no moniker_map entry, moniker_part_map is consulted for each
part individually.

diff --git a/Changes b/Changes
index d6ae9d7..f084568 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,7 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - Allow overriding individual moniker parts
+
 0.07036_04 2013-10-24
         - Set table_class to DBIx::Class::ResultSource::View for views, in
           supported backends (SQLite, MySQL, and Pg) (arc@cpan.org)

diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index 464b03c..c99f09f 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -110,6 +110,7 @@ __PACKAGE__->mk_group_accessors('simple', qw/
                                 qualify_objects
                                 moniker_parts
                                 moniker_part_separator
+                                moniker_part_map
 /);
 
 my $CURRENT_V = 'v7';
@@ -619,6 +620,25 @@ together. Examples:
     stations_visited | StationVisited
     routeChange      | RouteChange
 
+=head2 moniker_part_map
+
+Map for overriding the monikerization of individual L</moniker_parts>.
+The keys are the moniker part to override, the value is either a
+hashref of coderef for mapping the corresponding part of the
+moniker. If a coderef is used, it gets called with the moniker part
+and the hash key the code ref was found under.
+
+For example:
+
+    moniker_part_map => {
+        schema => sub { ... },
+    },
+
+Given the table C<foo.bar>, the code ref would be called with the
+arguments C<foo> and C<schema>.
+
+L</moniker_map> takes precedence over this.
+
 =head2 col_accessor_map
 
 Same as moniker_map, but for column accessor names.  If a coderef is
@@ -1229,6 +1249,9 @@ sub new {
     if (not defined $self->moniker_part_separator) {
         $self->moniker_part_separator('');
     }
+    if (not defined $self->moniker_part_map) {
+        $self->moniker_part_map({}),
+    }
 
     return $self;
 }
@@ -2643,7 +2666,8 @@ sub _default_table2moniker {
 
     my $v = $self->_get_naming_v('monikers');
 
-    my @name_parts = map $table->$_, @{ $self->moniker_parts };
+    my @moniker_parts = @{ $self->moniker_parts };
+    my @name_parts = map $table->$_, @moniker_parts;
 
     my $name_idx = firstidx { $_ eq 'name' } @{ $self->moniker_parts };
 
@@ -2652,6 +2676,16 @@ sub _default_table2moniker {
     foreach my $i (0 .. $#name_parts) {
         my $part = $name_parts[$i];
 
+        my $moniker_part = $self->_run_user_map(
+            $self->moniker_part_map->{$moniker_parts[$i]},
+            sub { '' },
+            $part, $moniker_parts[$i],
+        );
+        if (length $moniker_part) {
+            push @all_parts, $moniker_part;
+            next;
+        }
+
         if ($i != $name_idx || $v >= 8) {
             $part = $self->_to_identifier('monikers', $part, '_', 1);
         }

diff --git a/t/23dumpmore.t b/t/23dumpmore.t
index b7b0da1..babe3f0 100644 (file)
--- a/t/23dumpmore.t
+++ b/t/23dumpmore.t
@@ -404,6 +404,48 @@ $t->dump_test(
   },
 );
 
+# test moniker_map + moniker_part_map
+$t->dump_test(
+  classname => 'DBICTest::DumpMore::1',
+  options => {
+    db_schema => 'my_schema',
+    moniker_parts => ['_schema', 'name'],
+    moniker_part_separator => '::',
+    moniker_part_map => {
+        _schema => {
+            my_schema => 'OtherSchema',
+        },
+    },
+    moniker_map => {
+        my_schema => {
+            foo => 'MySchema::Floop',
+        },
+    },
+    qualify_objects => 1,
+    use_namespaces => 1,
+  },
+  warnings => [
+    qr/^db_schema is not supported on SQLite/,
+  ],
+  regexes => {
+    '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, but the class should
+      qr/^__PACKAGE__->has_many\(\n  "bars",\n  "DBICTest::DumpMore::1::Result::OtherSchema::Bar"/m,
+    ],
+    'Result/OtherSchema/Bar' => [
+      qr/^package DBICTest::DumpMore::1::Result::OtherSchema::Bar;/m,
+      qr/^\Q__PACKAGE__->table("my_schema.bar");\E/m,
+      # the has_many relname should not have the schema in it, but the class should
+      qr/^__PACKAGE__->belongs_to\(\n  "fooref",\n  "DBICTest::DumpMore::1::Result::MySchema::Floop"/m,
+    ],
+
+  },
+);
+
+
+
 $t->dump_test(
   classname => 'DBICTest::DumpMore::1',
   options => {