Commit | Line | Data |
d87d939a |
1 | package DBIx::Class::Schema::Loader::DBI::Oracle; |
e7262300 |
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 | |
c3fb509f |
9 | our $VERSION = '0.04999_09'; |
e7262300 |
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 | |
d0e184e9 |
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 | |
e7262300 |
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 | |
e7262300 |
77 | my $dbh = $self->schema->storage->dbh; |
78 | |
79 | my $sth = $dbh->prepare_cached( |
65ab592d |
80 | q{ |
c7bf4194 |
81 | SELECT constraint_name, acc.column_name |
82 | FROM all_constraints JOIN all_cons_columns acc USING (constraint_name) |
83 | WHERE acc.table_name=? AND constraint_type='U' |
84 | ORDER BY acc.position |
65ab592d |
85 | }, |
86 | {}, 1); |
e7262300 |
87 | |
88 | $sth->execute(uc $table); |
89 | my %constr_names; |
90 | while(my $constr = $sth->fetchrow_arrayref) { |
65ab592d |
91 | my $constr_name = lc $constr->[0]; |
92 | my $constr_def = lc $constr->[1]; |
e7262300 |
93 | $constr_name =~ s/\Q$self->{_quoter}\E//; |
94 | $constr_def =~ s/\Q$self->{_quoter}\E//; |
65ab592d |
95 | push @{$constr_names{$constr_name}}, $constr_def; |
e7262300 |
96 | } |
65ab592d |
97 | |
98 | my @uniqs = map { [ $_ => $constr_names{$_} ] } keys %constr_names; |
e7262300 |
99 | return \@uniqs; |
100 | } |
101 | |
102 | sub _table_pk_info { |
65ab592d |
103 | my ($self, $table) = @_; |
104 | return $self->next::method(uc $table); |
e7262300 |
105 | } |
106 | |
107 | sub _table_fk_info { |
108 | my ($self, $table) = @_; |
109 | |
65ab592d |
110 | my $rels = $self->next::method(uc $table); |
e7262300 |
111 | |
65ab592d |
112 | foreach my $rel (@$rels) { |
113 | $rel->{remote_table} = lc $rel->{remote_table}; |
e7262300 |
114 | } |
115 | |
65ab592d |
116 | return $rels; |
117 | } |
118 | |
119 | sub _columns_info_for { |
120 | my ($self, $table) = @_; |
121 | return $self->next::method(uc $table); |
e7262300 |
122 | } |
123 | |
fb328d1a |
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(*) |
c7bf4194 |
134 | FROM all_triggers ut JOIN all_trigger_cols atc USING (trigger_name) |
135 | WHERE atc.table_name = ? AND atc.column_name = ? |
fb328d1a |
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 | |
e7262300 |
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 | |
fb328d1a |
158 | Dagfinn Ilmari Mannsåker C<ilmari@ilmari.org> |
159 | |
e7262300 |
160 | =cut |
161 | |
162 | 1; |