From: Rafael Kitover Date: Sun, 2 Sep 2012 21:29:01 +0000 (-0400) Subject: introspect ON/DEFERRABLE FK clauses for SQLite X-Git-Tag: 0.07029~3 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3b61a7ca5fade36343b5abdd11bb6b29e47e043c;hp=8990a2b23d98bcb87da292ee3731de3ac4f1b86f;p=dbsrgits%2FDBIx-Class-Schema-Loader.git introspect ON/DEFERRABLE FK clauses for SQLite The ON clauses are simple to get, pragma foreign_key_list returns them, but for the DEFERRABLE clause we have to parse the table DDL from sqlite_master, a bit hairy but should be correct. --- diff --git a/Changes b/Changes index 1704655..57f72f1 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,9 @@ Revision history for Perl extension DBIx::Class::Schema::Loader + - SQLite: introspect ON DELETE/UPDATE and DEFERRABLE clauses + - SQLite WARNING: the default for on_delete/on_update is now 'NO ACTION' + not 'CASCADE', and the default for is_deferrable is now 0 not 1. + 0.07028 2012-08-30 05:32:42 - MSSQL: introspect ON DELETE/UPDATE clauses for foreign keys - MSSQL WARNING: the default for on_delete/on_update is now 'NO ACTION' diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm index ad747d5..e6ef0a9 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm @@ -11,7 +11,7 @@ our $VERSION = '0.07028'; =head1 NAME -DBIx::Class::Schema::Loader::DBI::Oracle - DBIx::Class::Schema::Loader::DBI +DBIx::Class::Schema::Loader::DBI::Oracle - DBIx::Class::Schema::Loader::DBI Oracle Implementation. =head1 DESCRIPTION @@ -100,7 +100,7 @@ EOF my $constr_col = $self->_lc($constr->[1]); push @{$constr_names{$constr_name}}, $constr_col; } - + my @uniqs = map { [ $_ => $constr_names{$_} ] } keys %constr_names; return \@uniqs; } @@ -115,7 +115,7 @@ sub _table_comment { ($table_comment) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name); SELECT comments FROM all_tab_comments -WHERE owner = ? +WHERE owner = ? AND table_name = ? AND (table_type = 'TABLE' OR table_type = 'VIEW') EOF @@ -133,7 +133,7 @@ sub _column_comment { ($column_comment) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $self->_uc($column_name)); SELECT comments FROM all_col_comments -WHERE owner = ? +WHERE owner = ? AND table_name = ? AND column_name = ? EOF @@ -315,7 +315,7 @@ EOF elsif (lc($info->{data_type}) eq 'binary_float') { $info->{data_type} = 'real'; $info->{original}{data_type} = 'binary_float'; - } + } elsif (lc($info->{data_type}) eq 'binary_double') { $info->{data_type} = 'double precision'; $info->{original}{data_type} = 'binary_double'; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm index 2499cf7..32e3f83 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLite.pm @@ -36,7 +36,7 @@ sub _setup { if (not defined $self->preserve_case) { $self->preserve_case(0); } - + if ($self->db_schema) { warn <<'EOF'; db_schema is not supported on SQLite, the option is implemented only for qualify_objects testing. @@ -126,11 +126,48 @@ sub _table_fk_info { push @{ $rel->{local_columns} }, $self->_lc($fk->{from}); push @{ $rel->{remote_columns} }, $self->_lc($fk->{to}) if defined $fk->{to}; + + $rel->{attrs} ||= { + on_delete => uc $fk->{on_delete}, + on_update => uc $fk->{on_update}, + }; + warn "This is supposed to be the same rel but remote_table changed from ", $rel->{remote_table}->name, " to ", $fk->{table} if $rel->{remote_table}->name ne $fk->{table}; } $sth->finish; + + # now we need to determine whether each FK is DEFERRABLE, this can only be + # done by parsing the DDL from sqlite_master + + my $ddl = $self->dbh->selectcol_arrayref(<<"EOF", undef, $table->name, $table->name)->[0]; +select sql from sqlite_master +where name = ? and tbl_name = ? +EOF + + foreach my $fk (@rels) { + my $local_cols = '"?' . (join '"? \s* , \s* "?', @{ $fk->{local_columns} }) . '"?'; + my $remote_cols = '"?' . (join '"? \s* , \s* "?', @{ $fk->{remote_columns} || [] }) . '"?'; + my ($deferrable_clause) = $ddl =~ / + foreign \s+ key \s* \( \s* $local_cols \s* \) \s* references \s* (?:\S+|".+?(?{attrs}{is_deferrable} = $deferrable_clause =~ /not/i ? 0 : 1; + } + else { + $fk->{attrs}{is_deferrable} = 0; + } + } + return \@rels; } @@ -205,3 +242,4 @@ the same terms as Perl itself. =cut 1; +# vim:et sts=4 sw=4 tw=0: diff --git a/t/10_01sqlite_common.t b/t/10_01sqlite_common.t index e588ded..93a499c 100644 --- a/t/10_01sqlite_common.t +++ b/t/10_01sqlite_common.t @@ -17,6 +17,8 @@ my $tester = dbixcsl_common_tests->new( on_connect_do => [ 'PRAGMA foreign_keys = ON', 'PRAGMA synchronous = OFF', ] }, loader_options => { preserve_case => 1 }, + default_is_deferrable => 0, + default_on_clause => 'NO ACTION', data_types => { # SQLite ignores data types aside from INTEGER pks. # We just test that they roundtrip sanely. @@ -112,11 +114,25 @@ my $tester = dbixcsl_common_tests->new( PRIMARY KEY (id1, id2) ) }, + q{ + create table extra_loader_test8 ( + id integer primary key + ) + }, + q{ + create table extra_loader_test9 ( + id integer primary key, + eight_id int, + foreign key (eight_id) references extra_loader_test8(id) + on delete restrict on update set null deferrable + ) + }, ], pre_drop_ddl => [ 'DROP VIEW extra_loader_test5' ], - drop => [ qw/extra_loader_test1 extra_loader_test2 extra_loader_test3 - extra_loader_test4 extra_loader_test6 extra_loader_test7/ ], - count => 11, + drop => [ qw/extra_loader_test1 extra_loader_test2 extra_loader_test3 + extra_loader_test4 extra_loader_test6 extra_loader_test7 + extra_loader_test8 extra_loader_test9 / ], + count => 15, run => sub { my ($schema, $monikers, $classes) = @_; @@ -152,6 +168,19 @@ my $tester = dbixcsl_common_tests->new( isnt $schema->resultset($monikers->{extra_loader_test7})->result_source->column_info('id1')->{is_auto_increment}, 1, q{composite integer PK with non-integer PK doesn't get marked autoinc}; + + # test on delete/update fk clause introspection + ok ((my $rel_info = $schema->source('ExtraLoaderTest9')->relationship_info('eight')), + '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}, 1, + 'DEFERRABLE clause introspected correctly'; }, }, ); @@ -159,5 +188,5 @@ my $tester = dbixcsl_common_tests->new( $tester->run_tests(); END { - unlink "$tdir/sqlite_test"; + unlink "$tdir/sqlite_test" unless $ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}; }