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 | } |
32 | } |
33 | |
34 | sub _tables_list { |
35 | my ($self, $opts) = @_; |
36 | |
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' |
41 | EOF |
42 | $sth->execute; |
43 | |
44 | my @tables = map @$_, @{ $sth->fetchall_arrayref }; |
45 | |
46 | return $self->_filter_tables(\@tables, $opts); |
47 | } |
48 | |
49 | sub _constraints_for { |
50 | my ($self, $table, $type) = @_; |
51 | |
52 | my $dbh = $self->schema->storage->dbh; |
53 | local $dbh->{FetchHashKeyName} = 'NAME_lc'; |
54 | |
55 | my $sth = $dbh->prepare(<<'EOF'); |
56 | select c.constrname, i.* |
57 | from sysconstraints c |
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 = ? |
61 | EOF |
62 | $sth->execute($table, $type); |
63 | my $indexes = $sth->fetchall_hashref('constrname'); |
64 | $sth->finish; |
65 | |
66 | my $cols = $self->_colnames_by_colno($table); |
67 | |
68 | my $constraints; |
69 | while (my ($constr_name, $idx_def) = each %$indexes) { |
70 | $constraints->{$constr_name} = $self->_idx_colnames($idx_def, $cols); |
71 | } |
72 | |
73 | return $constraints; |
74 | } |
75 | |
76 | sub _idx_colnames { |
77 | my ($self, $idx_info, $table_cols_by_colno) = @_; |
78 | |
79 | return [ map $self->_lc($table_cols_by_colno->{$_}), grep $_, map $idx_info->{$_}, map "part$_", (1..16) ]; |
80 | } |
81 | |
82 | sub _colnames_by_colno { |
83 | my ($self, $table) = @_; |
84 | |
85 | my $dbh = $self->schema->storage->dbh; |
86 | local $dbh->{FetchHashKeyName} = 'NAME_lc'; |
87 | |
88 | my $sth = $dbh->prepare(<<'EOF'); |
89 | select c.colname, c.colno |
90 | from syscolumns c |
91 | join systables t on c.tabid = t.tabid |
92 | where t.tabname = ? |
93 | EOF |
94 | $sth->execute($table); |
95 | my $cols = $sth->fetchall_hashref('colno'); |
96 | $cols = { map +($_, $cols->{$_}{colname}), keys %$cols }; |
97 | |
98 | return $cols; |
99 | } |
100 | |
101 | sub _table_pk_info { |
102 | my ($self, $table) = @_; |
103 | |
104 | my $pk = (values %{ $self->_constraints_for($table, 'P') || {} })[0]; |
105 | |
106 | return $pk; |
107 | } |
108 | |
109 | sub _table_uniq_info { |
110 | my ($self, $table) = @_; |
111 | |
112 | my $constraints = $self->_constraints_for($table, 'U'); |
113 | |
114 | my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints; |
115 | return \@uniqs; |
116 | } |
117 | |
118 | sub _table_fk_info { |
119 | my ($self, $table) = @_; |
120 | |
121 | my $local_columns = $self->_constraints_for($table, 'R'); |
122 | |
123 | my $dbh = $self->schema->storage->dbh; |
124 | local $dbh->{FetchHashKeyName} = 'NAME_lc'; |
125 | |
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' |
135 | EOF |
136 | $sth->execute($table); |
137 | my $remotes = $sth->fetchall_hashref('local_constraint'); |
138 | $sth->finish; |
139 | |
140 | my @rels; |
141 | |
142 | while (my ($local_constraint, $remote_info) = each %$remotes) { |
143 | push @rels, { |
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}, |
147 | }; |
148 | } |
149 | |
150 | return \@rels; |
151 | } |
152 | |
153 | sub _columns_info_for { |
154 | my $self = shift; |
155 | my ($table) = @_; |
156 | |
157 | my $result = $self->next::method(@_); |
158 | |
159 | my $dbh = $self->schema->storage->dbh; |
160 | local $dbh->{FetchHashKeyName} = 'NAME_lc'; |
161 | |
162 | my $sth = $dbh->prepare(<<'EOF'); |
163 | select c.colname, c.coltype, d.type deflt_type, d.default deflt |
164 | from syscolumns c |
165 | join systables t on c.tabid = t.tabid |
166 | left join sysdefaults d on t.tabid = d.tabid and c.colno = d.colno |
167 | where t.tabname = ? |
168 | EOF |
169 | $sth->execute($table); |
170 | my $cols = $sth->fetchall_hashref('colname'); |
171 | $sth->finish; |
172 | |
173 | while (my ($col, $info) = each %$cols) { |
174 | my $type = $info->{coltype} % 256; |
175 | |
176 | if ($type == 6) { # SERIAL |
177 | $result->{$col}{is_auto_increment} = 1; |
178 | } |
179 | |
180 | if (looks_like_number $result->{$col}{data_type}) { |
181 | if ($type == 7) { |
182 | $result->{$col}{data_type} = 'date'; |
183 | } |
184 | elsif ($type == 10) { |
58f0690e |
185 | $result->{$col}{data_type} = 'datetime year to fraction(5)'; |
bc5afe55 |
186 | } |
187 | } |
188 | |
189 | my ($default_type, $default) = @{$info}{qw/deflt_type deflt/}; |
190 | |
191 | next unless $default_type; |
192 | |
193 | if ($default_type eq 'C') { |
194 | my $current = 'CURRENT YEAR TO FRACTION(5)'; |
195 | $result->{$col}{default_value} = \$current; |
196 | } |
197 | elsif ($default_type eq 'T') { |
198 | my $today = 'TODAY'; |
199 | $result->{$col}{default_value} = \$today; |
200 | } |
201 | else { |
5cd983b7 |
202 | $default = (split ' ', $default, 2)[-1]; |
25e1e7bf |
203 | |
204 | $default =~ s/\s+\z// if looks_like_number $default; |
bc5afe55 |
205 | |
206 | # remove trailing 0s in floating point defaults |
a60e0f45 |
207 | # disabled, this is unsafe since it might be a varchar default |
208 | #$default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/; |
bc5afe55 |
209 | |
210 | $result->{$col}{default_value} = $default; |
211 | } |
212 | } |
213 | |
214 | return $result; |
215 | } |
216 | |
217 | =head1 SEE ALSO |
218 | |
219 | L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, |
220 | L<DBIx::Class::Schema::Loader::DBI> |
221 | |
222 | =head1 AUTHOR |
223 | |
224 | See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. |
225 | |
226 | =head1 LICENSE |
227 | |
228 | This library is free software; you can redistribute it and/or modify it under |
229 | the same terms as Perl itself. |
230 | |
231 | =cut |
232 | |
233 | 1; |
234 | # vim:et sw=4 sts=4 tw=0: |