From: Rafael Kitover Date: Mon, 1 Mar 2010 09:50:55 +0000 (-0500) Subject: some preliminary support for Firebird X-Git-Tag: 0.06000~72 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4cbddf8d2c6f28d894d0497a31e7c2503e0e7994;p=dbsrgits%2FDBIx-Class-Schema-Loader.git some preliminary support for Firebird --- diff --git a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm new file mode 100644 index 0000000..e731182 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm @@ -0,0 +1,122 @@ +package DBIx::Class::Schema::Loader::DBI::InterBase; + +use strict; +use warnings; +use namespace::autoclean; +use Class::C3; +use base qw/DBIx::Class::Schema::Loader::DBI/; +use Carp::Clan qw/^DBIx::Class/; + +our $VERSION = '0.05003'; + +=head1 NAME + +DBIx::Class::Schema::Loader::DBI::InterBase - DBIx::Class::Schema::Loader::DBI +Firebird Implementation. + +=head1 DESCRIPTION + +See L. + +=cut + +sub _table_pk_info { + my ($self, $table) = @_; + + my $dbh = $self->schema->storage->dbh; + my $sth = $dbh->prepare(<<'EOF'); +SELECT iseg.rdb$field_name +FROM rdb$relation_constraints rc +JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name +WHERE rc.rdb$constraint_type = 'PRIMARY KEY' and rc.rdb$relation_name = ? +ORDER BY iseg.rdb$field_position +EOF + $sth->execute($table); + + my @keydata; + + while (my ($col) = $sth->fetchrow_array) { + s/^\s+//, s/\s+\z// for $col; + + push @keydata, lc $col; + } + + return \@keydata; +} + +sub _table_fk_info { + my ($self, $table) = @_; + + my ($local_cols, $remote_cols, $remote_table, @rels); + my $dbh = $self->schema->storage->dbh; + my $sth = $dbh->prepare(<<'EOF'); +SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col +FROM rdb$relation_constraints rc +JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name +JOIN rdb$indices li ON rc.rdb$index_name = li.rdb$index_name +JOIN rdb$indices ri ON li.rdb$foreign_key = ri.rdb$index_name +JOIN rdb$index_segments riseg ON iseg.rdb$field_position = riseg.rdb$field_position and ri.rdb$index_name = riseg.rdb$index_name +WHERE rc.rdb$constraint_type = 'FOREIGN KEY' and rc.rdb$relation_name = ? +ORDER BY iseg.rdb$field_position +EOF + $sth->execute($table); + + while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) { + s/^\s+//, s/\s+\z// for $fk, $local_col, $remote_tab, $remote_col; + + push @{$local_cols->{$fk}}, lc $local_col; + push @{$remote_cols->{$fk}}, lc $remote_col; + $remote_table->{$fk} = $remote_tab; + } + + foreach my $fk (keys %$remote_table) { + push @rels, { + local_columns => $local_cols->{$fk}, + remote_columns => $remote_cols->{$fk}, + remote_table => $remote_table->{$fk}, + }; + } + return \@rels; +} + +sub _table_uniq_info { + my ($self, $table) = @_; + + my $dbh = $self->schema->storage->dbh; + my $sth = $dbh->prepare(<<'EOF'); +SELECT rc.rdb$constraint_name, iseg.rdb$field_name +FROM rdb$relation_constraints rc +JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name +WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ? +ORDER BY iseg.rdb$field_position +EOF + $sth->execute($table); + + my $constraints; + while (my ($constraint_name, $column) = $sth->fetchrow_array) { + s/^\s+//, s/\s+\z// for $constraint_name, $column; + + push @{$constraints->{$constraint_name}}, lc $column; + } + + my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints; + return \@uniqs; +} + +=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; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Firebird.pm b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Firebird.pm new file mode 100644 index 0000000..226d0a5 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/Firebird.pm @@ -0,0 +1,42 @@ +package DBIx::Class::Schema::Loader::DBI::ODBC::Firebird; + +use strict; +use warnings; +use base qw/ + DBIx::Class::Schema::Loader::DBI::ODBC + DBIx::Class::Schema::Loader::DBI::InterBase +/; +use Carp::Clan qw/^DBIx::Class/; +use Class::C3; + +our $VERSION = '0.05003'; + +=head1 NAME + +DBIx::Class::Schema::Loader::DBI::ODBC::Firebird - ODBC wrapper for +L + +=head1 DESCRIPTION + +Proxy for L when using L. + +See L for usage information. + +=head1 SEE ALSO + +L, +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; diff --git a/t/18firebird_common.t b/t/18firebird_common.t new file mode 100644 index 0000000..62da41c --- /dev/null +++ b/t/18firebird_common.t @@ -0,0 +1,47 @@ +use strict; +use lib qw(t/lib); +use dbixcsl_common_tests; + +my $dsn = $ENV{DBICTEST_FIREBIRD_DSN} || ''; +my $user = $ENV{DBICTEST_FIREBIRD_USER} || ''; +my $password = $ENV{DBICTEST_FIREBIRD_PASS} || ''; + +my $tester = dbixcsl_common_tests->new( + vendor => 'Firebird', + auto_inc_pk => 'INTEGER NOT NULL PRIMARY KEY', + auto_inc_cb => sub { + my ($table, $col) = @_; + return ( + qq{ CREATE GENERATOR gen_${table}_${col} }, + qq{ + CREATE TRIGGER ${table}_bi FOR $table + ACTIVE BEFORE INSERT POSITION 0 + AS + BEGIN + IF (NEW.$col IS NULL) THEN + NEW.$col = GEN_ID(gen_${table}_${col},1); + END + } + ); + }, + auto_inc_drop_cb => sub { + my ($table, $col) = @_; + return ( + qq{ DROP TRIGGER ${table}_bi }, + qq{ DROP GENERATOR gen_${table}_${col} }, + ); + }, + null => '', + date_datatype => 'TIMESTAMP', + dsn => $dsn, + user => $user, + password => $password, + connect_info_opts => { on_connect_call => 'use_softcommit' }, +); + +if( !$dsn ) { + $tester->skip_tests('You need to set the DBICTEST_FIREBIRD_DSN, _USER, and _PASS environment variables'); +} +else { + $tester->run_tests(); +} diff --git a/t/18firebird_odbc_common.t b/t/18firebird_odbc_common.t new file mode 100644 index 0000000..323b6f2 --- /dev/null +++ b/t/18firebird_odbc_common.t @@ -0,0 +1,46 @@ +use strict; +use lib qw(t/lib); +use dbixcsl_common_tests; + +my $dsn = $ENV{DBICTEST_FIREBIRD_ODBC_DSN} || ''; +my $user = $ENV{DBICTEST_FIREBIRD_ODBC_USER} || ''; +my $password = $ENV{DBICTEST_FIREBIRD_ODBC_PASS} || ''; + +my $tester = dbixcsl_common_tests->new( + vendor => 'Firebird', + auto_inc_pk => 'INTEGER NOT NULL PRIMARY KEY', + auto_inc_cb => sub { + my ($table, $col) = @_; + return ( + qq{ CREATE GENERATOR gen_${table}_${col} }, + qq{ + CREATE TRIGGER ${table}_bi FOR $table + ACTIVE BEFORE INSERT POSITION 0 + AS + BEGIN + IF (NEW.$col IS NULL) THEN + NEW.$col = GEN_ID(gen_${table}_${col},1); + END + } + ); + }, + auto_inc_drop_cb => sub { + my ($table, $col) = @_; + return ( + qq{ DROP TRIGGER ${table}_bi }, + qq{ DROP GENERATOR gen_${table}_${col} }, + ); + }, + null => '', + date_datatype => 'TIMESTAMP', + dsn => $dsn, + user => $user, + password => $password, +); + +if( !$dsn ) { + $tester->skip_tests('You need to set the DBICTEST_FIREBIRD_ODBC_DSN, _USER, and _PASS environment variables'); +} +else { + $tester->run_tests(); +} diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm index b56fcf5..92583bb 100644 --- a/t/lib/dbixcsl_common_tests.pm +++ b/t/lib/dbixcsl_common_tests.pm @@ -38,6 +38,8 @@ sub new { # Optional extra tables and tests $self->{extra} ||= {}; + $self->{date_datatype} ||= 'DATE'; + # Not all DBS do SQL-standard CURRENT_TIMESTAMP $self->{default_function} ||= "CURRENT_TIMESTAMP"; $self->{default_function_def} ||= "TIMESTAMP DEFAULT $self->{default_function}"; @@ -191,7 +193,7 @@ sub setup_schema { $warn_count++; is(scalar(@loader_warnings), $warn_count, "Expected loader warning") or diag @loader_warnings; - is(grep(/loader_test9 has no primary key/, @loader_warnings), 1, + is(grep(/loader_test9 has no primary key/i, @loader_warnings), 1, "Missing PK warning"); } } @@ -208,8 +210,13 @@ sub test_schema { my $classes = {}; foreach my $source_name ($schema_class->sources) { my $table_name = $schema_class->source($source_name)->from; + $monikers->{$table_name} = $source_name; $classes->{$table_name} = $schema_class . q{::} . $source_name; + + # some DBs (Firebird) uppercase everything + $monikers->{lc $table_name} = $source_name; + $classes->{lc $table_name} = $schema_class . q{::} . $source_name; } my $moniker1 = $monikers->{loader_test1s}; @@ -222,12 +229,12 @@ sub test_schema { my $rsobj2 = $conn->resultset($moniker2); check_no_duplicate_unique_constraints($class2); - my $moniker23 = $monikers->{LOADER_TEST23}; - my $class23 = $classes->{LOADER_TEST23}; + my $moniker23 = $monikers->{LOADER_TEST23} || $monikers->{loader_test23}; + my $class23 = $classes->{LOADER_TEST23} || $classes->{loader_test23}; my $rsobj23 = $conn->resultset($moniker1); - my $moniker24 = $monikers->{LoAdEr_test24}; - my $class24 = $classes->{LoAdEr_test24}; + my $moniker24 = $monikers->{LoAdEr_test24} || $monikers->{loader_test24}; + my $class24 = $classes->{LoAdEr_test24} || $classes->{loader_test24}; my $rsobj24 = $conn->resultset($moniker2); my $moniker35 = $monikers->{loader_test35}; @@ -774,6 +781,7 @@ sub test_schema { } $dbh->disconnect; + $conn->storage->disconnect; # needed for Firebird sleep 1; @@ -804,6 +812,8 @@ sub test_schema { } $self->{extra}->{run}->($conn, $monikers, $classes) if $self->{extra}->{run}; + + $conn->storage->disconnect; } sub check_no_duplicate_unique_constraints { @@ -898,7 +908,7 @@ sub create { qq{ CREATE TABLE loader_test36 ( id INTEGER NOT NULL PRIMARY KEY, - a_date DATE, + a_date $self->{date_datatype}, b_char_as_data VARCHAR(100), c_char_as_data VARCHAR(100) ) $self->{innodb}