t/99dbic_sqlt_parser.t

   1 use strict;
   2 use warnings;
   3
   4 use Test::More;
   5 use Test::Warn;
   6 use Test::Exception;
   7 use Scalar::Util ();
   8
   9 use lib qw(t/lib);
  10 use DBICTest;
  11 use DBIx::Class::_Util 'sigwarn_silencer';
  12
  13 BEGIN {
  14   require DBIx::Class;
  15   plan skip_all =>
  16       'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('deploy')
  17     unless DBIx::Class::Optional::Dependencies->req_ok_for ('deploy')
  18 }
  19
  20 # Test for SQLT-related leaks
  21 {
  22   require DBICTest::Schema;
  23   my $s = DBICTest::Schema->clone;
  24
  25   my @schemas = (
  26     create_schema ({ schema => $s }),
  27     create_schema ({ args => { parser_args => { dbic_schema => $s } } }),
  28   );
  29
  30   for my $parser_args_key (qw(
  31     DBIx::Class::Schema
  32     DBIx::Schema
  33     package
  34   )) {
  35     warnings_exist {
  36       push @schemas, create_schema({
  37         args => { parser_args => { $parser_args_key => $s } }
  38       });
  39     } qr/\Qparser_args => {\E.+?is deprecated.+\Q@{[__FILE__]}/,
  40     "deprecated crazy parser_arg '$parser_args_key' warned";
  41   }
  42
  43   Scalar::Util::weaken ($s);
  44
  45   ok (!$s, 'Schema not leaked');
  46
  47   isa_ok ($_, 'SQL::Translator::Schema', "SQLT schema object $_ produced")
  48     for @schemas;
  49 }
  50
  51 # make sure classname-style works
  52 lives_ok { isa_ok (create_schema ({ schema => 'DBICTest::Schema' }), 'SQL::Translator::Schema', 'SQLT schema object produced') };
  53
  54 # make sure a connected instance passed via $args does not get the $dbh improperly serialized
  55 SKIP: {
  56
  57   # YAML is a build_requires dep of SQLT - it may or may not be here
  58   eval { require YAML } or skip "Test requires YAML.pm", 1;
  59
  60   lives_ok {
  61
  62     my $s = DBICTest->init_schema(no_populate => 1);
  63     ok ($s->storage->connected, '$schema instance connected');
  64
  65     # roundtrip through YAML
  66     my $yaml_rt_schema = SQL::Translator->new(
  67       parser => 'SQL::Translator::Parser::YAML'
  68     )->translate(
  69       data => SQL::Translator->new(
  70         parser_args => { dbic_schema => $s },
  71         parser => 'SQL::Translator::Parser::DBIx::Class',
  72         producer => 'SQL::Translator::Producer::YAML',
  73       )->translate
  74     );
  75
  76     isa_ok ( $yaml_rt_schema, 'SQL::Translator::Schema', 'SQLT schema object produced after YAML roundtrip');
  77
  78     ok ($s->storage->connected, '$schema instance still connected');
  79   }
  80
  81   eval <<'EOE' or die $@;
  82   END {
  83     # we are in END - everything remains global
  84     #
  85     $^W = 1;  # important, otherwise DBI won't trip the next fail()
  86     $SIG{__WARN__} = sub {
  87       fail "Unexpected global destruction warning"
  88         if $_[0] =~ /is not a DBI/;
  89       warn @_;
  90     };
  91   }
  92 EOE
  93
  94 }
  95
  96 my $schema = DBICTest->init_schema( no_deploy => 1 );
  97
  98 # Dummy was yanked out by the sqlt hook test
  99 # CustomSql tests the horrific/deprecated ->name(\$sql) hack
 100 # YearXXXXCDs are views
 101 #
 102 my @sources = grep
 103   { $_ !~ /^ (?: Dummy | CustomSql | Year\d{4}CDs ) $/x }
 104   $schema->sources
 105 ;
 106
 107 my $idx_exceptions = {
 108     'Artwork'       => -1,
 109     'ForceForeign'  => -1,
 110     'LinerNotes'    => -1,
 111     'TwoKeys'       => -1, # TwoKeys has the index turned off on the rel def
 112 };
 113
 114 {
 115   my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { } } });
 116
 117   foreach my $source_name (@sources) {
 118     my $table = get_table($sqlt_schema, $schema, $source_name);
 119
 120     my $fk_count = scalar(grep { $_->type eq 'FOREIGN KEY' } $table->get_constraints);
 121     $fk_count += $idx_exceptions->{$source_name} || 0;
 122     my @indices = $table->get_indices;
 123
 124     my $index_count = scalar(@indices);
 125     is($index_count, $fk_count, "correct number of indices for $source_name with no args");
 126
 127     for my $index (@indices) {
 128         my $source = $schema->source($source_name);
 129         my $pk_test = join("\x00", $source->primary_columns);
 130         my $idx_test = join("\x00", $index->fields);
 131         isnt ( $pk_test, $idx_test, "no additional index for the primary columns exists in $source_name");
 132     }
 133   }
 134 }
 135
 136 {
 137   my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { add_fk_index => 1 } } });
 138
 139   foreach my $source_name (@sources) {
 140     my $table = get_table($sqlt_schema, $schema, $source_name);
 141
 142     my $fk_count = scalar(grep { $_->type eq 'FOREIGN KEY' } $table->get_constraints);
 143     $fk_count += $idx_exceptions->{$source_name} || 0;
 144     my @indices = $table->get_indices;
 145     my $index_count = scalar(@indices);
 146     is($index_count, $fk_count, "correct number of indices for $source_name with add_fk_index => 1");
 147   }
 148 }
 149
 150 {
 151   my $sqlt_schema = create_schema({ schema => $schema, args => { parser_args => { add_fk_index => 0 } } });
 152
 153   foreach my $source (@sources) {
 154     my $table = get_table($sqlt_schema, $schema, $source);
 155
 156     my @indices = $table->get_indices;
 157     my $index_count = scalar(@indices);
 158     is($index_count, 0, "correct number of indices for $source with add_fk_index => 0");
 159   }
 160 }
 161
 162 {
 163     {
 164         package # hide from PAUSE
 165             DBICTest::Schema::NoViewDefinition;
 166
 167         use base qw/DBICTest::BaseResult/;
 168
 169         __PACKAGE__->table_class('DBIx::Class::ResultSource::View');
 170         __PACKAGE__->table('noviewdefinition');
 171
 172         1;
 173     }
 174
 175     my $schema_invalid_view = $schema->clone;
 176     $schema_invalid_view->register_class('NoViewDefinition', 'DBICTest::Schema::NoViewDefinition');
 177
 178     throws_ok { create_schema({ schema => $schema_invalid_view }) }
 179         qr/view noviewdefinition is missing a view_definition/,
 180         'parser detects views with a view_definition';
 181 }
 182
 183 lives_ok (sub {
 184   my $sqlt_schema = create_schema ({
 185     schema => $schema,
 186     args => {
 187       parser_args => {
 188         sources => ['CD']
 189       },
 190     },
 191   });
 192
 193   is_deeply (
 194     [$sqlt_schema->get_tables ],
 195     ['cd'],
 196     'sources limitng with relationships works',
 197   );
 198
 199 });
 200
 201 {
 202   package DBICTest::PartialSchema;
 203
 204   use base qw/DBIx::Class::Schema/;
 205
 206   __PACKAGE__->load_classes(
 207     { 'DBICTest::Schema' => [qw/
 208       CD
 209       Track
 210       Tag
 211       Producer
 212       CD_to_Producer
 213     /]}
 214   );
 215 }
 216
 217 {
 218   my $partial_schema = DBICTest::PartialSchema->connect(DBICTest->_database);
 219
 220   lives_ok (sub {
 221     my $sqlt_schema = do {
 222
 223       local $SIG{__WARN__} = sigwarn_silencer(
 224         qr/Ignoring relationship .+ related resultsource .+ is not registered with this schema/
 225       );
 226
 227       create_schema({ schema => $partial_schema });
 228     };
 229
 230     my @tables = $sqlt_schema->get_tables;
 231
 232     is_deeply (
 233       [sort map { $_->name } @tables],
 234       [qw/cd cd_to_producer producer tags track/],
 235       'partial dbic schema parsing ok',
 236     );
 237
 238     # the primary key is currently unnamed in sqlt - adding below
 239     my %constraints_for_table = (
 240       producer =>       [qw/prod_name                                                         /],
 241       tags =>           [qw/tagid_cd tagid_cd_tag tags_fk_cd tags_tagid_tag tags_tagid_tag_cd /],
 242       track =>          [qw/track_cd_position track_cd_title track_fk_cd                      /],
 243       cd =>             [qw/cd_artist_title cd_fk_single_track                                /],
 244       cd_to_producer => [qw/cd_to_producer_fk_cd cd_to_producer_fk_producer                   /],
 245     );
 246
 247     for my $table (@tables) {
 248       my $tablename = $table->name;
 249       my @constraints = $table->get_constraints;
 250       is_deeply (
 251         [ sort map { $_->name } @constraints ],
 252
 253         # the primary key (present on all loaded tables) is currently named '' in sqlt
 254         # subject to future changes
 255         [ '', @{$constraints_for_table{$tablename}} ],
 256
 257         "constraints of table '$tablename' ok",
 258       );
 259     }
 260   }, 'partial schema tests successful');
 261 }
 262
 263 {
 264   my $cd_rsrc = $schema->source('CD');
 265   $cd_rsrc->name(\'main.cd');
 266
 267   my $sqlt_schema = create_schema(
 268     { schema => $schema },
 269     args => { ignore_constraint_names => 0, ignore_index_names => 0 }
 270   );
 271
 272   foreach my $source_name (qw(CD)) {
 273     my $table = get_table($sqlt_schema, $schema, $source_name);
 274     ok(
 275       !(grep {$_->name =~ m/main\./} $table->get_indices),
 276       'indices have periods stripped out'
 277     );
 278     ok(
 279       !(grep {$_->name =~ m/main\./} $table->get_constraints),
 280       'constraints have periods stripped out'
 281     );
 282   }
 283 }
 284
 285 done_testing;
 286
 287 sub create_schema {
 288   my $args = shift;
 289
 290   my $additional_sqltargs = $args->{args} || {};
 291
 292   my $sqltargs = {
 293     add_drop_table => 1,
 294     ignore_constraint_names => 1,
 295     ignore_index_names => 1,
 296     %{$additional_sqltargs}
 297   };
 298
 299   my $sqlt = SQL::Translator->new( $sqltargs );
 300
 301   $sqlt->parser('SQL::Translator::Parser::DBIx::Class');
 302   return $sqlt->translate(
 303     $args->{schema} ? ( data => $args->{schema} ) : ()
 304   ) || die $sqlt->error;
 305 }
 306
 307 sub get_table {
 308     my ($sqlt_schema, $schema, $source) = @_;
 309
 310     my $table_name = $schema->source($source)->from;
 311     $table_name    = $$table_name if ref $table_name;
 312
 313     return $sqlt_schema->get_table($table_name);
 314 }