File Coverage

lib/UR/DataSource/Oracle.pm
Criterion Covered Total %
statement 27 223 12.1
branch 13 106 12.2
condition 4 71 5.6
subroutine 6 31 19.3
pod 0 20 0.0
total 50 451 11.0


line stmt bran cond sub pod time code
1             package UR::DataSource::Oracle;
2 5     5   122 use strict;
  5         7  
  5         119  
3 5     5   14 use warnings;
  5         9  
  5         11342  
4              
5             require UR;
6             our $VERSION = "0.46"; # UR $VERSION;
7              
8             UR::Object::Type->define(
9             class_name => 'UR::DataSource::Oracle',
10             is => ['UR::DataSource::RDBMS'],
11             is_abstract => 1,
12             );
13              
14 0     0 0 0 sub driver { "Oracle" }
15              
16 0     0 0 0 sub owner { shift->_singleton_object->login }
17              
18 5     5 0 12 sub can_savepoint { 1 } # Oracle supports savepoints inside transactions
19              
20 10     10 0 28 sub does_support_limit_offset { 0 }
21              
22 0     0 0 0 sub does_support_recursive_queries { 'connect by' };
23              
24             sub set_savepoint {
25 0     0 0 0 my($self,$sp_name) = @_;
26              
27 0         0 my $dbh = $self->get_default_handle;
28 0         0 my $sp = $dbh->quote($sp_name);
29 0         0 $dbh->do("savepoint $sp_name");
30             }
31              
32              
33             sub rollback_to_savepoint {
34 0     0 0 0 my($self,$sp_name) = @_;
35              
36 0         0 my $dbh = $self->get_default_handle;
37 0         0 my $sp = $dbh->quote($sp_name);
38 0         0 $dbh->do("rollback to $sp_name");
39             }
40              
41              
42             my $DATE_FORMAT = 'YYYY-MM-DD HH24:MI:SS';
43             my $TIMESTAMP_FORMAT = 'YYYY-MM-DD HH24:MI:SSXFF';
44             sub _set_date_format {
45 0     0   0 my $self = shift;
46              
47 0         0 foreach my $sql ("alter session set NLS_DATE_FORMAT = '$DATE_FORMAT'",
48             "alter session set NLS_TIMESTAMP_FORMAT = '$TIMESTAMP_FORMAT'"
49             ) {
50 0         0 $self->do_sql($sql);
51             }
52             }
53              
54              
55             *_init_created_dbh = \&init_created_handle;
56             sub init_created_handle {
57 0     0 0 0 my ($self, $dbh) = @_;
58 0 0       0 return unless defined $dbh;
59 0         0 $dbh->{LongTruncOk} = 0;
60              
61 0         0 $self->_set_date_format();
62              
63 0         0 return $dbh;
64             }
65              
66             sub _dbi_connect_args {
67 0     0   0 my @args = shift->SUPER::_dbi_connect_args(@_);
68 0   0     0 $args[3]{ora_module_name} = (UR::Context::Process->get_current->prog_name || $0);
69 0         0 return @args;
70             }
71              
72             sub _prepare_for_lob {
73 0     0   0 { ora_auto_lob => 0 }
74             }
75              
76             sub _post_process_lob_values {
77 0     0   0 my ($self, $dbh, $lob_id_arrayref) = @_;
78             return
79             map {
80 0 0       0 if (defined($_)) {
  0         0  
81 0         0 my $length = $dbh->ora_lob_length($_);
82 0         0 my $data = $dbh->ora_lob_read($_, 1, $length);
83             # TODO: bind to a file for items of a certain size to save RAM.
84             # Special work with tying a scalar to the file?
85 0         0 $data;
86             }
87             else {
88 0         0 undef;
89             }
90             } @$lob_id_arrayref;
91             }
92              
93             sub _ignore_table {
94 0     0   0 my $self = shift;
95 0         0 my $table_name = shift;
96 0 0       0 return 1 if $table_name =~ /\$/;
97             }
98              
99             sub get_table_last_ddl_times_by_table_name {
100 0     0 0 0 my $self = shift;
101 0         0 my $sql = qq|
102             select object_name table_name, last_ddl_time
103             from all_objects o
104             where o.owner = ?
105             and (o.object_type = 'TABLE' or o.object_type = 'VIEW')
106             |;
107 0         0 my $data = $self->get_default_handle->selectall_arrayref(
108             $sql,
109             undef,
110             $self->owner
111             );
112 0         0 return { map { @$_ } @$data };
  0         0  
113             };
114              
115             sub _get_next_value_from_sequence {
116 0     0   0 my($self,$sequence_name) = @_;
117              
118             # we may need to change how this db handle is gotten
119 0         0 my $dbh = $self->get_default_handle;
120 0         0 my $new_id = $dbh->selectrow_array("SELECT " . $sequence_name . ".nextval from DUAL");
121              
122 0 0       0 if ($dbh->err) {
123 0         0 die "Failed to prepare SQL to generate a column id from sequence: $sequence_name.\n" . $dbh->errstr . "\n";
124 0         0 return;
125             }
126              
127 0         0 return $new_id;
128             }
129              
130             sub get_bitmap_index_details_from_data_dictionary {
131 0     0 0 0 my($self, $table_name) = @_;
132 0         0 my $sql = qq(
133             select c.table_name,c.column_name,c.index_name
134             from all_indexes i join all_ind_columns c on i.index_name = c.index_name
135             where i.index_type = 'BITMAP'
136             );
137              
138 0         0 my @select_params;
139 0 0       0 if ($table_name) {
140 0         0 @select_params = $self->_resolve_owner_and_table_from_table_name($table_name);
141 0         0 $sql .= " and i.table_owner = ? and i.table_name = ?";
142             }
143              
144 0         0 my $dbh = $self->get_default_handle;
145 0         0 my $rows = $dbh->selectall_arrayref($sql, undef, @select_params);
146 0 0       0 return undef unless $rows;
147            
148 0         0 my @ret = map { { table_name => $_->[0], column_name => $_->[1], index_name => $_->[2] } } @$rows;
  0         0  
149              
150 0         0 return \@ret;
151             }
152              
153              
154             sub get_unique_index_details_from_data_dictionary {
155 0     0 0 0 my ($self, $owner_name, $table_name) = @_;
156 0         0 my $sql = qq(
157             select cc.constraint_name, cc.column_name
158             from all_cons_columns cc
159             join all_constraints c
160             on c.constraint_name = cc.constraint_name
161             and c.owner = cc.owner
162             and c.constraint_type = 'U'
163             where cc.table_name = ?
164             and cc.owner = ?
165              
166             union
167              
168             select ai.index_name, aic.column_name
169             from all_indexes ai
170             join all_ind_columns aic
171             on aic.index_name = ai.index_name
172             and aic.index_owner = ai.owner
173             where ai.uniqueness = 'UNIQUE'
174             and aic.table_name = ?
175             and aic.index_owner = ?
176             );
177              
178 0         0 my $dbh = $self->get_default_handle();
179 0 0       0 return undef unless $dbh;
180              
181 0         0 my $sth = $dbh->prepare($sql);
182 0 0       0 return undef unless $sth;
183              
184 0         0 $sth->execute($table_name, $owner_name, $table_name, $owner_name);
185              
186 0         0 my $ret;
187 0         0 while (my $data = $sth->fetchrow_hashref()) {
188 0   0     0 $ret->{$data->{'CONSTRAINT_NAME'}} ||= [];
189 0         0 push @{ $ret->{ $data->{CONSTRAINT_NAME} } }, $data->{COLUMN_NAME};
  0         0  
190             }
191              
192 0         0 return $ret;
193             }
194              
195             sub set_userenv {
196              
197             # there are two places to set these oracle variables-
198             # 1. this method in UR::DataSource::Oracle is a class method
199             # that can be called to change the values later
200             # 2. the method in YourSubclass::DataSource::Oracle is called in
201             # init_created_handle which is called while the datasource
202             # is still being set up- it operates directly on the db handle
203              
204 0     0 0 0 my ($self, %p) = @_;
205              
206 0   0     0 my $dbh = $p{'dbh'} || $self->get_default_handle();
207              
208             # module is application name
209 0   0     0 my $module = $p{'module'} || $0;
210              
211             # storing username in 'action' oracle variable
212 0         0 my $action = $p{'action'};
213 0 0       0 if (! defined($action)) {
214 0         0 $action = getpwuid($>); # real UID
215             }
216              
217 0         0 my $sql = q{BEGIN dbms_application_info.set_module(?, ?); END;};
218              
219 0         0 my $sth = $dbh->prepare($sql);
220 0 0       0 if (!$sth) {
221 0         0 warn "Couldnt prepare query to set module/action in Oracle";
222 0         0 return undef;
223             }
224              
225 0 0       0 $sth->execute($module, $action) || warn "Couldnt set module/action in Oracle";
226             }
227              
228             sub get_userenv {
229              
230             # there are two ways to set these values but this is
231             # the only way to retrieve the values after they are set
232              
233 0     0 0 0 my ($self, $dbh) = @_;
234              
235 0 0       0 if (!$dbh) {
236 0         0 $dbh = $self->get_default_handle();
237             }
238              
239 0 0       0 if (!$dbh) {
240 0         0 warn "No dbh";
241 0         0 return undef;
242             }
243              
244 0         0 my $sql = q{
245             SELECT sys_context('USERENV','MODULE') as module,
246             sys_context('USERENV','ACTION') as action
247             FROM dual
248             };
249              
250 0         0 my $sth = $dbh->prepare($sql);
251 0 0       0 return undef unless $sth;
252              
253 0 0       0 $sth->execute() || die "execute failed: $!";
254 0         0 my $r = $sth->fetchrow_hashref();
255              
256 0         0 return $r;
257             }
258              
259              
260             my %ur_data_type_for_vendor_data_type = (
261             'VARCHAR2' => ['Text', undef],
262             'BLOB' => ['XmlBlob', undef],
263             );
264             sub ur_data_type_for_data_source_data_type {
265 3     3 0 138 my($class,$type) = @_;
266              
267 3         10 $type = $class->normalize_vendor_type($type);
268 3         4 my $urtype = $ur_data_type_for_vendor_data_type{$type};
269 3 50       6 unless (defined $urtype) {
270 3         8 $urtype = $class->SUPER::ur_data_type_for_data_source_data_type($type);
271             }
272 3         5 return $urtype;
273             }
274              
275             sub _alter_sth_for_selecting_blob_columns {
276 0     0   0 my($self, $sth, $column_objects) = @_;
277              
278 0         0 for (my $n = 0; $n < @$column_objects; $n++) {
279 0 0       0 next unless defined ($column_objects->[$n]); # No metaDB info for this one
280 0 0       0 if ($column_objects->[$n]->data_type eq 'BLOB') {
281 0         0 $sth->bind_param($n+1, undef, { ora_type => 23 });
282             }
283             }
284             }
285              
286             sub get_connection_debug_info {
287 0     0 0 0 my $self = shift;
288 0         0 my @debug_info = $self->SUPER::get_connection_debug_info(@_);
289             push @debug_info, (
290             "DBD::Oracle Version: ", $DBD::Oracle::VERSION, "\n",
291             "TNS_ADMIN: ", $ENV{TNS_ADMIN}, "\n",
292 0         0 "ORACLE_HOME: ", $ENV{ORACLE_HOME}, "\n",
293             );
294 0         0 return @debug_info;
295             }
296              
297              
298             # This is a near cut-and-paste from DBD::Oracle, with the exception that
299             # the query hint is removed, since it performs poorly on Oracle 11
300             sub get_table_details_from_data_dictionary {
301 0     0 0 0 my $self = shift;
302              
303 0         0 my $version = $self->_get_oracle_major_server_version();
304 0 0       0 if ($version < '11') {
305 0         0 return $self->SUPER::get_table_details_from_data_dictionary(@_);
306             }
307              
308 0         0 my($CatVal, $SchVal, $TblVal, $TypVal) = @_;
309 0         0 my $dbh = $self->get_default_handle();
310             # XXX add knowledge of temp tables, etc
311             # SQL/CLI (ISO/IEC JTC 1/SC 32 N 0595), 6.63 Tables
312 0 0       0 if (ref $CatVal eq 'HASH') {
313             ($CatVal, $SchVal, $TblVal, $TypVal) =
314 0         0 @$CatVal{'TABLE_CAT','TABLE_SCHEM','TABLE_NAME','TABLE_TYPE'};
315             }
316 0         0 my @Where = ();
317 0         0 my $SQL;
318 0 0 0     0 if ( defined $CatVal && $CatVal eq '%' && (!defined $SchVal || $SchVal eq '') && (!defined $TblVal || $TblVal eq '')) { # Rule 19a
    0 0        
    0 0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
      0        
319 0         0 $SQL = <<'SQL';
320             SELECT NULL TABLE_CAT
321             , NULL TABLE_SCHEM
322             , NULL TABLE_NAME
323             , NULL TABLE_TYPE
324             , NULL REMARKS
325             FROM DUAL
326             SQL
327             }
328             elsif ( defined $SchVal && $SchVal eq '%' && (!defined $CatVal || $CatVal eq '') && (!defined $TblVal || $TblVal eq '')) { # Rule 19b
329 0         0 $SQL = <<'SQL';
330             SELECT NULL TABLE_CAT
331             , s TABLE_SCHEM
332             , NULL TABLE_NAME
333             , NULL TABLE_TYPE
334             , NULL REMARKS
335             FROM
336             (
337             SELECT USERNAME s FROM ALL_USERS
338             UNION
339             SELECT 'PUBLIC' s FROM DUAL
340             )
341             ORDER BY TABLE_SCHEM
342             SQL
343             }
344             elsif ( defined $TypVal && $TypVal eq '%' && (!defined $CatVal || $CatVal eq '') && (!defined $SchVal || $SchVal eq '') && (!defined $TblVal || $TblVal eq '')) { # Rule 19c
345 0         0 $SQL = <<'SQL';
346             SELECT NULL TABLE_CAT
347             , NULL TABLE_SCHEM
348             , NULL TABLE_NAME
349             , t.tt TABLE_TYPE
350             , NULL REMARKS
351             FROM
352             (
353             SELECT 'TABLE' tt FROM DUAL
354             UNION
355             SELECT 'VIEW' tt FROM DUAL
356             UNION
357             SELECT 'SYNONYM' tt FROM DUAL
358             UNION
359             SELECT 'SEQUENCE' tt FROM DUAL
360             ) t
361             ORDER BY TABLE_TYPE
362             SQL
363             }
364             else {
365 0         0 $SQL = <<'SQL';
366             SELECT *
367             FROM
368             (
369             SELECT
370             NULL TABLE_CAT
371             , t.OWNER TABLE_SCHEM
372             , t.TABLE_NAME TABLE_NAME
373             , decode(t.OWNER
374             , 'SYS' , 'SYSTEM '
375             , 'SYSTEM' , 'SYSTEM '
376             , '' ) || t.TABLE_TYPE TABLE_TYPE
377             , c.COMMENTS REMARKS
378             FROM ALL_TAB_COMMENTS c
379             , ALL_CATALOG t
380             WHERE c.OWNER (+) = t.OWNER
381             AND c.TABLE_NAME (+) = t.TABLE_NAME
382             AND c.TABLE_TYPE (+) = t.TABLE_TYPE
383             )
384             SQL
385 0 0       0 if ( defined $SchVal ) {
386 0         0 push @Where, "TABLE_SCHEM LIKE '$SchVal' ESCAPE '\\'";
387             }
388 0 0       0 if ( defined $TblVal ) {
389 0         0 push @Where, "TABLE_NAME LIKE '$TblVal' ESCAPE '\\'";
390             }
391 0 0       0 if ( defined $TypVal ) {
392 0         0 my $table_type_list;
393 0         0 $TypVal =~ s/^\s+//;
394 0         0 $TypVal =~ s/\s+$//;
395 0         0 my @ttype_list = split (/\s*,\s*/, $TypVal);
396 0         0 foreach my $table_type (@ttype_list) {
397 0 0       0 if ($table_type !~ /^'.*'$/) {
398 0         0 $table_type = "'" . $table_type . "'";
399             }
400 0         0 $table_type_list = join(", ", @ttype_list);
401             }
402 0         0 push @Where, "TABLE_TYPE IN ($table_type_list)";
403             }
404 0 0       0 $SQL .= ' WHERE ' . join("\n AND ", @Where ) . "\n" if @Where;
405 0         0 $SQL .= " ORDER BY TABLE_TYPE, TABLE_SCHEM, TABLE_NAME\n";
406             }
407 0 0       0 my $sth = $dbh->prepare($SQL) or return undef;
408 0 0       0 $sth->execute or return undef;
409 0         0 $sth;
410             }
411              
412             sub get_column_details_from_data_dictionary {
413 0     0 0 0 my $self = shift;
414              
415 0         0 my $version = $self->_get_oracle_major_server_version();
416 0 0       0 if ($version < '11') {
417 0         0 return $self->SUPER::get_column_details_from_data_dictionary(@_);
418             }
419              
420 0         0 my $dbh = $self->get_default_handle();
421 0 0       0 my $attr = ( ref $_[0] eq 'HASH') ? $_[0] : {
422             'TABLE_SCHEM' => $_[1],'TABLE_NAME' => $_[2],'COLUMN_NAME' => $_[3] };
423 0         0 my($typecase,$typecaseend) = ('','');
424 0         0 my $v = DBD::Oracle::db::ora_server_version($dbh);
425 0 0 0     0 if (!defined($v) or $v->[0] >= 8) {
426 0         0 $typecase = <<'SQL';
427             CASE WHEN tc.DATA_TYPE LIKE 'TIMESTAMP% WITH% TIME ZONE' THEN 95
428             WHEN tc.DATA_TYPE LIKE 'TIMESTAMP%' THEN 93
429             WHEN tc.DATA_TYPE LIKE 'INTERVAL DAY% TO SECOND%' THEN 110
430             WHEN tc.DATA_TYPE LIKE 'INTERVAL YEAR% TO MONTH' THEN 107
431             ELSE
432             SQL
433 0         0 $typecaseend = 'END';
434             }
435 0         0 my $SQL = <<"SQL";
436             SELECT *
437             FROM
438             (
439             SELECT
440             to_char( NULL ) TABLE_CAT
441             , tc.OWNER TABLE_SCHEM
442             , tc.TABLE_NAME TABLE_NAME
443             , tc.COLUMN_NAME COLUMN_NAME
444             , $typecase decode( tc.DATA_TYPE
445             , 'MLSLABEL' , -9106
446             , 'ROWID' , -9104
447             , 'UROWID' , -9104
448             , 'BFILE' , -4 -- 31?
449             , 'LONG RAW' , -4
450             , 'RAW' , -3
451             , 'LONG' , -1
452             , 'UNDEFINED', 0
453             , 'CHAR' , 1
454             , 'NCHAR' , 1
455             , 'NUMBER' , decode( tc.DATA_SCALE, NULL, 8, 3 )
456             , 'FLOAT' , 8
457             , 'VARCHAR2' , 12
458             , 'NVARCHAR2', 12
459             , 'BLOB' , 30
460             , 'CLOB' , 40
461             , 'NCLOB' , 40
462             , 'DATE' , 93
463             , NULL
464             ) $typecaseend DATA_TYPE -- ...
465             , tc.DATA_TYPE TYPE_NAME -- std.?
466             , decode( tc.DATA_TYPE
467             , 'LONG RAW' , 2147483647
468             , 'LONG' , 2147483647
469             , 'CLOB' , 2147483647
470             , 'NCLOB' , 2147483647
471             , 'BLOB' , 2147483647
472             , 'BFILE' , 2147483647
473             , 'NUMBER' , decode( tc.DATA_SCALE
474             , NULL, 126
475             , nvl( tc.DATA_PRECISION, 38 )
476             )
477             , 'FLOAT' , tc.DATA_PRECISION
478             , 'DATE' , 19
479             , tc.DATA_LENGTH
480             ) COLUMN_SIZE
481             , decode( tc.DATA_TYPE
482             , 'LONG RAW' , 2147483647
483             , 'LONG' , 2147483647
484             , 'CLOB' , 2147483647
485             , 'NCLOB' , 2147483647
486             , 'BLOB' , 2147483647
487             , 'BFILE' , 2147483647
488             , 'NUMBER' , nvl( tc.DATA_PRECISION, 38 ) + 2
489             , 'FLOAT' , 8 -- ?
490             , 'DATE' , 16
491             , tc.DATA_LENGTH
492             ) BUFFER_LENGTH
493             , decode( tc.DATA_TYPE
494             , 'DATE' , 0
495             , tc.DATA_SCALE
496             ) DECIMAL_DIGITS -- ...
497             , decode( tc.DATA_TYPE
498             , 'FLOAT' , 2
499             , 'NUMBER' , decode( tc.DATA_SCALE, NULL, 2, 10 )
500             , NULL
501             ) NUM_PREC_RADIX
502             , decode( tc.NULLABLE
503             , 'Y' , 1
504             , 'N' , 0
505             , NULL
506             ) NULLABLE
507             , cc.COMMENTS REMARKS
508             , tc.DATA_DEFAULT COLUMN_DEF -- Column is LONG!
509             , decode( tc.DATA_TYPE
510             , 'MLSLABEL' , -9106
511             , 'ROWID' , -9104
512             , 'UROWID' , -9104
513             , 'BFILE' , -4 -- 31?
514             , 'LONG RAW' , -4
515             , 'RAW' , -3
516             , 'LONG' , -1
517             , 'UNDEFINED', 0
518             , 'CHAR' , 1
519             , 'NCHAR' , 1
520             , 'NUMBER' , decode( tc.DATA_SCALE, NULL, 8, 3 )
521             , 'FLOAT' , 8
522             , 'VARCHAR2' , 12
523             , 'NVARCHAR2', 12
524             , 'BLOB' , 30
525             , 'CLOB' , 40
526             , 'NCLOB' , 40
527             , 'DATE' , 9 -- not 93!
528             , NULL
529             ) SQL_DATA_TYPE -- ...
530             , decode( tc.DATA_TYPE
531             , 'DATE' , 3
532             , NULL
533             ) SQL_DATETIME_SUB -- ...
534             , to_number( NULL ) CHAR_OCTET_LENGTH -- TODO
535             , tc.COLUMN_ID ORDINAL_POSITION
536             , decode( tc.NULLABLE
537             , 'Y' , 'YES'
538             , 'N' , 'NO'
539             , NULL
540             ) IS_NULLABLE
541             FROM ALL_TAB_COLUMNS tc
542             , ALL_COL_COMMENTS cc
543             WHERE tc.OWNER = cc.OWNER
544             AND tc.TABLE_NAME = cc.TABLE_NAME
545             AND tc.COLUMN_NAME = cc.COLUMN_NAME
546             )
547             WHERE 1 = 1
548             SQL
549 0         0 my @BindVals = ();
550 0         0 while ( my ( $k, $v ) = each %$attr ) {
551 0 0       0 if ( $v ) {
552 0         0 $SQL .= " AND $k LIKE ? ESCAPE '\\'\n";
553 0         0 push @BindVals, $v;
554             }
555             }
556 0         0 $SQL .= " ORDER BY TABLE_SCHEM, TABLE_NAME, ORDINAL_POSITION\n";
557 0 0       0 my $sth = $dbh->prepare( $SQL ) or return undef;
558 0 0       0 $sth->execute( @BindVals ) or return undef;
559 0         0 $sth;
560             }
561              
562             sub get_primary_key_details_from_data_dictionary {
563 0     0 0 0 my $self = shift;
564              
565 0         0 my $version = $self->_get_oracle_major_server_version();
566 0 0       0 if ($version < '11') {
567 0         0 return $self->SUPER::get_primary_key_details_from_data_dictionary(@_);
568             }
569              
570 0         0 my $dbh = $self->get_default_handle();
571 0         0 my($catalog, $schema, $table) = @_;
572 0 0       0 if (ref $catalog eq 'HASH') {
573 0         0 ($schema, $table) = @$catalog{'TABLE_SCHEM','TABLE_NAME'};
574 0         0 $catalog = undef;
575             }
576 0         0 my $SQL = <<'SQL';
577             SELECT *
578             FROM
579             (
580             SELECT
581             NULL TABLE_CAT
582             , c.OWNER TABLE_SCHEM
583             , c.TABLE_NAME TABLE_NAME
584             , c.COLUMN_NAME COLUMN_NAME
585             , c.POSITION KEY_SEQ
586             , c.CONSTRAINT_NAME PK_NAME
587             FROM ALL_CONSTRAINTS p
588             , ALL_CONS_COLUMNS c
589             WHERE p.OWNER = c.OWNER
590             AND p.TABLE_NAME = c.TABLE_NAME
591             AND p.CONSTRAINT_NAME = c.CONSTRAINT_NAME
592             AND p.CONSTRAINT_TYPE = 'P'
593             )
594             WHERE TABLE_SCHEM = ?
595             AND TABLE_NAME = ?
596             ORDER BY TABLE_SCHEM, TABLE_NAME, KEY_SEQ
597             SQL
598             #warn "@_\n$Sql ($schema, $table)";
599 0 0       0 my $sth = $dbh->prepare($SQL) or return undef;
600 0 0       0 $sth->execute($schema, $table) or return undef;
601 0         0 $sth;
602             }
603              
604              
605              
606             sub get_foreign_key_details_from_data_dictionary {
607 0     0 0 0 my $self = shift;
608              
609 0         0 my $version = $self->_get_oracle_major_server_version();
610 0 0       0 if ($version < '11') {
611 0         0 return $self->SUPER::get_foreign_key_details_from_data_dictionary(@_);
612             }
613              
614 0         0 my $dbh = $self->get_default_handle();
615 0 0       0 my $attr = ( ref $_[0] eq 'HASH') ? $_[0] : {
616             'UK_TABLE_SCHEM' => $_[1],'UK_TABLE_NAME ' => $_[2]
617             ,'FK_TABLE_SCHEM' => $_[4],'FK_TABLE_NAME ' => $_[5] };
618 0         0 my $SQL = <<'SQL'; # XXX: DEFERABILITY
619             SELECT *
620             FROM
621             (
622             SELECT
623             to_char( NULL ) UK_TABLE_CAT
624             , uk.OWNER UK_TABLE_SCHEM
625             , uk.TABLE_NAME UK_TABLE_NAME
626             , uc.COLUMN_NAME UK_COLUMN_NAME
627             , to_char( NULL ) FK_TABLE_CAT
628             , fk.OWNER FK_TABLE_SCHEM
629             , fk.TABLE_NAME FK_TABLE_NAME
630             , fc.COLUMN_NAME FK_COLUMN_NAME
631             , uc.POSITION ORDINAL_POSITION
632             , 3 UPDATE_RULE
633             , decode( fk.DELETE_RULE, 'CASCADE', 0, 'RESTRICT', 1, 'SET NULL', 2, 'NO ACTION', 3, 'SET DEFAULT', 4 )
634             DELETE_RULE
635             , fk.CONSTRAINT_NAME FK_NAME
636             , uk.CONSTRAINT_NAME UK_NAME
637             , to_char( NULL ) DEFERABILITY
638             , decode( uk.CONSTRAINT_TYPE, 'P', 'PRIMARY', 'U', 'UNIQUE')
639             UNIQUE_OR_PRIMARY
640             FROM ALL_CONSTRAINTS uk
641             , ALL_CONS_COLUMNS uc
642             , ALL_CONSTRAINTS fk
643             , ALL_CONS_COLUMNS fc
644             WHERE uk.OWNER = uc.OWNER
645             AND uk.CONSTRAINT_NAME = uc.CONSTRAINT_NAME
646             AND fk.OWNER = fc.OWNER
647             AND fk.CONSTRAINT_NAME = fc.CONSTRAINT_NAME
648             AND uk.CONSTRAINT_TYPE IN ('P','U')
649             AND fk.CONSTRAINT_TYPE = 'R'
650             AND uk.CONSTRAINT_NAME = fk.R_CONSTRAINT_NAME
651             AND uk.OWNER = fk.R_OWNER
652             AND uc.POSITION = fc.POSITION
653             )
654             WHERE 1 = 1
655             SQL
656 0         0 my @BindVals = ();
657 0         0 while ( my ( $k, $v ) = each %$attr ) {
658 0 0       0 if ( $v ) {
659 0         0 $SQL .= " AND $k = ?\n";
660 0         0 push @BindVals, $v;
661             }
662             }
663 0         0 $SQL .= " ORDER BY UK_TABLE_SCHEM, UK_TABLE_NAME, FK_TABLE_SCHEM, FK_TABLE_NAME, ORDINAL_POSITION\n";
664 0 0       0 my $sth = $dbh->prepare( $SQL ) or return undef;
665 0 0       0 $sth->execute( @BindVals ) or return undef;
666 0         0 $sth;
667             }
668              
669              
670             sub _get_oracle_major_server_version {
671 0     0   0 my $self = shift;
672              
673 0 0       0 unless (exists $self->{'__ora_major_server_version'}) {
674 0         0 my $dbh = $self->get_default_handle();
675 0         0 my @data = $dbh->selectrow_arrayref('select version from v$instance');
676 0         0 $self->{'__ora_major_server_version'} = (split(/\./, $data[0]->[0]))[0];
677             }
678 0         0 return $self->{'__ora_major_server_version'};
679             }
680              
681             sub cast_for_data_conversion {
682 23     23 0 36 my($class, $left_type, $right_type, $operator, $sql_clause) = @_;
683              
684 23         56 my @retval = ('%s','%s');
685              
686             # compatible types
687 23 100 66     188 if ($left_type->isa($right_type)
688             or
689             $right_type->isa($left_type)
690             ) {
691 5         16 return @retval;
692             }
693              
694 18 50 66     109 if (! $left_type->isa('UR::Value::Text')
695             and
696             ! $right_type->isa('UR::Value::Text')
697             ) {
698             # We only support cases where one is a string, for now
699             # hopefully the DB can sort it out
700 0         0 return @retval;
701             }
702              
703             # Oracle can auto-convert strings into numbers and dates in the 'where'
704             # clause, but has issues in joins
705 18 100       34 if ($sql_clause eq 'where') {
706 2         7 return @retval;
707             }
708              
709             # Figure out which one is the non-string
710 16 100       58 my($data_type, $i) = $left_type->isa('UR::Value::Text')
711             ? ( $right_type, 1)
712             : ( $left_type, 0);
713              
714 16 100       65 if ($data_type->isa('UR::Value::Number')) {
    100          
    50          
715 12         19 $retval[$i] = q{to_char(%s)};
716              
717             } elsif ($data_type->isa('UR::Value::Timestamp')) {
718             # These time formats shoule match what's given in init_created_handle
719 2         8 $retval[$i] = qq{to_char(%s, '$TIMESTAMP_FORMAT')};
720              
721             } elsif ($data_type->isa('UR::Value::DateTime')) {
722 2         8 $retval[$i] = qq{to_char(%s, '$DATE_FORMAT')};
723              
724             } else {
725 0         0 @retval = $class->SUPER::cast_for_data_conversion($left_type, $right_type);
726             }
727              
728 16         47 return @retval;
729             }
730              
731             sub _vendor_data_type_for_ur_data_type {
732 0     0     return ( TEXT => 'VARCHAR2',
733             STRING => 'VARCHAR2',
734             BOOLEAN => 'INTEGER',
735             __default__ => 'VARCHAR2',
736             shift->SUPER::_vendor_data_type_for_ur_data_type(),
737             );
738             };
739              
740              
741             1;
742              
743             =pod
744              
745             =head1 NAME
746              
747             UR::DataSource::Oracle - Oracle specific subclass of UR::DataSource::RDBMS
748              
749             =head1 DESCRIPTION
750              
751             This module provides the Oracle-specific methods necessary for interacting with
752             Oracle databases
753              
754             =head1 SEE ALSO
755              
756             L, L
757              
758             =cut
759