1 package DBIx::Class::Schema::Loader::DBI::Informix;
5 use base qw/DBIx::Class::Schema::Loader::DBI/;
7 use Scalar::Util 'looks_like_number';
11 use DBIx::Class::Schema::Loader::Table::Informix ();
13 our $VERSION = '0.07046';
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);
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);
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 return [ map { [ $_ => $constraints->{$_} ] } sort keys %$constraints ];
284 my ($self, $table) = @_;
286 my $local_columns = $self->_constraints_for($table, 'R');
288 local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
290 my $db = $table->database;
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
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'
307 $sth->execute($table);
308 my $remotes = $sth->fetchall_hashref('local_constraint');
313 while (my ($local_constraint, $remote_info) = each %$remotes) {
314 my $remote_table = DBIx::Class::Schema::Loader::Table::Informix->new(
316 name => $remote_info->{remote_table},
318 schema => $remote_info->{remote_owner},
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,
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] );
337 my ($self, $collength) = @_;
339 my $i = ($collength % 16) + 1;
340 my $j = int(($collength % 256) / 16) + 1;
341 my $k = int($collength / 256);
343 my $len = $start_end[$i][1] - $start_end[$j][0];
346 if ($len == 0 || $j > 11) {
347 return $date_type[$j] . ' to ' . $date_type[$i];
350 $k = $start_end[$j][1] - $start_end[$j][0];
353 return $date_type[$j] . "($k) to " . $date_type[$i];
356 sub _columns_info_for {
360 my $result = $self->next::method(@_);
362 my $db = $table->database;
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
369 LEFT JOIN ${db}:informix.sysdefaults d
370 ON t.tabid = d.tabid AND c.colno = d.colno
373 $sth->execute($table);
374 my $cols = $sth->fetchall_hashref('colname');
377 while (my ($col, $info) = each %$cols) {
378 $col = $self->_lc($col);
380 my $type = $info->{coltype} % 256;
382 if ($type == 6) { # SERIAL
383 $result->{$col}{is_auto_increment} = 1;
386 $result->{$col}{data_type} = 'date';
388 elsif ($type == 10) {
389 $result->{$col}{data_type} = 'datetime year to fraction(5)';
390 # this doesn't work yet
391 # $result->{$col}{data_type} = 'datetime ' . $self->_informix_datetime_precision($info->{collength});
393 elsif ($type == 17 || $type == 52) {
394 $result->{$col}{data_type} = 'bigint';
396 elsif ($type == 40) {
397 $result->{$col}{data_type} = 'lvarchar';
398 $result->{$col}{size} = $info->{collength};
400 elsif ($type == 12) {
401 $result->{$col}{data_type} = 'text';
403 elsif ($type == 11) {
404 $result->{$col}{data_type} = 'bytea';
405 $result->{$col}{original}{data_type} = 'byte';
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';
411 elsif ($type == 21) {
412 $result->{$col}{data_type} = 'list';
414 elsif ($type == 20) {
415 $result->{$col}{data_type} = 'multiset';
417 elsif ($type == 19) {
418 $result->{$col}{data_type} = 'set';
420 elsif ($type == 15) {
421 $result->{$col}{data_type} = 'nchar';
423 elsif ($type == 16) {
424 $result->{$col}{data_type} = 'nvarchar';
427 elsif ($info->{coltype} == 2061) {
428 $result->{$col}{data_type} = 'idssecuritylabel';
431 my $data_type = $result->{$col}{data_type};
433 if ($data_type !~ /^(?:[nl]?(?:var)?char|decimal)\z/i) {
434 delete $result->{$col}{size};
437 if (lc($data_type) eq 'decimal') {
438 no warnings 'uninitialized';
440 $result->{$col}{data_type} = 'numeric';
442 my @size = @{ $result->{$col}{size} || [] };
444 if ($size[0] == 16 && $size[1] == -4) {
445 delete $result->{$col}{size};
447 elsif ($size[0] == 16 && $size[1] == 2) {
448 $result->{$col}{data_type} = 'money';
449 delete $result->{$col}{size};
452 elsif (lc($data_type) eq 'smallfloat') {
453 $result->{$col}{data_type} = 'real';
455 elsif (lc($data_type) eq 'float') {
456 $result->{$col}{data_type} = 'double precision';
458 elsif ($data_type =~ /^n?(?:var)?char\z/i) {
459 $result->{$col}{size} = $result->{$col}{size}[0];
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};
467 my ($default_type, $default) = @{$info}{qw/deflt_type deflt/};
469 next unless $default_type;
471 if ($default_type eq 'C') {
472 my $current = 'current year to fraction(5)';
473 $result->{$col}{default_value} = \$current;
475 elsif ($default_type eq 'T') {
477 $result->{$col}{default_value} = \$today;
480 $default = (split ' ', $default, 2)[-1];
482 $default =~ s/\s+\z// if looks_like_number $default;
484 # remove trailing 0s in floating point defaults
485 # disabled, this is unsafe since it might be a varchar default
486 #$default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/;
488 $result->{$col}{default_value} = $default;
497 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
498 L<DBIx::Class::Schema::Loader::DBI>
502 See L<DBIx::Class::Schema::Loader/AUTHORS>.
506 This library is free software; you can redistribute it and/or modify it under
507 the same terms as Perl itself.
512 # vim:et sw=4 sts=4 tw=0: