fix relname/method collisions (RT#62648)
Rafael Kitover [Fri, 21 Jan 2011 06:39:53 +0000 (01:39 -0500)]
Changes
lib/DBIx/Class/Schema/Loader/Base.pm
lib/DBIx/Class/Schema/Loader/RelBuilder.pm
t/lib/dbixcsl_common_tests.pm

diff --git a/Changes b/Changes
index ca52e5c..715fa0e 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,6 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - fix relname/method collisions (RT#62648)
         - fix fully qualified component classes (RT#62624)
         - improve sybase/mssql db_schema detection
         - remove MooseX::NonMoose from Schema files under use_moose=1
index 5e6da78..c35226c 100644 (file)
@@ -86,6 +86,7 @@ __PACKAGE__->mk_group_accessors('simple', qw/
                                 pod_comment_spillover_length
                                 preserve_case
                                 col_collision_map
+                                rel_collision_map
                                 real_dump_directory
                                 datetime_undef_if_invalid
 /);
@@ -517,6 +518,14 @@ Examples:
 
     col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
 
+=head2 rel_collision_map
+
+Works just like L</col_collision_map>, but for relationship names/accessors
+rather than column names/accessors.
+
+The default is to just append C<_rel> to the relationship name, see
+L</RELATIONSHIP NAME COLLISIONS>.
+
 =head1 METHODS
 
 None of these methods are intended for direct invocation by regular
@@ -1567,36 +1576,46 @@ sub _make_src_class {
     $self->_inject($table_class, @{$self->additional_base_classes});
 }
 
-sub _resolve_col_accessor_collisions {
-    my ($self, $table, $col_info) = @_;
+{
+    my %result_methods;
 
-    my $base       = $self->result_base_class || 'DBIx::Class::Core';
-    my @components = map { /^\+/ ? substr($_,1) : "DBIx::Class::$_" } @{ $self->components || [] };
+    sub _is_result_class_method {
+        my ($self, $name) = @_;
 
-    my $table_name = ref $table ? $$table : $table;
+        %result_methods || do {
+            my @methods;
+            my $base       = $self->result_base_class || 'DBIx::Class::Core';
+            my @components = map { /^\+/ ? substr($_,1) : "DBIx::Class::$_" } @{ $self->components || [] };
 
-    my @methods;
+            for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
+                load_class $class;
 
-    for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
-        load_class $class;
+                push @methods, @{ Class::Inspector->methods($class) || [] };
+            }
 
-        push @methods, @{ Class::Inspector->methods($class) || [] };
-    }
+            push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
 
-    push @methods, @{ Class::Inspector->methods('UNIVERSAL') };
+            @result_methods{@methods} = ();
 
-    my %methods;
-    @methods{@methods} = ();
+            # futureproof meta
+            $result_methods{meta} = undef;
+        };
 
-    # futureproof meta
-    $methods{meta} = undef;
+        return exists $result_methods{$name};
+    }
+}
+
+sub _resolve_col_accessor_collisions {
+    my ($self, $table, $col_info) = @_;
+
+    my $table_name = ref $table ? $$table : $table;
 
     while (my ($col, $info) = each %$col_info) {
         my $accessor = $info->{accessor} || $col;
 
         next if $accessor eq 'id'; # special case (very common column)
 
-        if (exists $methods{$accessor}) {
+        if ($self->_is_result_class_method($accessor)) {
             my $mapped = 0;
 
             if (my $map = $self->col_collision_map) {
@@ -1610,7 +1629,7 @@ sub _resolve_col_accessor_collisions {
 
             if (not $mapped) {
                 warn <<"EOF";
-Column $col in table $table_name collides with an inherited method.
+Column '$col' in table '$table_name' collides with an inherited method.
 See "COLUMN ACCESSOR COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
 EOF
                 $info->{accessor} = undef;
@@ -2085,6 +2104,20 @@ below the md5:
 
 Another option is to use the L</col_collision_map> option.
 
+=head1 RELATIONSHIP NAME COLLISIONS
+
+In very rare cases, you may get a collision between a generated relationship
+name and a method in your Result class, for example if you have a foreign key
+called C<belongs_to>.
+
+This is a problem because relationship names are also relationship accessor
+methods in L<DBIx::Class>.
+
+The default behavior is to append C<_rel> to the relationship name and print
+out a warning that refers to this text.
+
+You can also control the renaming with the L</rel_collision_map> option.
+
 =head1 SEE ALSO
 
 L<DBIx::Class::Schema::Loader>
index 90051ba..bc8e906 100644 (file)
@@ -87,6 +87,7 @@ __PACKAGE__->mk_group_accessors('simple', qw/
     inflect_plural
     inflect_singular
     relationship_attrs
+    rel_collision_map
     _temp_classes
 /);
 
@@ -108,6 +109,7 @@ sub new {
         inflect_plural     => $base->inflect_plural,
         inflect_singular   => $base->inflect_singular,
         relationship_attrs => $base->relationship_attrs,
+        rel_collision_map  => $base->rel_collision_map,
         _temp_classes      => [],
     };
 
@@ -286,6 +288,37 @@ sub _remote_relname {
     return $remote_relname;
 }
 
+sub _resolve_relname_collision {
+    my ($self, $moniker, $cols, $relname) = @_;
+
+    return $relname if $relname eq 'id'; # this shouldn't happen, but just in case
+
+    if ($self->base->_is_result_class_method($relname)) {
+        if (my $map = $self->rel_collision_map) {
+            for my $re (keys %$map) {
+                if (my @matches = $relname =~ /$re/) {
+                    return sprintf $map->{$re}, @matches;
+                }
+            }
+        }
+
+        my $new_relname = $relname;
+        while ($self->base->_is_result_class_method($new_relname)) {
+            $new_relname .= '_rel'
+        }
+
+        warn <<"EOF";
+Relationship '$relname' in source '$moniker' for columns '@{[ join ',', @$cols ]}' collides with an inherited method.
+Renaming to '$new_relname'.
+See "RELATIONSHIP NAME COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
+EOF
+
+        return $new_relname;
+    }
+
+    return $relname;
+}
+
 sub generate_code {
     my ($self, $local_moniker, $rels, $uniqs) = @_;
 
@@ -322,6 +355,9 @@ sub generate_code {
         my ( $local_relname, $remote_relname, $remote_method ) =
             $self->_relnames_and_method( $local_moniker, $rel, \%cond,  $uniqs, \%counters );
 
+        $remote_relname = $self->_resolve_relname_collision($local_moniker,  $local_cols,  $remote_relname);
+        $local_relname  = $self->_resolve_relname_collision($remote_moniker, $remote_cols, $local_relname);
+
         push(@{$all_code->{$local_class}},
             { method => 'belongs_to',
               args => [ $remote_relname,
index 6100032..1900cc3 100644 (file)
@@ -102,7 +102,7 @@ sub run_tests {
     $num_rescans++ if $self->{vendor} eq 'Firebird';
 
     plan tests => @connect_info *
-        (184 + $num_rescans * $column_accessor_map_tests + $extra_count + ($self->{data_type_tests}{test_count} || 0));
+        (188 + $num_rescans * $column_accessor_map_tests + $extra_count + ($self->{data_type_tests}{test_count} || 0));
 
     foreach my $info_idx (0..$#connect_info) {
         my $info = $connect_info[$info_idx];
@@ -209,7 +209,7 @@ sub setup_schema {
         additional_base_classes => 'TestAdditionalBase',
         left_base_classes       => [ qw/TestLeftBase/ ],
         components              => [ qw/TestComponent +TestComponentFQN/ ],
-        inflect_plural          => { loader_test4 => 'loader_test4zes' },
+        inflect_plural          => { loader_test4_fkid => 'loader_test4zes' },
         inflect_singular        => { fkid => 'fkid_singular' },
         moniker_map             => \&_monikerize,
         custom_column_info      => \&_custom_column_info,
@@ -220,6 +220,7 @@ sub setup_schema {
         datetime_locale         => 'de_DE',
         use_moose               => $ENV{SCHEMA_LOADER_TESTS_USE_MOOSE},
         col_collision_map       => { '^(can)\z' => 'caught_collision_%s' },
+        rel_collision_map       => { '^(set_primary_key)\z' => 'caught_rel_collision_%s' },
         column_accessor_map     => \&test_column_accessor_map,
         %{ $self->{loader_options} || {} },
     );
@@ -276,7 +277,9 @@ sub setup_schema {
  
         $warn_count++ for grep /\b(?!loader_test9)\w+ has no primary key/i, @loader_warnings;
 
-        $warn_count++ for grep /^Column \w+ in table \w+ collides with an inherited method\./, @loader_warnings;
+        $warn_count++ for grep /^Column '\w+' in table '\w+' collides with an inherited method\./, @loader_warnings;
+
+        $warn_count++ for grep /^Relationship '\w+' in source '\w+' for columns '[^']+' collides with an inherited method\./, @loader_warnings;
 
         $warn_count++ for grep { my $w = $_; grep $w =~ $_, @{ $self->{warnings} || [] } } @loader_warnings;
 
@@ -490,7 +493,7 @@ sub test_schema {
     );
 
     SKIP: {
-        skip $self->{skip_rels}, 116 if $self->{skip_rels};
+        skip $self->{skip_rels}, 120 if $self->{skip_rels};
 
         my $moniker3 = $monikers->{loader_test3};
         my $class3   = $classes->{loader_test3};
@@ -617,6 +620,14 @@ sub test_schema {
         my $obj4 = $rsobj4->find(123);
         isa_ok( $obj4->fkid_singular, $class3);
 
+        # test renaming rel that conflicts with a class method
+        ok ($obj4->has_relationship('belongs_to_rel'), 'relationship name that conflicts with a method renamed');
+        isa_ok( $obj4->belongs_to_rel, $class3);
+
+        ok ($obj4->has_relationship('caught_rel_collision_set_primary_key'),
+            'relationship name that conflicts with a method renamed based on rel_collision_map');
+        isa_ok( $obj4->caught_rel_collision_set_primary_key, $class3);
+
         ok($class4->column_info('fkid')->{is_foreign_key}, 'Foreign key detected');
 
         my $obj3 = $rsobj3->find(1);
@@ -1277,14 +1288,18 @@ sub create {
                 fkid INTEGER NOT NULL,
                 dat VARCHAR(32),
                 crumb_crisp_coating VARCHAR(32) $self->{null},
-                FOREIGN KEY( fkid ) REFERENCES loader_test3 (id)
+                belongs_to INTEGER $self->{null},
+                set_primary_key INTEGER $self->{null},
+                FOREIGN KEY( fkid ) REFERENCES loader_test3 (id),
+                FOREIGN KEY( belongs_to ) REFERENCES loader_test3 (id),
+                FOREIGN KEY( set_primary_key ) REFERENCES loader_test3 (id)
             ) $self->{innodb}
         },
 
-        q{ INSERT INTO loader_test4 (id,fkid,dat) VALUES(123,1,'aaa') },
-        q{ INSERT INTO loader_test4 (id,fkid,dat) VALUES(124,2,'bbb') }, 
-        q{ INSERT INTO loader_test4 (id,fkid,dat) VALUES(125,3,'ccc') },
-        q{ INSERT INTO loader_test4 (id,fkid,dat) VALUES(126,4,'ddd') },
+        q{ INSERT INTO loader_test4 (id,fkid,dat,belongs_to,set_primary_key) VALUES(123,1,'aaa',1,1) },
+        q{ INSERT INTO loader_test4 (id,fkid,dat,belongs_to,set_primary_key) VALUES(124,2,'bbb',2,2) }, 
+        q{ INSERT INTO loader_test4 (id,fkid,dat,belongs_to,set_primary_key) VALUES(125,3,'ccc',3,3) },
+        q{ INSERT INTO loader_test4 (id,fkid,dat,belongs_to,set_primary_key) VALUES(126,4,'ddd',4,4) },
 
         qq|
             CREATE TABLE loader_test5 (