File Coverage

blib/lib/DBIx/DBSchema/DBD/Oracle.pm
Criterion Covered Total %
statement 9 39 23.0
branch 0 8 0.0
condition n/a
subroutine 3 10 30.0
pod 5 5 100.0
total 17 62 27.4


line stmt bran cond sub pod time code
1             package DBIx::DBSchema::DBD::Oracle;
2              
3 1     1   466 use strict;
  1         6  
  1         35  
4 1     1   5 use vars qw($VERSION @ISA %typemap);
  1         2  
  1         60  
5 1     1   339 use DBIx::DBSchema::DBD;
  1         2  
  1         402  
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
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 0     0 1   my ($proto, $dbh, $table) = @_;
44 0           return $proto->_column_info($dbh, $table);
45             }
46              
47             sub column {
48 0     0 1   my ($proto, $dbh, $table, $column) = @_;
49 0           return $proto->_column_info($dbh, $table, $column);
50             }
51              
52             sub _column_info {
53 0     0     my ($proto, $dbh, $table, $column) = @_;
54 0           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 0 0         $sql .= " AND column_name = ?" if defined($column);
63 0 0         if(defined($column)) {
64 0           return $dbh->selectrow_arrayref($sql, undef, $table, $column);
65             } else { ### Assume columns
66 0           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 0     0 1   my ($proto, $dbh, $table) = @_;
74 0           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 0           my ($key) = $dbh->selectrow_array($sql, undef, $table);
80 0           return $key;
81             }
82              
83             ### Wraoper around _index_info
84             sub unique {
85 0     0 1   my ($proto, $dbh, $table) = @_;
86 0           return $proto->_index_info($dbh, $table, 'UNIQUE');
87             }
88              
89             ### Wrapper around _index_info
90             sub index {
91 0     0 1   my ($proto, $dbh, $table) = @_;
92 0           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 0     0     my ($proto, $dbh, $table, $type) = @_;
99              
100             ### Sanity-check
101 0 0         die "\$type must be 'UNIQUE' or 'NONUNIQUE'"
102             unless $type =~ /^(NON)?UNIQUE$/;
103              
104             ### Set up the query
105 0           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 0           my $sth = $dbh->prepare($sql);
111 0           $sth->execute($table, $type);
112              
113             ### Now collect the results
114 0           my $results = {};
115 0           while(my ($idx, $col) = $sth->fetchrow_array()) {
116 0 0         if(!exists($results->{$idx})) {
117 0           $results->{$idx} = [];
118             }
119 0           push @{$results->{$idx}}, $col;
  0            
120             }
121 0           return $results;
122             }
123              
124