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