DBSchema/DBD/Oracle.pm

   1 package DBIx::DBSchema::DBD::Oracle;
   2
   3 use strict;
   4 use vars qw($VERSION @ISA %typemap);
   5 use DBIx::DBSchema::DBD;
   6
   7 $VERSION = '0.01';
   8 @ISA = qw(DBIx::DBSchema::DBD);
   9
  10 %typemap = (
  11   'VARCHAR'         => 'VARCHAR2',
  12   'SERIAL'          => 'INTEGER',
  13   'LONG VARBINARY'  => 'BLOB',
  14   'TIMESTAMP'       => 'DATE',
  15   'BOOL'            => 'INTEGER'
  16 );
  17
  18 =head1 NAME
  19
  20 DBIx::DBSchema::DBD::Oracle - Oracle native driver for DBIx::DBSchema
  21
  22 =head1 SYNOPSIS
  23
  24 use DBI;
  25 use DBIx::DBSchema;
  26
  27 $dbh = DBI->connect('dbi:Oracle:tns_service_name', 'user','pass');
  28 $schema = new_native DBIx::DBSchema $dbh;
  29
  30 =head1 DESCRIPTION
  31
  32 This module implements a Oracle-native driver for DBIx::DBSchema.
  33
  34 =head1 AUTHOR
  35
  36 Daniel Hanks <hanksdc@about-inc.com>
  37
  38 =cut
  39
  40 ### Return column name, column type, nullability, column length, column default,
  41 ### and a field reserved for driver-specific use
  42 sub columns {
  43   my ($proto, $dbh, $table) = @_;
  44   return $proto->_column_info($dbh, $table);
  45 }
  46
  47 sub column {
  48   my ($proto, $dbh, $table, $column) = @_;
  49   return $proto->_column_info($dbh, $table, $column);
  50 }
  51
  52 sub _column_info {
  53   my ($proto, $dbh, $table, $column) = @_;
  54   my $sql = "SELECT column_name, data_type,
  55                     CASE WHEN nullable = 'Y' THEN 1
  56                          WHEN nullable = 'N' THEN 0
  57                          ELSE 1
  58                     END AS nullable,
  59                     data_length, data_default, NULL AS reserved
  60                FROM user_tab_columns
  61               WHERE table_name = ?";
  62      $sql .= "  AND column_name = ?" if defined($column);
  63   if(defined($column)) {
  64     return $dbh->selectrow_arrayref($sql, undef, $table, $column);
  65   } else { ### Assume columns
  66     return $dbh->selectall_arrayref($sql, undef, $table);
  67   }
  68 }
  69
  70 ### This is broken. Primary keys can be comprised of any subset of a tables
  71 ### fields, not just one field, as this module assumes.
  72 sub primary_key {
  73   my ($proto, $dbh, $table) = @_;
  74   my $sql = "SELECT column_name
  75                FROM user_constraints uc, user_cons_columns ucc
  76               WHERE uc.constraint_name = ucc.constraint_name
  77                 AND uc.constraint_type = 'P'
  78                 AND uc.table_name = ?";
  79   my ($key) = $dbh->selectrow_array($sql, undef, $table);
  80   return $key;
  81 }
  82
  83 ### Wraoper around _index_info
  84 sub unique {
  85   my ($proto, $dbh, $table) = @_;
  86   return $proto->_index_info($dbh, $table, 'UNIQUE');
  87 }
  88
  89 ### Wrapper around _index_info
  90 sub index {
  91   my ($proto, $dbh, $table) = @_;
  92   return $proto->_index_info($dbh, $table, 'NONUNIQUE');
  93 }
  94
  95 ### Collect info about unique or non-unique indexes
  96 ### $type must be 'UNIQUE' or 'NONUNIQUE'
  97 sub _index_info {
  98   my ($proto, $dbh, $table, $type) = @_;
  99
 100   ### Sanity-check
 101   die "\$type must be 'UNIQUE' or 'NONUNIQUE'"
 102     unless $type =~ /^(NON)?UNIQUE$/;
 103
 104   ### Set up the query
 105   my $sql = "SELECT ui.index_name, uic.column_name
 106                FROM user_indexes ui, user_ind_columns uic
 107               WHERE ui.index_name = uic.index_name
 108                 AND ui.uniqueness = ?
 109                 AND table_name = ?";
 110   my $sth = $dbh->prepare($sql);
 111   $sth->execute($table, $type);
 112
 113   ### Now collect the results
 114   my $results = {};
 115   while(my ($idx, $col) = $sth->fetchrow_array()) {
 116     if(!exists($results->{$idx})) {
 117       $results->{$idx} = [];
 118     }
 119     push @{$results->{$idx}}, $col;
 120   }
 121   return $results;
 122 }
 123
 124