[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 Class::C3;
use base qw/DBIx::Class::Schema::Loader::DBI/;
use namespace::autoclean;
use Carp::Clan qw/^DBIx::Class/;
use Scalar::Util 'looks_like_number';

our $VERSION = '0.07000';

=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 _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('.');
    }
}

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

    my $dbh = $self->schema->storage->dbh;
    my $sth = $dbh->prepare(<<'EOF');
select tabname from systables t
where t.owner <> 'informix' and t.owner <> '' and t.tabname <> ' VERSION'
EOF
    $sth->execute;

    my @tables = map @$_, @{ $sth->fetchall_arrayref };

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

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

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

    my $sth = $dbh->prepare(<<'EOF');
select c.constrname, i.*
from sysconstraints c
join systables t on t.tabid = c.tabid
join 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 $self->_lc($table_cols_by_colno->{$_}), grep $_, map $idx_info->{$_}, map "part$_", (1..16) ];
}

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

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

    my $sth = $dbh->prepare(<<'EOF');
select c.colname, c.colno
from syscolumns c
join systables t on c.tabid = t.tabid
where t.tabname = ?
EOF
    $sth->execute($table);
    my $cols = $sth->fetchall_hashref('colno');
    $cols = { map +($_, $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');

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

    my $sth = $dbh->prepare(<<'EOF');
select c.constrname local_constraint, rt.tabname remote_table, rc.constrname remote_constraint, ri.*
from sysconstraints c
join systables t on c.tabid = t.tabid
join sysreferences r on c.constrid = r.constrid
join sysconstraints rc on rc.constrid = r.primary
join systables rt on r.ptabid = rt.tabid
join 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) {
        push @rels, {
            local_columns => $local_columns->{$local_constraint},
            remote_columns => $self->_idx_colnames($remote_info, $self->_colnames_by_colno($remote_info->{remote_table})),
            remote_table => $remote_info->{remote_table},
        };
    }

    return \@rels;
}

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

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

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

    my $sth = $dbh->prepare(<<'EOF');
select c.colname, c.coltype, c.collength, c.colmin, d.type deflt_type, d.default deflt
from syscolumns c
join systables t on c.tabid = t.tabid
left join 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;
        }

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

        if (looks_like_number $data_type) {
            if ($type == 7) {
                $result->{$col}{data_type} = 'date';
            }
            elsif ($type == 10) {
                $result->{$col}{data_type} = 'datetime year to fraction(5)';
            }
            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';
            }
            elsif ($type == 21) {
                $result->{$col}{data_type} = 'list';
            }
            elsif ($type == 20) {
                $result->{$col}{data_type} = 'multiset';
            }
            elsif ($type == 19) {
                $result->{$col}{data_type} = 'set';
            }
        }

        if ($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';
        }

        # 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;
        }
    }

    # fix up data_types some more
    while (my ($col, $info) = each %$result) {
        my $data_type = $info->{data_type};

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

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

            $info->{data_type} = 'numeric';

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

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

    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;
	5	use Class::C3;
	6	use base qw/DBIx::Class::Schema::Loader::DBI/;
	7	use namespace::autoclean;
	8	use Carp::Clan qw/^DBIx::Class/;
	9	use Scalar::Util 'looks_like_number';
	10
	11	our $VERSION = '0.07000';
	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
157	sub _columns_info_for {
158	my $self = shift;
159	my ($table) = @_;
160
161	my $result = $self->next::method(@_);
162
163	my $dbh = $self->schema->storage->dbh;
164	local $dbh->{FetchHashKeyName} = 'NAME_lc';
165
166	my $sth = $dbh->prepare(<<'EOF');
c7e6dc1f	167	select c.colname, c.coltype, c.collength, c.colmin, d.type deflt_type, d.default deflt
bc5afe55	168	from syscolumns c
	169	join systables t on c.tabid = t.tabid
	170	left join sysdefaults d on t.tabid = d.tabid and c.colno = d.colno
	171	where t.tabname = ?
	172	EOF
	173	$sth->execute($table);
	174	my $cols = $sth->fetchall_hashref('colname');
	175	$sth->finish;
	176
	177	while (my ($col, $info) = each %$cols) {
c7e6dc1f	178	$col = $self->_lc($col);
c7e6dc1f	179
bc5afe55	180	my $type = $info->{coltype} % 256;
	181
	182	if ($type == 6) { # SERIAL
	183	$result->{$col}{is_auto_increment} = 1;
	184	}
	185
c7e6dc1f	186	my $data_type = $result->{$col}{data_type};
	187
	188	if (looks_like_number $data_type) {
bc5afe55	189	if ($type == 7) {
	190	$result->{$col}{data_type} = 'date';
	191	}
	192	elsif ($type == 10) {
58f0690e	193	$result->{$col}{data_type} = 'datetime year to fraction(5)';
bc5afe55	194	}
c7e6dc1f	195	elsif ($type == 17 \|\| $type == 52) {
	196	$result->{$col}{data_type} = 'bigint';
	197	}
	198	elsif ($type == 40) {
	199	$result->{$col}{data_type} = 'lvarchar';
	200	$result->{$col}{size} = $info->{collength};
	201	}
	202	elsif ($type == 12) {
	203	$result->{$col}{data_type} = 'text';
	204	}
	205	elsif ($type == 11) {
	206	$result->{$col}{data_type} = 'bytea';
	207	$result->{$col}{original}{data_type} = 'byte';
	208	}
	209	elsif ($type == 41) {
	210	# XXX no way to distinguish opaque types boolean, blob and clob
	211	$result->{$col}{data_type} = 'blob';
	212	}
	213	elsif ($type == 21) {
	214	$result->{$col}{data_type} = 'list';
	215	}
	216	elsif ($type == 20) {
	217	$result->{$col}{data_type} = 'multiset';
	218	}
	219	elsif ($type == 19) {
	220	$result->{$col}{data_type} = 'set';
	221	}
	222	}
	223
	224	if ($type == 15) {
	225	$result->{$col}{data_type} = 'nchar';
	226	}
	227	elsif ($type == 16) {
	228	$result->{$col}{data_type} = 'nvarchar';
	229	}
	230	# XXX untested!
	231	elsif ($info->{coltype} == 2061) {
	232	$result->{$col}{data_type} = 'idssecuritylabel';
bc5afe55	233	}
bc5afe55	234
c7e6dc1f	235	# XXX colmin doesn't work for min size of varchar columns, it's NULL
	236	# if (lc($data_type) eq 'varchar') {
	237	# $result->{$col}{size}[1] = $info->{colmin};
	238	# }
	239
bc5afe55	240	my ($default_type, $default) = @{$info}{qw/deflt_type deflt/};
	241
	242	next unless $default_type;
	243
	244	if ($default_type eq 'C') {
c7e6dc1f	245	my $current = 'current year to fraction(5)';
bc5afe55	246	$result->{$col}{default_value} = \$current;
	247	}
	248	elsif ($default_type eq 'T') {
c7e6dc1f	249	my $today = 'today';
bc5afe55	250	$result->{$col}{default_value} = \$today;
	251	}
	252	else {
5cd983b7	253	$default = (split ' ', $default, 2)[-1];
25e1e7bf	254
25e1e7bf	255	$default =~ s/\s+\z// if looks_like_number $default;
bc5afe55	256
bc5afe55	257	# remove trailing 0s in floating point defaults
a60e0f45	258	# disabled, this is unsafe since it might be a varchar default
a60e0f45	259	#$default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/;
bc5afe55	260
	261	$result->{$col}{default_value} = $default;
	262	}
	263	}
	264
c7e6dc1f	265	# fix up data_types some more
	266	while (my ($col, $info) = each %$result) {
	267	my $data_type = $info->{data_type};
	268
	269	if ($data_type !~ /^(?:[nl]?(?:var)?char\|decimal)\z/i) {
	270	delete $info->{size};
	271	}
	272
	273	if (lc($data_type) eq 'decimal') {
	274	no warnings 'uninitialized';
	275
	276	$info->{data_type} = 'numeric';
	277
	278	my @size = @{ $info->{size} \|\| [] };
	279
	280	if ($size[0] == 16 && $size[1] == -4) {
	281	delete $info->{size};
	282	}
	283	elsif ($size[0] == 16 && $size[1] == 2) {
	284	$info->{data_type} = 'money';
	285	delete $info->{size};
	286	}
	287	}
	288	elsif (lc($data_type) eq 'smallfloat') {
	289	$info->{data_type} = 'real';
	290	}
	291	elsif (lc($data_type) eq 'float') {
	292	$info->{data_type} = 'double precision';
	293	}
	294	elsif ($data_type =~ /^n?(?:var)?char\z/i) {
	295	$info->{size} = $info->{size}[0];
	296	}
	297	}
	298
bc5afe55	299	return $result;
	300	}
	301
	302	=head1 SEE ALSO
	303
	304	L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
	305	L<DBIx::Class::Schema::Loader::DBI>
	306
	307	=head1 AUTHOR
	308
	309	See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
	310
	311	=head1 LICENSE
	312
	313	This library is free software; you can redistribute it and/or modify it under
	314	the same terms as Perl itself.
	315
	316	=cut
	317
	318	1;
	319	# vim:et sw=4 sts=4 tw=0: