[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / DBI / Informix.pm

package DBIx::Class::Schema::Loader::DBI::Informix;

use strict;
use warnings;
use base qw/DBIx::Class::Schema::Loader::DBI/;
use mro 'c3';
use Scalar::Util 'looks_like_number';
use List::MoreUtils 'any';
use Try::Tiny;
use namespace::clean;
use DBIx::Class::Schema::Loader::Table::Informix ();

our $VERSION = '0.07038';

=head1 NAME

DBIx::Class::Schema::Loader::DBI::Informix - DBIx::Class::Schema::Loader::DBI
Informix Implementation.

=head1 DESCRIPTION

See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.

=cut

sub _build_name_sep { '.' }

sub _system_databases {
    return (qw/
        sysmaster sysutils sysuser sysadmin
    /);
}

sub _current_db {
    my $self = shift;

    my ($current_db) = $self->dbh->selectrow_array(<<'EOF');
SELECT rtrim(ODB_DBName)
FROM sysmaster:informix.SysOpenDB
WHERE ODB_SessionID = (
        SELECT DBINFO('sessionid')
        FROM informix.SysTables
        WHERE TabID = 1
    ) and ODB_IsCurrent = 'Y'
EOF

    return $current_db;
}

sub _owners {
    my ($self, $db) = @_;

    my ($owners) = $self->dbh->selectcol_arrayref(<<"EOF");
SELECT distinct(rtrim(owner))
FROM ${db}:informix.systables
EOF

    my @owners = grep $_ && $_ ne 'informix' && !/^\d/, @$owners;

    return @owners;
}

sub _setup {
    my $self = shift;

    $self->next::method(@_);

    if (not defined $self->preserve_case) {
        $self->preserve_case(0);
    }
    elsif ($self->preserve_case) {
        $self->schema->storage->sql_maker->quote_char('"');
        $self->schema->storage->sql_maker->name_sep('.');
    }

    my $current_db = $self->_current_db;

    if (ref $self->db_schema eq 'HASH') {
        if (keys %{ $self->db_schema } < 2) {
            my ($db) = keys %{ $self->db_schema };

            $db ||= $current_db;

            if ($db eq '%') {
                my $owners = $self->db_schema->{$db};

                my $db_names = $self->dbh->selectcol_arrayref(<<'EOF');
SELECT rtrim(name)
FROM sysmaster:sysdatabases
EOF

                my @dbs;

                foreach my $db_name (@$db_names) {
                    push @dbs, $db_name
                        unless any { $_ eq $db_name } $self->_system_databases;
                }

                $self->db_schema({});

                DB: foreach my $db (@dbs) {
                    if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') || $owners eq '%')) {
                        my @owners;

                        my @db_owners = try {
                            $self->_owners($db);
                        }
                        catch {
                            if (/without logging/) {
                                warn
"Database '$db' is unreferencable due to lack of logging.\n";
                            }
                            return ();
                        };

                        foreach my $owner (@$owners) {
                            push @owners, $owner
                                if any { $_ eq $owner } @db_owners;
                        }

                        next DB unless @owners;

                        $self->db_schema->{$db} = \@owners;
                    }
                    else {
                        # for post-processing below
                        $self->db_schema->{$db} = '%';
                    }
                }

                $self->qualify_objects(1);
            }
            else {
                if ($db ne $current_db) {
                    $self->qualify_objects(1);
                }
            }
        }
        else {
            $self->qualify_objects(1);
        }
    }
    elsif (ref $self->db_schema eq 'ARRAY' || (not defined $self->db_schema)) {
        my $owners = $self->db_schema;
        $owners ||= [ $self->dbh->selectrow_array(<<'EOF') ];
SELECT rtrim(username)
FROM sysmaster:syssessions
WHERE sid = DBINFO('sessionid')
EOF

        $self->qualify_objects(1) if @$owners > 1;

        $self->db_schema({ $current_db => $owners });
    }

    DB: foreach my $db (keys %{ $self->db_schema }) {
        if ($self->db_schema->{$db} eq '%') {
            my @db_owners = try {
                $self->_owners($db);
            }
            catch {
                if (/without logging/) {
                    warn
"Database '$db' is unreferencable due to lack of logging.\n";
                }
                return ();
            };

            if (not @db_owners) {
                delete $self->db_schema->{$db};
                next DB;
            }

            $self->db_schema->{$db} = \@db_owners;

            $self->qualify_objects(1);
        }
    }
}

