Commit | Line | Data |
d87d939a |
1 | package DBIx::Class::Schema::Loader::DBI::Oracle; |
e7262300 |
2 | |
3 | use strict; |
4 | use warnings; |
6b0e47fc |
5 | use base qw/ |
6 | DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault |
7 | DBIx::Class::Schema::Loader::DBI |
8 | /; |
e7262300 |
9 | use Carp::Clan qw/^DBIx::Class/; |
10 | use Class::C3; |
11 | |
9990e58f |
12 | our $VERSION = '0.07000'; |
e7262300 |
13 | |
14 | =head1 NAME |
15 | |
16 | DBIx::Class::Schema::Loader::DBI::Oracle - DBIx::Class::Schema::Loader::DBI |
17 | Oracle Implementation. |
18 | |
e7262300 |
19 | =head1 DESCRIPTION |
20 | |
21 | See L<DBIx::Class::Schema::Loader::Base>. |
22 | |
e7262300 |
23 | =cut |
24 | |
d0e184e9 |
25 | sub _setup { |
26 | my $self = shift; |
27 | |
28 | $self->next::method(@_); |
29 | |
30 | my $dbh = $self->schema->storage->dbh; |
46065bcb |
31 | |
32 | my ($current_schema) = $dbh->selectrow_array('SELECT USER FROM DUAL', {}); |
33 | |
34 | $self->{db_schema} ||= $current_schema; |
35 | |
36 | if (lc($self->db_schema) ne lc($current_schema)) { |
37 | $dbh->do('ALTER SESSION SET current_schema=' . $self->db_schema); |
38 | } |
bc1cb85e |
39 | |
40 | if (not defined $self->preserve_case) { |
41 | $self->preserve_case(0); |
42 | } |
d0e184e9 |
43 | } |
44 | |
075aff97 |
45 | sub _table_as_sql { |
e7262300 |
46 | my ($self, $table) = @_; |
47 | |
075aff97 |
48 | return $self->_quote_table_name($table); |
e7262300 |
49 | } |
50 | |
51 | sub _tables_list { |
bfb43060 |
52 | my ($self, $opts) = @_; |
e7262300 |
53 | |
54 | my $dbh = $self->schema->storage->dbh; |
55 | |
56 | my @tables; |
57 | for my $table ( $dbh->tables(undef, $self->db_schema, '%', 'TABLE,VIEW') ) { #catalog, schema, table, type |
58 | my $quoter = $dbh->get_info(29); |
59 | $table =~ s/$quoter//g; |
60 | |
61 | # remove "user." (schema) prefixes |
62 | $table =~ s/\w+\.//; |
63 | |
64 | next if $table eq 'PLAN_TABLE'; |
65 | $table = lc $table; |
66 | push @tables, $1 |
67 | if $table =~ /\A(\w+)\z/; |
68 | } |
ffb03c96 |
69 | |
bfb43060 |
70 | return $self->_filter_tables(\@tables, $opts); |
e7262300 |
71 | } |
72 | |
4337bddf |
73 | sub _table_columns { |
74 | my ($self, $table) = @_; |
75 | |
76 | my $dbh = $self->schema->storage->dbh; |
77 | |
78 | my $sth = $dbh->column_info(undef, $self->db_schema, uc $table, '%'); |
79 | return [ map lc($_->{COLUMN_NAME}), @{ $sth->fetchall_arrayref({ COLUMN_NAME => 1 }) || [] } ]; |
80 | } |
81 | |
e7262300 |
82 | sub _table_uniq_info { |
83 | my ($self, $table) = @_; |
84 | |
e7262300 |
85 | my $dbh = $self->schema->storage->dbh; |
86 | |
87 | my $sth = $dbh->prepare_cached( |
65ab592d |
88 | q{ |
c7bf4194 |
89 | SELECT constraint_name, acc.column_name |
90 | FROM all_constraints JOIN all_cons_columns acc USING (constraint_name) |
8803e4ed |
91 | WHERE acc.table_name=? and acc.owner = ? AND constraint_type='U' |
c7bf4194 |
92 | ORDER BY acc.position |
65ab592d |
93 | }, |
94 | {}, 1); |
e7262300 |
95 | |
8803e4ed |
96 | $sth->execute(uc $table,$self->{db_schema} ); |
e7262300 |
97 | my %constr_names; |
98 | while(my $constr = $sth->fetchrow_arrayref) { |
65ab592d |
99 | my $constr_name = lc $constr->[0]; |
100 | my $constr_def = lc $constr->[1]; |
e7262300 |
101 | $constr_name =~ s/\Q$self->{_quoter}\E//; |
102 | $constr_def =~ s/\Q$self->{_quoter}\E//; |
65ab592d |
103 | push @{$constr_names{$constr_name}}, $constr_def; |
e7262300 |
104 | } |
65ab592d |
105 | |
106 | my @uniqs = map { [ $_ => $constr_names{$_} ] } keys %constr_names; |
e7262300 |
107 | return \@uniqs; |
108 | } |
109 | |
110 | sub _table_pk_info { |
65ab592d |
111 | my ($self, $table) = @_; |
112 | return $self->next::method(uc $table); |
e7262300 |
113 | } |
114 | |
115 | sub _table_fk_info { |
116 | my ($self, $table) = @_; |
117 | |
65ab592d |
118 | my $rels = $self->next::method(uc $table); |
e7262300 |
119 | |
65ab592d |
120 | foreach my $rel (@$rels) { |
121 | $rel->{remote_table} = lc $rel->{remote_table}; |
e7262300 |
122 | } |
123 | |
65ab592d |
124 | return $rels; |
125 | } |
126 | |
127 | sub _columns_info_for { |
128 | my ($self, $table) = @_; |
129 | return $self->next::method(uc $table); |
e7262300 |
130 | } |
131 | |
fb328d1a |
132 | sub _extra_column_info { |
45be2ce7 |
133 | my ($self, $table, $column, $info, $dbi_info) = @_; |
fb328d1a |
134 | my %extra_info; |
135 | |
fb328d1a |
136 | my $dbh = $self->schema->storage->dbh; |
137 | my $sth = $dbh->prepare_cached( |
138 | q{ |
139 | SELECT COUNT(*) |
c7bf4194 |
140 | FROM all_triggers ut JOIN all_trigger_cols atc USING (trigger_name) |
141 | WHERE atc.table_name = ? AND atc.column_name = ? |
4337bddf |
142 | AND lower(column_usage) LIKE '%new%' AND lower(column_usage) LIKE '%out%' |
143 | AND trigger_type = 'BEFORE EACH ROW' AND lower(triggering_event) LIKE '%insert%' |
fb328d1a |
144 | }, |
145 | {}, 1); |
146 | |
147 | $sth->execute($table, $column); |
148 | if ($sth->fetchrow_array) { |
149 | $extra_info{is_auto_increment} = 1; |
150 | } |
151 | |
152 | return \%extra_info; |
153 | } |
154 | |
e7262300 |
155 | =head1 SEE ALSO |
156 | |
157 | L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, |
158 | L<DBIx::Class::Schema::Loader::DBI> |
159 | |
160 | =head1 AUTHOR |
161 | |
9cc8e7e1 |
162 | See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. |
e7262300 |
163 | |
be80bba7 |
164 | =head1 LICENSE |
165 | |
166 | This library is free software; you can redistribute it and/or modify it under |
167 | the same terms as Perl itself. |
fb328d1a |
168 | |
e7262300 |
169 | =cut |
170 | |
171 | 1; |