From: Rafael Kitover <rkitover@cpan.org>
Date: Mon, 12 Apr 2010 23:42:24 +0000 (-0400)
Subject: fix column name collisions with methods (RT#49443)
X-Git-Tag: 0.07000~71
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-Schema-Loader.git;a=commitdiff_plain;h=9fdf3d5b3489415dbacf5d5724c6cb19acc9950d

fix column name collisions with methods (RT#49443)
---

diff --git a/Changes b/Changes
index 4253b04..b52165a 100644
--- a/Changes
+++ b/Changes
@@ -1,5 +1,6 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - fix column name collisions with methods (RT#49443)
         - fix loading MySQL views on older MySQL versions (RT#47399)
 
 0.06001  2010-04-10 01:31:12
diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index 3514c57..f69f0ca 100644
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -1397,6 +1397,35 @@ sub _make_src_class {
     $self->_inject($table_class, @{$self->additional_base_classes});
 }
 
+sub _resolve_col_accessor_collisions {
+    my ($self, $col_info) = @_;
+
+    my $base       = $self->result_base_class || 'DBIx::Class::Core';
+    my @components = map "DBIx::Class::$_", @{ $self->components };
+
+    my @methods;
+
+    for my $class ($base, @components) {
+        eval "require ${class};";
+        die $@ if $@;
+
+        push @methods, @{ Class::Inspector->methods($class) || [] };
+    }
+
+    my %methods;
+    @methods{@methods} = ();
+
+    while (my ($col, $info) = each %$col_info) {
+        my $accessor = $info->{accessor} || $col;
+
+        next if $accessor eq 'id'; # XXX fix this in DBIC
+
+        if (exists $methods{$accessor}) {
+            $info->{accessor} = ucfirst $accessor;
+        }
+    }
+}
+
 # Set up metadata (cols, pks, etc)
 sub _setup_src_meta {
     my ($self, $table) = @_;
@@ -1427,6 +1456,8 @@ sub _setup_src_meta {
         $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
     }
 
+    $self->_resolve_col_accessor_collisions($col_info);
+
     my $fks = $self->_table_fk_info($table);
 
     for my $fkdef (@$fks) {
diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm
index 6f702a1..3ad36a3 100644
--- a/t/lib/dbixcsl_common_tests.pm
+++ b/t/lib/dbixcsl_common_tests.pm
@@ -87,7 +87,7 @@ sub run_tests {
 
     my $extra_count = $self->{extra}{count} || 0;
 
-    plan tests => @connect_info * (174 + $extra_count + ($self->{data_type_tests}{test_count} || 0));
+    plan tests => @connect_info * (176 + $extra_count + ($self->{data_type_tests}{test_count} || 0));
 
     foreach my $info_idx (0..$#connect_info) {
         my $info = $connect_info[$info_idx];
@@ -302,7 +302,13 @@ sub test_schema {
     isa_ok( $rsobj35, "DBIx::Class::ResultSet" );
 
     my @columns_lt2 = $class2->columns;
-    is_deeply( \@columns_lt2, [ qw/id dat dat2/ ], "Column Ordering" );
+    is_deeply( \@columns_lt2, [ qw/id dat dat2 set_primary_key dbix_class_testcomponent/ ], "Column Ordering" );
+
+    is $class2->column_info('set_primary_key')->{accessor}, 'Set_primary_key',
+        'accessor for column name that conflicts with a result base class method renamed';
+
+    is $class2->column_info('dbix_class_testcomponent')->{accessor}, 'Dbix_class_testcomponent',
+        'accessor for column name that conflicts with a component class method renamed';
 
     my %uniq1 = $class1->unique_constraints;
     my $uniq1_test = 0;
@@ -1040,11 +1046,14 @@ sub create {
         q{ INSERT INTO loader_test1s (dat) VALUES('bar') }, 
         q{ INSERT INTO loader_test1s (dat) VALUES('baz') }, 
 
+        # also test method collision
         qq{ 
             CREATE TABLE loader_test2 (
                 id $self->{auto_inc_pk},
                 dat VARCHAR(32) NOT NULL,
                 dat2 VARCHAR(32) NOT NULL,
+                set_primary_key INTEGER,
+                dbix_class_testcomponent INTEGER,
                 UNIQUE (dat2, dat)
             ) $self->{innodb}
         },