view release on metacpan or  search on metacpan

t/99dbic_sqlt_parser.t  view on Meta::CPAN

}

lives_ok (sub {
  my $sqlt_schema = create_schema ({
    schema => $schema,
    args => {
      parser_args => {
        sources => ['CD']
      },
    },
  });

  is_deeply (
    [$sqlt_schema->get_tables ],
    ['cd'],
    'sources limitng with relationships works',
  );

});

{
  package DBICTest::PartialSchema;

  use base qw/DBIx::Class::Schema/;

  __PACKAGE__->load_classes(
    { 'DBICTest::Schema' => [qw/
      CD
      Track
      Tag
      Producer
      CD_to_Producer
    /]}
  );
}

{
  my $partial_schema = DBICTest::PartialSchema->connect(DBICTest->_database);

  lives_ok (sub {
    my $sqlt_schema = do {

      local $SIG{__WARN__} = sigwarn_silencer(
        qr/Ignoring relationship .+ related resultsource .+ is not registered with this schema/
      );

      create_schema({ schema => $partial_schema });
    };

    my @tables = $sqlt_schema->get_tables;

    is_deeply (
      [sort map { $_->name } @tables],
      [qw/cd cd_to_producer producer tags track/],
      'partial dbic schema parsing ok',
    );

    # the primary key is currently unnamed in sqlt - adding below
    my %constraints_for_table = (
      producer =>       [qw/prod_name                                                         /],
      tags =>           [qw/tagid_cd tagid_cd_tag tags_fk_cd tags_tagid_tag tags_tagid_tag_cd /],
      track =>          [qw/track_cd_position track_cd_title track_fk_cd                      /],
      cd =>             [qw/cd_artist_title cd_fk_single_track                                /],
      cd_to_producer => [qw/cd_to_producer_fk_cd cd_to_producer_fk_producer                   /],
    );

    for my $table (@tables) {
      my $tablename = $table->name;
      my @constraints = $table->get_constraints;
      is_deeply (
        [ sort map { $_->name } @constraints ],

        # the primary key (present on all loaded tables) is currently named '' in sqlt
        # subject to future changes
        [ '', @{$constraints_for_table{$tablename}} ],

        "constraints of table '$tablename' ok",
      );
    }
  }, 'partial schema tests successful');
}

{
  my $cd_rsrc = $schema->source('CD');
  $cd_rsrc->name(\'main.cd');

  my $sqlt_schema = create_schema(
    { schema => $schema },
    args => { ignore_constraint_names => 0, ignore_index_names => 0 }
  );

  foreach my $source_name (qw(CD)) {
    my $table = get_table($sqlt_schema, $schema, $source_name);
    ok(
      !(grep {$_->name =~ m/main\./} $table->get_indices),
      'indices have periods stripped out'
    );
    ok(
      !(grep {$_->name =~ m/main\./} $table->get_constraints),
      'constraints have periods stripped out'
    );
  }
}

done_testing;

sub create_schema {
  my $args = shift;

  my $additional_sqltargs = $args->{args} || {};

  my $sqltargs = {
    add_drop_table => 1,
    ignore_constraint_names => 1,
    ignore_index_names => 1,
    %{$additional_sqltargs}
  };

  my $sqlt = SQL::Translator->new( $sqltargs );

  $sqlt->parser('SQL::Translator::Parser::DBIx::Class');