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'); |
167 | select c.colname, c.coltype, d.type deflt_type, d.default deflt |
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) { |
178 | my $type = $info->{coltype} % 256; |
179 | |
180 | if ($type == 6) { # SERIAL |
181 | $result->{$col}{is_auto_increment} = 1; |
182 | } |
183 | |
184 | if (looks_like_number $result->{$col}{data_type}) { |
185 | if ($type == 7) { |
186 | $result->{$col}{data_type} = 'date'; |
187 | } |
188 | elsif ($type == 10) { |
58f0690e |
189 | $result->{$col}{data_type} = 'datetime year to fraction(5)'; |
bc5afe55 |
190 | } |
191 | } |
192 | |
193 | my ($default_type, $default) = @{$info}{qw/deflt_type deflt/}; |
194 | |
195 | next unless $default_type; |
196 | |
197 | if ($default_type eq 'C') { |
198 | my $current = 'CURRENT YEAR TO FRACTION(5)'; |
199 | $result->{$col}{default_value} = \$current; |
200 | } |
201 | elsif ($default_type eq 'T') { |
202 | my $today = 'TODAY'; |
203 | $result->{$col}{default_value} = \$today; |
204 | } |
205 | else { |
5cd983b7 |
206 | $default = (split ' ', $default, 2)[-1]; |
25e1e7bf |
207 | |
208 | $default =~ s/\s+\z// if looks_like_number $default; |
bc5afe55 |
209 | |
210 | # remove trailing 0s in floating point defaults |
a60e0f45 |
211 | # disabled, this is unsafe since it might be a varchar default |
212 | #$default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/; |
bc5afe55 |
213 | |
214 | $result->{$col}{default_value} = $default; |
215 | } |
216 | } |
217 | |
218 | return $result; |
219 | } |
220 | |
221 | =head1 SEE ALSO |
222 | |
223 | L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, |
224 | L<DBIx::Class::Schema::Loader::DBI> |
225 | |
226 | =head1 AUTHOR |
227 | |
228 | See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. |
229 | |
230 | =head1 LICENSE |
231 | |
232 | This library is free software; you can redistribute it and/or modify it under |
233 | the same terms as Perl itself. |
234 | |
235 | =cut |
236 | |
237 | 1; |
238 | # vim:et sw=4 sts=4 tw=0: |