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