sub _tables_list {
    my ($self, $opts) = @_;

    my @tables;

    while (my ($db, $owners) = each %{ $self->db_schema }) {
        foreach my $owner (@$owners) {
            my $table_names = $self->dbh->selectcol_arrayref(<<"EOF", {}, $owner);
select tabname
FROM ${db}:informix.systables
WHERE rtrim(owner) = ?
EOF

            TABLE: foreach my $table_name (@$table_names) {
                next if $table_name =~ /^\s/;

                push @tables, DBIx::Class::Schema::Loader::Table::Informix->new(
                    loader   => $self,
                    name     => $table_name,
                    database => $db,
                    schema   => $owner,
                );
            }
        }
    }

    return $self->_filter_tables(\@tables, $opts);
}

sub _constraints_for {
    my ($self, $table, $type) = @_;

    local $self->dbh->{FetchHashKeyName} = 'NAME_lc';

    my $db = $table->database;

    my $sth = $self->dbh->prepare(<<"EOF");
SELECT c.constrname, i.*
FROM ${db}:informix.sysconstraints c
JOIN ${db}:informix.systables t
    ON t.tabid = c.tabid
JOIN ${db}:informix.sysindexes i
    ON c.idxname = i.idxname
WHERE t.tabname = ? and c.constrtype = ?
EOF
    $sth->execute($table, $type);
    my $indexes = $sth->fetchall_hashref('constrname');
    $sth->finish;

    my $cols = $self->_colnames_by_colno($table);

    my $constraints;
    while (my ($constr_name, $idx_def) = each %$indexes) {
        $constraints->{$constr_name} = $self->_idx_colnames($idx_def, $cols);
    }

    return $constraints;
}

sub _idx_colnames {
    my ($self, $idx_info, $table_cols_by_colno) = @_;

    return [ map $table_cols_by_colno->{$_}, grep $_, map $idx_info->{$_}, map "part$_", (1..16) ];
}

sub _colnames_by_colno {
    my ($self, $table) = @_;

    local $self->dbh->{FetchHashKeyName} = 'NAME_lc';

    my $db = $table->database;

    my $sth = $self->dbh->prepare(<<"EOF");
SELECT c.colname, c.colno
FROM ${db}:informix.syscolumns c
JOIN ${db}:informix.systables t
    ON c.tabid = t.tabid
WHERE t.tabname = ?
EOF
    $sth->execute($table);
    my $cols = $sth->fetchall_hashref('colno');
    $cols = { map +($_, $self->_lc($cols->{$_}{colname})), keys %$cols };

    return $cols;
}

sub _table_pk_info {
    my ($self, $table) = @_;

    my $pk = (values %{ $self->_constraints_for($table, 'P') || {} })[0];

    return $pk;
}

sub _table_uniq_info {
    my ($self, $table) = @_;

    my $constraints = $self->_constraints_for($table, 'U');

    my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
    return \@uniqs;
}

sub _table_fk_info {
    my ($self, $table) = @_;

    my $local_columns = $self->_constraints_for($table, 'R');

    local $self->dbh->{FetchHashKeyName} = 'NAME_lc';

    my $db = $table->database;

    my $sth = $self->dbh->prepare(<<"EOF");
SELECT c.constrname local_constraint, rt.tabname remote_table, rtrim(rt.owner) remote_owner, rc.constrname remote_constraint, ri.*
FROM ${db}:informix.sysconstraints c
JOIN ${db}:informix.systables t
    ON c.tabid = t.tabid
JOIN ${db}:informix.sysreferences r
    ON c.constrid = r.constrid
JOIN ${db}:informix.sysconstraints rc
    ON rc.constrid = r.primary
JOIN ${db}:informix.systables rt
    ON r.ptabid = rt.tabid
JOIN ${db}:informix.sysindexes ri
    ON rc.idxname = ri.idxname
WHERE t.tabname = ? and c.constrtype = 'R'
EOF
    $sth->execute($table);
    my $remotes = $sth->fetchall_hashref('local_constraint');
    $sth->finish;

    my @rels;

    while (my ($local_constraint, $remote_info) = each %$remotes) {
        my $remote_table = DBIx::Class::Schema::Loader::Table::Informix->new(
            loader   => $self,
            name     => $remote_info->{remote_table},
            database => $db,
            schema   => $remote_info->{remote_owner},
        );

        push @rels, {
            local_columns  => $local_columns->{$local_constraint},
            remote_columns => $self->_idx_colnames($remote_info, $self->_colnames_by_colno($remote_table)),
            remote_table   => $remote_table,
        };
    }

    return \@rels;
}

# This is directly from http://www.ibm.com/developerworks/data/zones/informix/library/techarticle/0305parker/0305parker.html
# it doesn't work at all
sub _informix_datetime_precision {
    my @date_type = qw/DUMMY year  month day   hour   minute  second  fraction(1) fraction(2) fraction(3) fraction(4) fraction(5)/;
    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]    );

    my ($self, $collength) = @_;

    my $i = ($collength % 16) + 1;
    my $j = int(($collength % 256) / 16) + 1;
    my $k = int($collength / 256);

    my $len = $start_end[$i][1] - $start_end[$j][0];
    $len = $k - $len;

    if ($len == 0 || $j > 11) {
        return $date_type[$j] . ' to ' . $date_type[$i];
    }

    $k  = $start_end[$j][1] - $start_end[$j][0];
    $k += $len;

    return $date_type[$j] . "($k) to " . $date_type[$i];
}

sub _columns_info_for {
    my $self = shift;
    my ($table) = @_;

    my $result = $self->next::method(@_);

    my $db = $table->database;

    my $sth = $self->dbh->prepare(<<"EOF");
SELECT c.colname, c.coltype, c.collength, c.colmin, d.type deflt_type, d.default deflt
FROM ${db}:informix.syscolumns c
JOIN ${db}:informix.systables t
    ON c.tabid = t.tabid
LEFT JOIN ${db}:informix.sysdefaults d
    ON t.tabid = d.tabid AND c.colno = d.colno
WHERE t.tabname = ?
EOF
    $sth->execute($table);
    my $cols = $sth->fetchall_hashref('colname');
    $sth->finish;

    while (my ($col, $info) = each %$cols) {
        $col = $self->_lc($col);

        my $type = $info->{coltype} % 256;

        if ($type == 6) { # SERIAL
            $result->{$col}{is_auto_increment} = 1;
        }
        elsif ($type == 7) {
            $result->{$col}{data_type} = 'date';
        }
        elsif ($type == 10) {
            $result->{$col}{data_type} = 'datetime year to fraction(5)';
            # this doesn't work yet
#                $result->{$col}{data_type} = 'datetime ' . $self->_informix_datetime_precision($info->{collength});
        }
        elsif ($type == 17 || $type == 52) {
            $result->{$col}{data_type} = 'bigint';
        }
        elsif ($type == 40) {
            $result->{$col}{data_type} = 'lvarchar';
            $result->{$col}{size}      = $info->{collength};
        }
        elsif ($type == 12) {
            $result->{$col}{data_type} = 'text';
        }
        elsif ($type == 11) {
            $result->{$col}{data_type}           = 'bytea';
            $result->{$col}{original}{data_type} = 'byte';
        }
        elsif ($type == 41) {
            # XXX no way to distinguish opaque types boolean, blob and clob
            $result->{$col}{data_type} = 'blob' unless $result->{$col}{data_type} eq 'smallint';
        }
        elsif ($type == 21) {
            $result->{$col}{data_type} = 'list';
        }
        elsif ($type == 20) {
            $result->{$col}{data_type} = 'multiset';
        }
        elsif ($type == 19) {
            $result->{$col}{data_type} = 'set';
        }
        elsif ($type == 15) {
            $result->{$col}{data_type} = 'nchar';
        }
        elsif ($type == 16) {
            $result->{$col}{data_type} = 'nvarchar';
        }
        # XXX untested!
        elsif ($info->{coltype} == 2061) {
            $result->{$col}{data_type} = 'idssecuritylabel';
        }

        my $data_type = $result->{$col}{data_type};

        if ($data_type !~ /^(?:[nl]?(?:var)?char|decimal)\z/i) {
            delete $result->{$col}{size};
        }

        if (lc($data_type) eq 'decimal') {
            no warnings 'uninitialized';

            $result->{$col}{data_type} = 'numeric';

            my @size = @{ $result->{$col}{size} || [] };

            if ($size[0] == 16 && $size[1] == -4) {
                delete $result->{$col}{size};
            }
            elsif ($size[0] == 16 && $size[1] == 2) {
                $result->{$col}{data_type} = 'money';
                delete $result->{$col}{size};
            }
        }
        elsif (lc($data_type) eq 'smallfloat') {
            $result->{$col}{data_type} = 'real';
        }
        elsif (lc($data_type) eq 'float') {
            $result->{$col}{data_type} = 'double precision';
        }
        elsif ($data_type =~ /^n?(?:var)?char\z/i) {
            $result->{$col}{size} = $result->{$col}{size}[0];
        }

        # XXX colmin doesn't work for min size of varchar columns, it's NULL
#        if (lc($data_type) eq 'varchar') {
#            $result->{$col}{size}[1] = $info->{colmin};
#        }
       
        my ($default_type, $default) = @{$info}{qw/deflt_type deflt/};

        next unless $default_type;

        if ($default_type eq 'C') {
            my $current = 'current year to fraction(5)';
            $result->{$col}{default_value} = \$current;
        }
        elsif ($default_type eq 'T') {
            my $today = 'today';
            $result->{$col}{default_value} = \$today;
        }
        else {
            $default = (split ' ', $default, 2)[-1];

            $default =~ s/\s+\z// if looks_like_number $default;

            # remove trailing 0s in floating point defaults
            # disabled, this is unsafe since it might be a varchar default
            #$default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/;

            $result->{$col}{default_value} = $default;
        }
    }

    return $result;
}

=head1 SEE ALSO

L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
L<DBIx::Class::Schema::Loader::DBI>

=head1 AUTHOR

See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.

=head1 LICENSE

This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut

1;
# vim:et sw=4 sts=4 tw=0:
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';
c4a69b87	8	use List::MoreUtils 'any';
c4a69b87	9	use Try::Tiny;
2b74a06b	10	use namespace::clean;
c4a69b87	11	use DBIx::Class::Schema::Loader::Table::Informix ();
bc5afe55	12
242c1525	13	our $VERSION = '0.07038';
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
	280	my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
	281	return \@uniqs;
	282	}
	283
	284	sub _table_fk_info {
	285	my ($self, $table) = @_;
	286
	287	my $local_columns = $self->_constraints_for($table, 'R');
	288
c4a69b87	289	local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
	290
	291	my $db = $table->database;
	292
	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
	297	ON c.tabid = t.tabid
	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'
bc5afe55	307	EOF
	308	$sth->execute($table);
	309	my $remotes = $sth->fetchall_hashref('local_constraint');
	310	$sth->finish;
	311
	312	my @rels;
	313
	314	while (my ($local_constraint, $remote_info) = each %$remotes) {
c4a69b87	315	my $remote_table = DBIx::Class::Schema::Loader::Table::Informix->new(
	316	loader => $self,
	317	name => $remote_info->{remote_table},
	318	database => $db,
	319	schema => $remote_info->{remote_owner},
	320	);
	321
bc5afe55	322	push @rels, {
c4a69b87	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,
bc5afe55	326	};
	327	}
	328
	329	return \@rels;
	330	}
	331
f916de47	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] );
	337
	338	my ($self, $collength) = @_;
	339
	340	my $i = ($collength % 16) + 1;
	341	my $j = int(($collength % 256) / 16) + 1;
	342	my $k = int($collength / 256);
	343
	344	my $len = $start_end[$i][1] - $start_end[$j][0];
	345	$len = $k - $len;
	346
	347	if ($len == 0 \|\| $j > 11) {
	348	return $date_type[$j] . ' to ' . $date_type[$i];
	349	}
	350
	351	$k = $start_end[$j][1] - $start_end[$j][0];
	352	$k += $len;
	353
	354	return $date_type[$j] . "($k) to " . $date_type[$i];
	355	}
	356
bc5afe55	357	sub _columns_info_for {
	358	my $self = shift;
	359	my ($table) = @_;
	360
	361	my $result = $self->next::method(@_);
	362
c4a69b87	363	my $db = $table->database;
bc5afe55	364
c4a69b87	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
	369	ON c.tabid = t.tabid
	370	LEFT JOIN ${db}:informix.sysdefaults d
	371	ON t.tabid = d.tabid AND c.colno = d.colno
	372	WHERE t.tabname = ?
bc5afe55	373	EOF
	374	$sth->execute($table);
	375	my $cols = $sth->fetchall_hashref('colname');
	376	$sth->finish;
	377
	378	while (my ($col, $info) = each %$cols) {
c7e6dc1f	379	$col = $self->_lc($col);
c7e6dc1f	380
bc5afe55	381	my $type = $info->{coltype} % 256;
	382
	383	if ($type == 6) { # SERIAL
	384	$result->{$col}{is_auto_increment} = 1;
	385	}
eaf7c54e	386	elsif ($type == 7) {
	387	$result->{$col}{data_type} = 'date';
	388	}
	389	elsif ($type == 10) {
	390	$result->{$col}{data_type} = 'datetime year to fraction(5)';
	391	# this doesn't work yet
f916de47	392	# $result->{$col}{data_type} = 'datetime ' . $self->_informix_datetime_precision($info->{collength});
c7e6dc1f	393	}
eaf7c54e	394	elsif ($type == 17 \|\| $type == 52) {
	395	$result->{$col}{data_type} = 'bigint';
	396	}
	397	elsif ($type == 40) {
	398	$result->{$col}{data_type} = 'lvarchar';
	399	$result->{$col}{size} = $info->{collength};
	400	}
	401	elsif ($type == 12) {
	402	$result->{$col}{data_type} = 'text';
	403	}
	404	elsif ($type == 11) {
	405	$result->{$col}{data_type} = 'bytea';
	406	$result->{$col}{original}{data_type} = 'byte';
	407	}
	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';
	411	}
	412	elsif ($type == 21) {
	413	$result->{$col}{data_type} = 'list';
	414	}
	415	elsif ($type == 20) {
	416	$result->{$col}{data_type} = 'multiset';
	417	}
	418	elsif ($type == 19) {
	419	$result->{$col}{data_type} = 'set';
	420	}
	421	elsif ($type == 15) {
c7e6dc1f	422	$result->{$col}{data_type} = 'nchar';
	423	}
	424	elsif ($type == 16) {
	425	$result->{$col}{data_type} = 'nvarchar';
	426	}
	427	# XXX untested!
	428	elsif ($info->{coltype} == 2061) {
	429	$result->{$col}{data_type} = 'idssecuritylabel';
bc5afe55	430	}
bc5afe55	431
eaf7c54e	432	my $data_type = $result->{$col}{data_type};
	433
	434	if ($data_type !~ /^(?:[nl]?(?:var)?char\|decimal)\z/i) {
	435	delete $result->{$col}{size};
	436	}
	437
	438	if (lc($data_type) eq 'decimal') {
	439	no warnings 'uninitialized';
	440
	441	$result->{$col}{data_type} = 'numeric';
	442
	443	my @size = @{ $result->{$col}{size} \|\| [] };
	444
	445	if ($size[0] == 16 && $size[1] == -4) {
	446	delete $result->{$col}{size};
	447	}
	448	elsif ($size[0] == 16 && $size[1] == 2) {
	449	$result->{$col}{data_type} = 'money';
	450	delete $result->{$col}{size};
	451	}
	452	}
	453	elsif (lc($data_type) eq 'smallfloat') {
	454	$result->{$col}{data_type} = 'real';
	455	}
	456	elsif (lc($data_type) eq 'float') {
	457	$result->{$col}{data_type} = 'double precision';
	458	}
	459	elsif ($data_type =~ /^n?(?:var)?char\z/i) {
	460	$result->{$col}{size} = $result->{$col}{size}[0];
	461	}
	462
c7e6dc1f	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};
	466	# }
	467
bc5afe55	468	my ($default_type, $default) = @{$info}{qw/deflt_type deflt/};
	469
	470	next unless $default_type;
	471
	472	if ($default_type eq 'C') {
c7e6dc1f	473	my $current = 'current year to fraction(5)';
bc5afe55	474	$result->{$col}{default_value} = \$current;
	475	}
	476	elsif ($default_type eq 'T') {
c7e6dc1f	477	my $today = 'today';
bc5afe55	478	$result->{$col}{default_value} = \$today;
	479	}
	480	else {
5cd983b7	481	$default = (split ' ', $default, 2)[-1];
25e1e7bf	482
25e1e7bf	483	$default =~ s/\s+\z// if looks_like_number $default;
bc5afe55	484
bc5afe55	485	# remove trailing 0s in floating point defaults
a60e0f45	486	# disabled, this is unsafe since it might be a varchar default
a60e0f45	487	#$default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/;
bc5afe55	488
	489	$result->{$col}{default_value} = $default;
	490	}
	491	}
	492
	493	return $result;
	494	}
	495
	496	=head1 SEE ALSO
	497
	498	L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
	499	L<DBIx::Class::Schema::Loader::DBI>
	500
	501	=head1 AUTHOR
	502
	503	See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
	504
	505	=head1 LICENSE
	506
	507	This library is free software; you can redistribute it and/or modify it under
	508	the same terms as Perl itself.
	509
	510	=cut
	511
	512	1;
	513	# vim:et sw=4 sts=4 tw=0: