finish preserve_case support
[dbsrgits/DBIx-Class-Schema-Loader.git] / lib / DBIx / Class / Schema / Loader / DBI / Informix.pm
CommitLineData
bc5afe55 1package DBIx::Class::Schema::Loader::DBI::Informix;
2
3use strict;
4use warnings;
5use Class::C3;
6use base qw/DBIx::Class::Schema::Loader::DBI/;
7use namespace::autoclean;
8use Carp::Clan qw/^DBIx::Class/;
9use Scalar::Util 'looks_like_number';
10
11our $VERSION = '0.07000';
12
13=head1 NAME
14
15DBIx::Class::Schema::Loader::DBI::Informix - DBIx::Class::Schema::Loader::DBI
16Informix Implementation.
17
18=head1 DESCRIPTION
19
20See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
21
22=cut
23
24sub _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
38sub _tables_list {
39 my ($self, $opts) = @_;
40
41 my $dbh = $self->schema->storage->dbh;
42 my $sth = $dbh->prepare(<<'EOF');
43select tabname from systables t
44where t.owner <> 'informix' and t.owner <> '' and t.tabname <> ' VERSION'
45EOF
46 $sth->execute;
47
48 my @tables = map @$_, @{ $sth->fetchall_arrayref };
49
50 return $self->_filter_tables(\@tables, $opts);
51}
52
53sub _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');
60select c.constrname, i.*
61from sysconstraints c
62join systables t on t.tabid = c.tabid
63join sysindexes i on c.idxname = i.idxname
64where t.tabname = ? and c.constrtype = ?
65EOF
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
80sub _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
86sub _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');
93select c.colname, c.colno
94from syscolumns c
95join systables t on c.tabid = t.tabid
96where t.tabname = ?
97EOF
98 $sth->execute($table);
99 my $cols = $sth->fetchall_hashref('colno');
100 $cols = { map +($_, $cols->{$_}{colname}), keys %$cols };
101
102 return $cols;
103}
104
105sub _table_pk_info {
106 my ($self, $table) = @_;
107
108 my $pk = (values %{ $self->_constraints_for($table, 'P') || {} })[0];
109
110 return $pk;
111}
112
113sub _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
122sub _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');
131select c.constrname local_constraint, rt.tabname remote_table, rc.constrname remote_constraint, ri.*
132from sysconstraints c
133join systables t on c.tabid = t.tabid
134join sysreferences r on c.constrid = r.constrid
135join sysconstraints rc on rc.constrid = r.primary
136join systables rt on r.ptabid = rt.tabid
137join sysindexes ri on rc.idxname = ri.idxname
138where t.tabname = ? and c.constrtype = 'R'
139EOF
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
157sub _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');
167select c.colname, c.coltype, d.type deflt_type, d.default deflt
168from syscolumns c
169join systables t on c.tabid = t.tabid
170left join sysdefaults d on t.tabid = d.tabid and c.colno = d.colno
171where t.tabname = ?
172EOF
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
223L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
224L<DBIx::Class::Schema::Loader::DBI>
225
226=head1 AUTHOR
227
228See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
229
230=head1 LICENSE
231
232This library is free software; you can redistribute it and/or modify it under
233the same terms as Perl itself.
234
235=cut
236
2371;
238# vim:et sw=4 sts=4 tw=0: