introspect ON DELETE/UPDATE and DEFERRABLE for pg
Rafael Kitover [Sun, 26 Aug 2012 22:35:23 +0000 (18:35 -0400)]
Apparently Pg has an information_schema, so I copied the _table_fk_info
from the MSSQL driver and modified it to introspect the ON and
DEFERRABLE clauses.

I will add this introspection for MSSQL shortly as well, after which I
will remove the duplication from these two drivers and add an
InformationSchema component.

Changes
lib/DBIx/Class/Schema/Loader/DBI/Pg.pm
t/10_02mysql_common.t
t/10_03pg_common.t
t/lib/dbixcsl_common_tests.pm

diff --git a/Changes b/Changes
index fba7d22..cd92137 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,11 @@
 Revision history for Perl extension DBIx::Class::Schema::Loader
 
+        - PostgreSQL: introspect ON DELETE/UPDATE clauses for foreign keys and
+          the DEFERRABLE clause.
+        - PostgreSQL WARNING: the default for on_delete/on_update attributes for
+          belongs_to relationships is now 'NO ACTION' not 'CASCADE! The default
+          for is_deferrable is now 0 not 1.
+
 0.07026  2012-08-26 01:01:26
         - MySQL: introspect ON DELETE/UPDATE clauses for foreign keys.
         - MySQL WARNING: the default on_delete/on_update attributes for
index 1f01898..4624311 100644 (file)
@@ -40,6 +40,58 @@ sub _system_schemas {
     return ($self->next::method(@_), 'pg_catalog');
 }
 
