Release 0.07047

[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / DBI / Oracle.pm

diff --git a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm
index 62cc0ad..dd10088 100644 (file)
--- a/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm
@@ -5,13 +5,14 @@ use warnings;
 use base 'DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault';
 use mro 'c3';
 use Try::Tiny;
+use DBIx::Class::Schema::Loader::Utils qw/sigwarn_silencer/;
 use namespace::clean;
 
-our $VERSION = '0.07026';
+our $VERSION = '0.07047';
 
 =head1 NAME
 
-DBIx::Class::Schema::Loader::DBI::Oracle - DBIx::Class::Schema::Loader::DBI 
+DBIx::Class::Schema::Loader::DBI::Oracle - DBIx::Class::Schema::Loader::DBI
 Oracle Implementation.
 
 =head1 DESCRIPTION
@@ -69,15 +70,42 @@ sub _filter_tables {
     my $self = shift;
 
     # silence a warning from older DBD::Oracles in tests
-    my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
-    local $SIG{__WARN__} = sub {
-        $warn_handler->(@_)
-        unless $_[0] =~ /^Field \d+ has an Oracle type \(\d+\) which is not explicitly supported/;
-    };
+    local $SIG{__WARN__} = sigwarn_silencer(
+        qr/^Field \d+ has an Oracle type \(\d+\) which is not explicitly supported/
+    );
 
     return $self->next::method(@_);
 }
 
+sub _table_fk_info {
+    my $self = shift;
+    my ($table) = @_;
+
+    my $rels = $self->next::method(@_);
+
+    my $deferrable_sth = $self->dbh->prepare_cached(<<'EOF');
+select deferrable from all_constraints
+where owner = ? and table_name = ? and constraint_name = ? and status = 'ENABLED'
+EOF
+
+    my @enabled_rels;
+    foreach my $rel (@$rels) {
+        # Oracle does not have update rules
+        $rel->{attrs}{on_update} = 'NO ACTION';;
+
+        # DBD::Oracle's foreign_key_info does not return DEFERRABILITY, so we get it ourselves
+        # Also use this to filter out disabled foreign keys, which are returned by DBD::Oracle < 1.76
+        my $deferrable = $self->dbh->selectrow_array(
+            $deferrable_sth, undef, $table->schema, $table->name, $rel->{_constraint_name}
+        ) or next;
+
+        $rel->{attrs}{is_deferrable} = $deferrable =~ /^DEFERRABLE/i ? 1 : 0;
+        push @enabled_rels, $rel;
+    }
+
+    return \@enabled_rels;
+}
+
 sub _table_uniq_info {
     my ($self, $table) = @_;
 
@@ -87,7 +115,8 @@ FROM all_constraints ac, all_cons_columns acc
 WHERE acc.table_name=? AND acc.owner = ?
     AND ac.table_name = acc.table_name AND ac.owner = acc.owner
     AND acc.constraint_name = ac.constraint_name
-    AND ac.constraint_type='U'
+    AND ac.constraint_type = 'U'
+    AND ac.status = 'ENABLED'
 ORDER BY acc.position
 EOF
 
@@ -100,9 +129,8 @@ EOF
         my $constr_col  = $self->_lc($constr->[1]);
         push @{$constr_names{$constr_name}}, $constr_col;
     }
-    
-    my @uniqs = map { [ $_ => $constr_names{$_} ] } keys %constr_names;
-    return \@uniqs;
+
+    return [ map { [ $_ => $constr_names{$_} ] } sort keys %constr_names ];
 }
 
 sub _table_comment {
@@ -115,7 +143,7 @@ sub _table_comment {
 
     ($table_comment) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name);
 SELECT comments FROM all_tab_comments
-WHERE owner = ? 
+WHERE owner = ?
   AND table_name = ?
   AND (table_type = 'TABLE' OR table_type = 'VIEW')
 EOF
@@ -133,7 +161,7 @@ sub _column_comment {
 
     ($column_comment) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $self->_uc($column_name));
 SELECT comments FROM all_col_comments
-WHERE owner = ? 
+WHERE owner = ?
   AND table_name = ?
   AND column_name = ?
 EOF
@@ -153,14 +181,14 @@ sub _columns_info_for {
     my $sth = $self->dbh->prepare_cached(<<'EOF', {}, 1);
 SELECT trigger_body
 FROM all_triggers
-WHERE table_name = ? AND table_owner = ?
+WHERE table_name = ? AND table_owner = ? AND status = 'ENABLED'
 AND upper(trigger_type) LIKE '%BEFORE EACH ROW%' AND lower(triggering_event) LIKE '%insert%'
 EOF
 
     $sth->execute($table->name, $table->schema);
 
     while (my ($trigger_body) = $sth->fetchrow_array) {
-        if (my ($seq_schema, $seq_name) = $trigger_body =~ /(?:\."?(\w+)"?)?"?(\w+)"?\.nextval/i) {
+        if (my ($seq_schema, $seq_name) = $trigger_body =~ /(?:"?(\w+)"?\.)?"?(\w+)"?\.nextval/i) {
             if (my ($col_name) = $trigger_body =~ /:new\.(\w+)/i) {
                 $col_name = $self->_lc($col_name);
 
@@ -174,6 +202,9 @@ EOF
         }
     }
 
+    # Old DBD::Oracle report the size in (UTF-16) bytes, not characters
+    my $nchar_size_factor = $DBD::Oracle::VERSION >= 1.52 ? 1 : 2;
+
     while (my ($col, $info) = each %$result) {
         no warnings 'uninitialized';
 
@@ -204,7 +235,7 @@ EOF
                 $info->{size} = $info->{size}[0] / 8;
             }
             else {
-                $info->{size} = $info->{size} / 2;
+                $info->{size} = $info->{size} / $nchar_size_factor;
             }
         }
         elsif ($info->{data_type} =~ /^(?:var)?char2?\z/i) {
@@ -315,7 +346,7 @@ EOF
         elsif (lc($info->{data_type}) eq 'binary_float') {
             $info->{data_type}           = 'real';
             $info->{original}{data_type} = 'binary_float';
-        } 
+        }
         elsif (lc($info->{data_type}) eq 'binary_double') {
             $info->{data_type}           = 'double precision';
             $info->{original}{data_type} = 'binary_double';
@@ -378,14 +409,24 @@ sub _dbh_column_info {
     return $self->next::method(@_);
 }
 
+sub _view_definition {
+    my ($self, $view) = @_;
+
+    return scalar $self->schema->storage->dbh->selectrow_array(<<'EOF', {}, $view->schema, $view->name);
+SELECT text
+FROM all_views
+WHERE owner = ? AND view_name = ?
+EOF
+}
+
 =head1 SEE ALSO
 
 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 L<DBIx::Class::Schema::Loader::DBI>
 
-=head1 AUTHOR
+=head1 AUTHORS
 
-See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+See L<DBIx::Class::Schema::Loader/AUTHORS>.
 
 =head1 LICENSE