Allow coderef maps to call back into the hashref mapping code

diff --git a/Changes b/Changes
index 1cb02e3..d89ec66 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,7 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - Allow coderef maps to call back into the hashref mapping code
+
 0.07037  2013-10-30
         - Allow overriding individual moniker parts
 

diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index 1994637..1304c1c 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -603,6 +603,11 @@ a coderef for a translator function taking a L<table
 object|DBIx::Class::Schema::Loader::Table> argument (which stringifies to the
 unqualified table name) and returning a scalar moniker
 
+The function is also passed a coderef that can be called with either
+of the hashref forms to get the moniker mapped accordingly.  This is
+useful if you need to handle some monikers specially, but want to use
+the hashref form for the rest.
+
 =back
 
 If the hash entry does not exist, or the function returns a false
@@ -635,7 +640,8 @@ For example:
     },
 
 Given the table C<foo.bar>, the code ref would be called with the
-arguments C<foo> and C<schema>.
+arguments C<foo> and C<schema>, plus a coderef similar to the one
+described in L</moniker_map>.
 
 L</moniker_map> takes precedence over this.
 
@@ -654,6 +660,7 @@ passed, the code is called with arguments of
       schema_class    => name of the schema class we are building,
       column_info     => hashref of column info (data_type, is_nullable, etc),
    }
+   coderef ref that can be called with a hashref map
 
 the L<table object|DBIx::Class::Schema::Loader::Table> stringifies to the
 unqualified table name.
@@ -680,7 +687,7 @@ instance, you could have
 and relationships that would have been named C<bar> will now be named C<baz>
 except that in the table whose moniker is C<Foo> it will be named C<blat>.
 
-If it is a coderef, the argument passed will be a hashref of this form:
+If it is a coderef, it will be passed a hashref of this form:
 
     {
         name           => default relationship name,
@@ -697,6 +704,8 @@ If it is a coderef, the argument passed will be a hashref of this form:
         link_rel_name  => name of the relationship to the link table
     }
 
+In addition it is passed a coderef that can be called with a hashref map.
+
 DBICSL will try to use the value returned as the relationship name.
 
 =head2 inflect_plural
@@ -2444,7 +2453,13 @@ sub _run_user_map {
         }
     }
     elsif( $map && ref $map eq 'CODE' ) {
-        $new_ident = $map->( $ident, $default_ident, @extra );
+        my $cb = sub {
+            my ($cb_map) = @_;
+            croak "reentered map must be a hashref"
+                unless 'HASH' eq ref($cb_map);
+            return $self->_run_user_map($cb_map, $default_code, $ident, @extra);
+        };
+        $new_ident = $map->( $ident, $default_ident, @extra, $cb );
     }
 
     $new_ident ||= $default_ident;

diff --git a/lib/DBIx/Class/Schema/Loader/RelBuilder.pm b/lib/DBIx/Class/Schema/Loader/RelBuilder.pm
index 9d76031..94820f9 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/RelBuilder.pm
+++ b/lib/DBIx/Class/Schema/Loader/RelBuilder.pm
@@ -959,9 +959,13 @@ sub _rel_name_map {
         remote_columns => $remote_cols,
     };
 
-    my $new_name = $relname;
+    $self->_run_user_map($self->rel_name_map, $info);
+}
+
+sub _run_user_map {
+    my ($self, $map, $info) = @_;
 
-    my $map = $self->rel_name_map;
+    my $new_name = $info->{name};
     my $mapped = 0;
 
     if ('HASH' eq ref($map)) {
@@ -979,7 +983,14 @@ sub _rel_name_map {
         }
     }
     elsif ('CODE' eq ref($map)) {
-        my $name = $map->($info);
+        my $cb = sub {
+            my ($cb_map) = @_;
+            croak "reentered rel_name_map must be a hashref"
+                unless 'HASH' eq ref($cb_map);
+            my ($cb_name, $cb_mapped) = $self->_run_user_map($cb_map, $info);
+            return $cb_mapped && $cb_name;
+        };
+        my $name = $map->($info, $cb);
         if ($name) {
             $new_name = $name;
             $mapped   = 1;

diff --git a/t/45relationships.t b/t/45relationships.t
index b46684e..e9e48d8 100644 (file)
--- a/t/45relationships.t
+++ b/t/45relationships.t
@@ -42,7 +42,7 @@ is( ref($hash_relationship->source('Bar')->relationship_info('got_fooref')),
 # test coderef as rel_name_map
 my $code_relationship = schema_with(
     rel_name_map => sub {
-        my ($args) = @_;
+        my ($args, $orig) = @_;
 
         if ($args->{local_moniker} eq 'Foo') {
             is_deeply(
@@ -61,7 +61,6 @@ my $code_relationship = schema_with(
                },
                'correct args for Foo passed'
               );
-           return 'bars_caught';
         }
        elsif ($args->{local_moniker} eq 'Bar') {
             is_deeply(
@@ -80,9 +79,15 @@ my $code_relationship = schema_with(
                },
                'correct args for Foo passed'
               );
-       
-            return 'fooref_caught';
        }
+        else {
+            fail( 'correct args passed to rel_name_map' );
+            diag "args were: ", explain $args;
+        }
+       return $orig->({
+           Bar => { fooref => 'fooref_caught' },
+           Foo => { bars => 'bars_caught' },
+       });
     }
   );
 is( ref($code_relationship->source('Foo')->relationship_info('bars_caught')),
@@ -94,6 +99,9 @@ is( ref($code_relationship->source('Bar')->relationship_info('fooref_caught')),
     'rel_name_map overrode remote_info correctly'
   );
 
+throws_ok {
+    schema_with( rel_name_map => sub { $_[-1]->(sub{}) } ),
+} qr/reentered rel_name_map must be a hashref/, 'throws error for invalid (code) rel_name_map callback map';
 
 
 # test relationship_attrs

diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm
index 037a805..861aa9d 100644 (file)
--- a/t/lib/dbixcsl_common_tests.pm
+++ b/t/lib/dbixcsl_common_tests.pm
@@ -88,8 +88,8 @@ sub skip_tests {
 
 sub _monikerize {
     my $name = shift;
-    return 'LoaderTest2X' if $name =~ /^loader_test2$/i;
-    return undef;
+    my $orig = pop;
+    return $orig->({ loader_test2 => 'LoaderTest2X' });
 }
 
 sub run_tests {