lib/DBIx/Class/Schema/Loader/RelBuilder.pm

   1 package DBIx::Class::Schema::Loader::RelBuilder;
   2
   3 use strict;
   4 use warnings;
   5 use Class::C3;
   6 use Carp::Clan qw/^DBIx::Class/;
   7 use Lingua::EN::Inflect::Phrase ();
   8 use DBIx::Class::Schema::Loader::Utils 'split_name';
   9
  10 our $VERSION = '0.07001';
  11
  12 =head1 NAME
  13
  14 DBIx::Class::Schema::Loader::RelBuilder - Builds relationships for DBIx::Class::Schema::Loader
  15
  16 =head1 SYNOPSIS
  17
  18 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
  19
  20 =head1 DESCRIPTION
  21
  22 This class builds relationships for L<DBIx::Class::Schema::Loader>.  This
  23 is module is not (yet) for external use.
  24
  25 =head1 METHODS
  26
  27 =head2 new
  28
  29 Arguments: $base object
  30
  31 =head2 generate_code
  32
  33 Arguments: local_moniker (scalar), fk_info (arrayref)
  34
  35 This generates the code for the relationships of a given table.
  36
  37 C<local_moniker> is the moniker name of the table which had the REFERENCES
  38 statements.  The fk_info arrayref's contents should take the form:
  39
  40     [
  41         {
  42             local_columns => [ 'col2', 'col3' ],
  43             remote_columns => [ 'col5', 'col7' ],
  44             remote_moniker => 'AnotherTableMoniker',
  45         },
  46         {
  47             local_columns => [ 'col1', 'col4' ],
  48             remote_columns => [ 'col1', 'col2' ],
  49             remote_moniker => 'YetAnotherTableMoniker',
  50         },
  51         # ...
  52     ],
  53
  54 This method will return the generated relationships as a hashref keyed on the
  55 class names.  The values are arrayrefs of hashes containing method name and
  56 arguments, like so:
  57
  58   {
  59       'Some::Source::Class' => [
  60           { method => 'belongs_to', arguments => [ 'col1', 'Another::Source::Class' ],
  61           { method => 'has_many', arguments => [ 'anothers', 'Yet::Another::Source::Class', 'col15' ],
  62       ],
  63       'Another::Source::Class' => [
  64           # ...
  65       ],
  66       # ...
  67   }
  68
  69 =cut
  70
  71
  72 sub new {
  73     my ( $class, $base ) = @_;
  74
  75     # from old POD about this constructor:
  76     # C<$schema_class> should be a schema class name, where the source
  77     # classes have already been set up and registered.  Column info,
  78     # primary key, and unique constraints will be drawn from this
  79     # schema for all of the existing source monikers.
  80
  81     # Options inflect_plural and inflect_singular are optional, and
  82     # are better documented in L<DBIx::Class::Schema::Loader::Base>.
  83
  84     my $self = {
  85         base               => $base,
  86         schema             => $base->schema,
  87         inflect_plural     => $base->inflect_plural,
  88         inflect_singular   => $base->inflect_singular,
  89         relationship_attrs => $base->relationship_attrs,
  90     };
  91
  92     Scalar::Util::weaken $self->{base}; #< don't leak
  93
  94     # validate the relationship_attrs arg
  95     if( defined $self->{relationship_attrs} ) {
  96         ref $self->{relationship_attrs} eq 'HASH'
  97             or croak "relationship_attrs must be a hashref";
  98     }
  99
 100     return bless $self => $class;
 101 }
 102
 103
 104 # pluralize a relationship name
 105 sub _inflect_plural {
 106     my ($self, $relname) = @_;
 107
 108     return '' if !defined $relname || $relname eq '';
 109
 110     if( ref $self->{inflect_plural} eq 'HASH' ) {
 111         return $self->{inflect_plural}->{$relname}
 112             if exists $self->{inflect_plural}->{$relname};
 113     }
 114     elsif( ref $self->{inflect_plural} eq 'CODE' ) {
 115         my $inflected = $self->{inflect_plural}->($relname);
 116         return $inflected if $inflected;
 117     }
 118
 119     return $self->_to_PL($relname);
 120 }
 121
 122 # Singularize a relationship name
 123 sub _inflect_singular {
 124     my ($self, $relname) = @_;
 125
 126     return '' if !defined $relname || $relname eq '';
 127
 128     if( ref $self->{inflect_singular} eq 'HASH' ) {
 129         return $self->{inflect_singular}->{$relname}
 130             if exists $self->{inflect_singular}->{$relname};
 131     }
 132     elsif( ref $self->{inflect_singular} eq 'CODE' ) {
 133         my $inflected = $self->{inflect_singular}->($relname);
 134         return $inflected if $inflected;
 135     }
 136
 137     return $self->_to_S($relname);
 138 }
 139
 140 sub _to_PL {
 141     my ($self, $name) = @_;
 142
 143     $name =~ s/_/ /g;
 144     my $plural = Lingua::EN::Inflect::Phrase::to_PL($name);
 145     $plural =~ s/ /_/g;
 146
 147     return $plural;
 148 }
 149
 150 sub _to_S {
 151     my ($self, $name) = @_;
 152
 153     $name =~ s/_/ /g;
 154     my $singular = Lingua::EN::Inflect::Phrase::to_S($name);
 155     $singular =~ s/ /_/g;
 156
 157     return $singular;
 158 }
 159
 160 sub _default_relationship_attrs { +{
 161     has_many => {
 162         cascade_delete => 0,
 163         cascade_copy   => 0,
 164     },
 165     might_have => {
 166         cascade_delete => 0,
 167         cascade_copy   => 0,
 168     },
 169     belongs_to => {
 170         on_delete => 'CASCADE',
 171         on_update => 'CASCADE',
 172         is_deferrable => 1,
 173     },
 174 } }
 175
 176 # accessor for options to be passed to each generated relationship
 177 # type.  take single argument, the relationship type name, and returns
 178 # either a hashref (if some options are set), or nothing
 179 sub _relationship_attrs {
 180     my ( $self, $reltype ) = @_;
 181     my $r = $self->{relationship_attrs};
 182
 183     my %composite = (
 184         %{ $self->_default_relationship_attrs->{$reltype} || {} },
 185         %{ $r->{all} || {} }
 186     );
 187
 188     if( my $specific = $r->{$reltype} ) {
 189         while( my ($k,$v) = each %$specific ) {
 190             $composite{$k} = $v;
 191         }
 192     }
 193     return \%composite;
 194 }
 195
 196 sub _array_eq {
 197     my ($self, $a, $b) = @_;
 198
 199     return unless @$a == @$b;
 200
 201     for (my $i = 0; $i < @$a; $i++) {
 202         return unless $a->[$i] eq $b->[$i];
 203     }
 204     return 1;
 205 }
 206
 207 sub _remote_attrs {
 208     my ($self, $local_moniker, $local_cols) = @_;
 209
 210     # get our base set of attrs from _relationship_attrs, if present
 211     my $attrs = $self->_relationship_attrs('belongs_to') || {};
 212
 213     # If the referring column is nullable, make 'belongs_to' an
 214     # outer join, unless explicitly set by relationship_attrs
 215     my $nullable = grep { $self->{schema}->source($local_moniker)->column_info($_)->{is_nullable} } @$local_cols;
 216     $attrs->{join_type} = 'LEFT' if $nullable && !defined $attrs->{join_type};
 217
 218     return $attrs;
 219 }
 220
 221 sub _sanitize_name {
 222     my ($self, $name) = @_;
 223
 224     if (ref $name) {
 225         # scalar ref for weird table name (like one containing a '.')
 226         ($name = $$name) =~ s/\W+/_/g;
 227     }
 228     else {
 229         # remove 'schema.' prefix if any
 230         $name =~ s/^[^.]+\.//;
 231     }
 232
 233     return $name;
 234 }
 235
 236 sub _normalize_name {
 237     my ($self, $name) = @_;
 238
 239     $name = $self->_sanitize_name($name);
 240
 241     my @words = split_name $name;
 242
 243     return join '_', map lc, @words;
 244 }
 245
 246 sub _remote_relname {
 247     my ($self, $remote_table, $cond) = @_;
 248
 249     my $remote_relname;
 250     # for single-column case, set the remote relname to the column
 251     # name, to make filter accessors work, but strip trailing _id
 252     if(scalar keys %{$cond} == 1) {
 253         my ($col) = values %{$cond};
 254         $col = $self->_normalize_name($col);
 255         $col =~ s/_id$//;
 256         $remote_relname = $self->_inflect_singular($col);
 257     }
 258     else {
 259         $remote_relname = $self->_inflect_singular($self->_normalize_name($remote_table));
 260     }
 261
 262     return $remote_relname;
 263 }
 264
 265 sub generate_code {
 266     my ($self, $local_moniker, $rels, $uniqs) = @_;
 267
 268     my $all_code = {};
 269
 270     my $local_class = $self->{schema}->class($local_moniker);
 271
 272     my %counters;
 273     foreach my $rel (@$rels) {
 274         next if !$rel->{remote_source};
 275         $counters{$rel->{remote_source}}++;
 276     }
 277
 278     foreach my $rel (@$rels) {
 279         my $remote_moniker = $rel->{remote_source}
 280             or next;
 281
 282         my $remote_class   = $self->{schema}->class($remote_moniker);
 283         my $remote_obj     = $self->{schema}->source($remote_moniker);
 284         my $remote_cols    = $rel->{remote_columns} || [ $remote_obj->primary_columns ];
 285
 286         my $local_cols     = $rel->{local_columns};
 287
 288         if($#$local_cols != $#$remote_cols) {
 289             croak "Column count mismatch: $local_moniker (@$local_cols) "
 290                 . "$remote_moniker (@$remote_cols)";
 291         }
 292
 293         my %cond;
 294         foreach my $i (0 .. $#$local_cols) {
 295             $cond{$remote_cols->[$i]} = $local_cols->[$i];
 296         }
 297
 298         my ( $local_relname, $remote_relname, $remote_method ) =
 299             $self->_relnames_and_method( $local_moniker, $rel, \%cond,  $uniqs, \%counters );
 300
 301         push(@{$all_code->{$local_class}},
 302             { method => 'belongs_to',
 303               args => [ $remote_relname,
 304                         $remote_class,
 305                         \%cond,
 306                         $self->_remote_attrs($local_moniker, $local_cols),
 307               ],
 308             }
 309         );
 310
 311         my %rev_cond = reverse %cond;
 312         for (keys %rev_cond) {
 313             $rev_cond{"foreign.$_"} = "self.".$rev_cond{$_};
 314             delete $rev_cond{$_};
 315         }
 316
 317         push(@{$all_code->{$remote_class}},
 318             { method => $remote_method,
 319               args => [ $local_relname,
 320                         $local_class,
 321                         \%rev_cond,
 322                         $self->_relationship_attrs($remote_method),
 323               ],
 324             }
 325         );
 326     }
 327
 328     return $all_code;
 329 }
 330
 331 sub _relnames_and_method {
 332     my ( $self, $local_moniker, $rel, $cond, $uniqs, $counters ) = @_;
 333
 334     my $remote_moniker = $rel->{remote_source};
 335     my $remote_obj     = $self->{schema}->source( $remote_moniker );
 336     my $remote_class   = $self->{schema}->class(  $remote_moniker );
 337     my $remote_relname = $self->_remote_relname( $remote_obj->from, $cond);
 338
 339     my $local_cols  = $rel->{local_columns};
 340     my $local_table = $self->{schema}->source($local_moniker)->from;
 341
 342     # If more than one rel between this pair of tables, use the local
 343     # col names to distinguish
 344     my ($local_relname, $local_relname_uninflected);
 345     if ( $counters->{$remote_moniker} > 1) {
 346         my $colnames = q{_} . $self->_normalize_name(join '_', @$local_cols);
 347         $remote_relname .= $colnames if keys %$cond > 1;
 348
 349         $local_relname = $self->_normalize_name($local_table . $colnames);
 350         $local_relname =~ s/_id$//;
 351
 352         $local_relname_uninflected = $local_relname;
 353         $local_relname = $self->_inflect_plural($local_relname);
 354     } else {
 355         $local_relname_uninflected = $self->_normalize_name($local_table);
 356         $local_relname = $self->_inflect_plural($self->_normalize_name($local_table));
 357     }
 358
 359     my $remote_method = 'has_many';
 360
 361     # If the local columns have a UNIQUE constraint, this is a one-to-one rel
 362     my $local_source = $self->{schema}->source($local_moniker);
 363     if ($self->_array_eq([ $local_source->primary_columns ], $local_cols) ||
 364             grep { $self->_array_eq($_->[1], $local_cols) } @$uniqs) {
 365         $remote_method = 'might_have';
 366         $local_relname = $self->_inflect_singular($local_relname_uninflected);
 367     }
 368
 369     return ( $local_relname, $remote_relname, $remote_method );
 370 }
 371
 372 =head1 AUTHOR
 373
 374 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 375
 376 =head1 LICENSE
 377
 378 This library is free software; you can redistribute it and/or modify it under
 379 the same terms as Perl itself.
 380
 381 =cut
 382
 383 1;
 384 # vim:et sts=4 sw=4 tw=0: