Release 0.07044
[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / RelBuilder.pm
1 package DBIx::Class::Schema::Loader::RelBuilder;
2
3 use strict;
4 use warnings;
5 use base 'Class::Accessor::Grouped';
6 use mro 'c3';
7 use Carp::Clan qw/^DBIx::Class/;
8 use Scalar::Util 'weaken';
9 use DBIx::Class::Schema::Loader::Utils qw/split_name slurp_file array_eq apply uniq/;
10 use Try::Tiny;
11 use List::Util qw/all any first/;
12 use namespace::clean;
13 use Lingua::EN::Inflect::Phrase ();
14 use Lingua::EN::Tagger ();
15 use String::ToIdentifier::EN ();
16 use String::ToIdentifier::EN::Unicode ();
17 use Class::Unload ();
18 use Class::Inspector ();
19
20 our $VERSION = '0.07044';
21
22 # Glossary:
23 #
24 # local_relname  -- name of relationship from the local table referring to the remote table
25 # remote_relname -- name of relationship from the remote table referring to the local table
26 # remote_method  -- relationship type from remote table to local table, usually has_many
27
28 =head1 NAME
29
30 DBIx::Class::Schema::Loader::RelBuilder - Builds relationships for DBIx::Class::Schema::Loader
31
32 =head1 SYNOPSIS
33
34 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
35
36 =head1 DESCRIPTION
37
38 This class builds relationships for L<DBIx::Class::Schema::Loader>.  This
39 is module is not (yet) for external use.
40
41 =head1 METHODS
42
43 =head2 new
44
45 Arguments: $loader object
46
47 =head2 generate_code
48
49 Arguments:
50
51     [
52         [ local_moniker1 (scalar), fk_info1 (arrayref), uniq_info1 (arrayref) ]
53         [ local_moniker2 (scalar), fk_info2 (arrayref), uniq_info2 (arrayref) ]
54         ...
55     ]
56
57 This generates the code for the relationships of each table.
58
59 C<local_moniker> is the moniker name of the table which had the REFERENCES
60 statements.  The fk_info arrayref's contents should take the form:
61
62     [
63         {
64             local_table    => 'some_table',
65             local_moniker  => 'SomeTable',
66             local_columns  => [ 'col2', 'col3' ],
67             remote_table   => 'another_table_moniker',
68             remote_moniker => 'AnotherTableMoniker',
69             remote_columns => [ 'col5', 'col7' ],
70         },
71         {
72             local_table    => 'some_other_table',
73             local_moniker  => 'SomeOtherTable',
74             local_columns  => [ 'col1', 'col4' ],
75             remote_table   => 'yet_another_table_moniker',
76             remote_moniker => 'YetAnotherTableMoniker',
77             remote_columns => [ 'col1', 'col2' ],
78         },
79         # ...
80     ],
81
82 The uniq_info arrayref's contents should take the form:
83
84     [
85         [
86             uniq_constraint_name         => [ 'col1', 'col2' ],
87         ],
88         [
89             another_uniq_constraint_name => [ 'col1', 'col2' ],
90         ],
91     ],
92
93 This method will return the generated relationships as a hashref keyed on the
94 class names.  The values are arrayrefs of hashes containing method name and
95 arguments, like so:
96
97     {
98         'Some::Source::Class' => [
99             { method => 'belongs_to', arguments => [
100               'col1', 'Another::Source::Class' ] },
101             { method => 'has_many', arguments => [
102               'anothers', 'Yet::Another::Source::Class', 'col15' ] },
103         ],
104         'Another::Source::Class' => [
105             # ...
106         ],
107         # ...
108     }
109
110 =cut
111
112 __PACKAGE__->mk_group_accessors('simple', qw/
113     loader
114     schema
115     inflect_plural
116     inflect_singular
117     relationship_attrs
118     rel_collision_map
119     rel_name_map
120     allow_extra_m2m_cols
121     _temp_classes
122     __tagger
123 /);
124
125 sub new {
126     my ($class, $loader) = @_;
127
128     # from old POD about this constructor:
129     # C<$schema_class> should be a schema class name, where the source
130     # classes have already been set up and registered.  Column info,
131     # primary key, and unique constraints will be drawn from this
132     # schema for all of the existing source monikers.
133
134     # Options inflect_plural and inflect_singular are optional, and
135     # are better documented in L<DBIx::Class::Schema::Loader::Base>.
136
137     my $self = {
138         loader             => $loader,
139         (map { $_ => $loader->$_ } qw(
140             schema inflect_plural inflect_singular
141             relationship_attrs rel_collision_map
142             rel_name_map allow_extra_m2m_cols
143         )),
144         _temp_classes      => [],
145     };
146
147     weaken $self->{loader}; #< don't leak
148
149     bless $self => $class;
150
151     # validate the relationship_attrs arg
152     if( defined $self->relationship_attrs ) {
153         (ref $self->relationship_attrs eq 'HASH' || ref $self->relationship_attrs eq 'CODE')
154             or croak "relationship_attrs must be a hashref or coderef";
155     }
156
157     return $self;
158 }
159
160
161 # pluralize a relationship name
162 sub _inflect_plural {
163     my ($self, $relname) = @_;
164
165     return '' if !defined $relname || $relname eq '';
166
167     my $result;
168     my $mapped = 0;
169
170     if( ref $self->inflect_plural eq 'HASH' ) {
171         if (exists $self->inflect_plural->{$relname}) {
172             $result = $self->inflect_plural->{$relname};
173             $mapped = 1;
174         }
175     }
176     elsif( ref $self->inflect_plural eq 'CODE' ) {
177         my $inflected = $self->inflect_plural->($relname);
178         if ($inflected) {
179             $result = $inflected;
180             $mapped = 1;
181         }
182     }
183
184     return ($result, $mapped) if $mapped;
185
186     return ($self->_to_PL($relname), 0);
187 }
188
189 # Singularize a relationship name
190 sub _inflect_singular {
191     my ($self, $relname) = @_;
192
193     return '' if !defined $relname || $relname eq '';
194
195     my $result;
196     my $mapped = 0;
197
198     if( ref $self->inflect_singular eq 'HASH' ) {
199         if (exists $self->inflect_singular->{$relname}) {
200             $result = $self->inflect_singular->{$relname};
201             $mapped = 1;
202         }
203     }
204     elsif( ref $self->inflect_singular eq 'CODE' ) {
205         my $inflected = $self->inflect_singular->($relname);
206         if ($inflected) {
207             $result = $inflected;
208             $mapped = 1;
209         }
210     }
211
212     return ($result, $mapped) if $mapped;
213
214     return ($self->_to_S($relname), 0);
215 }
216
217 sub _to_PL {
218     my ($self, $name) = @_;
219
220     $name =~ s/_/ /g;
221     my $plural = Lingua::EN::Inflect::Phrase::to_PL($name);
222     $plural =~ s/ /_/g;
223
224     return $plural;
225 }
226
227 sub _to_S {
228     my ($self, $name) = @_;
229
230     $name =~ s/_/ /g;
231     my $singular = Lingua::EN::Inflect::Phrase::to_S($name);
232     $singular =~ s/ /_/g;
233
234     return $singular;
235 }
236
237 sub _default_relationship_attrs { +{
238     has_many => {
239         cascade_delete => 0,
240         cascade_copy   => 0,
241     },
242     might_have => {
243         cascade_delete => 0,
244         cascade_copy   => 0,
245     },
246     belongs_to => {
247         on_delete => 'CASCADE',
248         on_update => 'CASCADE',
249         is_deferrable => 1,
250     },
251 } }
252
253 # Accessor for options to be passed to each generated relationship type. takes
254 # the relationship type name and optionally any attributes from the database
255 # (such as FK ON DELETE/UPDATE and DEFERRABLE clauses), and returns a
256 # hashref or undef if nothing is set.
257 #
258 # The attributes from the database override the default attributes, which in
259 # turn are overridden by user supplied attributes.
260 sub _relationship_attrs {
261     my ( $self, $reltype, $db_attrs, $params ) = @_;
262     my $r = $self->relationship_attrs;
263
264     my %composite = (
265         %{ $self->_default_relationship_attrs->{$reltype} || {} },
266         %{ $db_attrs || {} },
267         (
268             ref $r eq 'HASH' ? (
269                 %{ $r->{all} || {} },
270                 %{ $r->{$reltype} || {} },
271             )
272             :
273             ()
274         ),
275     );
276
277     if (ref $r eq 'CODE') {
278         $params->{attrs} = \%composite;
279
280         my %ret = %{ $r->(%$params) || {} };
281
282         %composite = %ret if %ret;
283     }
284
285     return %composite ? \%composite : undef;
286 }
287
288 sub _strip_id_postfix {
289     my ($self, $name) = @_;
290
291     $name =~ s/_?(?:id|ref|cd|code|num)\z//i;
292
293     return $name;
294 }
295
296 sub _remote_attrs {
297     my ($self, $local_moniker, $local_cols, $fk_attrs, $params) = @_;
298
299     # get our set of attrs from _relationship_attrs, which uses the FK attrs if available
300     my $attrs = $self->_relationship_attrs('belongs_to', $fk_attrs, $params) || {};
301
302     # If any referring column is nullable, make 'belongs_to' an
303     # outer join, unless explicitly set by relationship_attrs
304     my $nullable = first { $self->schema->source($local_moniker)->column_info($_)->{is_nullable} } @$local_cols;
305     $attrs->{join_type} = 'LEFT' if $nullable && !defined $attrs->{join_type};
306
307     return $attrs;
308 }
309
310 sub _sanitize_name {
311     my ($self, $name) = @_;
312
313     $name = $self->loader->_to_identifier('relationships', $name, '_');
314
315     $name =~ s/\W+/_/g; # if naming >= 8 to_identifier takes care of it
316
317     return $name;
318 }
319
320 sub _normalize_name {
321     my ($self, $name) = @_;
322
323     $name = $self->_sanitize_name($name);
324
325     my @words = split_name $name, $self->loader->_get_naming_v('relationships');
326
327     return join '_', map lc, @words;
328 }
329
330 sub _local_relname {
331     my ($self, $remote_table, $cond) = @_;
332
333     my $local_relname;
334     # for single-column case, set the remote relname to the column
335     # name, to make filter accessors work, but strip trailing _id
336     if(scalar keys %{$cond} == 1) {
337         my ($col) = values %{$cond};
338         $col = $self->_strip_id_postfix($self->_normalize_name($col));
339         ($local_relname) = $self->_inflect_singular($col);
340     }
341     else {
342         ($local_relname) = $self->_inflect_singular($self->_normalize_name($remote_table));
343     }
344
345     return $local_relname;
346 }
347
348 sub _resolve_relname_collision {
349     my ($self, $moniker, $cols, $relname) = @_;
350
351     return $relname if $relname eq 'id'; # this shouldn't happen, but just in case
352
353     my $table = $self->loader->moniker_to_table->{$moniker};
354
355     if ($self->loader->_is_result_class_method($relname, $table)) {
356         if (my $map = $self->rel_collision_map) {
357             for my $re (keys %$map) {
358                 if (my @matches = $relname =~ /$re/) {
359                     return sprintf $map->{$re}, @matches;
360                 }
361             }
362         }
363
364         my $new_relname = $relname;
365         while ($self->loader->_is_result_class_method($new_relname, $table)) {
366             $new_relname .= '_rel'
367         }
368
369         warn <<"EOF";
370 Relationship '$relname' in source '$moniker' for columns '@{[ join ',', @$cols ]}' collides with an inherited method. Renaming to '$new_relname'.
371 See "RELATIONSHIP NAME COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
372 EOF
373
374         return $new_relname;
375     }
376
377     return $relname;
378 }
379
380 sub generate_code {
381     my ($self, $tables) = @_;
382
383     # make a copy to destroy
384     my @tables = @$tables;
385
386     my $all_code = {};
387
388     while (my ($local_moniker, $rels, $uniqs) = @{ shift @tables || [] }) {
389         my $local_class = $self->schema->class($local_moniker);
390
391         my %counters;
392         foreach my $rel (@$rels) {
393             next if !$rel->{remote_source};
394             $counters{$rel->{remote_source}}++;
395         }
396
397         foreach my $rel (@$rels) {
398             my $remote_moniker = $rel->{remote_source}
399                 or next;
400
401             my $remote_class   = $self->schema->class($remote_moniker);
402             my $remote_obj     = $self->schema->source($remote_moniker);
403             my $remote_cols    = $rel->{remote_columns} || [ $remote_obj->primary_columns ];
404
405             my $local_cols     = $rel->{local_columns};
406
407             if($#$local_cols != $#$remote_cols) {
408                 croak "Column count mismatch: $local_moniker (@$local_cols) "
409                     . "$remote_moniker (@$remote_cols)";
410             }
411
412             my %cond;
413             @cond{@$remote_cols} = @$local_cols;
414
415             my ( $local_relname, $remote_relname, $remote_method ) =
416                 $self->_relnames_and_method( $local_moniker, $rel, \%cond,  $uniqs, \%counters );
417             my $local_method  = 'belongs_to';
418
419             ($local_relname) = $self->_rel_name_map(
420                 $local_relname, $local_method,
421                 $local_class, $local_moniker, $local_cols,
422                 $remote_class, $remote_moniker, $remote_cols,
423             );
424             ($remote_relname) = $self->_rel_name_map(
425                 $remote_relname, $remote_method,
426                 $remote_class, $remote_moniker, $remote_cols,
427                 $local_class, $local_moniker, $local_cols,
428             );
429
430             $local_relname = $self->_resolve_relname_collision(
431                 $local_moniker, $local_cols, $local_relname,
432             );
433             $remote_relname = $self->_resolve_relname_collision(
434                 $remote_moniker, $remote_cols, $remote_relname,
435             );
436
437             my $rel_attrs_params = {
438                 rel_name      => $local_relname,
439                 rel_type      => $local_method,
440                 local_source  => $self->schema->source($local_moniker),
441                 remote_source => $self->schema->source($remote_moniker),
442                 local_table   => $rel->{local_table},
443                 local_cols    => $local_cols,
444                 remote_table  => $rel->{remote_table},
445                 remote_cols   => $remote_cols,
446             };
447
448             push @{$all_code->{$local_class}}, {
449                 method => $local_method,
450                 args => [
451                     $local_relname,
452                     $remote_class,
453                     \%cond,
454                     $self->_remote_attrs($local_moniker, $local_cols, $rel->{attrs}, $rel_attrs_params),
455                 ],
456                 extra => {
457                     local_class    => $local_class,
458                     local_moniker  => $local_moniker,
459                     remote_moniker => $remote_moniker,
460                 },
461             };
462
463             my %rev_cond = reverse %cond;
464             for (keys %rev_cond) {
465                 $rev_cond{"foreign.$_"} = "self.".$rev_cond{$_};
466                 delete $rev_cond{$_};
467             }
468
469             $rel_attrs_params = {
470                 rel_name      => $remote_relname,
471                 rel_type      => $remote_method,
472                 local_source  => $self->schema->source($remote_moniker),
473                 remote_source => $self->schema->source($local_moniker),
474                 local_table   => $rel->{remote_table},
475                 local_cols    => $remote_cols,
476                 remote_table  => $rel->{local_table},
477                 remote_cols   => $local_cols,
478             };
479
480             push @{$all_code->{$remote_class}}, {
481                 method => $remote_method,
482                 args => [
483                     $remote_relname,
484                     $local_class,
485                     \%rev_cond,
486                     $self->_relationship_attrs($remote_method, {}, $rel_attrs_params),
487                 ],
488                 extra => {
489                     local_class    => $remote_class,
490                     local_moniker  => $remote_moniker,
491                     remote_moniker => $local_moniker,
492                 },
493             };
494         }
495     }
496
497     $self->_generate_m2ms($all_code);
498
499     # disambiguate rels with the same name
500     foreach my $class (keys %$all_code) {
501         my $dups = $self->_duplicates($all_code->{$class});
502
503         $self->_disambiguate($all_code, $class, $dups) if $dups;
504     }
505
506     $self->_cleanup;
507
508     return $all_code;
509 }
510
511 # Find classes with only 2 FKs which are the PK and make many_to_many bridges for them.
512 sub _generate_m2ms {
513     my ($self, $all_code) = @_;
514
515     LINK_CLASS:
516     foreach my $link_class (sort keys %$all_code) {
517         my @rels = grep $_->{method} eq 'belongs_to', @{$all_code->{$link_class}};
518         next unless @rels == 2;
519
520         my @class;
521         foreach my $this (0, 1) {
522             my $that = $this ? 0 : 1;
523             my %class;
524             $class[$this] = \%class;
525             $class{local_moniker}  = $rels[$this]{extra}{remote_moniker};
526             $class{remote_moniker} = $rels[$that]{extra}{remote_moniker};
527
528             $class{class} = $rels[$this]{args}[1];
529
530             my %link_cols = map { $_ => 1 } apply { s/^self\.//i } values %{ $rels[$this]{args}[2] };
531
532             $class{link_table_rel} = first {
533                 $_->{method} eq 'has_many'
534                     and
535                 $_->{args}[1] eq $link_class
536                     and
537                 all { $link_cols{$_} } apply { s/^foreign\.//i } keys %{$_->{args}[2]}
538             } @{ $all_code->{$class{class}} };
539
540             next LINK_CLASS unless $class{link_table_rel};
541
542             $class{link_table_rel_name} = $class{link_table_rel}{args}[0];
543
544             $class{link_rel} = $rels[$that]{args}[0];
545
546             $class{from_cols} = [ apply { s/^self\.//i } values %{
547                 $class{link_table_rel}->{args}[2]
548             } ];
549
550             $class{to_cols} = [ apply { s/^foreign\.//i } keys %{ $rels[$that]{args}[2] } ];
551
552             $class{from_link_cols} = [ apply { s/^self\.//i } values %{ $rels[$this]{args}[2] } ];
553         }
554
555         my $link_moniker = $rels[0]{extra}{local_moniker};
556
557         my @link_table_cols =
558             @{[ $self->schema->source($link_moniker)->columns ]};
559
560         my @link_table_primary_cols =
561             @{[ $self->schema->source($link_moniker)->primary_columns ]};
562
563         next unless array_eq(
564             [ sort +uniq @{$class[0]{from_link_cols}}, @{$class[1]{from_link_cols}} ],
565             [ sort @link_table_primary_cols ],
566         ) && ($self->allow_extra_m2m_cols || @link_table_cols == @link_table_primary_cols);
567
568         foreach my $this (0, 1) {
569             my $that = $this ? 0 : 1;
570             ($class[$this]{m2m_relname}) = $self->_rel_name_map(
571                 ($self->_inflect_plural($class[$this]{link_rel}))[0],
572                 'many_to_many',
573                 @{$class[$this]}{qw(class local_moniker from_cols)},
574                 $class[$that]{class},
575                 @{$class[$this]}{qw(remote_moniker to_cols)},
576                 {
577                     link_class => $link_class,
578                     link_moniker => $link_moniker,
579                     link_rel_name => $class[$this]{link_table_rel_name},
580                 },
581             );
582
583             $class[$this]{m2m_relname} = $self->_resolve_relname_collision(
584                 @{$class[$this]}{qw(local_moniker from_cols m2m_relname)},
585             );
586         }
587
588         for my $this (0, 1) {
589             my $that = $this ? 0 : 1;
590
591             push @{$all_code->{$class[$this]{class}}}, {
592                 method => 'many_to_many',
593                 args   => [
594                     @{$class[$this]}{qw(m2m_relname link_table_rel_name link_rel)},
595                     $self->_relationship_attrs('many_to_many', {}, {
596                         rel_type => 'many_to_many',
597                         rel_name => $class[$this]{class2_relname},
598                         local_source => $self->schema->source($class[$this]{local_moniker}),
599                         remote_source => $self->schema->source($class[$this]{remote_moniker}),
600                         local_table => $self->loader->class_to_table->{$class[$this]{class}},
601                         local_cols => $class[$this]{from_cols},
602                         remote_table => $self->loader->class_to_table->{$class[$that]{class}},
603                         remote_cols => $class[$that]{from_cols},
604                     }) || (),
605                 ],
606                 extra  => {
607                     local_class    => $class[$this]{class},
608                     link_class     => $link_class,
609                     local_moniker  => $class[$this]{local_moniker},
610                     remote_moniker => $class[$this]{remote_moniker},
611                 },
612             };
613         }
614     }
615 }
616
617 sub _duplicates {
618     my ($self, $rels) = @_;
619
620     my @rels = map [ $_->{args}[0] => $_ ], @$rels;
621     my %rel_names;
622     $rel_names{$_}++ foreach map $_->[0], @rels;
623
624     my @dups = grep $rel_names{$_} > 1, keys %rel_names;
625
626     my %dups;
627
628     foreach my $dup (@dups) {
629         $dups{$dup} = [ map $_->[1], grep { $_->[0] eq $dup } @rels ];
630     }
631
632     return if not %dups;
633
634     return \%dups;
635 }
636
637 sub _tagger {
638     my $self = shift;
639
640     $self->__tagger(Lingua::EN::Tagger->new) unless $self->__tagger;
641
642     return $self->__tagger;
643 }
644
645 sub _adjectives {
646     my ($self, @cols) = @_;
647
648     my @adjectives;
649
650     foreach my $col (@cols) {
651         my @words = split_name $col;
652
653         my $tagged = $self->_tagger->get_readable(join ' ', @words);
654
655         push @adjectives, $tagged =~ m{\G(\w+)/JJ\s+}g;
656     }
657
658     return @adjectives;
659 }
660
661 sub _name_to_identifier {
662     my ($self, $name) = @_;
663
664     my $to_identifier = $self->loader->naming->{force_ascii} ?
665         \&String::ToIdentifier::EN::to_identifier
666         : \&String::ToIdentifier::EN::Unicode::to_identifier;
667
668     return join '_', map lc, split_name $to_identifier->($name, '_');
669 }
670
671 sub _disambiguate {
672     my ($self, $all_code, $in_class, $dups) = @_;
673
674     DUP: foreach my $dup (keys %$dups) {
675         my @rels = @{ $dups->{$dup} };
676
677         # Check if there are rels to the same table name in different
678         # schemas/databases, if so qualify them.
679         my @tables = map $self->loader->moniker_to_table->{$_->{extra}{remote_moniker}},
680                         @rels;
681
682         # databases are different, prepend database
683         if ($tables[0]->can('database') && (uniq map $_->database||'', @tables) > 1) {
684             # If any rels are in the same database, we have to distinguish by
685             # both schema and database.
686             my %db_counts;
687             $db_counts{$_}++ for map $_->database, @tables;
688             my $use_schema = any { $_ > 1 } values %db_counts;
689
690             foreach my $i (0..$#rels) {
691                 my $rel   = $rels[$i];
692                 my $table = $tables[$i];
693
694                 $rel->{args}[0] = $self->_name_to_identifier($table->database)
695                     . ($use_schema ? ('_' . $self->name_to_identifier($table->schema)) : '')
696                     . '_' . $rel->{args}[0];
697             }
698             next DUP;
699         }
700         # schemas are different, prepend schema
701         elsif ((uniq map $_->schema||'', @tables) > 1) {
702             foreach my $i (0..$#rels) {
703                 my $rel   = $rels[$i];
704                 my $table = $tables[$i];
705
706                 $rel->{args}[0] = $self->_name_to_identifier($table->schema)
707                     . '_' . $rel->{args}[0];
708             }
709             next DUP;
710         }
711
712         foreach my $rel (@rels) {
713             next if $rel->{method} =~ /^(?:belongs_to|many_to_many)\z/;
714
715             my @to_cols = apply { s/^foreign\.//i }
716                 keys %{ $rel->{args}[2] };
717
718             my @adjectives = $self->_adjectives(@to_cols);
719
720             # If there are no adjectives, and there is only one might_have
721             # rel to that class, we hardcode 'active'.
722
723             my $to_class = $rel->{args}[1];
724
725             if ((not @adjectives)
726                 && (grep { $_->{method} eq 'might_have'
727                            && $_->{args}[1] eq $to_class } @{ $all_code->{$in_class} }) == 1) {
728
729                 @adjectives = 'active';
730             }
731
732             if (@adjectives) {
733                 my $rel_name = join '_', sort(@adjectives), $rel->{args}[0];
734
735                 ($rel_name) = $rel->{method} eq 'might_have' ?
736                     $self->_inflect_singular($rel_name)
737                     :
738                     $self->_inflect_plural($rel_name);
739
740                 my ($local_class, $local_moniker, $remote_moniker)
741                     = @{ $rel->{extra} }
742                         {qw/local_class local_moniker remote_moniker/};
743
744                 my @from_cols = apply { s/^self\.//i }
745                     values %{ $rel->{args}[2] };
746
747                 ($rel_name) = $self->_rel_name_map($rel_name, $rel->{method}, $local_class, $local_moniker, \@from_cols, $to_class, $remote_moniker, \@to_cols);
748
749                 $rel_name = $self->_resolve_relname_collision($local_moniker, \@from_cols, $rel_name);
750
751                 $rel->{args}[0] = $rel_name;
752             }
753         }
754     }
755
756     # Check again for duplicates, since the heuristics above may not have resolved them all.
757
758     if ($dups = $self->_duplicates($all_code->{$in_class})) {
759         foreach my $dup (keys %$dups) {
760             # sort by method
761             my @rels = map $_->[1], sort { $a->[0] <=> $b->[0] } map [
762                 {
763                     belongs_to   => 3,
764                     has_many     => 2,
765                     might_have   => 1,
766                     many_to_many => 0,
767                 }->{$_->{method}}, $_
768             ], @{ $dups->{$dup} };
769
770             my $rel_num = 2;
771
772             foreach my $rel (@rels[1 .. $#rels]) {
773                 my $inflect_type = $rel->{method} =~ /^(?:many_to_many|has_many)\z/ ?
774                     'inflect_plural'
775                     :
776                     'inflect_singular';
777
778                 my $inflect_method = "_$inflect_type";
779
780                 my $relname_new_uninflected = $rel->{args}[0] . "_$rel_num";
781
782                 $rel_num++;
783
784                 my ($local_class, $local_moniker, $remote_moniker)
785                     = @{ $rel->{extra} }
786                         {qw/local_class local_moniker remote_moniker/};
787
788                 my (@from_cols, @to_cols, $to_class);
789
790                 if ($rel->{method} eq 'many_to_many') {
791                     @from_cols = apply { s/^self\.//i } values %{
792                         (first { $_->{args}[0] eq $rel->{args}[1] } @{ $all_code->{$local_class} })
793                             ->{args}[2]
794                     };
795                     @to_cols   = apply { s/^foreign\.//i } keys %{
796                         (first { $_->{args}[0] eq $rel->{args}[2] }
797                             @{ $all_code->{ $rel->{extra}{link_class} } })
798                                 ->{args}[2]
799                     };
800                     $to_class  = $self->schema->source($remote_moniker)->result_class;
801                 }
802                 else {
803                     @from_cols = apply { s/^self\.//i }    values %{ $rel->{args}[2] };
804                     @to_cols   = apply { s/^foreign\.//i } keys   %{ $rel->{args}[2] };
805                     $to_class  = $rel->{args}[1];
806                 }
807
808                 my ($relname_new, $inflect_mapped) =
809                     $self->$inflect_method($relname_new_uninflected);
810
811                 my $rel_name_mapped;
812
813                 ($relname_new, $rel_name_mapped) = $self->_rel_name_map($relname_new, $rel->{method}, $local_class, $local_moniker, \@from_cols, $to_class, $remote_moniker, \@to_cols);
814
815                 my $mapped = $inflect_mapped || $rel_name_mapped;
816
817                 warn <<"EOF" unless $mapped;
818 Could not find a proper name for relationship '$relname_new' in source
819 '$local_moniker' for columns '@{[ join ',', @from_cols ]}'. Supply a value in
820 '$inflect_type' for '$relname_new_uninflected' or 'rel_name_map' for
821 '$relname_new' to name this relationship.
822 EOF
823
824                 $relname_new = $self->_resolve_relname_collision($local_moniker, \@from_cols, $relname_new);
825
826                 $rel->{args}[0] = $relname_new;
827             }
828         }
829     }
830 }
831
832 sub _relnames_and_method {
833     my ( $self, $local_moniker, $rel, $cond, $uniqs, $counters ) = @_;
834
835     my $remote_moniker  = $rel->{remote_source};
836     my $remote_obj      = $self->schema->source( $remote_moniker );
837     my $remote_class    = $self->schema->class(  $remote_moniker );
838     my $local_relname   = $self->_local_relname( $rel->{remote_table}, $cond);
839
840     my $local_cols      = $rel->{local_columns};
841     my $local_table     = $rel->{local_table};
842     my $local_class     = $self->schema->class($local_moniker);
843     my $local_source    = $self->schema->source($local_moniker);
844
845     my $remote_relname_uninflected = $self->_normalize_name($local_table);
846     my ($remote_relname) = $self->_inflect_plural($self->_normalize_name($local_table));
847
848     my $remote_method = 'has_many';
849
850     # If the local columns have a UNIQUE constraint, this is a one-to-one rel
851     if (array_eq([ $local_source->primary_columns ], $local_cols) ||
852             first { array_eq($_->[1], $local_cols) } @$uniqs) {
853         $remote_method   = 'might_have';
854         ($remote_relname) = $self->_inflect_singular($remote_relname_uninflected);
855     }
856
857     # If more than one rel between this pair of tables, use the local
858     # col names to distinguish, unless the rel was created previously.
859     if ($counters->{$remote_moniker} > 1) {
860         my $relationship_exists = 0;
861
862         if (-f (my $existing_remote_file = $self->loader->get_dump_filename($remote_class))) {
863             my $class = "${remote_class}Temporary";
864
865             if (not Class::Inspector->loaded($class)) {
866                 my $code = slurp_file $existing_remote_file;
867
868                 $code =~ s/(?<=package $remote_class)/Temporary/g;
869
870                 $code =~ s/__PACKAGE__->meta->make_immutable[^;]*;//g;
871
872                 eval $code;
873                 die $@ if $@;
874
875                 push @{ $self->_temp_classes }, $class;
876             }
877
878             if ($class->has_relationship($remote_relname)) {
879                 my $rel_cols = [ sort { $a cmp $b } apply { s/^foreign\.//i }
880                     (keys %{ $class->relationship_info($remote_relname)->{cond} }) ];
881
882                 $relationship_exists = 1 if array_eq([ sort @$local_cols ], $rel_cols);
883             }
884         }
885
886         if (not $relationship_exists) {
887             my $colnames = q{_} . $self->_normalize_name(join '_', @$local_cols);
888             $local_relname .= $colnames if keys %$cond > 1;
889
890             $remote_relname = $self->_strip_id_postfix($self->_normalize_name($local_table . $colnames));
891
892             $remote_relname_uninflected = $remote_relname;
893             ($remote_relname) = $self->_inflect_plural($remote_relname);
894
895             # if colnames were added and this is a might_have, re-inflect
896             if ($remote_method eq 'might_have') {
897                 ($remote_relname) = $self->_inflect_singular($remote_relname_uninflected);
898             }
899         }
900     }
901
902     return ($local_relname, $remote_relname, $remote_method);
903 }
904
905 sub _rel_name_map {
906     my ($self, $relname, $method, $local_class, $local_moniker, $local_cols,
907         $remote_class, $remote_moniker, $remote_cols, $extra) = @_;
908
909     my $info = {
910         %{$extra || {}},
911         name           => $relname,
912         type           => $method,
913         local_class    => $local_class,
914         local_moniker  => $local_moniker,
915         local_columns  => $local_cols,
916         remote_class   => $remote_class,
917         remote_moniker => $remote_moniker,
918         remote_columns => $remote_cols,
919     };
920
921     $self->_run_user_map($self->rel_name_map, $info);
922 }
923
924 sub _run_user_map {
925     my ($self, $map, $info) = @_;
926
927     my $new_name = $info->{name};
928     my $mapped = 0;
929
930     if ('HASH' eq ref($map)) {
931         my $name = $info->{name};
932         my $moniker = $info->{local_moniker};
933         if ($map->{$moniker} and 'HASH' eq ref($map->{$moniker})
934             and $map->{$moniker}{$name}
935         ) {
936             $new_name = $map->{$moniker}{$name};
937             $mapped   = 1;
938         }
939         elsif ($map->{$name} and not 'HASH' eq ref($map->{$name})) {
940             $new_name = $map->{$name};
941             $mapped   = 1;
942         }
943     }
944     elsif ('CODE' eq ref($map)) {
945         my $cb = sub {
946             my ($cb_map) = @_;
947             croak "reentered rel_name_map must be a hashref"
948                 unless 'HASH' eq ref($cb_map);
949             my ($cb_name, $cb_mapped) = $self->_run_user_map($cb_map, $info);
950             return $cb_mapped && $cb_name;
951         };
952         my $name = $map->($info, $cb);
953         if ($name) {
954             $new_name = $name;
955             $mapped   = 1;
956         }
957     }
958
959     return ($new_name, $mapped);
960 }
961
962 sub _cleanup {
963     my $self = shift;
964
965     for my $class (@{ $self->_temp_classes }) {
966         Class::Unload->unload($class);
967     }
968
969     $self->_temp_classes([]);
970 }
971
972 =head1 AUTHORS
973
974 See L<DBIx::Class::Schema::Loader/AUTHORS>.
975
976 =head1 LICENSE
977
978 This library is free software; you can redistribute it and/or modify it under
979 the same terms as Perl itself.
980
981 =cut
982
983 1;
984 # vim:et sts=4 sw=4 tw=0: