lib/DBIx/Class/Schema/Loader/DBI/Oracle.pm

   1 package DBIx::Class::Schema::Loader::DBI::Oracle;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/
   6     DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault
   7     DBIx::Class::Schema::Loader::DBI
   8 /;
   9 use Carp::Clan qw/^DBIx::Class/;
  10 use Class::C3;
  11
  12 our $VERSION = '0.05003';
  13
  14 =head1 NAME
  15
  16 DBIx::Class::Schema::Loader::DBI::Oracle - DBIx::Class::Schema::Loader::DBI
  17 Oracle Implementation.
  18
  19 =head1 SYNOPSIS
  20
  21   package My::Schema;
  22   use base qw/DBIx::Class::Schema::Loader/;
  23
  24   __PACKAGE__->loader_options( debug => 1 );
  25
  26   1;
  27
  28 =head1 DESCRIPTION
  29
  30 See L<DBIx::Class::Schema::Loader::Base>.
  31
  32 This module is considered experimental and not well tested yet.
  33
  34 =cut
  35
  36 sub _setup {
  37     my $self = shift;
  38
  39     $self->next::method(@_);
  40
  41     my $dbh = $self->schema->storage->dbh;
  42
  43     my ($current_schema) = $dbh->selectrow_array('SELECT USER FROM DUAL', {});
  44
  45     $self->{db_schema} ||= $current_schema;
  46
  47     if (lc($self->db_schema) ne lc($current_schema)) {
  48         $dbh->do('ALTER SESSION SET current_schema=' . $self->db_schema);
  49     }
  50 }
  51
  52 sub _table_as_sql {
  53     my ($self, $table) = @_;
  54
  55     return $self->_quote_table_name($table);
  56 }
  57
  58 sub _tables_list {
  59     my $self = shift;
  60
  61     my $dbh = $self->schema->storage->dbh;
  62
  63     my @tables;
  64     for my $table ( $dbh->tables(undef, $self->db_schema, '%', 'TABLE,VIEW') ) { #catalog, schema, table, type
  65         my $quoter = $dbh->get_info(29);
  66         $table =~ s/$quoter//g;
  67
  68         # remove "user." (schema) prefixes
  69         $table =~ s/\w+\.//;
  70
  71         next if $table eq 'PLAN_TABLE';
  72         $table = lc $table;
  73         push @tables, $1
  74           if $table =~ /\A(\w+)\z/;
  75     }
  76     return $self->_filter_tables(@tables);
  77 }
  78
  79 sub _table_uniq_info {
  80     my ($self, $table) = @_;
  81
  82     my $dbh = $self->schema->storage->dbh;
  83
  84     my $sth = $dbh->prepare_cached(
  85         q{
  86             SELECT constraint_name, acc.column_name
  87             FROM all_constraints JOIN all_cons_columns acc USING (constraint_name)
  88             WHERE acc.table_name=? and acc.owner = ? AND constraint_type='U'
  89             ORDER BY acc.position
  90         },
  91         {}, 1);
  92
  93     $sth->execute(uc $table,$self->{db_schema} );
  94     my %constr_names;
  95     while(my $constr = $sth->fetchrow_arrayref) {
  96         my $constr_name = lc $constr->[0];
  97         my $constr_def  = lc $constr->[1];
  98         $constr_name =~ s/\Q$self->{_quoter}\E//;
  99         $constr_def =~ s/\Q$self->{_quoter}\E//;
 100         push @{$constr_names{$constr_name}}, $constr_def;
 101     }
 102
 103     my @uniqs = map { [ $_ => $constr_names{$_} ] } keys %constr_names;
 104     return \@uniqs;
 105 }
 106
 107 sub _table_pk_info {
 108     my ($self, $table) = @_;
 109     return $self->next::method(uc $table);
 110 }
 111
 112 sub _table_fk_info {
 113     my ($self, $table) = @_;
 114
 115     my $rels = $self->next::method(uc $table);
 116
 117     foreach my $rel (@$rels) {
 118         $rel->{remote_table} = lc $rel->{remote_table};
 119     }
 120
 121     return $rels;
 122 }
 123
 124 sub _columns_info_for {
 125     my ($self, $table) = @_;
 126     return $self->next::method(uc $table);
 127 }
 128
 129 sub _extra_column_info {
 130     my ($self, $info) = @_;
 131     my %extra_info;
 132
 133     my ($table, $column) = @$info{qw/TABLE_NAME COLUMN_NAME/};
 134
 135     my $dbh = $self->schema->storage->dbh;
 136     my $sth = $dbh->prepare_cached(
 137         q{
 138             SELECT COUNT(*)
 139             FROM all_triggers ut JOIN all_trigger_cols atc USING (trigger_name)
 140             WHERE atc.table_name = ? AND atc.column_name = ?
 141             AND column_usage LIKE '%NEW%' AND column_usage LIKE '%OUT%'
 142             AND trigger_type = 'BEFORE EACH ROW' AND triggering_event LIKE '%INSERT%'
 143         },
 144         {}, 1);
 145
 146     $sth->execute($table, $column);
 147     if ($sth->fetchrow_array) {
 148         $extra_info{is_auto_increment} = 1;
 149     }
 150
 151     return \%extra_info;
 152 }
 153
 154 =head1 SEE ALSO
 155
 156 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 157 L<DBIx::Class::Schema::Loader::DBI>
 158
 159 =head1 AUTHOR
 160
 161 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 162
 163 =head1 LICENSE
 164
 165 This library is free software; you can redistribute it and/or modify it under
 166 the same terms as Perl itself.
 167
 168 =cut
 169
 170 1;