+sub _table_fk_info {
+    my ($self, $table) = @_;
+
+    my $sth = $self->dbh->prepare_cached(<<"EOF");
+SELECT rc.constraint_name, rc.unique_constraint_schema, uk_tc.table_name,
+       fk_kcu.column_name, uk_kcu.column_name, rc.delete_rule, rc.update_rule,
+       fk_tc.is_deferrable
+FROM INFORMATION_SCHEMA.TABLE_CONSTRAINTS fk_tc
+JOIN INFORMATION_SCHEMA.REFERENTIAL_CONSTRAINTS rc
+    ON rc.constraint_name = fk_tc.constraint_name
+        AND rc.constraint_schema = fk_tc.table_schema
+JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE fk_kcu
+    ON fk_kcu.constraint_name = fk_tc.constraint_name
+        AND fk_kcu.table_name = fk_tc.table_name
+        AND fk_kcu.table_schema = fk_tc.table_schema
+JOIN INFORMATION_SCHEMA.TABLE_CONSTRAINTS uk_tc
+    ON uk_tc.constraint_name = rc.unique_constraint_name
+        AND uk_tc.table_schema = rc.unique_constraint_schema
+JOIN INFORMATION_SCHEMA.KEY_COLUMN_USAGE uk_kcu
+    ON uk_kcu.constraint_name = rc.unique_constraint_name
+        AND uk_kcu.ordinal_position = fk_kcu.ordinal_position
+        AND uk_kcu.table_name = uk_tc.table_name
+        AND uk_kcu.table_schema = rc.unique_constraint_schema
+WHERE fk_tc.table_name = ?
+    AND fk_tc.table_schema = ?
+ORDER BY fk_kcu.ordinal_position
+EOF
+
+    $sth->execute($table->name, $table->schema);
+
+    my %rels;
+
+    while (my ($fk, $remote_schema, $remote_table, $col, $remote_col,
+               $delete_rule, $update_rule, $is_deferrable) = $sth->fetchrow_array) {
+        push @{ $rels{$fk}{local_columns}  }, $self->_lc($col);
+        push @{ $rels{$fk}{remote_columns} }, $self->_lc($remote_col);
+
+        $rels{$fk}{remote_table} = DBIx::Class::Schema::Loader::Table->new(
+            loader   => $self,
+            name     => $remote_table,
+            schema   => $remote_schema,
+        ) unless exists $rels{$fk}{remote_table};
+
+        $rels{$fk}{attrs}{on_delete} = uc $delete_rule;
+        $rels{$fk}{attrs}{on_update} = uc $update_rule;
+        $rels{$fk}{attrs}{is_deferrable} = uc $is_deferrable eq 'YES' ? 1 : 0;
+    }
+
+    return [ values %rels ];
+}
+
+
 sub _table_uniq_info {
     my ($self, $table) = @_;
 
@@ -108,8 +160,8 @@ sub _table_comment {
     return $table_comment if $table_comment;
 
     ($table_comment) = $self->dbh->selectrow_array(<<'EOF', {}, $table->name, $table->schema);
-SELECT obj_description(oid) 
-FROM pg_class 
+SELECT obj_description(oid)
+FROM pg_class
 WHERE relname=? AND relnamespace=(SELECT oid FROM pg_namespace WHERE nspname=?)
 EOF
 
@@ -127,7 +179,7 @@ sub _column_comment {
 
     my ($table_oid) = $self->dbh->selectrow_array(<<'EOF', {}, $table->name, $table->schema);
 SELECT oid
-FROM pg_class 
+FROM pg_class
 WHERE relname=? AND relnamespace=(SELECT oid FROM pg_namespace WHERE nspname=?)
 EOF
 
@@ -248,7 +300,7 @@ EOF
                 $info->{extra}{custom_type_name} = $info->{data_type};
 
                 $info->{data_type} = 'enum';
-                
+
                 delete $info->{size};
             }
         }
index 948d2c4..b251dc7 100644 (file)
@@ -26,18 +26,19 @@ my $innodb = $test_innodb ? q{Engine=InnoDB} : '';
 my ($schema, $databases_created); # for cleanup in END for extra tests
 
 my $tester = dbixcsl_common_tests->new(
-    vendor           => 'Mysql',
-    auto_inc_pk      => 'INTEGER NOT NULL PRIMARY KEY AUTO_INCREMENT',
-    innodb           => $innodb,
-    dsn              => $dsn,
-    user             => $user,
-    password         => $password,
-    connect_info_opts=> { on_connect_call => 'set_strict_mode' },
-    loader_options   => { preserve_case => 1 },
-    skip_rels        => $test_innodb ? 0 : $skip_rels_msg,
-    quote_char       => '`',
-    no_inline_rels   => 1,
-    no_implicit_rels => 1,
+    vendor            => 'Mysql',
+    auto_inc_pk       => 'INTEGER NOT NULL PRIMARY KEY AUTO_INCREMENT',
+    innodb            => $innodb,
+    dsn               => $dsn,
+    user              => $user,
+    password          => $password,
+    connect_info_opts => { on_connect_call => 'set_strict_mode' },
+    loader_options    => { preserve_case => 1 },
+    skip_rels         => $test_innodb ? 0 : $skip_rels_msg,
+    quote_char        => '`',
+    no_inline_rels    => 1,
+    no_implicit_rels  => 1,
+    default_on_clause => 'RESTRICT',
     data_types  => {
         # http://dev.mysql.com/doc/refman/5.5/en/data-type-overview.html
         # Numeric Types
index 4c9614b..342e771 100644 (file)
@@ -31,6 +31,8 @@ my $tester = dbixcsl_common_tests->new(
         on_connect_do  => [ 'SET client_min_messages=WARNING' ],
     },
     quote_char  => '"',
+    default_is_deferrable => 0,
+    default_on_clause => 'NO ACTION',
     data_types  => {
         # http://www.postgresql.org/docs/7.4/interactive/datatype.html
         #
@@ -226,6 +228,21 @@ my $tester = dbixcsl_common_tests->new(
                     pg_loader_test7_id INTEGER REFERENCES "dbicsl.test".pg_loader_test7 (id)
                 )
             },
+            # 4 through 8 are used for the multi-schema tests
+            q{
+                create table pg_loader_test9 (
+                    id bigserial primary key
+                )
+            },
+            q{
+                create table pg_loader_test10 (
+                    id bigserial primary key,
+                    eleven_id int,
+                    foreign key (eleven_id) references pg_loader_test9(id)
+                        on delete restrict on update set null
+                )
+            },
+
         ],
         pre_drop_ddl => [
             'DROP SCHEMA dbicsl_test CASCADE',
@@ -233,8 +250,8 @@ my $tester = dbixcsl_common_tests->new(
             'DROP SCHEMA "dbicsl.test" CASCADE',
             'DROP TYPE pg_loader_test_enum',
         ],
-        drop  => [ qw/ pg_loader_test1 pg_loader_test2 / ],
-        count => 4 + 30 * 2,
+        drop  => [ qw/pg_loader_test1 pg_loader_test2 pg_loader_test9 pg_loader_test10/ ],
+        count => 8 + 30 * 2,
         run   => sub {
             my ($schema, $monikers, $classes) = @_;
 
@@ -261,6 +278,19 @@ my $tester = dbixcsl_common_tests->new(
             like $code, qr/^=head1 NAME\n\n^$class\n\n=head1 DESCRIPTION\n\n^very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very very long comment\n\n^=cut\n/m,
                 'long table comment is in DESCRIPTION';
 
+            # test on delete/update fk clause introspection
+            ok ((my $rel_info = $schema->source('PgLoaderTest10')->relationship_info('eleven')),
+                'got rel info');
+
+            is $rel_info->{attrs}{on_delete}, 'RESTRICT',
+                'ON DELETE clause introspected correctly';
+
+            is $rel_info->{attrs}{on_update}, 'SET NULL',
+                'ON UPDATE clause introspected correctly';
+
+            is $rel_info->{attrs}{is_deferrable}, 0,
+                'DEFERRABLE clause introspected correctly';
+
             foreach my $db_schema (['dbicsl-test', 'dbicsl.test'], '%') {
                 lives_and {
                     rmtree EXTRA_DUMP_DIR;
index 5d6ca22..e00920b 100644 (file)
@@ -292,13 +292,13 @@ sub setup_schema {
             $expected_count += grep $_ =~ SOURCE_DDL,
                 @{ $self->{extra}{create} || [] };
 
-            $expected_count -= grep /CREATE TABLE/, @statements_inline_rels
+            $expected_count -= grep /CREATE TABLE/i, @statements_inline_rels
                 if $self->{skip_rels} || $self->{no_inline_rels};
 
-            $expected_count -= grep /CREATE TABLE/, @statements_implicit_rels
+            $expected_count -= grep /CREATE TABLE/i, @statements_implicit_rels
                 if $self->{skip_rels} || $self->{no_implicit_rels};
 
-            $expected_count -= grep /CREATE TABLE/, ($self->{vendor} =~ /sqlite/ ? @statements_advanced_sqlite : @statements_advanced), @statements_reltests
+            $expected_count -= grep /CREATE TABLE/i, ($self->{vendor} =~ /sqlite/ ? @statements_advanced_sqlite : @statements_advanced), @statements_reltests
                 if $self->{skip_rels};
         }
 
@@ -789,16 +789,24 @@ qr/\n__PACKAGE__->load_components\("TestSchemaComponent", "\+TestSchemaComponent
         ok ((not try { exists $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{is_deferrable} }),
             'has_many does not have is_deferrable');
 
-        like try { $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{on_delete} },
-            qr/^(?:CASCADE|RESTRICT)\z/,
-            "on_delete is either CASCADE or RESTRICT on belongs_to by default";
+        my $default_on_clause = $self->{default_on_clause} || 'CASCADE';
 
-        like try { $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{on_update} },
-            qr/^(?:CASCADE|RESTRICT)\z/,
-            "on_update is either CASCADE or RESTRICT on belongs_to by default";
+        is try { $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{on_delete} },
+            $default_on_clause,
+            "on_delete is $default_on_clause on belongs_to by default";
 
-        is try { $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{is_deferrable} }, 1,
-            "is_deferrable => 1 on belongs_to by default";
+        is try { $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{on_update} },
+            $default_on_clause,
+            "on_update is $default_on_clause on belongs_to by default";
+
+        my $default_is_deferrable = $self->{default_is_deferrable};
+
+        $default_is_deferrable = 1
+            if not defined $default_is_deferrable;
+
+        is try { $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{is_deferrable} },
+            $default_is_deferrable,
+            "is_deferrable => $default_is_deferrable on belongs_to by default";
 
         ok ((not try { exists $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{cascade_delete} }),
             'belongs_to does not have cascade_delete');