X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FBase.pm;h=83947a80c0622a67cb94a16b03f5aeb740ae476f;hb=19b7d71c67672e15f11ca6772963170fd6c6b588;hp=3514c5701c64d6f539bc8fce5cdc679f75e6d278;hpb=5afd3e723f5c9644e67f9b623b069f870e94fdc9;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

diff --git a/lib/DBIx/Class/Schema/Loader/Base.pm b/lib/DBIx/Class/Schema/Loader/Base.pm
index 3514c57..83947a8 100644
--- a/lib/DBIx/Class/Schema/Loader/Base.pm
+++ b/lib/DBIx/Class/Schema/Loader/Base.pm
@@ -22,7 +22,7 @@ use Scalar::Util 'looks_like_number';
 use File::Slurp 'slurp';
 require DBIx::Class;
 
-our $VERSION = '0.06001';
+our $VERSION = '0.07000';
 
 __PACKAGE__->mk_group_ro_accessors('simple', qw/
                                 schema
@@ -165,11 +165,27 @@ the v5 RelBuilder.
 
 =item v6
 
-All monikers and relationships inflected using L<Lingua::EN::Inflect::Phrase>,
-more aggressive C<_id> stripping from relationships.
+All monikers and relationships are inflected using
+L<Lingua::EN::Inflect::Phrase>, and there is more aggressive C<_id> stripping
+from relationship names.
 
 In general, there is very little difference between v5 and v6 schemas.
 
+=item v7
+
+This mode is identical to C<v6> mode, except that monikerization of CamelCase
+table names is also done correctly.
+
+CamelCase column names in case-sensitive mode will also be handled correctly
+for relationship name inflection.
+
+Currently, only Sybase ASE, MSSQL with CS/BIN collation and Firebird without
+the L<unquoted_ddl|DBIx::Class::Schema::Loader::DBI::InterBase/unquoted_ddl>
+option are in case-sensitive mode.
+
+If you don't have any CamelCase table or column names, you can upgrade without
+breaking any of your code.
+
 =back
 
 Dynamic schemas will always default to the 0.04XXX relationship names and won't
@@ -242,9 +258,6 @@ For example:
 will set the C<cascade_delete> option to 0 for all generated relationships,
 except for C<has_many>, which will have cascade_delete as 1.
 
-NOTE: this option is not supported if v4 backward-compatible naming is
-set either globally (naming => 'v4') or just for relationships.
-
 =head2 debug
 
 If set to true, each constructive L<DBIx::Class> statement the loader
@@ -273,17 +286,17 @@ a scalar moniker.  If the hash entry does not exist, or the function
 returns a false value, the code falls back to default behavior
 for that table name.
 
-The default behavior is to singularize the table name, and: C<join '', map
-ucfirst, split /[\W_]+/, lc $table>, which is to say: lowercase everything,
-split up the table name into chunks anywhere a non-alpha-numeric character
-occurs, change the case of first letter of each chunk to upper case, and put
-the chunks back together.  Examples:
+The default behavior is to split on case transition and non-alphanumeric
+boundaries, singularize the resulting phrase, then join the titlecased words
+together. Examples:
 
-    Table Name  | Moniker Name
-    ---------------------------
-    luser       | Luser
-    luser_group | LuserGroup
-    luser-opts  | LuserOpt
+    Table Name       | Moniker Name
+    ---------------------------------
+    luser            | Luser
+    luser_group      | LuserGroup
+    luser-opts       | LuserOpt
+    stations_visited | StationVisited
+    routeChange      | RouteChange
 
 =head2 inflect_plural
 
@@ -445,7 +458,7 @@ L<DBIx::Class::Schema::Loader>.
 
 =cut
 
-my $CURRENT_V = 'v6';
+my $CURRENT_V = 'v7';
 
 my @CLASS_ARGS = qw(
     schema_base_class result_base_class additional_base_classes
@@ -658,6 +671,8 @@ Version $real_ver static schema detected, turning on backcompat mode.
 Set the 'naming' attribute or the SCHEMA_LOADER_BACKCOMPAT environment variable
 to disable this warning.
 
+See: 'naming' in perldoc DBIx::Class::Schema::Loader::Base .
+
 See perldoc DBIx::Class::Schema::Loader::Manual::UpgradingFromV4 if upgrading
 from version 0.04006.
 EOF
@@ -917,7 +932,10 @@ sub _relbuilder {
         require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040;
         return $self->{relbuilder} ||=
             DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_040->new(
-                $self->schema, $self->inflect_plural, $self->inflect_singular
+                $self->schema,
+                $self->inflect_plural,
+                $self->inflect_singular,
+                $self->relationship_attrs,
             );
     }
     elsif ($self->naming->{relationships} eq 'v5') {
@@ -929,6 +947,15 @@ sub _relbuilder {
              $self->relationship_attrs,
         );
     }
+    elsif ($self->naming->{relationships} eq 'v6') {
+        require DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06;
+        return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder::Compat::v0_06->new (
+             $self->schema,
+             $self->inflect_plural,
+             $self->inflect_singular,
+             $self->relationship_attrs,
+        );
+    }
 
     return $self->{relbuilder} ||= DBIx::Class::Schema::Loader::RelBuilder->new (
              $self->schema,
@@ -1397,6 +1424,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'; # special case (very common column)
+
+        if (exists $methods{$accessor}) {
+            $info->{accessor} = undef;
+        }
+    }
+}
+
 # Set up metadata (cols, pks, etc)
 sub _setup_src_meta {
     my ($self, $table) = @_;
@@ -1423,10 +1479,14 @@ sub _setup_src_meta {
             $col_info->{$col}{accessor} = lc $col
                 if $col ne lc($col);
         }
-    } else {
+    }
+    else {
+        # XXX this needs to go away
         $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) {
@@ -1496,8 +1556,16 @@ sub _default_table2moniker {
         return join '', map ucfirst, split /[\W_]+/,
             Lingua::EN::Inflect::Number::to_S(lc $table);
     }
+    elsif ($self->naming->{monikers} eq 'v6') {
+        (my $as_phrase = lc $table) =~ s/_+/ /g;
+        my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
+
+        return join '', map ucfirst, split /\W+/, $inflected;
+    }
+
+    my @words = map lc, split /(?<=[[:lower:]])[\W_]*(?=[[:upper:]])|[\W_]+/, $table;
+    my $as_phrase = join ' ', @words;
 
-    (my $as_phrase = lc $table) =~ s/_+/ /g;
     my $inflected = Lingua::EN::Inflect::Phrase::to_S($as_phrase);
 
     return join '', map ucfirst, split /\W+/, $inflected;