From: Rafael Kitover Date: Fri, 30 Apr 2010 05:27:26 +0000 (-0400) Subject: preliminary Informix support X-Git-Tag: 0.07000~48 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-Schema-Loader.git;a=commitdiff_plain;h=bc5afe555b3a01ba28368c7f8aeb9c653074417b preliminary Informix support --- diff --git a/Changes b/Changes index c6454fb..a7d6290 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,6 @@ Revision history for Perl extension DBIx::Class::Schema::Loader + - preliminary Informix support - unregister dropped sources on rescan - added 'preserve_case' option with support for SQLite, mysql, MSSQL and Firebird/InterBase; removed the MSSQL 'case_sensitive_collation' and diff --git a/TODO b/TODO index 6b935ed..6b96101 100644 --- a/TODO +++ b/TODO @@ -21,6 +21,8 @@ - common tests for table/column comments - optimize queries - remove extra select for _filter_tables + - option to promote non-nullable unique constraints to PK (prefer int + columns when more than one) (RT#51696) - Relationships - Re-scan relations/tables after initial relation setup to find ->many_to_many() relations to be set up diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Informix.pm b/lib/DBIx/Class/Schema/Loader/DBI/Informix.pm new file mode 100644 index 0000000..a945018 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBI/Informix.pm @@ -0,0 +1,233 @@ +package DBIx::Class::Schema::Loader::DBI::Informix; + +use strict; +use warnings; +use Class::C3; +use base qw/DBIx::Class::Schema::Loader::DBI/; +use namespace::autoclean; +use Carp::Clan qw/^DBIx::Class/; +use Scalar::Util 'looks_like_number'; + +our $VERSION = '0.07000'; + +=head1 NAME + +DBIx::Class::Schema::Loader::DBI::Informix - DBIx::Class::Schema::Loader::DBI +Informix Implementation. + +=head1 DESCRIPTION + +See L and L. + +=cut + +sub _setup { + my $self = shift; + + $self->next::method(@_); + + if (not defined $self->preserve_case) { + $self->preserve_case(0); + } +} + +sub _tables_list { + my ($self, $opts) = @_; + + my $dbh = $self->schema->storage->dbh; + my $sth = $dbh->prepare(<<'EOF'); +select tabname from systables t +where t.owner <> 'informix' and t.owner <> '' and t.tabname <> ' VERSION' +EOF + $sth->execute; + + my @tables = map @$_, @{ $sth->fetchall_arrayref }; + + return $self->_filter_tables(\@tables, $opts); +} + +sub _constraints_for { + my ($self, $table, $type) = @_; + + my $dbh = $self->schema->storage->dbh; + local $dbh->{FetchHashKeyName} = 'NAME_lc'; + + my $sth = $dbh->prepare(<<'EOF'); +select c.constrname, i.* +from sysconstraints c +join systables t on t.tabid = c.tabid +join sysindexes i on c.idxname = i.idxname +where t.tabname = ? and c.constrtype = ? +EOF + $sth->execute($table, $type); + my $indexes = $sth->fetchall_hashref('constrname'); + $sth->finish; + + my $cols = $self->_colnames_by_colno($table); + + my $constraints; + while (my ($constr_name, $idx_def) = each %$indexes) { + $constraints->{$constr_name} = $self->_idx_colnames($idx_def, $cols); + } + + return $constraints; +} + +sub _idx_colnames { + my ($self, $idx_info, $table_cols_by_colno) = @_; + + return [ map $self->_lc($table_cols_by_colno->{$_}), grep $_, map $idx_info->{$_}, map "part$_", (1..16) ]; +} + +sub _colnames_by_colno { + my ($self, $table) = @_; + + my $dbh = $self->schema->storage->dbh; + local $dbh->{FetchHashKeyName} = 'NAME_lc'; + + my $sth = $dbh->prepare(<<'EOF'); +select c.colname, c.colno +from syscolumns c +join systables t on c.tabid = t.tabid +where t.tabname = ? +EOF + $sth->execute($table); + my $cols = $sth->fetchall_hashref('colno'); + $cols = { map +($_, $cols->{$_}{colname}), keys %$cols }; + + return $cols; +} + +sub _table_pk_info { + my ($self, $table) = @_; + + my $pk = (values %{ $self->_constraints_for($table, 'P') || {} })[0]; + + return $pk; +} + +sub _table_uniq_info { + my ($self, $table) = @_; + + my $constraints = $self->_constraints_for($table, 'U'); + + my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints; + return \@uniqs; +} + +sub _table_fk_info { + my ($self, $table) = @_; + + my $local_columns = $self->_constraints_for($table, 'R'); + + my $dbh = $self->schema->storage->dbh; + local $dbh->{FetchHashKeyName} = 'NAME_lc'; + + my $sth = $dbh->prepare(<<'EOF'); +select c.constrname local_constraint, rt.tabname remote_table, rc.constrname remote_constraint, ri.* +from sysconstraints c +join systables t on c.tabid = t.tabid +join sysreferences r on c.constrid = r.constrid +join sysconstraints rc on rc.constrid = r.primary +join systables rt on r.ptabid = rt.tabid +join sysindexes ri on rc.idxname = ri.idxname +where t.tabname = ? and c.constrtype = 'R' +EOF + $sth->execute($table); + my $remotes = $sth->fetchall_hashref('local_constraint'); + $sth->finish; + + my @rels; + + while (my ($local_constraint, $remote_info) = each %$remotes) { + push @rels, { + local_columns => $local_columns->{$local_constraint}, + remote_columns => $self->_idx_colnames($remote_info, $self->_colnames_by_colno($remote_info->{remote_table})), + remote_table => $remote_info->{remote_table}, + }; + } + + return \@rels; +} + +sub _columns_info_for { + my $self = shift; + my ($table) = @_; + + my $result = $self->next::method(@_); + + my $dbh = $self->schema->storage->dbh; + local $dbh->{FetchHashKeyName} = 'NAME_lc'; + + my $sth = $dbh->prepare(<<'EOF'); +select c.colname, c.coltype, d.type deflt_type, d.default deflt +from syscolumns c +join systables t on c.tabid = t.tabid +left join sysdefaults d on t.tabid = d.tabid and c.colno = d.colno +where t.tabname = ? +EOF + $sth->execute($table); + my $cols = $sth->fetchall_hashref('colname'); + $sth->finish; + + while (my ($col, $info) = each %$cols) { + my $type = $info->{coltype} % 256; + + if ($type == 6) { # SERIAL + $result->{$col}{is_auto_increment} = 1; + } + + if (looks_like_number $result->{$col}{data_type}) { + if ($type == 7) { + $result->{$col}{data_type} = 'date'; + } + elsif ($type == 10) { + $result->{$col}{data_type} = 'datetime'; + } + } + + my ($default_type, $default) = @{$info}{qw/deflt_type deflt/}; + + next unless $default_type; + + if ($default_type eq 'C') { + my $current = 'CURRENT YEAR TO FRACTION(5)'; + $result->{$col}{default_value} = \$current; + } + elsif ($default_type eq 'T') { + my $today = 'TODAY'; + $result->{$col}{default_value} = \$today; + } + else { + $default = (split ' ', $default)[-1]; + + # remove trailing 0s in floating point defaults + if (looks_like_number $default && int $default != $default) { + $default =~ s/0+\z//; + } + + $result->{$col}{default_value} = $default; + } + } + + return $result; +} + +=head1 SEE ALSO + +L, L, +L + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + +1; +# vim:et sw=4 sts=4 tw=0: diff --git a/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm b/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm index 63cacda..8cf364d 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/SQLAnywhere.pm @@ -18,7 +18,7 @@ SQL Anywhere Implementation. =head1 DESCRIPTION -See L. +See L and L. =cut diff --git a/t/19informix_common.t b/t/19informix_common.t new file mode 100644 index 0000000..2df6a97 --- /dev/null +++ b/t/19informix_common.t @@ -0,0 +1,28 @@ +use strict; +use lib qw(t/lib); +use dbixcsl_common_tests; + +# This test doesn't run over a shared memory connection, because of the single connection limit. + +my $dsn = $ENV{DBICTEST_INFORMIX_DSN} || ''; +my $user = $ENV{DBICTEST_INFORMIX_USER} || ''; +my $password = $ENV{DBICTEST_INFORMIX_PASS} || ''; + +my $tester = dbixcsl_common_tests->new( + vendor => 'Informix', + auto_inc_pk => 'SERIAL PRIMARY KEY', + null => '', + default_function => 'CURRENT YEAR TO FRACTION(5)', + default_function_def => 'DATETIME YEAR TO FRACTION(5) DEFAULT CURRENT YEAR TO FRACTION(5)', + dsn => $dsn, + user => $user, + password => $password, +); + +if( !$dsn ) { + $tester->skip_tests('You need to set the DBICTEST_INFORMIX_DSN, _USER, and _PASS environment variables'); +} +else { + $tester->run_tests(); +} +# vim:et sts=4 sw=4 tw=0: diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm index 0ecbda0..810c8ea 100644 --- a/t/lib/dbixcsl_common_tests.pm +++ b/t/lib/dbixcsl_common_tests.pm @@ -891,6 +891,7 @@ sub test_schema { my $before_digest = $digest->digest; + $conn->storage->disconnect; # needed for Firebird and Informix my $dbh = $self->dbconnect(1); { @@ -904,7 +905,6 @@ sub test_schema { } $dbh->disconnect; - $conn->storage->disconnect; # needed for Firebird sleep 1; @@ -1406,9 +1406,16 @@ sub create { }, $make_auto_inc->(qw/loader_test11 id11/), - (q{ ALTER TABLE loader_test10 ADD CONSTRAINT } . - q{ loader_test11_fk FOREIGN KEY (loader_test11) } . - q{ REFERENCES loader_test11 (id11) }), + (lc($self->{vendor}) ne 'informix' ? + (q{ ALTER TABLE loader_test10 ADD CONSTRAINT loader_test11_fk } . + q{ FOREIGN KEY (loader_test11) } . + q{ REFERENCES loader_test11 (id11) }) + : + (q{ ALTER TABLE loader_test10 ADD CONSTRAINT } . + q{ FOREIGN KEY (loader_test11) } . + q{ REFERENCES loader_test11 (id11) } . + q{ CONSTRAINT loader_test11_fk }) + ), ); @statements_advanced_sqlite = (