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