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.06001';
  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, $opts) = @_;
  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
  77     return $self->_filter_tables(\@tables, $opts);
  78 }
  79
  80 sub _table_uniq_info {
  81     my ($self, $table) = @_;
  82
  83     my $dbh = $self->schema->storage->dbh;
  84
  85     my $sth = $dbh->prepare_cached(
  86         q{
  87             SELECT constraint_name, acc.column_name
  88             FROM all_constraints JOIN all_cons_columns acc USING (constraint_name)
  89             WHERE acc.table_name=? and acc.owner = ? AND constraint_type='U'
  90             ORDER BY acc.position
  91         },
  92         {}, 1);
  93
  94     $sth->execute(uc $table,$self->{db_schema} );
  95     my %constr_names;
  96     while(my $constr = $sth->fetchrow_arrayref) {
  97         my $constr_name = lc $constr->[0];
  98         my $constr_def  = lc $constr->[1];
  99         $constr_name =~ s/\Q$self->{_quoter}\E//;
 100         $constr_def =~ s/\Q$self->{_quoter}\E//;
 101         push @{$constr_names{$constr_name}}, $constr_def;
 102     }
 103
 104     my @uniqs = map { [ $_ => $constr_names{$_} ] } keys %constr_names;
 105     return \@uniqs;
 106 }
 107
 108 sub _table_pk_info {
 109     my ($self, $table) = @_;
 110     return $self->next::method(uc $table);
 111 }
 112
 113 sub _table_fk_info {
 114     my ($self, $table) = @_;
 115
 116     my $rels = $self->next::method(uc $table);
 117
 118     foreach my $rel (@$rels) {
 119         $rel->{remote_table} = lc $rel->{remote_table};
 120     }
 121
 122     return $rels;
 123 }
 124
 125 sub _columns_info_for {
 126     my ($self, $table) = @_;
 127     return $self->next::method(uc $table);
 128 }
 129
 130 sub _extra_column_info {
 131     my ($self, $table, $column, $info, $dbi_info) = @_;
 132     my %extra_info;
 133
 134     my $dbh = $self->schema->storage->dbh;
 135     my $sth = $dbh->prepare_cached(
 136         q{
 137             SELECT COUNT(*)
 138             FROM all_triggers ut JOIN all_trigger_cols atc USING (trigger_name)
 139             WHERE atc.table_name = ? AND atc.column_name = ?
 140             AND column_usage LIKE '%NEW%' AND column_usage LIKE '%OUT%'
 141             AND trigger_type = 'BEFORE EACH ROW' AND triggering_event LIKE '%INSERT%'
 142         },
 143         {}, 1);
 144
 145     $sth->execute($table, $column);
 146     if ($sth->fetchrow_array) {
 147         $extra_info{is_auto_increment} = 1;
 148     }
 149
 150     return \%extra_info;
 151 }
 152
 153 =head1 SEE ALSO
 154
 155 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 156 L<DBIx::Class::Schema::Loader::DBI>
 157
 158 =head1 AUTHOR
 159
 160 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 161
 162 =head1 LICENSE
 163
 164 This library is free software; you can redistribute it and/or modify it under
 165 the same terms as Perl itself.
 166
 167 =cut
 168
 169 1;