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