view release on metacpan or  search on metacpan

lib/SQL/Translator/Parser/DBIx/Class.pm  view on Meta::CPAN

        foreach my $rel (sort @rels) {

            my $rel_info = $source->relationship_info($rel);

            # Ignore any rel cond that isn't a straight hash
            next unless ref $rel_info->{cond} eq 'HASH';

            my $relsource = try { $source->related_source($rel) };
            unless ($relsource) {
              carp "Ignoring relationship '$rel' on '$moniker' - related resultsource '$rel_info->{class}' is not registered with this schema\n";
              next;
            };

            # related sources might be excluded via a {sources} filter or might be views
            next unless exists $table_monikers{$relsource->source_name};

            my $rel_table = $relsource->name;

            # FIXME - this isn't the right way to do it, but sqlt does not
            # support quoting properly to be signaled about this
            $rel_table = $$rel_table if ref $rel_table eq 'SCALAR';

            # Force the order of @cond to match the order of ->add_columns
            my $idx;
            my %other_columns_idx = map {'foreign.'.$_ => ++$idx } $relsource->columns;

            for ( keys %{$rel_info->{cond}} ) {
              unless (exists $other_columns_idx{$_}) {
                carp "Ignoring relationship '$rel' on '$moniker' - related resultsource '@{[ $relsource->source_name ]}' does not contain one of the specified columns: '$_'\n";
                next REL;
              }
            }

            my @cond = sort { $other_columns_idx{$a} <=> $other_columns_idx{$b} } keys(%{$rel_info->{cond}});

            # Get the key information, mapping off the foreign/self markers
            my @refkeys = map {/^\w+\.(\w+)$/} @cond;
            my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;

            # determine if this relationship is a self.fk => foreign.pk (i.e. belongs_to)
            my $fk_constraint;

            #first it can be specified explicitly
            if ( exists $rel_info->{attrs}{is_foreign_key_constraint} ) {
                $fk_constraint = $rel_info->{attrs}{is_foreign_key_constraint};
            }
            # it can not be multi
            elsif ( $rel_info->{attrs}{accessor}
                    && $rel_info->{attrs}{accessor} eq 'multi' ) {
                $fk_constraint = 0;
            }
            # if indeed single, check if all self.columns are our primary keys.
            # this is supposed to indicate a has_one/might_have...
            # where's the introspection!!?? :)
            else {
                $fk_constraint = not $source->_compare_relationship_keys(\@keys, \@primary);
            }

            my ($otherrelname, $otherrelationship) = %{ $source->reverse_relationship_info($rel) };

            my $cascade;
            for my $c (qw/delete update/) {
                if (exists $rel_info->{attrs}{"on_$c"}) {
                    if ($fk_constraint) {
                        $cascade->{$c} = $rel_info->{attrs}{"on_$c"};
                    }
                    elsif ( $rel_info->{attrs}{"on_$c"} ) {
                        carp "SQLT attribute 'on_$c' was supplied for relationship '$moniker/$rel', which does not appear to be a foreign constraint. "
                            . "If you are sure that SQLT must generate a constraint for this relationship, add 'is_foreign_key_constraint => 1' to the attributes.\n";
                    }
                }
                elsif (defined $otherrelationship and $otherrelationship->{attrs}{$c eq 'update' ? 'cascade_copy' : 'cascade_delete'}) {
                    $cascade->{$c} = 'CASCADE';
                }
            }

            if($rel_table) {
                # Constraints are added only if applicable
                next unless $fk_constraint;

                # Make sure we don't create the same foreign key constraint twice
                my $key_test = join("\x00", sort @keys);
                next if $created_FK_rels{$rel_table}->{$key_test};

                if (scalar(@keys)) {
                  $created_FK_rels{$rel_table}->{$key_test} = 1;

                  my $is_deferrable = $rel_info->{attrs}{is_deferrable};

                  # calculate dependencies: do not consider deferrable constraints and
                  # self-references for dependency calculations
                  if (! $is_deferrable and $rel_table ne $table_name) {
                    $tables{$table_name}{foreign_table_deps}{$rel_table}++;
                  }

                  # trim schema before generating constraint/index names
                  (my $table_abbrev = $table_name) =~ s/ ^ [^\.]+ \. //x;

                  $table->add_constraint(
                    type             => 'foreign_key',
                    name             => join('_', $table_abbrev, 'fk', @keys),
                    fields           => \@keys,
                    reference_fields => \@refkeys,
                    reference_table  => $rel_table,
                    on_delete        => uc ($cascade->{delete} || ''),
                    on_update        => uc ($cascade->{update} || ''),
                    (defined $is_deferrable ? ( deferrable => $is_deferrable ) : ()),
                  );

                  # global parser_args add_fk_index param can be overridden on the rel def
                  my $add_fk_index_rel = (exists $rel_info->{attrs}{add_fk_index}) ? $rel_info->{attrs}{add_fk_index} : $add_fk_index;

                  # Check that we do not create an index identical to the PK index
                  # (some RDBMS croak on this, and it generally doesn't make much sense)
                  # NOTE: we do not sort the key columns because the order of
                  # columns is important for indexes and two indexes with the
                  # same cols but different order are allowed and sometimes
                  # needed
                  next if join("\x00", @keys) eq join("\x00", @primary);

                  if ($add_fk_index_rel) {
                      (my $idx_name = $table_name) =~ s/ ^ [^\.]+ \. //x;
                      my $index = $table->add_index(
                          name   => join('_', $table_abbrev, 'idx', @keys),
                          fields => \@keys,
                          type   => 'NORMAL',
                      );
                  }
              }
            }
        }

    }

    # attach the tables to the schema in dependency order
    my $dependencies = {
      map { $_ => _resolve_deps ($_, \%tables) } (keys %tables)
    };

    for my $table (sort
      {
        keys %{$dependencies->{$a} || {} } <=> keys %{ $dependencies->{$b} || {} }
          ||
        $a cmp $b
      }
      (keys %tables)
    ) {
      $schema->add_table ($tables{$table}{object});
      $tables{$table}{source} -> _invoke_sqlt_deploy_hook( $tables{$table}{object} );

      # the hook might have already removed the table
      if ($schema->get_table($table) && $table =~ /^ \s* \( \s* SELECT \s+/ix) {
        carp <<'EOW';

Custom SQL through ->name(\'( SELECT ...') is DEPRECATED, for more details see
"Arbitrary SQL through a custom ResultSource" in DBIx::Class::Manual::Cookbook
or http://search.cpan.org/dist/DBIx-Class/lib/DBIx/Class/Manual/Cookbook.pod

EOW

        # remove the table as there is no way someone might want to
        # actually deploy this
        $schema->drop_table ($table);
      }
    }