moved code to ::DBI::MSSQL and added DT inflation test
[dbsrgits/DBIx-Class-Historic.git] / t / 86sqlt.t
1 use strict;
2 use warnings;
3
4 use Test::More;
5 use lib qw(t/lib);
6 use DBICTest;
7
8 eval "use SQL::Translator";
9 plan skip_all => 'SQL::Translator required' if $@;
10
11 my $schema = DBICTest->init_schema;
12
13 plan tests => 133;
14
15 my $translator = SQL::Translator->new( 
16   parser_args => {
17     'DBIx::Schema' => $schema,
18   },
19   producer_args => {},
20 );
21
22 {
23     my $warn = '';
24     local $SIG{__WARN__} = sub { $warn = shift };
25
26     my $relinfo = $schema->source('Artist')->relationship_info ('cds');
27     local $relinfo->{attrs}{on_delete} = 'restrict';
28
29     $schema->source('Track')->sqlt_deploy_callback(sub {
30       my ($self, $sqlt_table) = @_;
31
32       if ($schema->storage->sqlt_type eq 'SQLite' ) {
33         $sqlt_table->add_index( name => 'track_title', fields => ['title'] )
34           or die $sqlt_table->error;
35       }
36
37       $self->default_sqlt_deploy_hook($sqlt_table);
38     });
39
40     $translator->parser('SQL::Translator::Parser::DBIx::Class');
41     $translator->producer('SQLite');
42
43     my $output = $translator->translate();
44
45     ok($output, "SQLT produced someoutput")
46       or diag($translator->error);
47
48     like (
49       $warn,
50       qr/SQLT attribute .+? was supplied for relationship .+? which does not appear to be a foreign constraint/,
51       'Warn about dubious on_delete/on_update attributes',
52     );
53 }
54
55 # Note that the constraints listed here are the only ones that are tested -- if
56 # more exist in the Schema than are listed here and all listed constraints are
57 # correct, the test will still pass. If you add a class with UNIQUE or FOREIGN
58 # KEY constraints to DBICTest::Schema, add tests here if you think the existing
59 # test coverage is not sufficient
60
61 my %fk_constraints = (
62
63   # TwoKeys
64   twokeys => [
65     {
66       'display' => 'twokeys->cd',
67       'name' => 'twokeys_fk_cd', 'index_name' => 'twokeys_idx_cd',
68       'selftable' => 'twokeys', 'foreigntable' => 'cd', 
69       'selfcols'  => ['cd'], 'foreigncols' => ['cdid'], 
70       'noindex'  => 1,
71       on_delete => '', on_update => '', deferrable => 0,
72     },
73     {
74       'display' => 'twokeys->artist',
75       'name' => 'twokeys_fk_artist', 'index_name' => 'twokeys_idx_artist',
76       'selftable' => 'twokeys', 'foreigntable' => 'artist', 
77       'selfcols'  => ['artist'], 'foreigncols' => ['artistid'],
78       on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
79     },
80   ],
81
82   # FourKeys_to_TwoKeys
83   fourkeys_to_twokeys => [
84     {
85       'display' => 'fourkeys_to_twokeys->twokeys',
86       'name' => 'fourkeys_to_twokeys_fk_t_artist_t_cd', 'index_name' => 'fourkeys_to_twokeys_idx_t_artist_t_cd',
87       'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'twokeys', 
88       'selfcols'  => ['t_artist', 't_cd'], 'foreigncols' => ['artist', 'cd'], 
89       on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
90     },
91     {
92       'display' => 'fourkeys_to_twokeys->fourkeys', 'index_name' => 'fourkeys_to_twokeys_idx_f_foo_f_bar_f_hello_f_goodbye',
93       'name' => 'fourkeys_to_twokeys_fk_f_foo_f_bar_f_hello_f_goodbye',
94       'selftable' => 'fourkeys_to_twokeys', 'foreigntable' => 'fourkeys', 
95       'selfcols'  => [qw(f_foo f_bar f_hello f_goodbye)],
96       'foreigncols' => [qw(foo bar hello goodbye)], 
97       on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
98     },
99   ],
100
101   # CD_to_Producer
102   cd_to_producer => [
103     {
104       'display' => 'cd_to_producer->cd',
105       'name' => 'cd_to_producer_fk_cd', 'index_name' => 'cd_to_producer_idx_cd',
106       'selftable' => 'cd_to_producer', 'foreigntable' => 'cd', 
107       'selfcols'  => ['cd'], 'foreigncols' => ['cdid'],
108       on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
109     },
110     {
111       'display' => 'cd_to_producer->producer',
112       'name' => 'cd_to_producer_fk_producer', 'index_name' => 'cd_to_producer_idx_producer',
113       'selftable' => 'cd_to_producer', 'foreigntable' => 'producer', 
114       'selfcols'  => ['producer'], 'foreigncols' => ['producerid'],
115       on_delete => '', on_update => '', deferrable => 1,
116     },
117   ],
118
119   # Self_ref_alias
120   self_ref_alias => [
121     {
122       'display' => 'self_ref_alias->self_ref for self_ref',
123       'name' => 'self_ref_alias_fk_self_ref', 'index_name' => 'self_ref_alias_idx_self_ref',
124       'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref', 
125       'selfcols'  => ['self_ref'], 'foreigncols' => ['id'],
126       on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
127     },
128     {
129       'display' => 'self_ref_alias->self_ref for alias',
130       'name' => 'self_ref_alias_fk_alias', 'index_name' => 'self_ref_alias_idx_alias',
131       'selftable' => 'self_ref_alias', 'foreigntable' => 'self_ref', 
132       'selfcols'  => ['alias'], 'foreigncols' => ['id'],
133       on_delete => '', on_update => '', deferrable => 1,
134     },
135   ],
136
137   # CD
138   cd => [
139     {
140       'display' => 'cd->artist',
141       'name' => 'cd_fk_artist', 'index_name' => 'cd_idx_artist',
142       'selftable' => 'cd', 'foreigntable' => 'artist', 
143       'selfcols'  => ['artist'], 'foreigncols' => ['artistid'],
144       on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
145     },
146   ],
147
148   # Artist_undirected_map
149   artist_undirected_map => [
150     {
151       'display' => 'artist_undirected_map->artist for id1',
152       'name' => 'artist_undirected_map_fk_id1', 'index_name' => 'artist_undirected_map_idx_id1',
153       'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist', 
154       'selfcols'  => ['id1'], 'foreigncols' => ['artistid'],
155       on_delete => 'RESTRICT', on_update => 'CASCADE', deferrable => 1,
156     },
157     {
158       'display' => 'artist_undirected_map->artist for id2',
159       'name' => 'artist_undirected_map_fk_id2', 'index_name' => 'artist_undirected_map_idx_id2',
160       'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist', 
161       'selfcols'  => ['id2'], 'foreigncols' => ['artistid'],
162       on_delete => '', on_update => '', deferrable => 1,
163     },
164   ],
165
166   # Track
167   track => [
168     {
169       'display' => 'track->cd',
170       'name' => 'track_fk_cd', 'index_name' => 'track_idx_cd',
171       'selftable' => 'track', 'foreigntable' => 'cd', 
172       'selfcols'  => ['cd'], 'foreigncols' => ['cdid'],
173       on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
174     },
175   ],
176
177   # TreeLike
178   treelike => [
179     {
180       'display' => 'treelike->treelike for parent',
181       'name' => 'treelike_fk_parent', 'index_name' => 'treelike_idx_parent',
182       'selftable' => 'treelike', 'foreigntable' => 'treelike', 
183       'selfcols'  => ['parent'], 'foreigncols' => ['id'],
184       on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
185     },
186   ],
187
188   # TwoKeyTreeLike
189   twokeytreelike => [
190     {
191       'display' => 'twokeytreelike->twokeytreelike for parent1,parent2',
192       'name' => 'twokeytreelike_fk_parent1_parent2', 'index_name' => 'twokeytreelike_idx_parent1_parent2',
193       'selftable' => 'twokeytreelike', 'foreigntable' => 'twokeytreelike', 
194       'selfcols'  => ['parent1', 'parent2'], 'foreigncols' => ['id1','id2'],
195       on_delete => '', on_update => '', deferrable => 1,
196     },
197   ],
198
199   # Tags
200   tags => [
201     {
202       'display' => 'tags->cd',
203       'name' => 'tags_fk_cd', 'index_name' => 'tags_idx_cd',
204       'selftable' => 'tags', 'foreigntable' => 'cd', 
205       'selfcols'  => ['cd'], 'foreigncols' => ['cdid'],
206       on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
207     },
208   ],
209
210   # Bookmark
211   bookmark => [
212     {
213       'display' => 'bookmark->link',
214       'name' => 'bookmark_fk_link', 'index_name' => 'bookmark_idx_link',
215       'selftable' => 'bookmark', 'foreigntable' => 'link', 
216       'selfcols'  => ['link'], 'foreigncols' => ['id'],
217       on_delete => 'SET NULL', on_update => 'CASCADE', deferrable => 1,
218     },
219   ],
220   # ForceForeign
221   forceforeign => [
222     {
223       'display' => 'forceforeign->artist',
224       'name' => 'forceforeign_fk_artist', 'index_name' => 'forceforeign_idx_artist',
225       'selftable' => 'forceforeign', 'foreigntable' => 'artist', 
226       'selfcols'  => ['artist'], 'foreigncols' => ['artistid'], 
227       on_delete => '', on_update => '', deferrable => 1,
228     },
229   ],
230 );
231
232 my %unique_constraints = (
233   # CD
234   cd => [
235     {
236       'display' => 'cd artist and title unique',
237       'name' => 'cd_artist_title',
238       'table' => 'cd', 'cols' => ['artist', 'title'],
239     },
240   ],
241
242   # Producer
243   producer => [
244     {
245       'display' => 'producer name unique',
246       'name' => 'prod_name', # explicit name
247       'table' => 'producer', 'cols' => ['name'],
248     },
249   ],
250
251   # TwoKeyTreeLike
252   twokeytreelike => [
253     {
254       'display' => 'twokeytreelike name unique',
255       'name' => 'tktlnameunique', # explicit name
256       'table' => 'twokeytreelike', 'cols'  => ['name'],
257     },
258   ],
259
260   # Employee
261 # Constraint is commented out in DBICTest/Schema/Employee.pm
262 #  employee => [
263 #    {
264 #      'display' => 'employee position and group_id unique',
265 #      'name' => 'position_group',
266 #      'table' => 'employee', cols => ['position', 'group_id'],
267 #    },
268 #  ],
269 );
270
271 my %indexes = (
272   artist => [
273     {
274       'fields' => ['name']
275     },
276   ],
277   track => [
278     {
279       'fields' => ['title']
280     }
281   ],
282 );
283
284 my $tschema = $translator->schema();
285 # Test that the $schema->sqlt_deploy_hook was called okay and that it removed
286 # the 'dummy' table
287 ok( !defined($tschema->get_table('dummy')), "Dummy table was removed by hook");
288
289 # Test that the Artist resultsource sqlt_deploy_hook was called okay and added
290 # an index
291 SKIP: {
292     skip ('Artist sqlt_deploy_hook is only called with an SQLite backend', 1)
293         if $schema->storage->sqlt_type ne 'SQLite';
294
295     ok( ( grep 
296         { $_->name eq 'artist_name_hookidx' }
297         $tschema->get_table('artist')->get_indices
298     ), 'sqlt_deploy_hook fired within a resultsource');
299 }
300
301 # Test that nonexistent constraints are not found
302 my $constraint = get_constraint('FOREIGN KEY', 'cd', ['title'], 'cd', ['year']);
303 ok( !defined($constraint), 'nonexistent FOREIGN KEY constraint not found' );
304 $constraint = get_constraint('UNIQUE', 'cd', ['artist']);
305 ok( !defined($constraint), 'nonexistent UNIQUE constraint not found' );
306 $constraint = get_constraint('FOREIGN KEY', 'forceforeign', ['cd'], 'cd', ['cdid']);
307 ok( !defined($constraint), 'forced nonexistent FOREIGN KEY constraint not found' );
308
309 for my $expected_constraints (keys %fk_constraints) {
310   for my $expected_constraint (@{ $fk_constraints{$expected_constraints} }) {
311     my $desc = $expected_constraint->{display};
312     my $constraint = get_constraint(
313       'FOREIGN KEY',
314       $expected_constraint->{selftable}, $expected_constraint->{selfcols},
315       $expected_constraint->{foreigntable}, $expected_constraint->{foreigncols},
316     );
317     ok( defined($constraint), "FOREIGN KEY constraint matching `$desc' found" );
318     test_fk($expected_constraint, $constraint);
319   }
320 }
321
322 for my $expected_constraints (keys %unique_constraints) {
323   for my $expected_constraint (@{ $unique_constraints{$expected_constraints} }) {
324     my $desc = $expected_constraint->{display};
325     my $constraint = get_constraint(
326       'UNIQUE', $expected_constraint->{table}, $expected_constraint->{cols},
327     );
328     ok( defined($constraint), "UNIQUE constraint matching `$desc' found" );
329     test_unique($expected_constraint, $constraint);
330   }
331 }
332
333 for my $table_index (keys %indexes) {
334   for my $expected_index ( @{ $indexes{$table_index} } ) {
335     ok ( get_index($table_index, $expected_index), "Got a matching index on $table_index table");
336   }
337 }
338
339 # Returns the Constraint object for the specified constraint type, table and
340 # columns from the SQL::Translator schema, or undef if no matching constraint
341 # is found.
342 #
343 # NB: $type is either 'FOREIGN KEY' or 'UNIQUE'. In UNIQUE constraints the last
344 # two parameters are not used.
345 sub get_constraint {
346   my ($type, $table_name, $cols, $f_table, $f_cols) = @_;
347   $f_table ||= ''; # For UNIQUE constraints, reference_table is ''
348   $f_cols ||= [];
349
350   my $table = $tschema->get_table($table_name);
351
352   my %fields = map { $_ => 1 } @$cols;
353   my %f_fields = map { $_ => 1 } @$f_cols;
354
355   die "No $table_name" unless $table;
356  CONSTRAINT:
357   for my $constraint ( $table->get_constraints ) {
358     next unless $constraint->type eq $type;
359     next unless $constraint->reference_table eq $f_table;
360
361     my %rev_fields = map { $_ => 1 } $constraint->fields;
362     my %rev_f_fields = map { $_ => 1 } $constraint->reference_fields;
363
364     # Check that the given fields are a subset of the constraint's fields
365     for my $field ($constraint->fields) {
366       next CONSTRAINT unless $fields{$field};
367     }
368     if ($type eq 'FOREIGN KEY') {
369       for my $f_field ($constraint->reference_fields) {
370         next CONSTRAINT unless $f_fields{$f_field};
371       }
372     }
373
374     # Check that the constraint's fields are a subset of the given fields
375     for my $field (@$cols) {
376       next CONSTRAINT unless $rev_fields{$field};
377     }
378     if ($type eq 'FOREIGN KEY') {
379       for my $f_field (@$f_cols) {
380         next CONSTRAINT unless $rev_f_fields{$f_field};
381       }
382     }
383
384     return $constraint; # everything passes, found the constraint
385   }
386   return undef; # didn't find a matching constraint
387 }
388
389 sub get_index {
390   my ($table_name, $index) = @_;
391
392   my $table = $tschema->get_table($table_name);
393
394  CAND_INDEX:
395   for my $cand_index ( $table->get_indices ) {
396    
397     next CAND_INDEX if $index->{name} && $cand_index->name ne $index->{name}
398                     || $index->{type} && $cand_index->type ne $index->{type};
399
400     my %idx_fields = map { $_ => 1 } $cand_index->fields;
401
402     for my $field ( @{ $index->{fields} } ) {
403       next CAND_INDEX unless $idx_fields{$field};
404     }
405
406     %idx_fields = map { $_ => 1 } @{$index->{fields}};
407     for my $field ( $cand_index->fields) {
408       next CAND_INDEX unless $idx_fields{$field};
409     }
410
411     return $cand_index;
412   }
413
414   return undef; # No matching idx
415 }
416
417 # Test parameters in a FOREIGN KEY constraint other than columns
418 sub test_fk {
419   my ($expected, $got) = @_;
420   my $desc = $expected->{display};
421   is( $got->name, $expected->{name},
422       "name parameter correct for `$desc'" );
423   is( $got->on_delete, $expected->{on_delete},
424       "on_delete parameter correct for `$desc'" );
425   is( $got->on_update, $expected->{on_update},
426       "on_update parameter correct for `$desc'" );
427   is( $got->deferrable, $expected->{deferrable},
428       "is_deferrable parameter correct for `$desc'" );
429
430   my $index = get_index( $got->table, { fields => $expected->{selfcols} } );
431
432   if ($expected->{noindex}) {
433       ok( !defined $index, "index doesn't for `$desc'" );
434   } else {
435       ok( defined $index, "index exists for `$desc'" );
436       is( $index->name, $expected->{index_name}, "index has correct name for `$desc'" );
437   }
438 }
439
440 sub test_unique {
441   my ($expected, $got) = @_;
442   my $desc = $expected->{display};
443   is( $got->name, $expected->{name},
444       "name parameter correct for `$desc'" );
445 }