From: Brandon Black Date: Fri, 30 Mar 2007 22:37:04 +0000 (+0000) Subject: Merging oracle branch into current: X-Git-Tag: 0.03999_01~9 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e726230000730abe2ee6834f9569a7196e437e15;p=dbsrgits%2FDBIx-Class-Schema-Loader.git Merging oracle branch into current: r27336 (orig r3165): blblack | 2007-03-30 17:29:24 -0500 tweak up the oracle support, needs some testing r20321 (orig r2775): blblack | 2006-09-12 16:21:11 -0500 added Oracle code from TSUNODA Kazuya r20319 (orig r2773): blblack | 2006-09-12 15:58:20 -0500 creating new oracle branch --- diff --git a/Build.PL b/Build.PL index f6f1ce2..81897ad 100644 --- a/Build.PL +++ b/Build.PL @@ -25,6 +25,7 @@ my %arguments = ( 'DBD::mysql' => 3.0003, 'DBD::Pg' => 1.49, 'DBD::DB2' => 0.78, + 'DBD::Oracle' => 0.19, }, build_requires => { 'Test::More' => 0.32, diff --git a/Changes b/Changes index cb1e628..d9fa464 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,7 @@ Revision history for Perl extension DBIx::Class::Schema::Loader + - Added *experimental* Oracle support from work done + by Tsunoda Kazuya some months ago. Not well tested. - Added "rescan" schema (and loader) method, which picks up newly created tables at runtime - Made dump_to_dir / dump_overwrite much more intelligent diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm new file mode 100644 index 0000000..42dec0b --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm @@ -0,0 +1,142 @@ +package DBIx::Class::Schema::Loader::DBI::Oracle; + +use strict; +use warnings; +use base 'DBIx::Class::Schema::Loader::DBI'; +use Carp::Clan qw/^DBIx::Class/; +use Class::C3; + +our $VERSION = '0.03999_01'; + +=head1 NAME + +DBIx::Class::Schema::Loader::DBI::Oracle - DBIx::Class::Schema::Loader::DBI +Oracle Implementation. + +=head1 SYNOPSIS + + package My::Schema; + use base qw/DBIx::Class::Schema::Loader/; + + __PACKAGE__->loader_options( debug => 1 ); + + 1; + +=head1 DESCRIPTION + +See L. + +This module is considered experimental and not well tested yet. + +=cut + +sub _table_columns { + my ($self, $table) = @_; + + my $dbh = $self->schema->storage->dbh; + + my $sth = $dbh->prepare($self->schema->storage->sql_maker->select($table, undef, \'1 = 0')); + $sth->execute; + return \@{$sth->{NAME_lc}}; +} + +sub _tables_list { + my $self = shift; + + my $dbh = $self->schema->storage->dbh; + + my @tables; + for my $table ( $dbh->tables(undef, $self->db_schema, '%', 'TABLE,VIEW') ) { #catalog, schema, table, type + my $quoter = $dbh->get_info(29); + $table =~ s/$quoter//g; + + # remove "user." (schema) prefixes + $table =~ s/\w+\.//; + + next if $table eq 'PLAN_TABLE'; + $table = lc $table; + push @tables, $1 + if $table =~ /\A(\w+)\z/; + } + return @tables; +} + +sub _table_uniq_info { + my ($self, $table) = @_; + + my @uniqs; + my $dbh = $self->schema->storage->dbh; + + my $sth = $dbh->prepare_cached( + qq{SELECT constraint_name, ucc.column_name FROM user_constraints JOIN user_cons_columns ucc USING (constraint_name) WHERE ucc.table_name=? AND constraint_type='U'} + ,{}, 1); + + $sth->execute(uc $table); + my %constr_names; + while(my $constr = $sth->fetchrow_arrayref) { + my $constr_name = $constr->[0]; + my $constr_def = $constr->[1]; + $constr_name =~ s/\Q$self->{_quoter}\E//; + $constr_def =~ s/\Q$self->{_quoter}\E//; + push @{$constr_names{$constr_name}}, lc $constr_def; + } + map { + push(@uniqs, [ lc $_ => $constr_names{$_} ]); + } keys %constr_names; + + return \@uniqs; +} + +sub _table_pk_info { + my ( $self, $table ) = @_; + return $self->SUPER::_table_pk_info(uc $table); +} + +sub _table_fk_info { + my ($self, $table) = @_; + + my $dbh = $self->schema->storage->dbh; + my $sth = $dbh->foreign_key_info( '', '', '', '', + $self->db_schema, uc $table ); + return [] if !$sth; + + my %rels; + + my $i = 1; # for unnamed rels, which hopefully have only 1 column ... + while(my $raw_rel = $sth->fetchrow_arrayref) { + my $uk_tbl = lc $raw_rel->[2]; + my $uk_col = lc $raw_rel->[3]; + my $fk_col = lc $raw_rel->[7]; + my $relid = ($raw_rel->[11] || ( "__dcsld__" . $i++ )); + $uk_tbl =~ s/\Q$self->{_quoter}\E//g; + $uk_col =~ s/\Q$self->{_quoter}\E//g; + $fk_col =~ s/\Q$self->{_quoter}\E//g; + $relid =~ s/\Q$self->{_quoter}\E//g; + $rels{$relid}->{tbl} = $uk_tbl; + $rels{$relid}->{cols}->{$uk_col} = $fk_col; + } + + my @rels; + foreach my $relid (keys %rels) { + push(@rels, { + remote_columns => [ keys %{$rels{$relid}->{cols}} ], + local_columns => [ values %{$rels{$relid}->{cols}} ], + remote_table => $rels{$relid}->{tbl}, + }); + } + + return \@rels; +} + +=head1 SEE ALSO + +L, L, +L + +=head1 AUTHOR + +TSUNODA Kazuya C + +=cut + +1; diff --git a/t/01use.t b/t/01use.t index 8ebdc27..ace9e5e 100644 --- a/t/01use.t +++ b/t/01use.t @@ -10,5 +10,6 @@ BEGIN { use_ok 'DBIx::Class::Schema::Loader::DBI::mysql'; use_ok 'DBIx::Class::Schema::Loader::DBI::Pg'; use_ok 'DBIx::Class::Schema::Loader::DBI::DB2'; + use_ok 'DBIx::Class::Schema::Loader::DBI::Oracle'; use_ok 'DBIx::Class::Schema::Loader::DBI::Writing'; } diff --git a/t/14ora_common.t b/t/14ora_common.t new file mode 100644 index 0000000..ad63787 --- /dev/null +++ b/t/14ora_common.t @@ -0,0 +1,22 @@ +use strict; +use lib qw(t/lib); +use dbixcsl_common_tests; + +my $dsn = $ENV{DBICTEST_ORA_DSN} || ''; +my $user = $ENV{DBICTEST_ORA_USER} || ''; +my $password = $ENV{DBICTEST_ORA_PASS} || ''; + +my $tester = dbixcsl_common_tests->new( + vendor => 'Oracle', + auto_inc_pk => 'SERIAL NOT NULL PRIMARY KEY', + dsn => $dsn, + user => $user, + password => $password, +); + +if( !$dsn || !$user ) { + $tester->skip_tests('You need to set the DBICTEST_ORA_DSN, _USER, and _PASS environment variables'); +} +else { + $tester->run_tests(); +}