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