- Allow explicit specification of ON DELETE/ON UPDATE constraints when using the...
Peter Rabbitson [Fri, 22 Aug 2008 12:48:18 +0000 (12:48 +0000)]
- Minor refactor of the parser (needs more work)

lib/DBIx/Class/Relationship/Base.pm
lib/SQL/Translator/Parser/DBIx/Class.pm
t/86sqlt.t
t/lib/DBICTest/Schema/ArtistUndirectedMap.pm
t/lib/DBICTest/Schema/CD.pm

index b8f2467..72ac9f0 100644 (file)
@@ -109,6 +109,19 @@ is creating constraints where it shouldn't, or not creating them where it
 should, set this attribute to a true or false value to override the detection
 of when to create constraints.
 
+=item on_delete / on_update
+
+If you are using L<SQL::Translator> to create SQL for you, you can use these
+attributes to explicitly set the desired C<ON DELETE> or C<ON UPDATE> constraint 
+type. If not supplied the SQLT parser will attempt to infer the constraint type by 
+interrogating the attributes of the B<opposite> relationship. For any 'multi'
+relationship with C<< cascade_delete => 1 >>, the corresponding belongs_to 
+relationship will be created with an C<ON DELETE CASCADE> constraint. For any 
+relationship bearing C<< cascade_copy => 1 >> the resulting belongs_to constraint
+will be C<ON UPDATE CASCADE>. If you wish to disable this autodetection, and just
+use the RDBMS' default constraint type, pass C<< on_delete => undef >> or 
+C<< on_delete => '' >>, and the same for C<on_update> respectively.
+
 =item is_deferrable
 
 Tells L<SQL::Translator> that the foreign key constraint it creates should be
index 8305dde..ce6e7e3 100644 (file)
@@ -129,6 +129,9 @@ sub parse {
             my $othertable = $source->related_source($rel);
             my $rel_table = $othertable->name;
 
+            my $reverse_rels = $source->reverse_relationship_info($rel);
+            my ($otherrelname, $otherrelationship) = each %{$reverse_rels};
+
             # Force the order of @cond to match the order of ->add_columns
             my $idx;
             my %other_columns_idx = map {'foreign.'.$_ => ++$idx } $othertable->columns;            
@@ -138,43 +141,54 @@ sub parse {
             my @refkeys = map {/^\w+\.(\w+)$/} @cond;
             my @keys = map {$rel_info->{cond}->{$_} =~ /^\w+\.(\w+)$/} @cond;
 
-            if($rel_table)
-            {
-                my $reverse_rels = $source->reverse_relationship_info($rel);
-                my ($otherrelname, $otherrelationship) = each %{$reverse_rels};
+            # determine if this relationship is a self.fk => foreign.pk (i.e. belongs_to)
+            my $fk_constraint;
 
-                my $on_delete = '';
-                my $on_update = '';
+            #first it can be specified explicitly
+            if ( exists $rel_info->{attrs}{is_foreign_key_constraint} ) {
+                $fk_constraint = $rel_info->{attrs}{is_foreign_key_constraint};
+            }
+            # it can not be multi
+            elsif ( $rel_info->{attrs}{accessor} eq 'multi' ) {
+                $fk_constraint = 0;
+            }
+            # if indeed single, check if all self.columns are our primary keys.
+            # this is supposed to indicate a has_one/might_have...
+            # where's the introspection!!?? :)
+            else {
+                $fk_constraint = not $source->compare_relationship_keys(\@keys, \@primary);
+            }
 
-                if (defined $otherrelationship) {
-                    $on_delete = $otherrelationship->{'attrs'}->{cascade_delete} ? 'CASCADE' : '';
-                    $on_update = $otherrelationship->{'attrs'}->{cascade_copy} ? 'CASCADE' : '';
+            my $cascade;
+            for my $c (qw/delete update/) {
+                if (exists $rel_info->{attrs}{"on_$c"}) {
+                    if ($fk_constraint) {
+                        $cascade->{$c} = $rel_info->{attrs}{"on_$c"};
+                    }
+                    else {
+                        warn "SQLT attribute 'on_$c' was supplied for relationship '$moniker/$rel', which does not appear to be a foreign constraint. "
+                            . "If you are sure that SQLT must generate a constraint for this relationship, add 'is_foreign_key_constraint => 1' to the attributes.\n";
+                    }
+                }
+                elsif (defined $otherrelationship and $otherrelationship->{attrs}{$c eq 'update' ? 'cascade_copy' : 'cascade_delete'}) {
+                    $cascade->{$c} = 'CASCADE';
                 }
+            }
+
+            if($rel_table)
+            {
+                # Constraints are added only if applicable
+                next unless $fk_constraint;
+
+                # Make sure we dont create the same foreign key constraint twice
+                my $key_test = join("\x00", @keys);
+                next if $created_FK_rels{$rel_table}->{$key_test};
 
                 my $is_deferrable = $rel_info->{attrs}{is_deferrable};
                 
                 # global parser_args add_fk_index param can be overridden on the rel def
                 my $add_fk_index_rel = (exists $rel_info->{attrs}{add_fk_index}) ? $rel_info->{attrs}{add_fk_index} : $add_fk_index;
 
-                # Make sure we dont create the same foreign key constraint twice
-                my $key_test = join("\x00", @keys);
-
-                #Decide if this is a foreign key based on whether the self
-                #items are our primary columns.
-
-                # If the sets are different, then we assume it's a foreign key from
-                # us to another table.
-                # OR: If is_foreign_key_constraint attr is explicity set (or set to false) on the relation
-                next if ( exists $created_FK_rels{$rel_table}->{$key_test} );
-                if ( exists $rel_info->{attrs}{is_foreign_key_constraint}) {
-                  # not is this attr set to 0 but definitely if set to 1
-                  next unless ($rel_info->{attrs}{is_foreign_key_constraint});
-                } else {
-                  # not if might have
-                  # next if ($rel_info->{attrs}{accessor} eq 'single' && exists $rel_info->{attrs}{join_type} && uc($rel_info->{attrs}{join_type}) eq 'LEFT');
-                  # not sure about this one
-                  next if $source->compare_relationship_keys(\@keys, \@primary);
-                }
 
                 $created_FK_rels{$rel_table}->{$key_test} = 1;
                 if (scalar(@keys)) {
@@ -184,8 +198,8 @@ sub parse {
                                     fields           => \@keys,
                                     reference_fields => \@refkeys,
                                     reference_table  => $rel_table,
-                                    on_delete        => $on_delete,
-                                    on_update        => $on_update,
+                                    on_delete        => $cascade->{delete},
+                                    on_update        => $cascade->{update},
                                     (defined $is_deferrable ? ( deferrable => $is_deferrable ) : ()),
                   );
                     
index 8211c90..c583414 100644 (file)
@@ -10,7 +10,7 @@ plan skip_all => 'SQL::Translator required' if $@;
 
 my $schema = DBICTest->init_schema;
 
-plan tests => 130;
+plan tests => 131;
 
 my $translator = SQL::Translator->new( 
   parser_args => {
@@ -19,14 +19,23 @@ my $translator = SQL::Translator->new(
   producer_args => {},
 );
 
-$translator->parser('SQL::Translator::Parser::DBIx::Class');
-$translator->producer('SQLite');
+{
+    my $warn = '';
+    local $SIG{__WARN__} = sub { $warn = shift };
 
-my $output = $translator->translate();
+    my $relinfo = $schema->source('Artist')->relationship_info ('cds');
+    local $relinfo->{attrs}{on_delete} = 'restrict';
 
+    $translator->parser('SQL::Translator::Parser::DBIx::Class');
+    $translator->producer('SQLite');
 
-ok($output, "SQLT produced someoutput")
-  or diag($translator->error);
+    my $output = $translator->translate();
+
+    ok($output, "SQLT produced someoutput")
+      or diag($translator->error);
+
+    like ($warn, qr/^SQLT attribute .+? was supplied for relationship/, 'Warn about dubious on_delete/on_update attributes');
+}
 
 # Note that the constraints listed here are the only ones that are tested -- if
 # more exist in the Schema than are listed here and all listed constraints are
@@ -117,7 +126,7 @@ my %fk_constraints = (
       'name' => 'cd_fk_artist', 'index_name' => 'cd_idx_artist',
       'selftable' => 'cd', 'foreigntable' => 'artist', 
       'selfcols'  => ['artist'], 'foreigncols' => ['artistid'],
-      on_delete => 'CASCADE', on_update => 'CASCADE', deferrable => 1,
+      on_delete => '', on_update => 'SET NULL', deferrable => 1,
     },
   ],
 
@@ -128,14 +137,14 @@ my %fk_constraints = (
       'name' => 'artist_undirected_map_fk_id1', 'index_name' => 'artist_undirected_map_idx_id1',
       'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist', 
       'selfcols'  => ['id1'], 'foreigncols' => ['artistid'],
-      on_delete => 'CASCADE', on_update => '', deferrable => 1,
+      on_delete => 'RESTRICT', on_update => 'CASCADE', deferrable => 1,
     },
     {
       'display' => 'artist_undirected_map->artist for id2',
       'name' => 'artist_undirected_map_fk_id2', 'index_name' => 'artist_undirected_map_idx_id2',
       'selftable' => 'artist_undirected_map', 'foreigntable' => 'artist', 
       'selfcols'  => ['id2'], 'foreigncols' => ['artistid'],
-      on_delete => 'CASCADE', on_update => '', deferrable => 1,
+      on_delete => '', on_update => 'CASCADE', deferrable => 1,
     },
   ],
 
@@ -203,7 +212,6 @@ my %fk_constraints = (
       on_delete => '', on_update => '', deferrable => 1,
     },
   ],
-
 );
 
 my %unique_constraints = (
index 2669575..c709572 100644 (file)
@@ -10,8 +10,8 @@ __PACKAGE__->add_columns(
 );
 __PACKAGE__->set_primary_key(qw/id1 id2/);
 
-__PACKAGE__->belongs_to( 'artist1', 'DBICTest::Schema::Artist', 'id1' );
-__PACKAGE__->belongs_to( 'artist2', 'DBICTest::Schema::Artist', 'id2');
+__PACKAGE__->belongs_to( 'artist1', 'DBICTest::Schema::Artist', 'id1', { on_delete => 'RESTRICT', on_update => 'CASCADE'} );
+__PACKAGE__->belongs_to( 'artist2', 'DBICTest::Schema::Artist', 'id2', { on_delete => undef, on_update => 'CASCADE'} );
 __PACKAGE__->has_many(
   'mapped_artists', 'DBICTest::Schema::Artist',
   [ {'foreign.artistid' => 'self.id1'}, {'foreign.artistid' => 'self.id2'} ],
index 2530c7c..f44db21 100644 (file)
@@ -24,7 +24,11 @@ __PACKAGE__->add_columns(
 __PACKAGE__->set_primary_key('cdid');
 __PACKAGE__->add_unique_constraint([ qw/artist title/ ]);
 
-__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist', undef, { is_deferrable => 1 } );
+__PACKAGE__->belongs_to( artist => 'DBICTest::Schema::Artist', undef, { 
+    is_deferrable => 1, 
+    on_delete => undef,
+    on_update => 'SET NULL',
+});
 
 __PACKAGE__->has_many( tracks => 'DBICTest::Schema::Track' );
 __PACKAGE__->has_many(