multi db_schema support
[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/;
10 use Try::Tiny;
11 use List::MoreUtils 'apply';
12 use namespace::clean;
13 use Lingua::EN::Inflect::Phrase ();
14 use Lingua::EN::Tagger ();
15 use Class::Unload ();
16 use Class::Inspector ();
17
18 our $VERSION = '0.07010';
19
20 # Glossary:
21 #
22 # remote_relname -- name of relationship from the local table referring to the remote table
23 # local_relname  -- name of relationship from the remote table referring to the local table
24 # remote_method  -- relationship type from remote table to local table, usually has_many
25
26 =head1 NAME
27
28 DBIx::Class::Schema::Loader::RelBuilder - Builds relationships for DBIx::Class::Schema::Loader
29
30 =head1 SYNOPSIS
31
32 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
33
34 =head1 DESCRIPTION
35
36 This class builds relationships for L<DBIx::Class::Schema::Loader>.  This
37 is module is not (yet) for external use.
38
39 =head1 METHODS
40
41 =head2 new
42
43 Arguments: $loader object
44
45 =head2 generate_code
46
47 Arguments: 
48     
49     [
50         [ local_moniker1 (scalar), fk_info1 (arrayref), uniq_info1 (arrayref) ]
51         [ local_moniker2 (scalar), fk_info2 (arrayref), uniq_info2 (arrayref) ]
52         ...
53     ]
54
55 This generates the code for the relationships of each table.
56
57 C<local_moniker> is the moniker name of the table which had the REFERENCES
58 statements.  The fk_info arrayref's contents should take the form:
59
60     [
61         {
62             local_table    => 'some_table',
63             local_moniker  => 'SomeTable',
64             local_columns  => [ 'col2', 'col3' ],
65             remote_table   => 'another_table_moniker',
66             remote_moniker => 'AnotherTableMoniker',
67             remote_columns => [ 'col5', 'col7' ],
68         },
69         {
70             local_table    => 'some_other_table',
71             local_moniker  => 'SomeOtherTable',
72             local_columns  => [ 'col1', 'col4' ],
73             remote_table   => 'yet_another_table_moniker',
74             remote_moniker => 'YetAnotherTableMoniker',
75             remote_columns => [ 'col1', 'col2' ],
76         },
77         # ...
78     ],
79
80 The uniq_info arrayref's contents should take the form:
81
82     [
83         [
84             uniq_constraint_name         => [ 'col1', 'col2' ],
85         ],
86         [
87             another_uniq_constraint_name => [ 'col1', 'col2' ],
88         ],
89     ],
90
91 This method will return the generated relationships as a hashref keyed on the
92 class names.  The values are arrayrefs of hashes containing method name and
93 arguments, like so:
94
95   {
96       'Some::Source::Class' => [
97           { method => 'belongs_to', arguments => [ 'col1', 'Another::Source::Class' ],
98           { method => 'has_many', arguments => [ 'anothers', 'Yet::Another::Source::Class', 'col15' ],
99       ],
100       'Another::Source::Class' => [
101           # ...
102       ],
103       # ...
104   }
105
106 =cut
107
108 __PACKAGE__->mk_group_accessors('simple', qw/
109     loader
110     schema
111     inflect_plural
112     inflect_singular
113     relationship_attrs
114     rel_collision_map
115     rel_name_map
116     _temp_classes
117     __tagger
118 /);
119
120 sub new {
121     my ($class, $loader) = @_;
122
123     # from old POD about this constructor:
124     # C<$schema_class> should be a schema class name, where the source
125     # classes have already been set up and registered.  Column info,
126     # primary key, and unique constraints will be drawn from this
127     # schema for all of the existing source monikers.
128
129     # Options inflect_plural and inflect_singular are optional, and
130     # are better documented in L<DBIx::Class::Schema::Loader::Base>.
131
132     my $self = {
133         loader             => $loader,
134         schema             => $loader->schema,
135         inflect_plural     => $loader->inflect_plural,
136         inflect_singular   => $loader->inflect_singular,
137         relationship_attrs => $loader->relationship_attrs,
138         rel_collision_map  => $loader->rel_collision_map,
139         rel_name_map       => $loader->rel_name_map,
140         _temp_classes      => [],
141     };
142
143     weaken $self->{loader}; #< don't leak
144
145     bless $self => $class;
146
147     # validate the relationship_attrs arg
148     if( defined $self->relationship_attrs ) {
149         ref $self->relationship_attrs eq 'HASH'
150             or croak "relationship_attrs must be a hashref";
151     }
152
153     return $self;
154 }
155
156
157 # pluralize a relationship name
158 sub _inflect_plural {
159     my ($self, $relname) = @_;
160
161     return '' if !defined $relname || $relname eq '';
162
163     my $result;
164     my $mapped = 0;
165
166     if( ref $self->inflect_plural eq 'HASH' ) {
167         if (exists $self->inflect_plural->{$relname}) {
168             $result = $self->inflect_plural->{$relname};
169             $mapped = 1;
170         }
171     }
172     elsif( ref $self->inflect_plural eq 'CODE' ) {
173         my $inflected = $self->inflect_plural->($relname);
174         if ($inflected) {
175             $result = $inflected;
176             $mapped = 1;
177         }
178     }
179
180     return ($result, $mapped) if $mapped;
181
182     return ($self->_to_PL($relname), 0);
183 }
184
185 # Singularize a relationship name
186 sub _inflect_singular {
187     my ($self, $relname) = @_;
188
189     return '' if !defined $relname || $relname eq '';
190
191     my $result;
192     my $mapped = 0;
193
194     if( ref $self->inflect_singular eq 'HASH' ) {
195         if (exists $self->inflect_singular->{$relname}) {
196             $result = $self->inflect_singular->{$relname};
197             $mapped = 1;
198         }
199     }
200     elsif( ref $self->inflect_singular eq 'CODE' ) {
201         my $inflected = $self->inflect_singular->($relname);
202         if ($inflected) {
203             $result = $inflected;
204             $mapped = 1;
205         }
206     }
207
208     return ($result, $mapped) if $mapped;
209
210     return ($self->_to_S($relname), 0);
211 }
212
213 sub _to_PL {
214     my ($self, $name) = @_;
215
216     $name =~ s/_/ /g;
217     my $plural = Lingua::EN::Inflect::Phrase::to_PL($name);
218     $plural =~ s/ /_/g;
219
220     return $plural;
221 }
222
223 sub _to_S {
224     my ($self, $name) = @_;
225
226     $name =~ s/_/ /g;
227     my $singular = Lingua::EN::Inflect::Phrase::to_S($name);
228     $singular =~ s/ /_/g;
229
230     return $singular;
231 }
232
233 sub _default_relationship_attrs { +{
234     has_many => {
235         cascade_delete => 0,
236         cascade_copy   => 0,
237     },
238     might_have => {
239         cascade_delete => 0,
240         cascade_copy   => 0,
241     },
242     belongs_to => {
243         on_delete => 'CASCADE',
244         on_update => 'CASCADE',
245         is_deferrable => 1,
246     },
247 } }
248
249 # accessor for options to be passed to each generated relationship
250 # type.  take single argument, the relationship type name, and returns
251 # either a hashref (if some options are set), or nothing
252 sub _relationship_attrs {
253     my ( $self, $reltype ) = @_;
254     my $r = $self->relationship_attrs;
255
256     my %composite = (
257         %{ $self->_default_relationship_attrs->{$reltype} || {} },
258         %{ $r->{all} || {} }
259     );
260
261     if( my $specific = $r->{$reltype} ) {
262         while( my ($k,$v) = each %$specific ) {
263             $composite{$k} = $v;
264         }
265     }
266     return \%composite;
267 }
268
269 sub _array_eq {
270     my ($self, $a, $b) = @_;
271
272     return unless @$a == @$b;
273
274     for (my $i = 0; $i < @$a; $i++) {
275         return unless $a->[$i] eq $b->[$i];
276     }
277     return 1;
278 }
279
280 sub _remote_attrs {
281     my ($self, $local_moniker, $local_cols) = @_;
282
283     # get our base set of attrs from _relationship_attrs, if present
284     my $attrs = $self->_relationship_attrs('belongs_to') || {};
285
286     # If the referring column is nullable, make 'belongs_to' an
287     # outer join, unless explicitly set by relationship_attrs
288     my $nullable = grep { $self->schema->source($local_moniker)->column_info($_)->{is_nullable} } @$local_cols;
289     $attrs->{join_type} = 'LEFT' if $nullable && !defined $attrs->{join_type};
290
291     return $attrs;
292 }
293
294 sub _sanitize_name {
295     my ($self, $name) = @_;
296
297     $name =~ s/\W+/_/g;
298
299     return $name;
300 }
301
302 sub _normalize_name {
303     my ($self, $name) = @_;
304
305     $name = $self->_sanitize_name($name);
306
307     my @words = split_name $name;
308
309     return join '_', map lc, @words;
310 }
311
312 sub _remote_relname {
313     my ($self, $remote_table, $cond) = @_;
314
315     my $remote_relname;
316     # for single-column case, set the remote relname to the column
317     # name, to make filter accessors work, but strip trailing _id
318     if(scalar keys %{$cond} == 1) {
319         my ($col) = values %{$cond};
320         $col = $self->_normalize_name($col);
321         $col =~ s/_id$//;
322         ($remote_relname) = $self->_inflect_singular($col);
323     }
324     else {
325         ($remote_relname) = $self->_inflect_singular($self->_normalize_name($remote_table));
326     }
327
328     return $remote_relname;
329 }
330
331 sub _resolve_relname_collision {
332     my ($self, $moniker, $cols, $relname) = @_;
333
334     return $relname if $relname eq 'id'; # this shouldn't happen, but just in case
335
336     my $table = $self->loader->moniker_to_table->{$moniker};
337
338     if ($self->loader->_is_result_class_method($relname, $table)) {
339         if (my $map = $self->rel_collision_map) {
340             for my $re (keys %$map) {
341                 if (my @matches = $relname =~ /$re/) {
342                     return sprintf $map->{$re}, @matches;
343                 }
344             }
345         }
346
347         my $new_relname = $relname;
348         while ($self->loader->_is_result_class_method($new_relname, $table)) {
349             $new_relname .= '_rel'
350         }
351
352         warn <<"EOF";
353 Relationship '$relname' in source '$moniker' for columns '@{[ join ',', @$cols ]}' collides with an inherited method. Renaming to '$new_relname'.
354 See "RELATIONSHIP NAME COLLISIONS" in perldoc DBIx::Class::Schema::Loader::Base .
355 EOF
356
357         return $new_relname;
358     }
359
360     return $relname;
361 }
362
363 sub generate_code {
364     my ($self, $tables) = @_;
365     
366     # make a copy to destroy
367     my @tables = @$tables;
368
369     my $all_code = {};
370
371     while (my ($local_moniker, $rels, $uniqs) = @{ shift @tables || [] }) {
372         my $local_class = $self->schema->class($local_moniker);
373
374         my %counters;
375         foreach my $rel (@$rels) {
376             next if !$rel->{remote_source};
377             $counters{$rel->{remote_source}}++;
378         }
379
380         foreach my $rel (@$rels) {
381             my $remote_moniker = $rel->{remote_source}
382                 or next;
383
384             my $remote_class   = $self->schema->class($remote_moniker);
385             my $remote_obj     = $self->schema->source($remote_moniker);
386             my $remote_cols    = $rel->{remote_columns} || [ $remote_obj->primary_columns ];
387
388             my $local_cols     = $rel->{local_columns};
389
390             if($#$local_cols != $#$remote_cols) {
391                 croak "Column count mismatch: $local_moniker (@$local_cols) "
392                     . "$remote_moniker (@$remote_cols)";
393             }
394
395             my %cond;
396             foreach my $i (0 .. $#$local_cols) {
397                 $cond{$remote_cols->[$i]} = $local_cols->[$i];
398             }
399
400             my ( $local_relname, $remote_relname, $remote_method ) =
401                 $self->_relnames_and_method( $local_moniker, $rel, \%cond,  $uniqs, \%counters );
402             my $local_method  = 'belongs_to';
403
404             ($remote_relname) = $self->_rel_name_map($remote_relname, $local_method, $local_class, $local_moniker, $local_cols, $remote_class, $remote_moniker, $remote_cols);
405             ($local_relname)  = $self->_rel_name_map($local_relname, $remote_method, $remote_class, $remote_moniker, $remote_cols, $local_class, $local_moniker, $local_cols);
406
407             $remote_relname   = $self->_resolve_relname_collision($local_moniker,  $local_cols,  $remote_relname);
408             $local_relname    = $self->_resolve_relname_collision($remote_moniker, $remote_cols, $local_relname);
409
410             push(@{$all_code->{$local_class}},
411                 { method => $local_method,
412                   args => [ $remote_relname,
413                             $remote_class,
414                             \%cond,
415                             $self->_remote_attrs($local_moniker, $local_cols),
416                   ],
417                   extra => {
418                       local_class    => $local_class,
419                       local_moniker  => $local_moniker,
420                       remote_moniker => $remote_moniker,
421                   },
422                 }
423             );
424
425             my %rev_cond = reverse %cond;
426             for (keys %rev_cond) {
427                 $rev_cond{"foreign.$_"} = "self.".$rev_cond{$_};
428                 delete $rev_cond{$_};
429             }
430
431             push(@{$all_code->{$remote_class}},
432                 { method => $remote_method,
433                   args => [ $local_relname,
434                             $local_class,
435                             \%rev_cond,
436                             $self->_relationship_attrs($remote_method),
437                   ],
438                   extra => {
439                       local_class    => $remote_class,
440                       local_moniker  => $remote_moniker,
441                       remote_moniker => $local_moniker,
442                   },
443                 }
444             );
445         }
446     }
447
448     # disambiguate rels with the same name
449     foreach my $class (keys %$all_code) {
450         my $dups = $self->_duplicates($all_code->{$class});
451
452         $self->_disambiguate($all_code->{$class}, $dups) if $dups;
453     }
454
455     $self->_cleanup;
456
457     return $all_code;
458 }
459
460 sub _duplicates {
461     my ($self, $rels) = @_;
462
463     my @rels = map [ $_->{args}[0] => $_ ], @$rels;
464     my %rel_names;
465     $rel_names{$_}++ foreach map $_->[0], @rels;
466
467     my @dups = grep $rel_names{$_} > 1, keys %rel_names;
468
469     my %dups;
470
471     foreach my $dup (@dups) {
472         $dups{$dup} = [ map $_->[1], grep { $_->[0] eq $dup } @rels ];
473     }
474
475     return if not %dups;
476
477     return \%dups;
478 }
479
480 sub _tagger {
481     my $self = shift;
482
483     $self->__tagger(Lingua::EN::Tagger->new) unless $self->__tagger;
484
485     return $self->__tagger;
486 }
487
488 sub _adjectives {
489     my ($self, @cols) = @_;
490
491     my @adjectives;
492
493     foreach my $col (@cols) {
494         my @words = split_name $col;
495
496         my $tagged = $self->_tagger->get_readable(join ' ', @words);
497
498         push @adjectives, $tagged =~ m{\G(\w+)/JJ\s+}g;
499     }
500
501     return @adjectives;
502 }
503
504 sub _disambiguate {
505     my ($self, $all_rels, $dups) = @_;
506
507     foreach my $dup (keys %$dups) {
508         my @rels = @{ $dups->{$dup} };
509
510         foreach my $rel (@rels) {
511             next if $rel->{method} eq 'belongs_to';
512
513             my @to_cols = apply { s/^foreign\.//i }
514                 keys %{ $rel->{args}[2] };
515
516             my @adjectives = $self->_adjectives(@to_cols);
517
518             # If there are no adjectives, and there is only one might_have
519             # rel to that class, we hardcode 'active'.
520
521             my $to_class = $rel->{args}[1];
522
523             if ((not @adjectives)
524                 && (grep { $_->{method} eq 'might_have'
525                            && $_->{args}[1] eq $to_class } @$all_rels) == 1) {
526
527                 @adjectives = 'active';
528             }
529
530             if (@adjectives) {
531                 my $rel_name = join '_', sort(@adjectives), $rel->{args}[0];
532
533                 ($rel_name) = $rel->{method} eq 'might_have' ?
534                     $self->_inflect_singular($rel_name)
535                     :
536                     $self->_inflect_plural($rel_name);
537
538                 my ($local_class, $local_moniker, $remote_moniker)
539                     = @{ $rel->{extra} }
540                         {qw/local_class local_moniker remote_moniker/};
541
542                 my @from_cols = apply { s/^self\.//i }
543                     values %{ $rel->{args}[2] };
544
545                 ($rel_name) = $self->_rel_name_map($rel_name, $rel->{method}, $local_class, $local_moniker, \@from_cols, $to_class, $remote_moniker, \@to_cols);
546
547                 $rel_name = $self->_resolve_relname_collision($local_moniker, \@from_cols, $rel_name);
548
549                 $rel->{args}[0] = $rel_name;
550             }
551         }
552     }
553
554     # Check again for duplicates, since the heuristics above may not have resolved them all.
555
556     if ($dups = $self->_duplicates($all_rels)) {
557         foreach my $dup (keys %$dups) {
558             # sort by method
559             my @rels = map $_->[1], sort { $a->[0] <=> $b->[0] } map [
560                 ($_->{method} eq 'belongs_to' ? 3 : $_->{method} eq 'has_many' ? 2 : 1), $_
561             ], @{ $dups->{$dup} };
562
563             my $rel_num = 2;
564
565             foreach my $rel (@rels[1 .. $#rels]) {
566                 my $inflect_type = $rel->{method} eq 'has_many' ?
567                     'inflect_plural'
568                     :
569                     'inflect_singular';
570
571                 my $inflect_method = "_$inflect_type";
572
573                 my $relname_new_uninflected = $rel->{args}[0] . "_$rel_num";
574
575                 $rel_num++;
576
577                 my ($local_class, $local_moniker, $remote_moniker)
578                     = @{ $rel->{extra} }
579                         {qw/local_class local_moniker remote_moniker/};
580
581                 my @from_cols = apply { s/^self\.//i }
582                     values %{ $rel->{args}[2] };
583
584                 my @to_cols = apply { s/^foreign\.//i }
585                     keys %{ $rel->{args}[2] };
586
587                 my $to_class = $rel->{args}[1];
588
589                 my ($relname_new, $inflect_mapped) =
590                     $self->$inflect_method($relname_new_uninflected);
591
592                 my $rel_name_mapped;
593
594                 ($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);
595                 
596                 my $mapped = $inflect_mapped || $rel_name_mapped;
597
598                 warn <<"EOF" unless $mapped;
599 Could not find a proper name for relationship '$relname_new' in source
600 '$local_moniker' for columns '@{[ join ',', @from_cols ]}'. Supply a value in
601 '$inflect_type' or 'rel_name_map' for '$relname_new_uninflected' to name this
602 relationship.
603 EOF
604
605                 $relname_new = $self->_resolve_relname_collision($local_moniker, \@from_cols, $relname_new);
606
607                 $rel->{args}[0] = $relname_new;
608             }
609         }
610     }
611 }
612
613 sub _relnames_and_method {
614     my ( $self, $local_moniker, $rel, $cond, $uniqs, $counters ) = @_;
615
616     my $remote_moniker  = $rel->{remote_source};
617     my $remote_obj      = $self->schema->source( $remote_moniker );
618     my $remote_class    = $self->schema->class(  $remote_moniker );
619     my $remote_relname  = $self->_remote_relname( $rel->{remote_table}, $cond);
620
621     my $local_cols      = $rel->{local_columns};
622     my $local_table     = $rel->{local_table};
623     my $local_class     = $self->schema->class($local_moniker);
624     my $local_source    = $self->schema->source($local_moniker);
625
626     my $local_relname_uninflected = $self->_normalize_name($local_table);
627     my ($local_relname) = $self->_inflect_plural($self->_normalize_name($local_table));
628
629     my $remote_method = 'has_many';
630
631     # If the local columns have a UNIQUE constraint, this is a one-to-one rel
632     if ($self->_array_eq([ $local_source->primary_columns ], $local_cols) ||
633             grep { $self->_array_eq($_->[1], $local_cols) } @$uniqs) {
634         $remote_method   = 'might_have';
635         ($local_relname) = $self->_inflect_singular($local_relname_uninflected);
636     }
637
638     # If more than one rel between this pair of tables, use the local
639     # col names to distinguish, unless the rel was created previously.
640     if ($counters->{$remote_moniker} > 1) {
641         my $relationship_exists = 0;
642
643         if (-f (my $existing_remote_file = $self->loader->get_dump_filename($remote_class))) {
644             my $class = "${remote_class}Temporary";
645
646             if (not Class::Inspector->loaded($class)) {
647                 my $code = slurp_file $existing_remote_file;
648
649                 $code =~ s/(?<=package $remote_class)/Temporary/g;
650
651                 $code =~ s/__PACKAGE__->meta->make_immutable[^;]*;//g;
652
653                 eval $code;
654                 die $@ if $@;
655
656                 push @{ $self->_temp_classes }, $class;
657             }
658
659             if ($class->has_relationship($local_relname)) {
660                 my $rel_cols = [ sort { $a cmp $b } apply { s/^foreign\.//i }
661                     (keys %{ $class->relationship_info($local_relname)->{cond} }) ];
662
663                 $relationship_exists = 1 if $self->_array_eq([ sort @$local_cols ], $rel_cols);
664             }
665         }
666
667         if (not $relationship_exists) {
668             my $colnames = q{_} . $self->_normalize_name(join '_', @$local_cols);
669             $remote_relname .= $colnames if keys %$cond > 1;
670
671             $local_relname = $self->_normalize_name($local_table . $colnames);
672             $local_relname =~ s/_id$//;
673
674             $local_relname_uninflected = $local_relname;
675             ($local_relname) = $self->_inflect_plural($local_relname);
676
677             # if colnames were added and this is a might_have, re-inflect
678             if ($remote_method eq 'might_have') {
679                 ($local_relname) = $self->_inflect_singular($local_relname_uninflected);
680             }
681         }
682     }
683
684     return ($local_relname, $remote_relname, $remote_method);
685 }
686
687 sub _rel_name_map {
688     my ($self, $relname, $method, $local_class, $local_moniker, $local_cols,
689         $remote_class, $remote_moniker, $remote_cols) = @_;
690
691     my $info = {
692         name           => $relname,
693         type           => $method,
694         local_class    => $local_class,
695         local_moniker  => $local_moniker,
696         local_columns  => $local_cols,
697         remote_class   => $remote_class,
698         remote_moniker => $remote_moniker,
699         remote_columns => $remote_cols,
700     };
701
702     my $new_name = $relname;
703
704     my $map = $self->rel_name_map;
705     my $mapped = 0;
706
707     if ('HASH' eq ref($map)) {
708         my $name = $info->{name};
709         my $moniker = $info->{local_moniker};
710         if ($map->{$moniker} and 'HASH' eq ref($map->{$moniker})
711             and $map->{$moniker}{$name}
712         ) {
713             $new_name = $map->{$moniker}{$name};
714             $mapped   = 1;
715         }
716         elsif ($map->{$name} and not 'HASH' eq ref($map->{$name})) {
717             $new_name = $map->{$name};
718             $mapped   = 1;
719         }
720     }
721     elsif ('CODE' eq ref($map)) {
722         my $name = $map->($info);
723         if ($name) {
724             $new_name = $name;
725             $mapped   = 1;
726         }
727     }
728
729     return ($new_name, $mapped);
730 }
731
732 sub _cleanup {
733     my $self = shift;
734
735     for my $class (@{ $self->_temp_classes }) {
736         Class::Unload->unload($class);
737     }
738
739     $self->_temp_classes([]);
740 }
741
742 =head1 AUTHOR
743
744 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
745
746 =head1 LICENSE
747
748 This library is free software; you can redistribute it and/or modify it under
749 the same terms as Perl itself.
750
751 =cut
752
753 1;
754 # vim:et sts=4 sw=4 tw=0: