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/; |
942bd5e0 |
10 | use mro 'c3'; |
e7262300 |
11 | |
4295c4b4 |
12 | our $VERSION = '0.07010'; |
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 | } |
3785bc2e |
43 | elsif ($self->preserve_case) { |
c930f78b |
44 | $self->schema->storage->sql_maker->quote_char('"'); |
45 | $self->schema->storage->sql_maker->name_sep('.'); |
3785bc2e |
46 | } |
d0e184e9 |
47 | } |
48 | |
075aff97 |
49 | sub _table_as_sql { |
e7262300 |
50 | my ($self, $table) = @_; |
51 | |
a78f0826 |
52 | return $self->_quote($table); |
e7262300 |
53 | } |
54 | |
55 | sub _tables_list { |
bfb43060 |
56 | my ($self, $opts) = @_; |
e7262300 |
57 | |
58 | my $dbh = $self->schema->storage->dbh; |
59 | |
60 | my @tables; |
61 | for my $table ( $dbh->tables(undef, $self->db_schema, '%', 'TABLE,VIEW') ) { #catalog, schema, table, type |
62 | my $quoter = $dbh->get_info(29); |
63 | $table =~ s/$quoter//g; |
64 | |
65 | # remove "user." (schema) prefixes |
66 | $table =~ s/\w+\.//; |
67 | |
68 | next if $table eq 'PLAN_TABLE'; |
3785bc2e |
69 | $table = $self->_lc($table); |
e7262300 |
70 | push @tables, $1 |
71 | if $table =~ /\A(\w+)\z/; |
72 | } |
ffb03c96 |
73 | |
128f61d8 |
74 | { |
75 | # silence a warning from older DBD::Oracles in tests |
76 | my $warn_handler = $SIG{__WARN__} || sub { warn @_ }; |
77 | local $SIG{__WARN__} = sub { |
78 | $warn_handler->(@_) |
79 | unless $_[0] =~ /^Field \d+ has an Oracle type \(\d+\) which is not explicitly supported/; |
80 | }; |
81 | |
82 | return $self->_filter_tables(\@tables, $opts); |
83 | } |
e7262300 |
84 | } |
85 | |
4337bddf |
86 | sub _table_columns { |
87 | my ($self, $table) = @_; |
88 | |
89 | my $dbh = $self->schema->storage->dbh; |
90 | |
3785bc2e |
91 | my $sth = $dbh->column_info(undef, $self->db_schema, $self->_uc($table), '%'); |
92 | |
b511f36e |
93 | return [ map $self->_lc($_->{COLUMN_NAME}), @{ $sth->fetchall_arrayref({ COLUMN_NAME => 1 }) || [] } ]; |
4337bddf |
94 | } |
95 | |
e7262300 |
96 | sub _table_uniq_info { |
97 | my ($self, $table) = @_; |
98 | |
e7262300 |
99 | my $dbh = $self->schema->storage->dbh; |
100 | |
101 | my $sth = $dbh->prepare_cached( |
65ab592d |
102 | q{ |
c7bf4194 |
103 | SELECT constraint_name, acc.column_name |
104 | FROM all_constraints JOIN all_cons_columns acc USING (constraint_name) |
8803e4ed |
105 | WHERE acc.table_name=? and acc.owner = ? AND constraint_type='U' |
c7bf4194 |
106 | ORDER BY acc.position |
65ab592d |
107 | }, |
108 | {}, 1); |
e7262300 |
109 | |
3785bc2e |
110 | $sth->execute($self->_uc($table),$self->{db_schema} ); |
e7262300 |
111 | my %constr_names; |
112 | while(my $constr = $sth->fetchrow_arrayref) { |
f28e7eae |
113 | my $constr_name = $self->_lc($constr->[0]); |
3785bc2e |
114 | my $constr_col = $self->_lc($constr->[1]); |
e7262300 |
115 | $constr_name =~ s/\Q$self->{_quoter}\E//; |
3785bc2e |
116 | $constr_col =~ s/\Q$self->{_quoter}\E//; |
117 | push @{$constr_names{$constr_name}}, $constr_col; |
e7262300 |
118 | } |
65ab592d |
119 | |
120 | my @uniqs = map { [ $_ => $constr_names{$_} ] } keys %constr_names; |
e7262300 |
121 | return \@uniqs; |
122 | } |
123 | |
4cd5155b |
124 | sub _table_comment { |
ea998e8e |
125 | my $self = shift; |
126 | my ($table) = @_; |
127 | |
128 | my $table_comment = $self->next::method(@_); |
129 | |
130 | return $table_comment if $table_comment; |
131 | |
132 | ($table_comment) = $self->schema->storage->dbh->selectrow_array( |
4cd5155b |
133 | q{ |
134 | SELECT comments FROM all_tab_comments |
135 | WHERE owner = ? |
136 | AND table_name = ? |
137 | AND table_type = 'TABLE' |
138 | }, undef, $self->db_schema, $self->_uc($table) |
139 | ); |
140 | |
141 | return $table_comment |
142 | } |
143 | |
144 | sub _column_comment { |
ea998e8e |
145 | my $self = shift; |
146 | my ($table, $column_number, $column_name) = @_; |
147 | |
148 | my $column_comment = $self->next::method(@_); |
149 | |
150 | return $column_comment if $column_comment; |
151 | |
152 | ($column_comment) = $self->schema->storage->dbh->selectrow_array( |
4cd5155b |
153 | q{ |
154 | SELECT comments FROM all_col_comments |
155 | WHERE owner = ? |
156 | AND table_name = ? |
157 | AND column_name = ? |
158 | }, undef, $self->db_schema, $self->_uc( $table ), $self->_uc( $column_name ) |
159 | ); |
160 | return $column_comment |
161 | } |
162 | |
e7262300 |
163 | sub _table_pk_info { |
3785bc2e |
164 | my ($self, $table) = (shift, shift); |
165 | |
166 | return $self->next::method($self->_uc($table), @_); |
e7262300 |
167 | } |
168 | |
169 | sub _table_fk_info { |
3785bc2e |
170 | my ($self, $table) = (shift, shift); |
e7262300 |
171 | |
3785bc2e |
172 | my $rels = $self->next::method($self->_uc($table), @_); |
e7262300 |
173 | |
65ab592d |
174 | foreach my $rel (@$rels) { |
3785bc2e |
175 | $rel->{remote_table} = $self->_lc($rel->{remote_table}); |
e7262300 |
176 | } |
177 | |
65ab592d |
178 | return $rels; |
179 | } |
180 | |
181 | sub _columns_info_for { |
760fd65c |
182 | my ($self, $table) = (shift, shift); |
e7262300 |
183 | |
3785bc2e |
184 | my $result = $self->next::method($self->_uc($table), @_); |
fb328d1a |
185 | |
fb328d1a |
186 | my $dbh = $self->schema->storage->dbh; |
fb328d1a |
187 | |
5cd600fa |
188 | local $dbh->{LongReadLen} = 100000; |
189 | local $dbh->{LongTruncOk} = 1; |
190 | |
760fd65c |
191 | my $sth = $dbh->prepare_cached(q{ |
5cd600fa |
192 | SELECT atc.column_name, ut.trigger_body |
760fd65c |
193 | FROM all_triggers ut |
194 | JOIN all_trigger_cols atc USING (trigger_name) |
195 | WHERE atc.table_name = ? |
196 | AND lower(column_usage) LIKE '%new%' AND lower(column_usage) LIKE '%out%' |
197 | AND upper(trigger_type) LIKE '%BEFORE EACH ROW%' AND lower(triggering_event) LIKE '%insert%' |
198 | }, {}, 1); |
199 | |
3785bc2e |
200 | $sth->execute($self->_uc($table)); |
760fd65c |
201 | |
5cd600fa |
202 | while (my ($col_name, $trigger_body) = $sth->fetchrow_array) { |
203 | $col_name = $self->_lc($col_name); |
204 | |
205 | $result->{$col_name}{is_auto_increment} = 1; |
206 | |
69219349 |
207 | if (my ($seq_schema, $seq_name) = $trigger_body =~ /(?:\."?(\w+)"?)?"?(\w+)"?\.nextval/i) { |
1db66065 |
208 | $seq_schema = $self->_lc($seq_schema || $self->db_schema); |
69219349 |
209 | $seq_name = $self->_lc($seq_name); |
5cd600fa |
210 | |
69219349 |
211 | $result->{$col_name}{sequence} = ($self->qualify_objects ? ($seq_schema . '.') : '') . $seq_name; |
5cd600fa |
212 | } |
760fd65c |
213 | } |
214 | |
215 | while (my ($col, $info) = each %$result) { |
216 | no warnings 'uninitialized'; |
217 | |
218 | if ($info->{data_type} =~ /^(?:n?[cb]lob|long(?: raw)?|bfile|date|binary_(?:float|double)|rowid)\z/i) { |
219 | delete $info->{size}; |
220 | } |
221 | |
222 | if ($info->{data_type} =~ /^n(?:var)?char2?\z/i) { |
223 | $info->{size} = $info->{size} / 2; |
224 | } |
225 | elsif (lc($info->{data_type}) eq 'number') { |
4ea15dfe |
226 | $info->{original}{data_type} = 'number'; |
227 | $info->{data_type} = 'numeric'; |
760fd65c |
228 | |
229 | if (eval { $info->{size}[0] == 38 && $info->{size}[1] == 0 }) { |
4ea15dfe |
230 | $info->{original}{size} = $info->{size}; |
231 | |
760fd65c |
232 | $info->{data_type} = 'integer'; |
233 | delete $info->{size}; |
234 | } |
235 | } |
236 | elsif (my ($precision) = $info->{data_type} =~ /^timestamp\((\d+)\)(?: with (?:local )?time zone)?\z/i) { |
237 | $info->{data_type} = join ' ', $info->{data_type} =~ /[a-z]+/ig; |
238 | |
239 | if ($precision == 6) { |
240 | delete $info->{size}; |
241 | } |
242 | else { |
243 | $info->{size} = $precision; |
244 | } |
245 | } |
246 | elsif (($precision) = $info->{data_type} =~ /^interval year\((\d+)\) to month\z/i) { |
247 | $info->{data_type} = join ' ', $info->{data_type} =~ /[a-z]+/ig; |
248 | |
249 | if ($precision == 2) { |
250 | delete $info->{size}; |
251 | } |
252 | else { |
253 | $info->{size} = $precision; |
254 | } |
255 | } |
256 | elsif (my ($day_precision, $second_precision) = $info->{data_type} =~ /^interval day\((\d+)\) to second\((\d+)\)\z/i) { |
257 | $info->{data_type} = join ' ', $info->{data_type} =~ /[a-z]+/ig; |
258 | |
259 | if ($day_precision == 2 && $second_precision == 6) { |
260 | delete $info->{size}; |
261 | } |
262 | else { |
263 | $info->{size} = [ $day_precision, $second_precision ]; |
264 | } |
265 | } |
1c22571b |
266 | elsif (lc($info->{data_type}) eq 'float') { |
267 | $info->{original}{data_type} = 'float'; |
268 | $info->{original}{size} = $info->{size}; |
269 | |
270 | if ($info->{size} <= 63) { |
271 | $info->{data_type} = 'real'; |
272 | } |
273 | else { |
274 | $info->{data_type} = 'double precision'; |
275 | } |
276 | delete $info->{size}; |
277 | } |
760fd65c |
278 | elsif (lc($info->{data_type}) eq 'urowid' && $info->{size} == 4000) { |
279 | delete $info->{size}; |
280 | } |
3785bc2e |
281 | elsif (lc($info->{data_type}) eq 'date') { |
282 | $info->{data_type} = 'datetime'; |
283 | $info->{original}{data_type} = 'date'; |
284 | } |
1c22571b |
285 | elsif (lc($info->{data_type}) eq 'binary_float') { |
286 | $info->{data_type} = 'real'; |
287 | $info->{original}{data_type} = 'binary_float'; |
288 | } |
289 | elsif (lc($info->{data_type}) eq 'binary_double') { |
290 | $info->{data_type} = 'double precision'; |
291 | $info->{original}{data_type} = 'binary_double'; |
292 | } |
760fd65c |
293 | |
268cc246 |
294 | if ((eval { lc(${ $info->{default_value} }) }||'') eq 'sysdate') { |
3785bc2e |
295 | my $current_timestamp = 'current_timestamp'; |
296 | $info->{default_value} = \$current_timestamp; |
701cd3e3 |
297 | |
298 | my $sysdate = 'sysdate'; |
299 | $info->{original}{default_value} = \$sysdate; |
760fd65c |
300 | } |
fb328d1a |
301 | } |
302 | |
760fd65c |
303 | return $result; |
fb328d1a |
304 | } |
305 | |
e7262300 |
306 | =head1 SEE ALSO |
307 | |
308 | L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, |
309 | L<DBIx::Class::Schema::Loader::DBI> |
310 | |
311 | =head1 AUTHOR |
312 | |
9cc8e7e1 |
313 | See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. |
e7262300 |
314 | |
be80bba7 |
315 | =head1 LICENSE |
316 | |
317 | This library is free software; you can redistribute it and/or modify it under |
318 | the same terms as Perl itself. |
fb328d1a |
319 | |
e7262300 |
320 | =cut |
321 | |
322 | 1; |
760fd65c |
323 | # vim:et sts=4 sw=4 tw=0: |