lib/SQL/Translator/Parser/DBI/Oracle.pm

   1 package SQL::Translator::Parser::DBI::Oracle;
   2
   3 =head1 NAME
   4
   5 SQL::Translator::Parser::DBI::Oracle - parser for DBD::Oracle
   6
   7 =head1 SYNOPSIS
   8
   9 See SQL::Translator::Parser::DBI.
  10
  11 =head1 DESCRIPTION
  12
  13 Uses DBI introspection methods to determine schema details.
  14
  15 =cut
  16
  17 use strict;
  18 use warnings;
  19 use DBI;
  20 use SQL::Translator::Schema::Constants;
  21 use SQL::Translator::Schema::Table;
  22 use SQL::Translator::Schema::Field;
  23 use SQL::Translator::Schema::Constraint;
  24
  25 our $VERSION = '1.59';
  26
  27 # -------------------------------------------------------------------
  28 sub parse {
  29     my ( $tr, $dbh ) = @_;
  30
  31     my $schema = $tr->schema;
  32
  33     my $db_user = uc $tr->parser_args()->{db_user};
  34     my $sth = $dbh->table_info(undef, $db_user, '%', 'TABLE');
  35
  36     while(my $table_info = $sth->fetchrow_hashref('NAME_uc')) {
  37         next if ($table_info->{TABLE_NAME} =~ /\$/);
  38
  39         # create the table
  40
  41         my $table = $schema->add_table(
  42             name => $table_info->{TABLE_NAME},
  43             type => $table_info->{TABLE_TYPE},
  44         );
  45
  46         # add the fields (columns) for this table
  47
  48         my $sth;
  49
  50         $sth = $dbh->column_info(
  51             undef,
  52             $table_info->{TABLE_SCHEM},
  53             $table_info->{TABLE_NAME},
  54             '%'
  55         );
  56
  57         while(my $column = $sth->fetchrow_hashref('NAME_uc')) {
  58             my $f = $table->add_field(
  59                 name          => $column->{COLUMN_NAME},
  60                 default_value => $column->{COLUMN_DEF},
  61                 data_type     => $column->{TYPE_NAME},
  62                 order         => $column->{ORDINAL_POSITION},
  63                 size          => $column->{COLUMN_SIZE},
  64             ) || die $table->error;
  65
  66             $f->is_nullable( $column->{NULLABLE} == 1 );
  67         }
  68
  69         # add the primary key info
  70
  71         $sth = $dbh->primary_key_info(
  72             undef,
  73             $table_info->{TABLE_SCHEM},
  74             $table_info->{TABLE_NAME},
  75         );
  76
  77         while(my $primary_key = $sth->fetchrow_hashref('NAME_uc')) {
  78             my $f = $table->get_field( $primary_key->{COLUMN_NAME} );
  79             $f->is_primary_key(1);
  80         }
  81
  82         # add the foreign key info (constraints)
  83
  84         $sth = $dbh->foreign_key_info(
  85             undef,
  86             undef,
  87             undef,
  88             undef,
  89             $table_info->{TABLE_SCHEM},
  90             $table_info->{TABLE_NAME},
  91         );
  92
  93         my $cons = {};
  94         while(my $foreign_key = $sth->fetchrow_hashref('NAME_uc')) {
  95             my $name = $foreign_key->{FK_NAME};
  96             $cons->{$name}->{reference_table} = $foreign_key->{UK_TABLE_NAME};
  97             push @{ $cons->{$name}->{fields} },
  98                 $foreign_key->{FK_COLUMN_NAME};
  99             push @{ $cons->{$name}->{reference_fields} },
 100                 $foreign_key->{UK_COLUMN_NAME};
 101         }
 102
 103         for my $name ( keys %$cons ) {
 104             my $c = $table->add_constraint(
 105                 type             => FOREIGN_KEY,
 106                 name             => $name,
 107                 fields           => $cons->{$name}->{fields},
 108                 reference_fields => $cons->{$name}->{reference_fields},
 109                 reference_table  => $cons->{$name}->{reference_table},
 110             ) || die $table->error;
 111         }
 112     }
 113
 114     return 1;
 115 }
 116
 117 1;
 118
 119 =pod
 120
 121 =head1 AUTHOR
 122
 123 Earl Cahill E<lt>cpan@spack.netE<gt>.
 124
 125 =head1 ACKNOWLEDGEMENT
 126
 127 Initial revision of this module came almost entirely from work done by
 128 Todd Hepler E<lt>thepler@freeshell.orgE<gt>.  My changes were
 129 quite minor (ensuring NAME_uc, changing a couple variable names,
 130 skipping tables with a $ in them).
 131
 132 Todd claimed his work to be an almost verbatim copy of
 133 SQL::Translator::Parser::DBI::PostgreSQL revision 1.7
 134
 135 For me, the real work happens in DBD::Oracle and DBI, which, also
 136 for me, that is the beauty of having introspection methods in DBI.
 137
 138 =head1 SEE ALSO
 139
 140 SQL::Translator, DBD::Oracle.
 141
 142 =cut