Commit | Line | Data |
996be9ee |
1 | package DBIx::Class::Schema::Loader::DBI::DB2; |
2 | |
3 | use strict; |
4 | use warnings; |
41968729 |
5 | use base qw/ |
6 | DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault |
7 | DBIx::Class::Schema::Loader::DBI |
8 | /; |
942bd5e0 |
9 | use mro 'c3'; |
996be9ee |
10 | |
ecf22f0a |
11 | use List::Util 'any'; |
c4a69b87 |
12 | use namespace::clean; |
13 | |
14 | use DBIx::Class::Schema::Loader::Table (); |
15 | |
306bf770 |
16 | our $VERSION = '0.07047'; |
32f784fc |
17 | |
996be9ee |
18 | =head1 NAME |
19 | |
20 | DBIx::Class::Schema::Loader::DBI::DB2 - DBIx::Class::Schema::Loader::DBI DB2 Implementation. |
21 | |
996be9ee |
22 | =head1 DESCRIPTION |
23 | |
c4a69b87 |
24 | See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>. |
996be9ee |
25 | |
26 | =cut |
27 | |
c4a69b87 |
28 | sub _system_schemas { |
29 | my $self = shift; |
30 | |
31 | return ($self->next::method(@_), qw/ |
32 | SYSCAT SYSIBM SYSIBMADM SYSPUBLIC SYSSTAT SYSTOOLS |
33 | /); |
34 | } |
35 | |
7a930e63 |
36 | sub _setup { |
37 | my $self = shift; |
38 | |
39 | $self->next::method(@_); |
40 | |
c4a69b87 |
41 | my $ns = $self->name_sep; |
42 | |
43 | $self->db_schema([ $self->dbh->selectrow_array(<<"EOF", {}) ]) unless $self->db_schema; |
44 | SELECT CURRENT_SCHEMA FROM sysibm${ns}sysdummy1 |
45 | EOF |
bc1cb85e |
46 | |
47 | if (not defined $self->preserve_case) { |
48 | $self->preserve_case(0); |
49 | } |
b511f36e |
50 | elsif ($self->preserve_case) { |
51 | $self->schema->storage->sql_maker->quote_char('"'); |
c4a69b87 |
52 | $self->schema->storage->sql_maker->name_sep($ns); |
b511f36e |
53 | } |
7a930e63 |
54 | } |
55 | |
996be9ee |
56 | sub _table_uniq_info { |
57 | my ($self, $table) = @_; |
58 | |
59 | my @uniqs; |
60 | |
c4a69b87 |
61 | my $sth = $self->{_cache}->{db2_uniq} ||= $self->dbh->prepare(<<'EOF'); |
62 | SELECT kcu.colname, kcu.constname, kcu.colseq |
63 | FROM syscat.tabconst as tc |
64 | JOIN syscat.keycoluse as kcu |
65 | ON tc.constname = kcu.constname |
66 | AND tc.tabschema = kcu.tabschema |
67 | AND tc.tabname = kcu.tabname |
68 | WHERE tc.tabschema = ? and tc.tabname = ? and tc.type = 'U' |
69 | EOF |
5223f24a |
70 | |
c4a69b87 |
71 | $sth->execute($table->schema, $table->name); |
996be9ee |
72 | |
73 | my %keydata; |
74 | while(my $row = $sth->fetchrow_arrayref) { |
75 | my ($col, $constname, $seq) = @$row; |
b511f36e |
76 | push(@{$keydata{$constname}}, [ $seq, $self->_lc($col) ]); |
996be9ee |
77 | } |
6c4f5a4a |
78 | foreach my $keyname (sort keys %keydata) { |
996be9ee |
79 | my @ordered_cols = map { $_->[1] } sort { $a->[0] <=> $b->[0] } |
80 | @{$keydata{$keyname}}; |
81 | push(@uniqs, [ $keyname => \@ordered_cols ]); |
82 | } |
4421d6a3 |
83 | |
996be9ee |
84 | $sth->finish; |
075473b9 |
85 | |
996be9ee |
86 | return \@uniqs; |
87 | } |
88 | |
a168c1c4 |
89 | sub _table_fk_info { |
90 | my ($self, $table) = @_; |
91 | |
c4a69b87 |
92 | my $sth = $self->{_cache}->{db2_fk} ||= $self->dbh->prepare(<<'EOF'); |
93 | SELECT tc.constname, sr.reftabschema, sr.reftabname, |
075473b9 |
94 | kcu.colname, rkcu.colname, kcu.colseq, |
95 | sr.deleterule, sr.updaterule |
c4a69b87 |
96 | FROM syscat.tabconst tc |
97 | JOIN syscat.keycoluse kcu |
98 | ON tc.constname = kcu.constname |
99 | AND tc.tabschema = kcu.tabschema |
100 | AND tc.tabname = kcu.tabname |
101 | JOIN syscat.references sr |
102 | ON tc.constname = sr.constname |
103 | AND tc.tabschema = sr.tabschema |
104 | AND tc.tabname = sr.tabname |
105 | JOIN syscat.keycoluse rkcu |
106 | ON sr.refkeyname = rkcu.constname |
208bdf79 |
107 | AND sr.reftabschema = rkcu.tabschema |
108 | AND sr.reftabname = rkcu.tabname |
c4a69b87 |
109 | AND kcu.colseq = rkcu.colseq |
110 | WHERE tc.tabschema = ? |
111 | AND tc.tabname = ? |
112 | AND tc.type = 'F'; |
113 | EOF |
114 | $sth->execute($table->schema, $table->name); |
115 | |
116 | my %rels; |
117 | |
075473b9 |
118 | my %rules = ( |
119 | A => 'NO ACTION', |
120 | C => 'CASCADE', |
121 | N => 'SET NULL', |
122 | R => 'RESTRICT', |
123 | ); |
124 | |
c4a69b87 |
125 | COLS: while (my @row = $sth->fetchrow_array) { |
126 | my ($fk, $remote_schema, $remote_table, $local_col, $remote_col, |
075473b9 |
127 | $colseq, $delete_rule, $update_rule) = @row; |
c4a69b87 |
128 | |
129 | if (not exists $rels{$fk}) { |
130 | if ($self->db_schema && $self->db_schema->[0] ne '%' |
131 | && (not any { $_ eq $remote_schema } @{ $self->db_schema })) { |
132 | |
133 | next COLS; |
134 | } |
a168c1c4 |
135 | |
c4a69b87 |
136 | $rels{$fk}{remote_table} = DBIx::Class::Schema::Loader::Table->new( |
137 | loader => $self, |
138 | name => $remote_table, |
139 | schema => $remote_schema, |
140 | ); |
141 | } |
142 | |
143 | $rels{$fk}{local_columns}[$colseq-1] = $self->_lc($local_col); |
144 | $rels{$fk}{remote_columns}[$colseq-1] = $self->_lc($remote_col); |
075473b9 |
145 | |
146 | $rels{$fk}{attrs} ||= { |
147 | on_delete => $rules{$delete_rule}, |
148 | on_update => $rules{$update_rule}, |
149 | is_deferrable => 1, # DB2 has no deferrable constraints |
150 | }; |
a168c1c4 |
151 | } |
152 | |
c4a69b87 |
153 | return [ values %rels ]; |
154 | } |
155 | |
156 | |
e80ea87b |
157 | # DBD::DB2 doesn't follow the DBI API for ->tables (pre 1.85), but since its |
158 | # backwards compatible we don't change it. |
159 | # DBD::DB2 1.85 and beyond default TABLE_NAME to '', previously defaulted to |
160 | # '%'. so we supply it. |
c4a69b87 |
161 | sub _dbh_tables { |
162 | my ($self, $schema) = @_; |
163 | |
e80ea87b |
164 | return $self->dbh->tables($schema ? { TABLE_SCHEM => $schema, TABLE_NAME => '%' } : undef); |
a168c1c4 |
165 | } |
166 | |
d9a16c64 |
167 | sub _dbh_table_info { |
168 | my $self = shift; |
169 | |
170 | local $^W = 0; # shut up undef warning from DBD::DB2 |
171 | |
172 | $self->next::method(@_); |
173 | } |
174 | |
a168c1c4 |
175 | sub _columns_info_for { |
8a64178e |
176 | my $self = shift; |
177 | my ($table) = @_; |
a168c1c4 |
178 | |
c4a69b87 |
179 | my $result = $self->next::method(@_); |
8a64178e |
180 | |
181 | while (my ($col, $info) = each %$result) { |
182 | # check for identities |
c4a69b87 |
183 | my $sth = $self->dbh->prepare_cached( |
8a64178e |
184 | q{ |
185 | SELECT COUNT(*) |
186 | FROM syscat.columns |
187 | WHERE tabschema = ? AND tabname = ? AND colname = ? |
188 | AND identity = 'Y' AND generated != '' |
189 | }, |
190 | {}, 1); |
c4a69b87 |
191 | $sth->execute($table->schema, $table->name, $self->_uc($col)); |
8a64178e |
192 | if ($sth->fetchrow_array) { |
193 | $info->{is_auto_increment} = 1; |
194 | } |
195 | |
7640ef4b |
196 | my $data_type = $info->{data_type}; |
197 | |
198 | if ($data_type !~ /^(?:(?:var)?(?:char|graphic)|decimal)\z/i) { |
8a64178e |
199 | delete $info->{size}; |
7640ef4b |
200 | } |
201 | |
202 | if ($data_type eq 'double') { |
203 | $info->{data_type} = 'double precision'; |
204 | } |
205 | elsif ($data_type eq 'decimal') { |
206 | no warnings 'uninitialized'; |
207 | |
208 | $info->{data_type} = 'numeric'; |
209 | |
210 | my @size = @{ $info->{size} || [] }; |
211 | |
212 | if ($size[0] == 5 && $size[1] == 0) { |
213 | delete $info->{size}; |
214 | } |
215 | } |
216 | elsif ($data_type =~ /^(?:((?:var)?char) \(\) for bit data|(long varchar) for bit data)\z/i) { |
217 | my $base_type = lc($1 || $2); |
218 | |
219 | (my $original_type = $data_type) =~ s/[()]+ //; |
220 | |
221 | $info->{original}{data_type} = $original_type; |
222 | |
223 | if ($base_type eq 'long varchar') { |
224 | $info->{data_type} = 'blob'; |
225 | } |
226 | else { |
227 | if ($base_type eq 'char') { |
228 | $info->{data_type} = 'binary'; |
229 | } |
230 | elsif ($base_type eq 'varchar') { |
231 | $info->{data_type} = 'varbinary'; |
232 | } |
233 | |
c4a69b87 |
234 | my ($size) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $self->_uc($col)); |
7640ef4b |
235 | SELECT length |
236 | FROM syscat.columns |
237 | WHERE tabschema = ? AND tabname = ? AND colname = ? |
238 | EOF |
239 | |
240 | $info->{size} = $size if $size; |
241 | } |
242 | } |
243 | |
244 | if ((eval { lc ${ $info->{default_value} } }||'') =~ /^current (date|time(?:stamp)?)\z/i) { |
245 | my $type = lc($1); |
246 | |
247 | ${ $info->{default_value} } = 'current_timestamp'; |
701cd3e3 |
248 | |
7640ef4b |
249 | my $orig_deflt = "current $type"; |
701cd3e3 |
250 | $info->{original}{default_value} = \$orig_deflt; |
8a64178e |
251 | } |
772cfe65 |
252 | } |
253 | |
8a64178e |
254 | return $result; |
772cfe65 |
255 | } |
256 | |
996be9ee |
257 | =head1 SEE ALSO |
258 | |
259 | L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, |
260 | L<DBIx::Class::Schema::Loader::DBI> |
261 | |
b87ab391 |
262 | =head1 AUTHORS |
be80bba7 |
263 | |
b87ab391 |
264 | See L<DBIx::Class::Schema::Loader/AUTHORS>. |
be80bba7 |
265 | |
266 | =head1 LICENSE |
267 | |
268 | This library is free software; you can redistribute it and/or modify it under |
269 | the same terms as Perl itself. |
270 | |
996be9ee |
271 | =cut |
272 | |
273 | 1; |
8a64178e |
274 | # vim:et sts=4 sw=4 tw=0: |