1package DBIx::Class::Schema::Loader::DBI::Oracle; 2 3use strict; 4use warnings; 5use base qw/ 6 DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault 7 DBIx::Class::Schema::Loader::DBI 8/; 9use Carp::Clan qw/^DBIx::Class/; 10use Class::C3; 11 12our $VERSION = '0.05003'; 13 14=head1 NAME 15 16DBIx::Class::Schema::Loader::DBI::Oracle - DBIx::Class::Schema::Loader::DBI 17Oracle 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 30See L<DBIx::Class::Schema::Loader::Base>. 31 32This module is considered experimental and not well tested yet. 33 34=cut 35 36sub _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 52sub _table_as_sql { 53 my ($self, $table) = @_; 54 55 return $self->_quote_table_name($table); 56} 57 58sub _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 79sub _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 107sub _table_pk_info { 108 my ($self, $table) = @_; 109 return $self->next::method(uc $table); 110} 111 112sub _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 124sub _columns_info_for { 125 my ($self, $table) = @_; 126 return $self->next::method(uc $table); 127} 128 129sub _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 156L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, 157L<DBIx::Class::Schema::Loader::DBI> 158 159=head1 AUTHOR 160 161See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. 162 163=head1 LICENSE 164 165This library is free software; you can redistribute it and/or modify it under 166the same terms as Perl itself. 167 168=cut 169 1701; 171