1 package DBIx::Class::Schema::Loader::DBI::Informix;
5 use base qw/DBIx::Class::Schema::Loader::DBI/;
7 use Scalar::Util 'looks_like_number';
8 use List::MoreUtils 'any';
11 use DBIx::Class::Schema::Loader::Table::Informix ();
13 our $VERSION = '0.07036_02';
17 DBIx::Class::Schema::Loader::DBI::Informix - DBIx::Class::Schema::Loader::DBI
18 Informix Implementation.
22 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
26 sub _build_name_sep { '.' }
28 sub _system_databases {
30 sysmaster sysutils sysuser sysadmin
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
44 ) and ODB_IsCurrent = 'Y'
53 my ($owners) = $self->dbh->selectcol_arrayref(<<"EOF");
54 SELECT distinct(rtrim(owner))
55 FROM ${db}:informix.systables
58 my @owners = grep $_ && $_ ne 'informix' && !/^\d/, @$owners;
66 $self->next::method(@_);
68 if (not defined $self->preserve_case) {
69 $self->preserve_case(0);
71 elsif ($self->preserve_case) {
72 $self->schema->storage->sql_maker->quote_char('"');
73 $self->schema->storage->sql_maker->name_sep('.');
76 my $current_db = $self->_current_db;
78 if (ref $self->db_schema eq 'HASH') {
79 if (keys %{ $self->db_schema } < 2) {
80 my ($db) = keys %{ $self->db_schema };
85 my $owners = $self->db_schema->{$db};
87 my $db_names = $self->dbh->selectcol_arrayref(<<'EOF');
89 FROM sysmaster:sysdatabases
94 foreach my $db_name (@$db_names) {
96 unless any { $_ eq $db_name } $self->_system_databases;
101 DB: foreach my $db (@dbs) {
102 if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') || $owners eq '%')) {
105 my @db_owners = try {
109 if (/without logging/) {
111 "Database '$db' is unreferencable due to lack of logging.\n";
116 foreach my $owner (@$owners) {
118 if any { $_ eq $owner } @db_owners;
121 next DB unless @owners;
123 $self->db_schema->{$db} = \@owners;
126 # for post-processing below
127 $self->db_schema->{$db} = '%';
131 $self->qualify_objects(1);
134 if ($db ne $current_db) {
135 $self->qualify_objects(1);
140 $self->qualify_objects(1);
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')
151 $self->qualify_objects(1) if @$owners > 1;
153 $self->db_schema({ $current_db => $owners });
156 DB: foreach my $db (keys %{ $self->db_schema }) {
157 if ($self->db_schema->{$db} eq '%') {
158 my @db_owners = try {
162 if (/without logging/) {
164 "Database '$db' is unreferencable due to lack of logging.\n";
169 if (not @db_owners) {
170 delete $self->db_schema->{$db};
174 $self->db_schema->{$db} = \@db_owners;
176 $self->qualify_objects(1);
182 my ($self, $opts) = @_;
186 while (my ($db, $owners) = each %{ $self->db_schema }) {
187 foreach my $owner (@$owners) {
188 my $table_names = $self->dbh->selectcol_arrayref(<<"EOF", {}, $owner);
190 FROM ${db}:informix.systables
191 WHERE rtrim(owner) = ?
194 TABLE: foreach my $table_name (@$table_names) {
195 next if $table_name =~ /^\s/;
197 push @tables, DBIx::Class::Schema::Loader::Table::Informix->new(
207 return $self->_filter_tables(\@tables, $opts);
210 sub _constraints_for {
211 my ($self, $table, $type) = @_;
213 local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
215 my $db = $table->database;
217 my $sth = $self->dbh->prepare(<<"EOF");
218 SELECT c.constrname, i.*
219 FROM ${db}:informix.sysconstraints c
220 JOIN ${db}:informix.systables t
222 JOIN ${db}:informix.sysindexes i
223 ON c.idxname = i.idxname
224 WHERE t.tabname = ? and c.constrtype = ?
226 $sth->execute($table, $type);
227 my $indexes = $sth->fetchall_hashref('constrname');
230 my $cols = $self->_colnames_by_colno($table);
233 while (my ($constr_name, $idx_def) = each %$indexes) {
234 $constraints->{$constr_name} = $self->_idx_colnames($idx_def, $cols);
241 my ($self, $idx_info, $table_cols_by_colno) = @_;
243 return [ map $table_cols_by_colno->{$_}, grep $_, map $idx_info->{$_}, map "part$_", (1..16) ];
246 sub _colnames_by_colno {
247 my ($self, $table) = @_;
249 local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
251 my $db = $table->database;
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
260 $sth->execute($table);
261 my $cols = $sth->fetchall_hashref('colno');
262 $cols = { map +($_, $self->_lc($cols->{$_}{colname})), keys %$cols };
268 my ($self, $table) = @_;
270 my $pk = (values %{ $self->_constraints_for($table, 'P') || {} })[0];
275 sub _table_uniq_info {
276 my ($self, $table) = @_;
278 my $constraints = $self->_constraints_for($table, 'U');
280 my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
285 my ($self, $table) = @_;
287 my $local_columns = $self->_constraints_for($table, 'R');
289 local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
291 my $db = $table->database;
293 my $sth = $self->dbh->prepare(<<"EOF");
294 SELECT c.constrname local_constraint, rt.tabname remote_table, rtrim(rt.owner) remote_owner, rc.constrname remote_constraint, ri.*
295 FROM ${db}:informix.sysconstraints c
296 JOIN ${db}:informix.systables t
298 JOIN ${db}:informix.sysreferences r
299 ON c.constrid = r.constrid
300 JOIN ${db}:informix.sysconstraints rc
301 ON rc.constrid = r.primary
302 JOIN ${db}:informix.systables rt
303 ON r.ptabid = rt.tabid
304 JOIN ${db}:informix.sysindexes ri
305 ON rc.idxname = ri.idxname
306 WHERE t.tabname = ? and c.constrtype = 'R'
308 $sth->execute($table);
309 my $remotes = $sth->fetchall_hashref('local_constraint');
314 while (my ($local_constraint, $remote_info) = each %$remotes) {
315 my $remote_table = DBIx::Class::Schema::Loader::Table::Informix->new(
317 name => $remote_info->{remote_table},
319 schema => $remote_info->{remote_owner},
323 local_columns => $local_columns->{$local_constraint},
324 remote_columns => $self->_idx_colnames($remote_info, $self->_colnames_by_colno($remote_table)),
325 remote_table => $remote_table,
332 # This is directly from http://www.ibm.com/developerworks/data/zones/informix/library/techarticle/0305parker/0305parker.html
333 # it doesn't work at all
334 sub _informix_datetime_precision {
335 my @date_type = qw/DUMMY year month day hour minute second fraction(1) fraction(2) fraction(3) fraction(4) fraction(5)/;
336 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] );
338 my ($self, $collength) = @_;
340 my $i = ($collength % 16) + 1;
341 my $j = int(($collength % 256) / 16) + 1;
342 my $k = int($collength / 256);
344 my $len = $start_end[$i][1] - $start_end[$j][0];
347 if ($len == 0 || $j > 11) {
348 return $date_type[$j] . ' to ' . $date_type[$i];
351 $k = $start_end[$j][1] - $start_end[$j][0];
354 return $date_type[$j] . "($k) to " . $date_type[$i];
357 sub _columns_info_for {
361 my $result = $self->next::method(@_);
363 my $db = $table->database;
365 my $sth = $self->dbh->prepare(<<"EOF");
366 SELECT c.colname, c.coltype, c.collength, c.colmin, d.type deflt_type, d.default deflt
367 FROM ${db}:informix.syscolumns c
368 JOIN ${db}:informix.systables t
370 LEFT JOIN ${db}:informix.sysdefaults d
371 ON t.tabid = d.tabid AND c.colno = d.colno
374 $sth->execute($table);
375 my $cols = $sth->fetchall_hashref('colname');
378 while (my ($col, $info) = each %$cols) {
379 $col = $self->_lc($col);
381 my $type = $info->{coltype} % 256;
383 if ($type == 6) { # SERIAL
384 $result->{$col}{is_auto_increment} = 1;
387 $result->{$col}{data_type} = 'date';
389 elsif ($type == 10) {
390 $result->{$col}{data_type} = 'datetime year to fraction(5)';
391 # this doesn't work yet
392 # $result->{$col}{data_type} = 'datetime ' . $self->_informix_datetime_precision($info->{collength});
394 elsif ($type == 17 || $type == 52) {
395 $result->{$col}{data_type} = 'bigint';
397 elsif ($type == 40) {
398 $result->{$col}{data_type} = 'lvarchar';
399 $result->{$col}{size} = $info->{collength};
401 elsif ($type == 12) {
402 $result->{$col}{data_type} = 'text';
404 elsif ($type == 11) {
405 $result->{$col}{data_type} = 'bytea';
406 $result->{$col}{original}{data_type} = 'byte';
408 elsif ($type == 41) {
409 # XXX no way to distinguish opaque types boolean, blob and clob
410 $result->{$col}{data_type} = 'blob' unless $result->{$col}{data_type} eq 'smallint';
412 elsif ($type == 21) {
413 $result->{$col}{data_type} = 'list';
415 elsif ($type == 20) {
416 $result->{$col}{data_type} = 'multiset';
418 elsif ($type == 19) {
419 $result->{$col}{data_type} = 'set';
421 elsif ($type == 15) {
422 $result->{$col}{data_type} = 'nchar';
424 elsif ($type == 16) {
425 $result->{$col}{data_type} = 'nvarchar';
428 elsif ($info->{coltype} == 2061) {
429 $result->{$col}{data_type} = 'idssecuritylabel';
432 my $data_type = $result->{$col}{data_type};
434 if ($data_type !~ /^(?:[nl]?(?:var)?char|decimal)\z/i) {
435 delete $result->{$col}{size};
438 if (lc($data_type) eq 'decimal') {
439 no warnings 'uninitialized';
441 $result->{$col}{data_type} = 'numeric';
443 my @size = @{ $result->{$col}{size} || [] };
445 if ($size[0] == 16 && $size[1] == -4) {
446 delete $result->{$col}{size};
448 elsif ($size[0] == 16 && $size[1] == 2) {
449 $result->{$col}{data_type} = 'money';
450 delete $result->{$col}{size};
453 elsif (lc($data_type) eq 'smallfloat') {
454 $result->{$col}{data_type} = 'real';
456 elsif (lc($data_type) eq 'float') {
457 $result->{$col}{data_type} = 'double precision';
459 elsif ($data_type =~ /^n?(?:var)?char\z/i) {
460 $result->{$col}{size} = $result->{$col}{size}[0];
463 # XXX colmin doesn't work for min size of varchar columns, it's NULL
464 # if (lc($data_type) eq 'varchar') {
465 # $result->{$col}{size}[1] = $info->{colmin};
468 my ($default_type, $default) = @{$info}{qw/deflt_type deflt/};
470 next unless $default_type;
472 if ($default_type eq 'C') {
473 my $current = 'current year to fraction(5)';
474 $result->{$col}{default_value} = \$current;
476 elsif ($default_type eq 'T') {
478 $result->{$col}{default_value} = \$today;
481 $default = (split ' ', $default, 2)[-1];
483 $default =~ s/\s+\z// if looks_like_number $default;
485 # remove trailing 0s in floating point defaults
486 # disabled, this is unsafe since it might be a varchar default
487 #$default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/;
489 $result->{$col}{default_value} = $default;
498 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
499 L<DBIx::Class::Schema::Loader::DBI>
503 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
507 This library is free software; you can redistribute it and/or modify it under
508 the same terms as Perl itself.
513 # vim:et sw=4 sts=4 tw=0: