Commit | Line | Data |
bc5afe55 |
1 | package DBIx::Class::Schema::Loader::DBI::Informix; |
2 | |
3 | use strict; |
4 | use warnings; |
bc5afe55 |
5 | use base qw/DBIx::Class::Schema::Loader::DBI/; |
c4a69b87 |
6 | use mro 'c3'; |
bc5afe55 |
7 | use Scalar::Util 'looks_like_number'; |
ecf22f0a |
8 | use List::Util 'any'; |
c4a69b87 |
9 | use Try::Tiny; |
2b74a06b |
10 | use namespace::clean; |
c4a69b87 |
11 | use DBIx::Class::Schema::Loader::Table::Informix (); |
bc5afe55 |
12 | |
6bef6696 |
13 | our $VERSION = '0.07043'; |
bc5afe55 |
14 | |
15 | =head1 NAME |
16 | |
17 | DBIx::Class::Schema::Loader::DBI::Informix - DBIx::Class::Schema::Loader::DBI |
18 | Informix Implementation. |
19 | |
20 | =head1 DESCRIPTION |
21 | |
22 | See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>. |
23 | |
24 | =cut |
25 | |
c4a69b87 |
26 | sub _build_name_sep { '.' } |
27 | |
28 | sub _system_databases { |
29 | return (qw/ |
30 | sysmaster sysutils sysuser sysadmin |
31 | /); |
32 | } |
33 | |
34 | sub _current_db { |
35 | my $self = shift; |
36 | |
37 | my ($current_db) = $self->dbh->selectrow_array(<<'EOF'); |
38 | SELECT rtrim(ODB_DBName) |
39 | FROM sysmaster:informix.SysOpenDB |
40 | WHERE ODB_SessionID = ( |
41 | SELECT DBINFO('sessionid') |
42 | FROM informix.SysTables |
43 | WHERE TabID = 1 |
44 | ) and ODB_IsCurrent = 'Y' |
45 | EOF |
46 | |
47 | return $current_db; |
48 | } |
49 | |
50 | sub _owners { |
51 | my ($self, $db) = @_; |
52 | |
53 | my ($owners) = $self->dbh->selectcol_arrayref(<<"EOF"); |
54 | SELECT distinct(rtrim(owner)) |
55 | FROM ${db}:informix.systables |
56 | EOF |
57 | |
58 | my @owners = grep $_ && $_ ne 'informix' && !/^\d/, @$owners; |
59 | |
60 | return @owners; |
61 | } |
62 | |
bc5afe55 |
63 | sub _setup { |
64 | my $self = shift; |
65 | |
66 | $self->next::method(@_); |
67 | |
68 | if (not defined $self->preserve_case) { |
69 | $self->preserve_case(0); |
70 | } |
b511f36e |
71 | elsif ($self->preserve_case) { |
72 | $self->schema->storage->sql_maker->quote_char('"'); |
73 | $self->schema->storage->sql_maker->name_sep('.'); |
74 | } |
c4a69b87 |
75 | |
76 | my $current_db = $self->_current_db; |
77 | |
78 | if (ref $self->db_schema eq 'HASH') { |
79 | if (keys %{ $self->db_schema } < 2) { |
80 | my ($db) = keys %{ $self->db_schema }; |
81 | |
82 | $db ||= $current_db; |
83 | |
84 | if ($db eq '%') { |
85 | my $owners = $self->db_schema->{$db}; |
86 | |
87 | my $db_names = $self->dbh->selectcol_arrayref(<<'EOF'); |
88 | SELECT rtrim(name) |
89 | FROM sysmaster:sysdatabases |
90 | EOF |
91 | |
92 | my @dbs; |
93 | |
94 | foreach my $db_name (@$db_names) { |
95 | push @dbs, $db_name |
96 | unless any { $_ eq $db_name } $self->_system_databases; |
97 | } |
98 | |
99 | $self->db_schema({}); |
100 | |
101 | DB: foreach my $db (@dbs) { |
102 | if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') || $owners eq '%')) { |
103 | my @owners; |
104 | |
105 | my @db_owners = try { |
106 | $self->_owners($db); |
107 | } |
108 | catch { |
109 | if (/without logging/) { |
110 | warn |
111 | "Database '$db' is unreferencable due to lack of logging.\n"; |
112 | } |
113 | return (); |
114 | }; |
115 | |
116 | foreach my $owner (@$owners) { |
117 | push @owners, $owner |
118 | if any { $_ eq $owner } @db_owners; |
119 | } |
120 | |
121 | next DB unless @owners; |
122 | |
123 | $self->db_schema->{$db} = \@owners; |
124 | } |
125 | else { |
126 | # for post-processing below |
127 | $self->db_schema->{$db} = '%'; |
128 | } |
129 | } |
130 | |
131 | $self->qualify_objects(1); |
132 | } |
133 | else { |
134 | if ($db ne $current_db) { |
135 | $self->qualify_objects(1); |
136 | } |
137 | } |
138 | } |
139 | else { |
140 | $self->qualify_objects(1); |
141 | } |
142 | } |
143 | elsif (ref $self->db_schema eq 'ARRAY' || (not defined $self->db_schema)) { |
144 | my $owners = $self->db_schema; |
145 | $owners ||= [ $self->dbh->selectrow_array(<<'EOF') ]; |
146 | SELECT rtrim(username) |
147 | FROM sysmaster:syssessions |
148 | WHERE sid = DBINFO('sessionid') |
149 | EOF |
150 | |
151 | $self->qualify_objects(1) if @$owners > 1; |
152 | |
153 | $self->db_schema({ $current_db => $owners }); |
154 | } |
155 | |
156 | DB: foreach my $db (keys %{ $self->db_schema }) { |
157 | if ($self->db_schema->{$db} eq '%') { |
158 | my @db_owners = try { |
159 | $self->_owners($db); |
160 | } |
161 | catch { |
162 | if (/without logging/) { |
163 | warn |
164 | "Database '$db' is unreferencable due to lack of logging.\n"; |
165 | } |
166 | return (); |
167 | }; |
168 | |
169 | if (not @db_owners) { |
170 | delete $self->db_schema->{$db}; |
171 | next DB; |
172 | } |
173 | |
174 | $self->db_schema->{$db} = \@db_owners; |
175 | |
176 | $self->qualify_objects(1); |
177 | } |
178 | } |
bc5afe55 |
179 | } |
180 | |
181 | sub _tables_list { |
182 | my ($self, $opts) = @_; |
183 | |
c4a69b87 |
184 | my @tables; |
185 | |
186 | while (my ($db, $owners) = each %{ $self->db_schema }) { |
187 | foreach my $owner (@$owners) { |
188 | my $table_names = $self->dbh->selectcol_arrayref(<<"EOF", {}, $owner); |
189 | select tabname |
190 | FROM ${db}:informix.systables |
191 | WHERE rtrim(owner) = ? |
bc5afe55 |
192 | EOF |
bc5afe55 |
193 | |
c4a69b87 |
194 | TABLE: foreach my $table_name (@$table_names) { |
195 | next if $table_name =~ /^\s/; |
196 | |
197 | push @tables, DBIx::Class::Schema::Loader::Table::Informix->new( |
198 | loader => $self, |
199 | name => $table_name, |
200 | database => $db, |
201 | schema => $owner, |
202 | ); |
203 | } |
204 | } |
205 | } |
bc5afe55 |
206 | |
207 | return $self->_filter_tables(\@tables, $opts); |
208 | } |
209 | |
210 | sub _constraints_for { |
211 | my ($self, $table, $type) = @_; |
212 | |
c4a69b87 |
213 | local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; |
214 | |
215 | my $db = $table->database; |
bc5afe55 |
216 | |
c4a69b87 |
217 | my $sth = $self->dbh->prepare(<<"EOF"); |
218 | SELECT c.constrname, i.* |
219 | FROM ${db}:informix.sysconstraints c |
220 | JOIN ${db}:informix.systables t |
221 | ON t.tabid = c.tabid |
222 | JOIN ${db}:informix.sysindexes i |
223 | ON c.idxname = i.idxname |
224 | WHERE t.tabname = ? and c.constrtype = ? |
bc5afe55 |
225 | EOF |
226 | $sth->execute($table, $type); |
227 | my $indexes = $sth->fetchall_hashref('constrname'); |
228 | $sth->finish; |
229 | |
230 | my $cols = $self->_colnames_by_colno($table); |
231 | |
232 | my $constraints; |
233 | while (my ($constr_name, $idx_def) = each %$indexes) { |
234 | $constraints->{$constr_name} = $self->_idx_colnames($idx_def, $cols); |
235 | } |
236 | |
237 | return $constraints; |
238 | } |
239 | |
240 | sub _idx_colnames { |
241 | my ($self, $idx_info, $table_cols_by_colno) = @_; |
242 | |
116431d6 |
243 | return [ map $table_cols_by_colno->{$_}, grep $_, map $idx_info->{$_}, map "part$_", (1..16) ]; |
bc5afe55 |
244 | } |
245 | |
246 | sub _colnames_by_colno { |
247 | my ($self, $table) = @_; |
248 | |
c4a69b87 |
249 | local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; |
bc5afe55 |
250 | |
c4a69b87 |
251 | my $db = $table->database; |
252 | |
253 | my $sth = $self->dbh->prepare(<<"EOF"); |
254 | SELECT c.colname, c.colno |
255 | FROM ${db}:informix.syscolumns c |
256 | JOIN ${db}:informix.systables t |
257 | ON c.tabid = t.tabid |
258 | WHERE t.tabname = ? |
bc5afe55 |
259 | EOF |
260 | $sth->execute($table); |
261 | my $cols = $sth->fetchall_hashref('colno'); |
116431d6 |
262 | $cols = { map +($_, $self->_lc($cols->{$_}{colname})), keys %$cols }; |
bc5afe55 |
263 | |
264 | return $cols; |
265 | } |
266 | |
267 | sub _table_pk_info { |
268 | my ($self, $table) = @_; |
269 | |
270 | my $pk = (values %{ $self->_constraints_for($table, 'P') || {} })[0]; |
271 | |
272 | return $pk; |
273 | } |
274 | |
275 | sub _table_uniq_info { |
276 | my ($self, $table) = @_; |
277 | |
278 | my $constraints = $self->_constraints_for($table, 'U'); |
279 | |
6c4f5a4a |
280 | return [ map { [ $_ => $constraints->{$_} ] } sort keys %$constraints ]; |
bc5afe55 |
281 | } |
282 | |
283 | sub _table_fk_info { |
284 | my ($self, $table) = @_; |
285 | |
286 | my $local_columns = $self->_constraints_for($table, 'R'); |
287 | |
c4a69b87 |
288 | local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; |
289 | |
290 | my $db = $table->database; |
291 | |
292 | my $sth = $self->dbh->prepare(<<"EOF"); |
293 | SELECT c.constrname local_constraint, rt.tabname remote_table, rtrim(rt.owner) remote_owner, rc.constrname remote_constraint, ri.* |
294 | FROM ${db}:informix.sysconstraints c |
295 | JOIN ${db}:informix.systables t |
296 | ON c.tabid = t.tabid |
297 | JOIN ${db}:informix.sysreferences r |
298 | ON c.constrid = r.constrid |
299 | JOIN ${db}:informix.sysconstraints rc |
300 | ON rc.constrid = r.primary |
301 | JOIN ${db}:informix.systables rt |
302 | ON r.ptabid = rt.tabid |
303 | JOIN ${db}:informix.sysindexes ri |
304 | ON rc.idxname = ri.idxname |
305 | WHERE t.tabname = ? and c.constrtype = 'R' |
bc5afe55 |
306 | EOF |
307 | $sth->execute($table); |
308 | my $remotes = $sth->fetchall_hashref('local_constraint'); |
309 | $sth->finish; |
310 | |
311 | my @rels; |
312 | |
313 | while (my ($local_constraint, $remote_info) = each %$remotes) { |
c4a69b87 |
314 | my $remote_table = DBIx::Class::Schema::Loader::Table::Informix->new( |
315 | loader => $self, |
316 | name => $remote_info->{remote_table}, |
317 | database => $db, |
318 | schema => $remote_info->{remote_owner}, |
319 | ); |
320 | |
bc5afe55 |
321 | push @rels, { |
c4a69b87 |
322 | local_columns => $local_columns->{$local_constraint}, |
323 | remote_columns => $self->_idx_colnames($remote_info, $self->_colnames_by_colno($remote_table)), |
324 | remote_table => $remote_table, |
bc5afe55 |
325 | }; |
326 | } |
327 | |
328 | return \@rels; |
329 | } |
330 | |
f916de47 |
331 | # This is directly from http://www.ibm.com/developerworks/data/zones/informix/library/techarticle/0305parker/0305parker.html |
332 | # it doesn't work at all |
333 | sub _informix_datetime_precision { |
334 | my @date_type = qw/DUMMY year month day hour minute second fraction(1) fraction(2) fraction(3) fraction(4) fraction(5)/; |
335 | 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] ); |
336 | |
337 | my ($self, $collength) = @_; |
338 | |
339 | my $i = ($collength % 16) + 1; |
340 | my $j = int(($collength % 256) / 16) + 1; |
341 | my $k = int($collength / 256); |
342 | |
343 | my $len = $start_end[$i][1] - $start_end[$j][0]; |
344 | $len = $k - $len; |
345 | |
346 | if ($len == 0 || $j > 11) { |
347 | return $date_type[$j] . ' to ' . $date_type[$i]; |
348 | } |
349 | |
350 | $k = $start_end[$j][1] - $start_end[$j][0]; |
351 | $k += $len; |
352 | |
353 | return $date_type[$j] . "($k) to " . $date_type[$i]; |
354 | } |
355 | |
bc5afe55 |
356 | sub _columns_info_for { |
357 | my $self = shift; |
358 | my ($table) = @_; |
359 | |
360 | my $result = $self->next::method(@_); |
361 | |
c4a69b87 |
362 | my $db = $table->database; |
bc5afe55 |
363 | |
c4a69b87 |
364 | my $sth = $self->dbh->prepare(<<"EOF"); |
365 | SELECT c.colname, c.coltype, c.collength, c.colmin, d.type deflt_type, d.default deflt |
366 | FROM ${db}:informix.syscolumns c |
367 | JOIN ${db}:informix.systables t |
368 | ON c.tabid = t.tabid |
369 | LEFT JOIN ${db}:informix.sysdefaults d |
370 | ON t.tabid = d.tabid AND c.colno = d.colno |
371 | WHERE t.tabname = ? |
bc5afe55 |
372 | EOF |
373 | $sth->execute($table); |
374 | my $cols = $sth->fetchall_hashref('colname'); |
375 | $sth->finish; |
376 | |
377 | while (my ($col, $info) = each %$cols) { |
c7e6dc1f |
378 | $col = $self->_lc($col); |
379 | |
bc5afe55 |
380 | my $type = $info->{coltype} % 256; |
381 | |
382 | if ($type == 6) { # SERIAL |
383 | $result->{$col}{is_auto_increment} = 1; |
384 | } |
eaf7c54e |
385 | elsif ($type == 7) { |
386 | $result->{$col}{data_type} = 'date'; |
387 | } |
388 | elsif ($type == 10) { |
389 | $result->{$col}{data_type} = 'datetime year to fraction(5)'; |
390 | # this doesn't work yet |
f916de47 |
391 | # $result->{$col}{data_type} = 'datetime ' . $self->_informix_datetime_precision($info->{collength}); |
c7e6dc1f |
392 | } |
eaf7c54e |
393 | elsif ($type == 17 || $type == 52) { |
394 | $result->{$col}{data_type} = 'bigint'; |
395 | } |
396 | elsif ($type == 40) { |
397 | $result->{$col}{data_type} = 'lvarchar'; |
398 | $result->{$col}{size} = $info->{collength}; |
399 | } |
400 | elsif ($type == 12) { |
401 | $result->{$col}{data_type} = 'text'; |
402 | } |
403 | elsif ($type == 11) { |
404 | $result->{$col}{data_type} = 'bytea'; |
405 | $result->{$col}{original}{data_type} = 'byte'; |
406 | } |
407 | elsif ($type == 41) { |
408 | # XXX no way to distinguish opaque types boolean, blob and clob |
409 | $result->{$col}{data_type} = 'blob' unless $result->{$col}{data_type} eq 'smallint'; |
410 | } |
411 | elsif ($type == 21) { |
412 | $result->{$col}{data_type} = 'list'; |
413 | } |
414 | elsif ($type == 20) { |
415 | $result->{$col}{data_type} = 'multiset'; |
416 | } |
417 | elsif ($type == 19) { |
418 | $result->{$col}{data_type} = 'set'; |
419 | } |
420 | elsif ($type == 15) { |
c7e6dc1f |
421 | $result->{$col}{data_type} = 'nchar'; |
422 | } |
423 | elsif ($type == 16) { |
424 | $result->{$col}{data_type} = 'nvarchar'; |
425 | } |
426 | # XXX untested! |
427 | elsif ($info->{coltype} == 2061) { |
428 | $result->{$col}{data_type} = 'idssecuritylabel'; |
bc5afe55 |
429 | } |
430 | |
eaf7c54e |
431 | my $data_type = $result->{$col}{data_type}; |
432 | |
433 | if ($data_type !~ /^(?:[nl]?(?:var)?char|decimal)\z/i) { |
434 | delete $result->{$col}{size}; |
435 | } |
436 | |
437 | if (lc($data_type) eq 'decimal') { |
438 | no warnings 'uninitialized'; |
439 | |
440 | $result->{$col}{data_type} = 'numeric'; |
441 | |
442 | my @size = @{ $result->{$col}{size} || [] }; |
443 | |
444 | if ($size[0] == 16 && $size[1] == -4) { |
445 | delete $result->{$col}{size}; |
446 | } |
447 | elsif ($size[0] == 16 && $size[1] == 2) { |
448 | $result->{$col}{data_type} = 'money'; |
449 | delete $result->{$col}{size}; |
450 | } |
451 | } |
452 | elsif (lc($data_type) eq 'smallfloat') { |
453 | $result->{$col}{data_type} = 'real'; |
454 | } |
455 | elsif (lc($data_type) eq 'float') { |
456 | $result->{$col}{data_type} = 'double precision'; |
457 | } |
458 | elsif ($data_type =~ /^n?(?:var)?char\z/i) { |
459 | $result->{$col}{size} = $result->{$col}{size}[0]; |
460 | } |
461 | |
c7e6dc1f |
462 | # XXX colmin doesn't work for min size of varchar columns, it's NULL |
463 | # if (lc($data_type) eq 'varchar') { |
464 | # $result->{$col}{size}[1] = $info->{colmin}; |
465 | # } |
494e0205 |
466 | |
bc5afe55 |
467 | my ($default_type, $default) = @{$info}{qw/deflt_type deflt/}; |
468 | |
469 | next unless $default_type; |
470 | |
471 | if ($default_type eq 'C') { |
c7e6dc1f |
472 | my $current = 'current year to fraction(5)'; |
bc5afe55 |
473 | $result->{$col}{default_value} = \$current; |
474 | } |
475 | elsif ($default_type eq 'T') { |
c7e6dc1f |
476 | my $today = 'today'; |
bc5afe55 |
477 | $result->{$col}{default_value} = \$today; |
478 | } |
479 | else { |
5cd983b7 |
480 | $default = (split ' ', $default, 2)[-1]; |
25e1e7bf |
481 | |
482 | $default =~ s/\s+\z// if looks_like_number $default; |
bc5afe55 |
483 | |
484 | # remove trailing 0s in floating point defaults |
a60e0f45 |
485 | # disabled, this is unsafe since it might be a varchar default |
486 | #$default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/; |
bc5afe55 |
487 | |
488 | $result->{$col}{default_value} = $default; |
489 | } |
490 | } |
491 | |
492 | return $result; |
493 | } |
494 | |
495 | =head1 SEE ALSO |
496 | |
497 | L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, |
498 | L<DBIx::Class::Schema::Loader::DBI> |
499 | |
b87ab391 |
500 | =head1 AUTHORS |
bc5afe55 |
501 | |
b87ab391 |
502 | See L<DBIx::Class::Schema::Loader/AUTHORS>. |
bc5afe55 |
503 | |
504 | =head1 LICENSE |
505 | |
506 | This library is free software; you can redistribute it and/or modify it under |
507 | the same terms as Perl itself. |
508 | |
509 | =cut |
510 | |
511 | 1; |
512 | # vim:et sw=4 sts=4 tw=0: |