added warning and documentation for column accessor collisions, and the col_collision...

diff --git a/Changes b/Changes
index 4e00988..5f81d36 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,7 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - Added warning for column-accessor collisions, doc section in ::Base
+          ("COLUMN ACCESSOR COLLISIONS") and the col_collision_map option.
         - Handle column accessor collisions with UNIVERSAL methods
         - Generate custom_type_name hint for PostgreSQL enums, as used
           by very recent SQL::Translator

diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index 84bee40..0b9b6b7 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -84,6 +84,7 @@ __PACKAGE__->mk_group_accessors('simple', qw/
                                 pod_comment_mode
                                 pod_comment_spillover_length
                                 preserve_case
+                                col_collision_map
 /);
 
 =head1 NAME
@@ -482,6 +483,23 @@ classes immutable.
 
 It is safe to upgrade your existing Schema to this option.
 
+=head2 col_collision_map
+
+This option controls how accessors for column names which collide with perl
+methods are named. See L</COLUMN ACCESSOR COLLISIONS> for more information.
+
+This option takes either a single L<perlfunc/sprintf> format or a hashref of
+strings which are compiled to regular expressions that map to
+L<perlfunc/sprintf> formats.
+
+Examples:
+
+    col_collision_map => 'column_%s'
+
+    col_collision_map => { '(.*)' => 'column_%s' }
+
+    col_collision_map => { '(foo).*(bar)' => 'column_%s_%s' }
+
 =head1 METHODS
 
 None of these methods are intended for direct invocation by regular
@@ -608,6 +626,17 @@ sub new {
     $self->pod_comment_mode('auto')         unless defined $self->pod_comment_mode;
     $self->pod_comment_spillover_length(60) unless defined $self->pod_comment_spillover_length;
 
+    if (my $col_collision_map = $self->col_collision_map) {
+        if (my $reftype = ref $col_collision_map) {
+            if ($reftype ne 'HASH') {
+                croak "Invalid type $reftype for option 'col_collision_map'";
+            }
+        }
+        else {
+            $self->col_collision_map({ '(.*)' => $col_collision_map });
+        }
+    }
+
     $self;
 }
 
@@ -1500,11 +1529,13 @@ sub _make_src_class {
 }
 
 sub _resolve_col_accessor_collisions {
-    my ($self, $col_info) = @_;
+    my ($self, $table, $col_info) = @_;
 
     my $base       = $self->result_base_class || 'DBIx::Class::Core';
     my @components = map "DBIx::Class::$_", @{ $self->components || [] };
 
+    my $table_name = ref $table ? $$table : $table;
+
     my @methods;
 
     for my $class ($base, @components, $self->use_moose ? 'Moose::Object' : ()) {
@@ -1527,7 +1558,24 @@ sub _resolve_col_accessor_collisions {
         next if $accessor eq 'id'; # special case (very common column)
 
         if (exists $methods{$accessor}) {
-            $info->{accessor} = undef;
+            my $mapped = 0;
+
+            if (my $map = $self->col_collision_map) {
+                for my $re (keys %$map) {
+                    if (my @matches = $col =~ /$re/) {
+                        $info->{accessor} = sprintf $map->{$re}, @matches;
+                        $mapped = 1;
+                    }
+                }
+            }
+
+            if (not $mapped) {
+                warn <<"EOF";
+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;
+            }
         }
     }
 }
@@ -1588,7 +1636,7 @@ sub _setup_src_meta {
         $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
     }
 
-    $self->_resolve_col_accessor_collisions($col_info);
+    $self->_resolve_col_accessor_collisions($full_table_name, $col_info);
 
     my $fks = $self->_table_fk_info($table);
 
@@ -1952,6 +2000,19 @@ Returns a hashref of table to class mappings.  In some cases it will
 contain multiple entries per table for the original and normalized table
 names, as above in L</monikers>.
 
+=head1 COLUMN ACCESSOR COLLISIONS
+
+Occasionally you may have a column name that collides with a perl method, such
+as C<can>. In such cases, the default action is to set the C<accessor> of the
+column spec to C<undef>.
+
+You can then name the accessor yourself by placing code such as the following
+below the md5:
+
+    __PACKAGE__->add_column('+can' => { accessor => 'my_can' });
+
+Another option is to use the L</col_collision_map> option.
+
 =head1 SEE ALSO
 
 L<DBIx::Class::Schema::Loader>

diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm
index c8bc757..3f2dc26 100644 (file)
--- a/t/lib/dbixcsl_common_tests.pm
+++ b/t/lib/dbixcsl_common_tests.pm
@@ -200,6 +200,7 @@ sub setup_schema {
         datetime_timezone       => 'Europe/Berlin',
         datetime_locale         => 'de_DE',
         use_moose               => $ENV{SCHEMA_LOADER_TESTS_USE_MOOSE},
+        col_collision_map       => { '^(can)\z' => 'caught_collision_%s' },
         %{ $self->{loader_options} || {} },
     );
 
@@ -253,6 +254,8 @@ 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 { my $w = $_; grep $w =~ $_, @{ $self->{warnings} || [] } } @loader_warnings;
 
         if ($standard_sources) {
@@ -326,8 +329,8 @@ sub test_schema {
     my @columns_lt2 = $class2->columns;
     is_deeply( \@columns_lt2, [ qw/id dat dat2 set_primary_key can dbix_class_testcomponent meta/ ], "Column Ordering" );
 
-    is $class2->column_info('can')->{accessor}, undef,
-        'accessor for column name that conflicts with a UNIVERSAL method removed';
+    is $class2->column_info('can')->{accessor}, 'caught_collision_can',
+        'accessor for column name that conflicts with a UNIVERSAL method renamed based on col_collision_map';
 
     is $class2->column_info('set_primary_key')->{accessor}, undef,
         'accessor for column name that conflicts with a result base class method removed';
@@ -933,7 +936,7 @@ sub test_schema {
 
         my @new = do {
             local $SIG{__WARN__} = sub { warn @_
-                unless $_[0] =~ /(?i:loader_test)\d+ has no primary key|^Dumping manual schema|^Schema dump completed/
+                unless $_[0] =~ /(?i:loader_test)\d+ has no primary key|^Dumping manual schema|^Schema dump completed|collides with an inherited method/
             };
             $conn->rescan;
         };
@@ -966,7 +969,7 @@ sub test_schema {
 
         @new = do {
             local $SIG{__WARN__} = sub { warn @_
-                unless $_[0] =~ /(?i:loader_test)\d+ has no primary key|^Dumping manual schema|^Schema dump completed/
+                unless $_[0] =~ /(?i:loader_test)\d+ has no primary key|^Dumping manual schema|^Schema dump completed|collides with an inherited method/
             };
             $conn->rescan;
         };
@@ -1047,7 +1050,7 @@ qq| INSERT INTO ${oqt}LoaderTest41${cqt} VALUES (1, 1) |,
 
     {
         local $SIG{__WARN__} = sub { warn @_
-            unless $_[0] =~ /(?i:loader_test)\d+ has no primary key|^Dumping manual schema|^Schema dump completed/
+            unless $_[0] =~ /(?i:loader_test)\d+ has no primary key|^Dumping manual schema|^Schema dump completed|collides with an inherited method/
         };
         $conn->rescan;
     };