Commit | Line | Data |
d87d939a |
1 | package DBIx::Class::Schema::Loader::DBI::Oracle; |
e7262300 |
2 | |
3 | use strict; |
4 | use warnings; |
383bd2a8 |
5 | use base 'DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault'; |
942bd5e0 |
6 | use mro 'c3'; |
1af21646 |
7 | use Try::Tiny; |
ff4b0152 |
8 | use DBIx::Class::Schema::Loader::Utils qw/sigwarn_silencer/; |
1af21646 |
9 | use namespace::clean; |
e7262300 |
10 | |
38a64290 |
11 | our $VERSION = '0.07049'; |
e7262300 |
12 | |
13 | =head1 NAME |
14 | |
3b61a7ca |
15 | DBIx::Class::Schema::Loader::DBI::Oracle - DBIx::Class::Schema::Loader::DBI |
e7262300 |
16 | Oracle Implementation. |
17 | |
e7262300 |
18 | =head1 DESCRIPTION |
19 | |
c4a69b87 |
20 | See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>. |
e7262300 |
21 | |
e7262300 |
22 | =cut |
23 | |
d0e184e9 |
24 | sub _setup { |
25 | my $self = shift; |
26 | |
27 | $self->next::method(@_); |
28 | |
c4a69b87 |
29 | my ($current_schema) = $self->dbh->selectrow_array('SELECT USER FROM DUAL'); |
46065bcb |
30 | |
c4a69b87 |
31 | $self->db_schema([ $current_schema ]) unless $self->db_schema; |
46065bcb |
32 | |
c4a69b87 |
33 | if (@{ $self->db_schema } == 1 && $self->db_schema->[0] ne '%' |
34 | && lc($self->db_schema->[0]) ne lc($current_schema)) { |
35 | $self->dbh->do('ALTER SESSION SET current_schema=' . $self->db_schema->[0]); |
46065bcb |
36 | } |
bc1cb85e |
37 | |
38 | if (not defined $self->preserve_case) { |
39 | $self->preserve_case(0); |
40 | } |
3785bc2e |
41 | elsif ($self->preserve_case) { |
c930f78b |
42 | $self->schema->storage->sql_maker->quote_char('"'); |
43 | $self->schema->storage->sql_maker->name_sep('.'); |
3785bc2e |
44 | } |
d0e184e9 |
45 | } |
46 | |
c4a69b87 |
47 | sub _build_name_sep { '.' } |
48 | |
49 | sub _system_schemas { |
50 | my $self = shift; |
e7262300 |
51 | |
c4a69b87 |
52 | # From http://www.adp-gmbh.ch/ora/misc/known_schemas.html |
53 | |
54 | return ($self->next::method(@_), qw/ANONYMOUS APEX_PUBLIC_USER APEX_030200 APPQOSSYS CTXSYS DBSNMP DIP DMSYS EXFSYS LBACSYS MDDATA MDSYS MGMT_VIEW OLAPSYS ORACLE_OCM ORDDATA ORDPLUGINS ORDSYS OUTLN SI_INFORMTN_SCHEMA SPATIAL_CSW_ADMIN_USR SPATIAL_WFS_ADMIN_USR SYS SYSMAN SYSTEM TRACESRV MTSSYS OASPUBLIC OWBSYS OWBSYS_AUDIT WEBSYS WK_PROXY WKSYS WK_TEST WMSYS XDB OSE$HTTP$ADMIN AURORA$JIS$UTILITY$ AURORA$ORB$UNAUTHENTICATED/, qr/^FLOWS_\d\d\d\d\d\d\z/); |
e7262300 |
55 | } |
56 | |
c4a69b87 |
57 | sub _system_tables { |
58 | my $self = shift; |
e7262300 |
59 | |
41a60472 |
60 | return ( |
61 | $self->next::method(@_), |
62 | 'PLAN_TABLE', |
63 | qr/\ABIN\$.*\$\d+\z/, # Tables in the recycle bin |
64 | ); |
c4a69b87 |
65 | } |
e7262300 |
66 | |
c4a69b87 |
67 | sub _dbh_tables { |
68 | my ($self, $schema) = @_; |
e7262300 |
69 | |
c4a69b87 |
70 | return $self->dbh->tables(undef, $schema, '%', 'TABLE,VIEW'); |
71 | } |
e7262300 |
72 | |
c4a69b87 |
73 | sub _filter_tables { |
74 | my $self = shift; |
ffb03c96 |
75 | |
c4a69b87 |
76 | # silence a warning from older DBD::Oracles in tests |
ff4b0152 |
77 | local $SIG{__WARN__} = sigwarn_silencer( |
78 | qr/^Field \d+ has an Oracle type \(\d+\) which is not explicitly supported/ |
79 | ); |
128f61d8 |
80 | |
c4a69b87 |
81 | return $self->next::method(@_); |
e7262300 |
82 | } |
83 | |
a40434df |
84 | sub _table_fk_info { |
85 | my $self = shift; |
86 | my ($table) = @_; |
87 | |
88 | my $rels = $self->next::method(@_); |
89 | |
90 | my $deferrable_sth = $self->dbh->prepare_cached(<<'EOF'); |
91 | select deferrable from all_constraints |
48c1a6c5 |
92 | where owner = ? and table_name = ? and constraint_name = ? and status = 'ENABLED' |
a40434df |
93 | EOF |
94 | |
029e9d1e |
95 | my @enabled_rels; |
a40434df |
96 | foreach my $rel (@$rels) { |
97 | # Oracle does not have update rules |
98 | $rel->{attrs}{on_update} = 'NO ACTION';; |
99 | |
100 | # DBD::Oracle's foreign_key_info does not return DEFERRABILITY, so we get it ourselves |
029e9d1e |
101 | # Also use this to filter out disabled foreign keys, which are returned by DBD::Oracle < 1.76 |
102 | my $deferrable = $self->dbh->selectrow_array( |
a40434df |
103 | $deferrable_sth, undef, $table->schema, $table->name, $rel->{_constraint_name} |
029e9d1e |
104 | ) or next; |
a40434df |
105 | |
029e9d1e |
106 | $rel->{attrs}{is_deferrable} = $deferrable =~ /^DEFERRABLE/i ? 1 : 0; |
107 | push @enabled_rels, $rel; |
a40434df |
108 | } |
109 | |
029e9d1e |
110 | return \@enabled_rels; |
a40434df |
111 | } |
112 | |
e7262300 |
113 | sub _table_uniq_info { |
114 | my ($self, $table) = @_; |
115 | |
c4a69b87 |
116 | my $sth = $self->dbh->prepare_cached(<<'EOF', {}, 1); |
5975bbe6 |
117 | SELECT ac.constraint_name, acc.column_name |
118 | FROM all_constraints ac, all_cons_columns acc |
119 | WHERE acc.table_name=? AND acc.owner = ? |
120 | AND ac.table_name = acc.table_name AND ac.owner = acc.owner |
121 | AND acc.constraint_name = ac.constraint_name |
48c1a6c5 |
122 | AND ac.constraint_type = 'U' |
123 | AND ac.status = 'ENABLED' |
c4a69b87 |
124 | ORDER BY acc.position |
125 | EOF |
e7262300 |
126 | |
c4a69b87 |
127 | $sth->execute($table->name, $table->schema); |
e7262300 |
128 | |
e7262300 |
129 | my %constr_names; |
c4a69b87 |
130 | |
e7262300 |
131 | while(my $constr = $sth->fetchrow_arrayref) { |
f28e7eae |
132 | my $constr_name = $self->_lc($constr->[0]); |
3785bc2e |
133 | my $constr_col = $self->_lc($constr->[1]); |
3785bc2e |
134 | push @{$constr_names{$constr_name}}, $constr_col; |
e7262300 |
135 | } |
3b61a7ca |
136 | |
6c4f5a4a |
137 | return [ map { [ $_ => $constr_names{$_} ] } sort keys %constr_names ]; |
e7262300 |
138 | } |
139 | |
4cd5155b |
140 | sub _table_comment { |
ea998e8e |
141 | my $self = shift; |
142 | my ($table) = @_; |
143 | |
144 | my $table_comment = $self->next::method(@_); |
145 | |
146 | return $table_comment if $table_comment; |
147 | |
c4a69b87 |
148 | ($table_comment) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name); |
149 | SELECT comments FROM all_tab_comments |
3b61a7ca |
150 | WHERE owner = ? |
c4a69b87 |
151 | AND table_name = ? |
152 | AND (table_type = 'TABLE' OR table_type = 'VIEW') |
153 | EOF |
4cd5155b |
154 | |
155 | return $table_comment |
156 | } |
157 | |
158 | sub _column_comment { |
ea998e8e |
159 | my $self = shift; |
160 | my ($table, $column_number, $column_name) = @_; |
161 | |
162 | my $column_comment = $self->next::method(@_); |
163 | |
164 | return $column_comment if $column_comment; |
165 | |
c4a69b87 |
166 | ($column_comment) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $self->_uc($column_name)); |
167 | SELECT comments FROM all_col_comments |
3b61a7ca |
168 | WHERE owner = ? |
c4a69b87 |
169 | AND table_name = ? |
170 | AND column_name = ? |
171 | EOF |
e7262300 |
172 | |
c4a69b87 |
173 | return $column_comment |
65ab592d |
174 | } |
175 | |
176 | sub _columns_info_for { |
c4a69b87 |
177 | my $self = shift; |
178 | my ($table) = @_; |
fb328d1a |
179 | |
c4a69b87 |
180 | my $result = $self->next::method(@_); |
fb328d1a |
181 | |
1af21646 |
182 | local $self->dbh->{LongReadLen} = 1_000_000; |
c4a69b87 |
183 | local $self->dbh->{LongTruncOk} = 1; |
5cd600fa |
184 | |
c4a69b87 |
185 | my $sth = $self->dbh->prepare_cached(<<'EOF', {}, 1); |
5975bbe6 |
186 | SELECT trigger_body |
187 | FROM all_triggers |
48c1a6c5 |
188 | WHERE table_name = ? AND table_owner = ? AND status = 'ENABLED' |
760fd65c |
189 | AND upper(trigger_type) LIKE '%BEFORE EACH ROW%' AND lower(triggering_event) LIKE '%insert%' |
c4a69b87 |
190 | EOF |
760fd65c |
191 | |
5975bbe6 |
192 | $sth->execute($table->name, $table->schema); |
760fd65c |
193 | |
5975bbe6 |
194 | while (my ($trigger_body) = $sth->fetchrow_array) { |
1de9c8e1 |
195 | if (my ($seq_schema, $seq_name) = $trigger_body =~ /(?:"?(\w+)"?\.)?"?(\w+)"?\.nextval/i) { |
5975bbe6 |
196 | if (my ($col_name) = $trigger_body =~ /:new\.(\w+)/i) { |
197 | $col_name = $self->_lc($col_name); |
5cd600fa |
198 | |
5975bbe6 |
199 | $result->{$col_name}{is_auto_increment} = 1; |
5cd600fa |
200 | |
5975bbe6 |
201 | $seq_schema = $self->_lc($seq_schema || $table->schema); |
202 | $seq_name = $self->_lc($seq_name); |
5cd600fa |
203 | |
5975bbe6 |
204 | $result->{$col_name}{sequence} = ($self->qualify_objects ? ($seq_schema . '.') : '') . $seq_name; |
205 | } |
5cd600fa |
206 | } |
760fd65c |
207 | } |
208 | |
08ae3055 |
209 | # Old DBD::Oracle report the size in (UTF-16) bytes, not characters |
210 | my $nchar_size_factor = $DBD::Oracle::VERSION >= 1.52 ? 1 : 2; |
211 | |
760fd65c |
212 | while (my ($col, $info) = each %$result) { |
213 | no warnings 'uninitialized'; |
214 | |
1af21646 |
215 | my $sth = $self->dbh->prepare_cached(<<'EOF', {}, 1); |
216 | SELECT data_type, data_length |
217 | FROM all_tab_columns |
218 | WHERE column_name = ? AND table_name = ? AND owner = ? |
219 | EOF |
220 | $sth->execute($self->_uc($col), $table->name, $table->schema); |
221 | my ($data_type, $data_length) = $sth->fetchrow_array; |
222 | $sth->finish; |
223 | $data_type = lc $data_type; |
224 | |
225 | if ($data_type =~ /^(?:n(?:var)?char2?|u?rowid|nclob|timestamp\(\d+\)(?: with(?: local)? time zone)?|binary_(?:float|double))\z/i) { |
226 | $info->{data_type} = $data_type; |
227 | |
228 | if ($data_type =~ /^u?rowid\z/i) { |
229 | $info->{size} = $data_length; |
230 | } |
231 | } |
232 | |
760fd65c |
233 | if ($info->{data_type} =~ /^(?:n?[cb]lob|long(?: raw)?|bfile|date|binary_(?:float|double)|rowid)\z/i) { |
234 | delete $info->{size}; |
235 | } |
236 | |
237 | if ($info->{data_type} =~ /^n(?:var)?char2?\z/i) { |
1af21646 |
238 | if (ref $info->{size}) { |
239 | $info->{size} = $info->{size}[0] / 8; |
240 | } |
241 | else { |
08ae3055 |
242 | $info->{size} = $info->{size} / $nchar_size_factor; |
1af21646 |
243 | } |
244 | } |
245 | elsif ($info->{data_type} =~ /^(?:var)?char2?\z/i) { |
246 | if (ref $info->{size}) { |
247 | $info->{size} = $info->{size}[0]; |
248 | } |
760fd65c |
249 | } |
1af21646 |
250 | elsif (lc($info->{data_type}) =~ /^(?:number|decimal)\z/i) { |
4ea15dfe |
251 | $info->{original}{data_type} = 'number'; |
252 | $info->{data_type} = 'numeric'; |
760fd65c |
253 | |
1af21646 |
254 | if (try { $info->{size}[0] == 38 && $info->{size}[1] == 0 }) { |
4ea15dfe |
255 | $info->{original}{size} = $info->{size}; |
256 | |
760fd65c |
257 | $info->{data_type} = 'integer'; |
258 | delete $info->{size}; |
259 | } |
260 | } |
261 | elsif (my ($precision) = $info->{data_type} =~ /^timestamp\((\d+)\)(?: with (?:local )?time zone)?\z/i) { |
262 | $info->{data_type} = join ' ', $info->{data_type} =~ /[a-z]+/ig; |
263 | |
264 | if ($precision == 6) { |
265 | delete $info->{size}; |
266 | } |
267 | else { |
268 | $info->{size} = $precision; |
269 | } |
270 | } |
1af21646 |
271 | elsif ($info->{data_type} =~ /timestamp/i && ref $info->{size} && $info->{size}[0] == 0) { |
272 | my $size = $info->{size}[1]; |
273 | delete $info->{size}; |
274 | $info->{size} = $size unless $size == 6; |
275 | } |
760fd65c |
276 | elsif (($precision) = $info->{data_type} =~ /^interval year\((\d+)\) to month\z/i) { |
277 | $info->{data_type} = join ' ', $info->{data_type} =~ /[a-z]+/ig; |
278 | |
279 | if ($precision == 2) { |
280 | delete $info->{size}; |
281 | } |
282 | else { |
283 | $info->{size} = $precision; |
284 | } |
285 | } |
286 | elsif (my ($day_precision, $second_precision) = $info->{data_type} =~ /^interval day\((\d+)\) to second\((\d+)\)\z/i) { |
287 | $info->{data_type} = join ' ', $info->{data_type} =~ /[a-z]+/ig; |
288 | |
289 | if ($day_precision == 2 && $second_precision == 6) { |
290 | delete $info->{size}; |
291 | } |
292 | else { |
293 | $info->{size} = [ $day_precision, $second_precision ]; |
294 | } |
295 | } |
1af21646 |
296 | elsif ($info->{data_type} =~ /^interval year to month\z/i && ref $info->{size}) { |
297 | my $precision = $info->{size}[0]; |
298 | |
299 | if ($precision == 2) { |
300 | delete $info->{size}; |
301 | } |
302 | else { |
303 | $info->{size} = $precision; |
304 | } |
305 | } |
306 | elsif ($info->{data_type} =~ /^interval day to second\z/i && ref $info->{size}) { |
307 | if ($info->{size}[0] == 2 && $info->{size}[1] == 6) { |
308 | delete $info->{size}; |
309 | } |
310 | } |
1c22571b |
311 | elsif (lc($info->{data_type}) eq 'float') { |
312 | $info->{original}{data_type} = 'float'; |
313 | $info->{original}{size} = $info->{size}; |
314 | |
315 | if ($info->{size} <= 63) { |
316 | $info->{data_type} = 'real'; |
317 | } |
318 | else { |
319 | $info->{data_type} = 'double precision'; |
320 | } |
321 | delete $info->{size}; |
322 | } |
1af21646 |
323 | elsif (lc($info->{data_type}) eq 'double precision') { |
324 | $info->{original}{data_type} = 'float'; |
325 | |
326 | my $size = try { $info->{size}[0] }; |
327 | |
328 | $info->{original}{size} = $size; |
329 | |
330 | if ($size <= 63) { |
331 | $info->{data_type} = 'real'; |
332 | } |
333 | delete $info->{size}; |
334 | } |
760fd65c |
335 | elsif (lc($info->{data_type}) eq 'urowid' && $info->{size} == 4000) { |
336 | delete $info->{size}; |
337 | } |
1af21646 |
338 | elsif ($info->{data_type} eq '-9104') { |
339 | $info->{data_type} = 'rowid'; |
340 | delete $info->{size}; |
341 | } |
342 | elsif ($info->{data_type} eq '-2') { |
343 | $info->{data_type} = 'raw'; |
344 | $info->{size} = try { $info->{size}[0] / 2 }; |
345 | } |
3785bc2e |
346 | elsif (lc($info->{data_type}) eq 'date') { |
347 | $info->{data_type} = 'datetime'; |
348 | $info->{original}{data_type} = 'date'; |
349 | } |
1c22571b |
350 | elsif (lc($info->{data_type}) eq 'binary_float') { |
351 | $info->{data_type} = 'real'; |
352 | $info->{original}{data_type} = 'binary_float'; |
3b61a7ca |
353 | } |
1c22571b |
354 | elsif (lc($info->{data_type}) eq 'binary_double') { |
355 | $info->{data_type} = 'double precision'; |
356 | $info->{original}{data_type} = 'binary_double'; |
1af21646 |
357 | } |
358 | |
359 | # DEFAULT could be missed by ::DBI because of ORA-24345 |
360 | if (not defined $info->{default_value}) { |
361 | local $self->dbh->{LongReadLen} = 1_000_000; |
362 | local $self->dbh->{LongTruncOk} = 1; |
363 | my $sth = $self->dbh->prepare_cached(<<'EOF', {}, 1); |
364 | SELECT data_default |
365 | FROM all_tab_columns |
366 | WHERE column_name = ? AND table_name = ? AND owner = ? |
367 | EOF |
368 | $sth->execute($self->_uc($col), $table->name, $table->schema); |
369 | my ($default) = $sth->fetchrow_array; |
370 | $sth->finish; |
371 | |
372 | # this is mostly copied from ::DBI::QuotedDefault |
373 | if (defined $default) { |
374 | s/^\s+//, s/\s+\z// for $default; |
375 | |
376 | if ($default =~ /^'(.*?)'\z/) { |
377 | $info->{default_value} = $1; |
378 | } |
379 | elsif ($default =~ /^(-?\d.*?)\z/) { |
380 | $info->{default_value} = $1; |
381 | } |
382 | elsif ($default =~ /^NULL\z/i) { |
383 | my $null = 'null'; |
384 | $info->{default_value} = \$null; |
385 | } |
386 | elsif ($default ne '') { |
387 | my $val = $default; |
388 | $info->{default_value} = \$val; |
389 | } |
390 | } |
391 | } |
760fd65c |
392 | |
1af21646 |
393 | if ((try { lc(${ $info->{default_value} }) }||'') eq 'sysdate') { |
3785bc2e |
394 | my $current_timestamp = 'current_timestamp'; |
395 | $info->{default_value} = \$current_timestamp; |
701cd3e3 |
396 | |
397 | my $sysdate = 'sysdate'; |
398 | $info->{original}{default_value} = \$sysdate; |
760fd65c |
399 | } |
fb328d1a |
400 | } |
401 | |
760fd65c |
402 | return $result; |
fb328d1a |
403 | } |
404 | |
1af21646 |
405 | sub _dbh_column_info { |
406 | my $self = shift; |
407 | my ($dbh) = @_; |
408 | |
409 | # try to avoid ORA-24345 |
410 | local $dbh->{LongReadLen} = 1_000_000; |
411 | local $dbh->{LongTruncOk} = 1; |
412 | |
413 | return $self->next::method(@_); |
414 | } |
415 | |
d7e0e0e8 |
416 | sub _view_definition { |
417 | my ($self, $view) = @_; |
418 | |
419 | return scalar $self->schema->storage->dbh->selectrow_array(<<'EOF', {}, $view->schema, $view->name); |
420 | SELECT text |
421 | FROM all_views |
422 | WHERE owner = ? AND view_name = ? |
423 | EOF |
424 | } |
425 | |
e7262300 |
426 | =head1 SEE ALSO |
427 | |
428 | L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, |
429 | L<DBIx::Class::Schema::Loader::DBI> |
430 | |
b87ab391 |
431 | =head1 AUTHORS |
e7262300 |
432 | |
b87ab391 |
433 | See L<DBIx::Class::Schema::Loader/AUTHORS>. |
e7262300 |
434 | |
be80bba7 |
435 | =head1 LICENSE |
436 | |
437 | This library is free software; you can redistribute it and/or modify it under |
438 | the same terms as Perl itself. |
fb328d1a |
439 | |
e7262300 |
440 | =cut |
441 | |
442 | 1; |
760fd65c |
443 | # vim:et sts=4 sw=4 tw=0: |