t/99dbic_sqlt_parser.t

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