handle digits when splitting by case transition
[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / RelBuilder.pm
index 4d5912a..7847c77 100644 (file)
@@ -4,9 +4,10 @@ use strict;
 use warnings;
 use Class::C3;
 use Carp::Clan qw/^DBIx::Class/;
-use Lingua::EN::Inflect::Number ();
+use Lingua::EN::Inflect::Phrase ();
+use DBIx::Class::Schema::Loader::Constants 'BY_CASE_TRANSITION';
 
-our $VERSION = '0.04999_14';
+our $VERSION = '0.07000';
 
 =head1 NAME
 
@@ -14,7 +15,7 @@ DBIx::Class::Schema::Loader::RelBuilder - Builds relationships for DBIx::Class::
 
 =head1 SYNOPSIS
 
-See L<DBIx::Class::Schema::Loader>
+See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
 
 =head1 DESCRIPTION
 
@@ -76,7 +77,6 @@ arguments, like so:
 =cut
 
 sub new {
-
     my ( $class, $schema, $inflect_pl, $inflect_singular, $rel_attrs ) = @_;
 
     my $self = {
@@ -100,6 +100,8 @@ sub new {
 sub _inflect_plural {
     my ($self, $relname) = @_;
 
+    return '' if !defined $relname || $relname eq '';
+
     if( ref $self->{inflect_plural} eq 'HASH' ) {
         return $self->{inflect_plural}->{$relname}
             if exists $self->{inflect_plural}->{$relname};
@@ -109,13 +111,15 @@ sub _inflect_plural {
         return $inflected if $inflected;
     }
 
-    return Lingua::EN::Inflect::Number::to_PL($relname);
+    return $self->_to_PL($relname);
 }
 
 # Singularize a relationship name
 sub _inflect_singular {
     my ($self, $relname) = @_;
 
+    return '' if !defined $relname || $relname eq '';
+
     if( ref $self->{inflect_singular} eq 'HASH' ) {
         return $self->{inflect_singular}->{$relname}
             if exists $self->{inflect_singular}->{$relname};
@@ -125,18 +129,57 @@ sub _inflect_singular {
         return $inflected if $inflected;
     }
 
-    return Lingua::EN::Inflect::Number::to_S($relname);
+    return $self->_to_S($relname);
+}
+
+sub _to_PL {
+    my ($self, $name) = @_;
+
+    $name =~ s/_/ /g;
+    my $plural = Lingua::EN::Inflect::Phrase::to_PL($name);
+    $plural =~ s/ /_/g;
+
+    return $plural;
 }
 
+sub _to_S {
+    my ($self, $name) = @_;
+
+    $name =~ s/_/ /g;
+    my $singular = Lingua::EN::Inflect::Phrase::to_S($name);
+    $singular =~ s/ /_/g;
+
+    return $singular;
+}
+
+sub _default_relationship_attrs { +{
+    has_many => {
+        cascade_delete => 0,
+        cascade_copy   => 0,
+    },
+    might_have => {
+        cascade_delete => 0,
+        cascade_copy   => 0,
+    },
+    belongs_to => {
+        on_delete => 'CASCADE',
+        on_update => 'CASCADE',
+#        is_deferrable => 1,
+    },
+} }
+
 # accessor for options to be passed to each generated relationship
 # type.  take single argument, the relationship type name, and returns
 # either a hashref (if some options are set), or nothing
 sub _relationship_attrs {
     my ( $self, $reltype ) = @_;
     my $r = $self->{relationship_attrs};
-    return unless $r && ( $r->{all} || $r->{$reltype} );
 
-    my %composite = %{ $r->{all} || {} };
+    my %composite = (
+        %{ $self->_default_relationship_attrs->{$reltype} || {} },
+        %{ $r->{all} || {} }
+    );
+
     if( my $specific = $r->{$reltype} ) {
        while( my ($k,$v) = each %$specific ) {
            $composite{$k} = $v;
@@ -146,7 +189,7 @@ sub _relationship_attrs {
 }
 
 sub _array_eq {
-    my ($a, $b) = @_;
+    my ($self, $a, $b) = @_;
 
     return unless @$a == @$b;
 
@@ -156,36 +199,26 @@ sub _array_eq {
     return 1;
 }
 
-sub _uniq_fk_rel {
-    my ($self, $local_moniker, $local_relname, $local_cols, $uniqs) = @_;
+sub _remote_attrs {
+    my ($self, $local_moniker, $local_cols) = @_;
 
-    my $remote_method = 'has_many';
+    # get our base set of attrs from _relationship_attrs, if present
+    my $attrs = $self->_relationship_attrs('belongs_to') || {};
 
-    # If the local columns have a UNIQUE constraint, this is a one-to-one rel
-    my $local_source = $self->{schema}->source($local_moniker);
-    if (_array_eq([ $local_source->primary_columns ], $local_cols) ||
-            grep { _array_eq($_->[1], $local_cols) } @$uniqs) {
-        $remote_method = 'might_have';
-        $local_relname = $self->_inflect_singular($local_relname);
-    }
+    # If the referring column is nullable, make 'belongs_to' an
+    # outer join, unless explicitly set by relationship_attrs
+    my $nullable = grep { $self->{schema}->source($local_moniker)->column_info($_)->{is_nullable} } @$local_cols;
+    $attrs->{join_type} = 'LEFT' if $nullable && !defined $attrs->{join_type};
 
-    return ($remote_method, $local_relname);
+    return $attrs;
 }
 
-sub _remote_attrs {
-       my ($self, $local_moniker, $local_cols) = @_;
-
-       # get our base set of attrs from _relationship_attrs, if present
-       my $attrs = $self->_relationship_attrs('belongs_to') || {};
+sub _normalize_name {
+    my ($self, $name) = @_;
 
-       # If the referring column is nullable, make 'belongs_to' an
-       # outer join, unless explicitly set by relationship_attrs
-       my $nullable = grep { $self->{schema}->source($local_moniker)->column_info($_)->{is_nullable} }
-               @$local_cols;
-       $attrs->{join_type} = 'LEFT'
-           if $nullable && !defined $attrs->{join_type};
+    my @words = split BY_CASE_TRANSITION, $name;
 
-       return $attrs;
+    return join '_', map lc, @words;
 }
 
 sub _remote_relname {
@@ -196,11 +229,12 @@ sub _remote_relname {
     # name, to make filter accessors work, but strip trailing _id
     if(scalar keys %{$cond} == 1) {
         my ($col) = values %{$cond};
+        $col = $self->_normalize_name($col);
         $col =~ s/_id$//;
         $remote_relname = $self->_inflect_singular($col);
     }
     else {
-        $remote_relname = $self->_inflect_singular(lc $remote_table);
+        $remote_relname = $self->_inflect_singular($self->_normalize_name($remote_table));
     }
 
     return $remote_relname;
@@ -211,9 +245,8 @@ sub generate_code {
 
     my $all_code = {};
 
-    my $local_table = $self->{schema}->source($local_moniker)->from;
     my $local_class = $self->{schema}->class($local_moniker);
-        
+
     my %counters;
     foreach my $rel (@$rels) {
         next if !$rel->{remote_source};
@@ -221,14 +254,14 @@ sub generate_code {
     }
 
     foreach my $rel (@$rels) {
-        next if !$rel->{remote_source};
-        my $local_cols = $rel->{local_columns};
-        my $remote_cols = $rel->{remote_columns};
-        my $remote_moniker = $rel->{remote_source};
-        my $remote_obj = $self->{schema}->source($remote_moniker);
-        my $remote_class = $self->{schema}->class($remote_moniker);
-        my $remote_table = $remote_obj->from;
-        $remote_cols ||= [ $remote_obj->primary_columns ];
+        my $remote_moniker = $rel->{remote_source}
+            or next;
+
+        my $remote_class   = $self->{schema}->class($remote_moniker);
+        my $remote_obj     = $self->{schema}->source($remote_moniker);
+        my $remote_cols    = $rel->{remote_columns} || [ $remote_obj->primary_columns ];
+
+        my $local_cols     = $rel->{local_columns};
 
         if($#$local_cols != $#$remote_cols) {
             croak "Column count mismatch: $local_moniker (@$local_cols) "
@@ -240,31 +273,8 @@ sub generate_code {
             $cond{$remote_cols->[$i]} = $local_cols->[$i];
         }
 
-        my $local_relname;
-        my $remote_relname = $self->_remote_relname($remote_table, \%cond);
-
-        # If more than one rel between this pair of tables, use the local
-        # col names to distinguish
-        if($counters{$remote_moniker} > 1) {
-            my $colnames = q{_} . join(q{_}, @$local_cols);
-            $local_relname = $self->_inflect_plural(
-                lc($local_table) . $colnames
-            );
-            $remote_relname .= $colnames if keys %cond > 1;
-        } else {
-            $local_relname = $self->_inflect_plural(lc $local_table);
-        }
-
-        my %rev_cond = reverse %cond;
-
-        for (keys %rev_cond) {
-            $rev_cond{"foreign.$_"} = "self.".$rev_cond{$_};
-            delete $rev_cond{$_};
-        }
-
-        my ($remote_method);
-
-        ($remote_method, $local_relname) = $self->_uniq_fk_rel($local_moniker, $local_relname, $local_cols, $uniqs);
+        my ( $local_relname, $remote_relname, $remote_method ) =
+            $self->_relnames_and_method( $local_moniker, $rel, \%cond,  $uniqs, \%counters );
 
         push(@{$all_code->{$local_class}},
             { method => 'belongs_to',
@@ -276,6 +286,12 @@ sub generate_code {
             }
         );
 
+        my %rev_cond = reverse %cond;
+        for (keys %rev_cond) {
+            $rev_cond{"foreign.$_"} = "self.".$rev_cond{$_};
+            delete $rev_cond{$_};
+        }
+
         push(@{$all_code->{$remote_class}},
             { method => $remote_method,
               args => [ $local_relname,
@@ -290,6 +306,47 @@ sub generate_code {
     return $all_code;
 }
 
+sub _relnames_and_method {
+    my ( $self, $local_moniker, $rel, $cond, $uniqs, $counters ) = @_;
+
+    my $remote_moniker = $rel->{remote_source};
+    my $remote_obj     = $self->{schema}->source( $remote_moniker );
+    my $remote_class   = $self->{schema}->class(  $remote_moniker );
+    my $remote_relname = $self->_remote_relname( $remote_obj->from, $cond);
+
+    my $local_cols  = $rel->{local_columns};
+    my $local_table = $self->{schema}->source($local_moniker)->from;
+
+    # If more than one rel between this pair of tables, use the local
+    # col names to distinguish
+    my ($local_relname, $local_relname_uninflected);
+    if ( $counters->{$remote_moniker} > 1) {
+        my $colnames = q{_} . $self->_normalize_name(join '_', @$local_cols);
+        $remote_relname .= $colnames if keys %$cond > 1;
+
+        $local_relname = $self->_normalize_name($local_table . $colnames);
+        $local_relname =~ s/_id$//;
+
+        $local_relname_uninflected = $local_relname;
+        $local_relname = $self->_inflect_plural($local_relname);
+    } else {
+        $local_relname_uninflected = $self->_normalize_name($local_table);
+        $local_relname = $self->_inflect_plural($self->_normalize_name($local_table));
+    }
+
+    my $remote_method = 'has_many';
+
+    # If the local columns have a UNIQUE constraint, this is a one-to-one rel
+    my $local_source = $self->{schema}->source($local_moniker);
+    if ($self->_array_eq([ $local_source->primary_columns ], $local_cols) ||
+            grep { $self->_array_eq($_->[1], $local_cols) } @$uniqs) {
+        $remote_method = 'might_have';
+        $local_relname = $self->_inflect_singular($local_relname_uninflected);
+    }
+
+    return ( $local_relname, $remote_relname, $remote_method );
+}
+
 =head1 AUTHOR
 
 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
@@ -302,3 +359,4 @@ the same terms as Perl itself.
 =cut
 
 1;
+# vim:et sts=4 sw=4 tw=0: