1 package DBIx::Class::Schema::Loader::DBI::Informix;
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';
11 our $VERSION = '0.07000';
15 DBIx::Class::Schema::Loader::DBI::Informix - DBIx::Class::Schema::Loader::DBI
16 Informix Implementation.
20 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
27 $self->next::method(@_);
29 if (not defined $self->preserve_case) {
30 $self->preserve_case(0);
35 my ($self, $opts) = @_;
37 my $dbh = $self->schema->storage->dbh;
38 my $sth = $dbh->prepare(<<'EOF');
39 select tabname from systables t
40 where t.owner <> 'informix' and t.owner <> '' and t.tabname <> ' VERSION'
44 my @tables = map @$_, @{ $sth->fetchall_arrayref };
46 return $self->_filter_tables(\@tables, $opts);
49 sub _constraints_for {
50 my ($self, $table, $type) = @_;
52 my $dbh = $self->schema->storage->dbh;
53 local $dbh->{FetchHashKeyName} = 'NAME_lc';
55 my $sth = $dbh->prepare(<<'EOF');
56 select c.constrname, i.*
58 join systables t on t.tabid = c.tabid
59 join sysindexes i on c.idxname = i.idxname
60 where t.tabname = ? and c.constrtype = ?
62 $sth->execute($table, $type);
63 my $indexes = $sth->fetchall_hashref('constrname');
66 my $cols = $self->_colnames_by_colno($table);
69 while (my ($constr_name, $idx_def) = each %$indexes) {
70 $constraints->{$constr_name} = $self->_idx_colnames($idx_def, $cols);
77 my ($self, $idx_info, $table_cols_by_colno) = @_;
79 return [ map $self->_lc($table_cols_by_colno->{$_}), grep $_, map $idx_info->{$_}, map "part$_", (1..16) ];
82 sub _colnames_by_colno {
83 my ($self, $table) = @_;
85 my $dbh = $self->schema->storage->dbh;
86 local $dbh->{FetchHashKeyName} = 'NAME_lc';
88 my $sth = $dbh->prepare(<<'EOF');
89 select c.colname, c.colno
91 join systables t on c.tabid = t.tabid
94 $sth->execute($table);
95 my $cols = $sth->fetchall_hashref('colno');
96 $cols = { map +($_, $cols->{$_}{colname}), keys %$cols };
102 my ($self, $table) = @_;
104 my $pk = (values %{ $self->_constraints_for($table, 'P') || {} })[0];
109 sub _table_uniq_info {
110 my ($self, $table) = @_;
112 my $constraints = $self->_constraints_for($table, 'U');
114 my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
119 my ($self, $table) = @_;
121 my $local_columns = $self->_constraints_for($table, 'R');
123 my $dbh = $self->schema->storage->dbh;
124 local $dbh->{FetchHashKeyName} = 'NAME_lc';
126 my $sth = $dbh->prepare(<<'EOF');
127 select c.constrname local_constraint, rt.tabname remote_table, rc.constrname remote_constraint, ri.*
128 from sysconstraints c
129 join systables t on c.tabid = t.tabid
130 join sysreferences r on c.constrid = r.constrid
131 join sysconstraints rc on rc.constrid = r.primary
132 join systables rt on r.ptabid = rt.tabid
133 join sysindexes ri on rc.idxname = ri.idxname
134 where t.tabname = ? and c.constrtype = 'R'
136 $sth->execute($table);
137 my $remotes = $sth->fetchall_hashref('local_constraint');
142 while (my ($local_constraint, $remote_info) = each %$remotes) {
144 local_columns => $local_columns->{$local_constraint},
145 remote_columns => $self->_idx_colnames($remote_info, $self->_colnames_by_colno($remote_info->{remote_table})),
146 remote_table => $remote_info->{remote_table},
153 sub _columns_info_for {
157 my $result = $self->next::method(@_);
159 my $dbh = $self->schema->storage->dbh;
160 local $dbh->{FetchHashKeyName} = 'NAME_lc';
162 my $sth = $dbh->prepare(<<'EOF');
163 select c.colname, c.coltype, d.type deflt_type, d.default deflt
165 join systables t on c.tabid = t.tabid
166 left join sysdefaults d on t.tabid = d.tabid and c.colno = d.colno
169 $sth->execute($table);
170 my $cols = $sth->fetchall_hashref('colname');
173 while (my ($col, $info) = each %$cols) {
174 my $type = $info->{coltype} % 256;
176 if ($type == 6) { # SERIAL
177 $result->{$col}{is_auto_increment} = 1;
180 if (looks_like_number $result->{$col}{data_type}) {
182 $result->{$col}{data_type} = 'date';
184 elsif ($type == 10) {
185 $result->{$col}{data_type} = 'datetime';
189 my ($default_type, $default) = @{$info}{qw/deflt_type deflt/};
191 next unless $default_type;
193 if ($default_type eq 'C') {
194 my $current = 'CURRENT YEAR TO FRACTION(5)';
195 $result->{$col}{default_value} = \$current;
197 elsif ($default_type eq 'T') {
199 $result->{$col}{default_value} = \$today;
202 $default = (split ' ', $default)[-1];
204 # remove trailing 0s in floating point defaults
205 if (looks_like_number $default && int $default != $default) {
206 $default =~ s/0+\z//;
209 $result->{$col}{default_value} = $default;
218 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
219 L<DBIx::Class::Schema::Loader::DBI>
223 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
227 This library is free software; you can redistribute it and/or modify it under
228 the same terms as Perl itself.
233 # vim:et sw=4 sts=4 tw=0: