Commit | Line | Data |
bc5afe55 |
1 | package DBIx::Class::Schema::Loader::DBI::Informix; |
2 | |
3 | use strict; |
4 | use warnings; |
942bd5e0 |
5 | use mro 'c3'; |
bc5afe55 |
6 | use base qw/DBIx::Class::Schema::Loader::DBI/; |
bc5afe55 |
7 | use Carp::Clan qw/^DBIx::Class/; |
8 | use Scalar::Util 'looks_like_number'; |
2b74a06b |
9 | use namespace::clean; |
bc5afe55 |
10 | |
e94ccbea |
11 | our $VERSION = '0.07006'; |
bc5afe55 |
12 | |
13 | =head1 NAME |
14 | |
15 | DBIx::Class::Schema::Loader::DBI::Informix - DBIx::Class::Schema::Loader::DBI |
16 | Informix Implementation. |
17 | |
18 | =head1 DESCRIPTION |
19 | |
20 | See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>. |
21 | |
22 | =cut |
23 | |
24 | sub _setup { |
25 | my $self = shift; |
26 | |
27 | $self->next::method(@_); |
28 | |
29 | if (not defined $self->preserve_case) { |
30 | $self->preserve_case(0); |
31 | } |
b511f36e |
32 | elsif ($self->preserve_case) { |
33 | $self->schema->storage->sql_maker->quote_char('"'); |
34 | $self->schema->storage->sql_maker->name_sep('.'); |
35 | } |
bc5afe55 |
36 | } |
37 | |
38 | sub _tables_list { |
39 | my ($self, $opts) = @_; |
40 | |
41 | my $dbh = $self->schema->storage->dbh; |
42 | my $sth = $dbh->prepare(<<'EOF'); |
43 | select tabname from systables t |
44 | where t.owner <> 'informix' and t.owner <> '' and t.tabname <> ' VERSION' |
45 | EOF |
46 | $sth->execute; |
47 | |
48 | my @tables = map @$_, @{ $sth->fetchall_arrayref }; |
49 | |
50 | return $self->_filter_tables(\@tables, $opts); |
51 | } |
52 | |
53 | sub _constraints_for { |
54 | my ($self, $table, $type) = @_; |
55 | |
56 | my $dbh = $self->schema->storage->dbh; |
57 | local $dbh->{FetchHashKeyName} = 'NAME_lc'; |
58 | |
59 | my $sth = $dbh->prepare(<<'EOF'); |
60 | select c.constrname, i.* |
61 | from sysconstraints c |
62 | join systables t on t.tabid = c.tabid |
63 | join sysindexes i on c.idxname = i.idxname |
64 | where t.tabname = ? and c.constrtype = ? |
65 | EOF |
66 | $sth->execute($table, $type); |
67 | my $indexes = $sth->fetchall_hashref('constrname'); |
68 | $sth->finish; |
69 | |
70 | my $cols = $self->_colnames_by_colno($table); |
71 | |
72 | my $constraints; |
73 | while (my ($constr_name, $idx_def) = each %$indexes) { |
74 | $constraints->{$constr_name} = $self->_idx_colnames($idx_def, $cols); |
75 | } |
76 | |
77 | return $constraints; |
78 | } |
79 | |
80 | sub _idx_colnames { |
81 | my ($self, $idx_info, $table_cols_by_colno) = @_; |
82 | |
83 | return [ map $self->_lc($table_cols_by_colno->{$_}), grep $_, map $idx_info->{$_}, map "part$_", (1..16) ]; |
84 | } |
85 | |
86 | sub _colnames_by_colno { |
87 | my ($self, $table) = @_; |
88 | |
89 | my $dbh = $self->schema->storage->dbh; |
90 | local $dbh->{FetchHashKeyName} = 'NAME_lc'; |
91 | |
92 | my $sth = $dbh->prepare(<<'EOF'); |
93 | select c.colname, c.colno |
94 | from syscolumns c |
95 | join systables t on c.tabid = t.tabid |
96 | where t.tabname = ? |
97 | EOF |
98 | $sth->execute($table); |
99 | my $cols = $sth->fetchall_hashref('colno'); |
100 | $cols = { map +($_, $cols->{$_}{colname}), keys %$cols }; |
101 | |
102 | return $cols; |
103 | } |
104 | |
105 | sub _table_pk_info { |
106 | my ($self, $table) = @_; |
107 | |
108 | my $pk = (values %{ $self->_constraints_for($table, 'P') || {} })[0]; |
109 | |
110 | return $pk; |
111 | } |
112 | |
113 | sub _table_uniq_info { |
114 | my ($self, $table) = @_; |
115 | |
116 | my $constraints = $self->_constraints_for($table, 'U'); |
117 | |
118 | my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints; |
119 | return \@uniqs; |
120 | } |
121 | |
122 | sub _table_fk_info { |
123 | my ($self, $table) = @_; |
124 | |
125 | my $local_columns = $self->_constraints_for($table, 'R'); |
126 | |
127 | my $dbh = $self->schema->storage->dbh; |
128 | local $dbh->{FetchHashKeyName} = 'NAME_lc'; |
129 | |
130 | my $sth = $dbh->prepare(<<'EOF'); |
131 | select c.constrname local_constraint, rt.tabname remote_table, rc.constrname remote_constraint, ri.* |
132 | from sysconstraints c |
133 | join systables t on c.tabid = t.tabid |
134 | join sysreferences r on c.constrid = r.constrid |
135 | join sysconstraints rc on rc.constrid = r.primary |
136 | join systables rt on r.ptabid = rt.tabid |
137 | join sysindexes ri on rc.idxname = ri.idxname |
138 | where t.tabname = ? and c.constrtype = 'R' |
139 | EOF |
140 | $sth->execute($table); |
141 | my $remotes = $sth->fetchall_hashref('local_constraint'); |
142 | $sth->finish; |
143 | |
144 | my @rels; |
145 | |
146 | while (my ($local_constraint, $remote_info) = each %$remotes) { |
147 | push @rels, { |
148 | local_columns => $local_columns->{$local_constraint}, |
149 | remote_columns => $self->_idx_colnames($remote_info, $self->_colnames_by_colno($remote_info->{remote_table})), |
150 | remote_table => $remote_info->{remote_table}, |
151 | }; |
152 | } |
153 | |
154 | return \@rels; |
155 | } |
156 | |
f916de47 |
157 | # This is directly from http://www.ibm.com/developerworks/data/zones/informix/library/techarticle/0305parker/0305parker.html |
158 | # it doesn't work at all |
159 | sub _informix_datetime_precision { |
160 | my @date_type = qw/DUMMY year month day hour minute second fraction(1) fraction(2) fraction(3) fraction(4) fraction(5)/; |
161 | my @start_end = ( [], [1,5],[5,7],[7,9],[9,11],[11,13],[13,15],[15,16], [16,17], [17,18], [18,19], [19,20] ); |
162 | |
163 | my ($self, $collength) = @_; |
164 | |
165 | my $i = ($collength % 16) + 1; |
166 | my $j = int(($collength % 256) / 16) + 1; |
167 | my $k = int($collength / 256); |
168 | |
169 | my $len = $start_end[$i][1] - $start_end[$j][0]; |
170 | $len = $k - $len; |
171 | |
172 | if ($len == 0 || $j > 11) { |
173 | return $date_type[$j] . ' to ' . $date_type[$i]; |
174 | } |
175 | |
176 | $k = $start_end[$j][1] - $start_end[$j][0]; |
177 | $k += $len; |
178 | |
179 | return $date_type[$j] . "($k) to " . $date_type[$i]; |
180 | } |
181 | |
bc5afe55 |
182 | sub _columns_info_for { |
183 | my $self = shift; |
184 | my ($table) = @_; |
185 | |
186 | my $result = $self->next::method(@_); |
187 | |
188 | my $dbh = $self->schema->storage->dbh; |
bc5afe55 |
189 | |
190 | my $sth = $dbh->prepare(<<'EOF'); |
c7e6dc1f |
191 | select c.colname, c.coltype, c.collength, c.colmin, d.type deflt_type, d.default deflt |
bc5afe55 |
192 | from syscolumns c |
193 | join systables t on c.tabid = t.tabid |
194 | left join sysdefaults d on t.tabid = d.tabid and c.colno = d.colno |
195 | where t.tabname = ? |
196 | EOF |
197 | $sth->execute($table); |
198 | my $cols = $sth->fetchall_hashref('colname'); |
199 | $sth->finish; |
200 | |
201 | while (my ($col, $info) = each %$cols) { |
c7e6dc1f |
202 | $col = $self->_lc($col); |
203 | |
bc5afe55 |
204 | my $type = $info->{coltype} % 256; |
205 | |
206 | if ($type == 6) { # SERIAL |
207 | $result->{$col}{is_auto_increment} = 1; |
208 | } |
209 | |
c7e6dc1f |
210 | my $data_type = $result->{$col}{data_type}; |
211 | |
212 | if (looks_like_number $data_type) { |
bc5afe55 |
213 | if ($type == 7) { |
214 | $result->{$col}{data_type} = 'date'; |
215 | } |
216 | elsif ($type == 10) { |
58f0690e |
217 | $result->{$col}{data_type} = 'datetime year to fraction(5)'; |
f916de47 |
218 | # this doesn't work yet |
219 | # $result->{$col}{data_type} = 'datetime ' . $self->_informix_datetime_precision($info->{collength}); |
bc5afe55 |
220 | } |
c7e6dc1f |
221 | elsif ($type == 17 || $type == 52) { |
222 | $result->{$col}{data_type} = 'bigint'; |
223 | } |
224 | elsif ($type == 40) { |
225 | $result->{$col}{data_type} = 'lvarchar'; |
226 | $result->{$col}{size} = $info->{collength}; |
227 | } |
228 | elsif ($type == 12) { |
229 | $result->{$col}{data_type} = 'text'; |
230 | } |
231 | elsif ($type == 11) { |
232 | $result->{$col}{data_type} = 'bytea'; |
233 | $result->{$col}{original}{data_type} = 'byte'; |
234 | } |
235 | elsif ($type == 41) { |
236 | # XXX no way to distinguish opaque types boolean, blob and clob |
237 | $result->{$col}{data_type} = 'blob'; |
238 | } |
239 | elsif ($type == 21) { |
240 | $result->{$col}{data_type} = 'list'; |
241 | } |
242 | elsif ($type == 20) { |
243 | $result->{$col}{data_type} = 'multiset'; |
244 | } |
245 | elsif ($type == 19) { |
246 | $result->{$col}{data_type} = 'set'; |
247 | } |
248 | } |
249 | |
250 | if ($type == 15) { |
251 | $result->{$col}{data_type} = 'nchar'; |
252 | } |
253 | elsif ($type == 16) { |
254 | $result->{$col}{data_type} = 'nvarchar'; |
255 | } |
256 | # XXX untested! |
257 | elsif ($info->{coltype} == 2061) { |
258 | $result->{$col}{data_type} = 'idssecuritylabel'; |
bc5afe55 |
259 | } |
260 | |
c7e6dc1f |
261 | # XXX colmin doesn't work for min size of varchar columns, it's NULL |
262 | # if (lc($data_type) eq 'varchar') { |
263 | # $result->{$col}{size}[1] = $info->{colmin}; |
264 | # } |
265 | |
bc5afe55 |
266 | my ($default_type, $default) = @{$info}{qw/deflt_type deflt/}; |
267 | |
268 | next unless $default_type; |
269 | |
270 | if ($default_type eq 'C') { |
c7e6dc1f |
271 | my $current = 'current year to fraction(5)'; |
bc5afe55 |
272 | $result->{$col}{default_value} = \$current; |
273 | } |
274 | elsif ($default_type eq 'T') { |
c7e6dc1f |
275 | my $today = 'today'; |
bc5afe55 |
276 | $result->{$col}{default_value} = \$today; |
277 | } |
278 | else { |
5cd983b7 |
279 | $default = (split ' ', $default, 2)[-1]; |
25e1e7bf |
280 | |
281 | $default =~ s/\s+\z// if looks_like_number $default; |
bc5afe55 |
282 | |
283 | # remove trailing 0s in floating point defaults |
a60e0f45 |
284 | # disabled, this is unsafe since it might be a varchar default |
285 | #$default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/; |
bc5afe55 |
286 | |
287 | $result->{$col}{default_value} = $default; |
288 | } |
289 | } |
290 | |
c7e6dc1f |
291 | # fix up data_types some more |
292 | while (my ($col, $info) = each %$result) { |
293 | my $data_type = $info->{data_type}; |
294 | |
295 | if ($data_type !~ /^(?:[nl]?(?:var)?char|decimal)\z/i) { |
296 | delete $info->{size}; |
297 | } |
298 | |
299 | if (lc($data_type) eq 'decimal') { |
300 | no warnings 'uninitialized'; |
301 | |
302 | $info->{data_type} = 'numeric'; |
303 | |
304 | my @size = @{ $info->{size} || [] }; |
305 | |
306 | if ($size[0] == 16 && $size[1] == -4) { |
307 | delete $info->{size}; |
308 | } |
309 | elsif ($size[0] == 16 && $size[1] == 2) { |
310 | $info->{data_type} = 'money'; |
311 | delete $info->{size}; |
312 | } |
313 | } |
314 | elsif (lc($data_type) eq 'smallfloat') { |
315 | $info->{data_type} = 'real'; |
316 | } |
317 | elsif (lc($data_type) eq 'float') { |
318 | $info->{data_type} = 'double precision'; |
319 | } |
320 | elsif ($data_type =~ /^n?(?:var)?char\z/i) { |
321 | $info->{size} = $info->{size}[0]; |
322 | } |
323 | } |
324 | |
bc5afe55 |
325 | return $result; |
326 | } |
327 | |
328 | =head1 SEE ALSO |
329 | |
330 | L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, |
331 | L<DBIx::Class::Schema::Loader::DBI> |
332 | |
333 | =head1 AUTHOR |
334 | |
335 | See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. |
336 | |
337 | =head1 LICENSE |
338 | |
339 | This library is free software; you can redistribute it and/or modify it under |
340 | the same terms as Perl itself. |
341 | |
342 | =cut |
343 | |
344 | 1; |
345 | # vim:et sw=4 sts=4 tw=0: |