Fix Pg date/time types with zero fractional second digits
[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;
bc5afe55 5use base qw/DBIx::Class::Schema::Loader::DBI/;
c4a69b87 6use mro 'c3';
bc5afe55 7use Scalar::Util 'looks_like_number';
ecf22f0a 8use List::Util 'any';
c4a69b87 9use Try::Tiny;
2b74a06b 10use namespace::clean;
c4a69b87 11use DBIx::Class::Schema::Loader::Table::Informix ();
bc5afe55 12
6bef6696 13our $VERSION = '0.07043';
bc5afe55 14
15=head1 NAME
16
17DBIx::Class::Schema::Loader::DBI::Informix - DBIx::Class::Schema::Loader::DBI
18Informix Implementation.
19
20=head1 DESCRIPTION
21
22See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
23
24=cut
25
c4a69b87 26sub _build_name_sep { '.' }
27
28sub _system_databases {
29 return (qw/
30 sysmaster sysutils sysuser sysadmin
31 /);
32}
33
34sub _current_db {
35 my $self = shift;
36
37 my ($current_db) = $self->dbh->selectrow_array(<<'EOF');
38SELECT rtrim(ODB_DBName)
39FROM sysmaster:informix.SysOpenDB
40WHERE ODB_SessionID = (
41 SELECT DBINFO('sessionid')
42 FROM informix.SysTables
43 WHERE TabID = 1
44 ) and ODB_IsCurrent = 'Y'
45EOF
46
47 return $current_db;
48}
49
50sub _owners {
51 my ($self, $db) = @_;
52
53 my ($owners) = $self->dbh->selectcol_arrayref(<<"EOF");
54SELECT distinct(rtrim(owner))
55FROM ${db}:informix.systables
56EOF
57
58 my @owners = grep $_ && $_ ne 'informix' && !/^\d/, @$owners;
59
60 return @owners;
61}
62
bc5afe55 63sub _setup {
64 my $self = shift;
65
66 $self->next::method(@_);
67
68 if (not defined $self->preserve_case) {
69 $self->preserve_case(0);
70 }
b511f36e 71 elsif ($self->preserve_case) {
72 $self->schema->storage->sql_maker->quote_char('"');
73 $self->schema->storage->sql_maker->name_sep('.');
74 }
c4a69b87 75
76 my $current_db = $self->_current_db;
77
78 if (ref $self->db_schema eq 'HASH') {
79 if (keys %{ $self->db_schema } < 2) {
80 my ($db) = keys %{ $self->db_schema };
81
82 $db ||= $current_db;
83
84 if ($db eq '%') {
85 my $owners = $self->db_schema->{$db};
86
87 my $db_names = $self->dbh->selectcol_arrayref(<<'EOF');
88SELECT rtrim(name)
89FROM sysmaster:sysdatabases
90EOF
91
92 my @dbs;
93
94 foreach my $db_name (@$db_names) {
95 push @dbs, $db_name
96 unless any { $_ eq $db_name } $self->_system_databases;
97 }
98
99 $self->db_schema({});
100
101 DB: foreach my $db (@dbs) {
102 if (not ((ref $owners eq 'ARRAY' && $owners->[0] eq '%') || $owners eq '%')) {
103 my @owners;
104
105 my @db_owners = try {
106 $self->_owners($db);
107 }
108 catch {
109 if (/without logging/) {
110 warn
111"Database '$db' is unreferencable due to lack of logging.\n";
112 }
113 return ();
114 };
115
116 foreach my $owner (@$owners) {
117 push @owners, $owner
118 if any { $_ eq $owner } @db_owners;
119 }
120
121 next DB unless @owners;
122
123 $self->db_schema->{$db} = \@owners;
124 }
125 else {
126 # for post-processing below
127 $self->db_schema->{$db} = '%';
128 }
129 }
130
131 $self->qualify_objects(1);
132 }
133 else {
134 if ($db ne $current_db) {
135 $self->qualify_objects(1);
136 }
137 }
138 }
139 else {
140 $self->qualify_objects(1);
141 }
142 }
143 elsif (ref $self->db_schema eq 'ARRAY' || (not defined $self->db_schema)) {
144 my $owners = $self->db_schema;
145 $owners ||= [ $self->dbh->selectrow_array(<<'EOF') ];
146SELECT rtrim(username)
147FROM sysmaster:syssessions
148WHERE sid = DBINFO('sessionid')
149EOF
150
151 $self->qualify_objects(1) if @$owners > 1;
152
153 $self->db_schema({ $current_db => $owners });
154 }
155
156 DB: foreach my $db (keys %{ $self->db_schema }) {
157 if ($self->db_schema->{$db} eq '%') {
158 my @db_owners = try {
159 $self->_owners($db);
160 }
161 catch {
162 if (/without logging/) {
163 warn
164"Database '$db' is unreferencable due to lack of logging.\n";
165 }
166 return ();
167 };
168
169 if (not @db_owners) {
170 delete $self->db_schema->{$db};
171 next DB;
172 }
173
174 $self->db_schema->{$db} = \@db_owners;
175
176 $self->qualify_objects(1);
177 }
178 }
bc5afe55 179}
180
181sub _tables_list {
182 my ($self, $opts) = @_;
183
c4a69b87 184 my @tables;
185
186 while (my ($db, $owners) = each %{ $self->db_schema }) {
187 foreach my $owner (@$owners) {
188 my $table_names = $self->dbh->selectcol_arrayref(<<"EOF", {}, $owner);
189select tabname
190FROM ${db}:informix.systables
191WHERE rtrim(owner) = ?
bc5afe55 192EOF
bc5afe55 193
c4a69b87 194 TABLE: foreach my $table_name (@$table_names) {
195 next if $table_name =~ /^\s/;
196
197 push @tables, DBIx::Class::Schema::Loader::Table::Informix->new(
198 loader => $self,
199 name => $table_name,
200 database => $db,
201 schema => $owner,
202 );
203 }
204 }
205 }
bc5afe55 206
207 return $self->_filter_tables(\@tables, $opts);
208}
209
210sub _constraints_for {
211 my ($self, $table, $type) = @_;
212
c4a69b87 213 local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
214
215 my $db = $table->database;
bc5afe55 216
c4a69b87 217 my $sth = $self->dbh->prepare(<<"EOF");
218SELECT c.constrname, i.*
219FROM ${db}:informix.sysconstraints c
220JOIN ${db}:informix.systables t
221 ON t.tabid = c.tabid
222JOIN ${db}:informix.sysindexes i
223 ON c.idxname = i.idxname
224WHERE t.tabname = ? and c.constrtype = ?
bc5afe55 225EOF
226 $sth->execute($table, $type);
227 my $indexes = $sth->fetchall_hashref('constrname');
228 $sth->finish;
229
230 my $cols = $self->_colnames_by_colno($table);
231
232 my $constraints;
233 while (my ($constr_name, $idx_def) = each %$indexes) {
234 $constraints->{$constr_name} = $self->_idx_colnames($idx_def, $cols);
235 }
236
237 return $constraints;
238}
239
240sub _idx_colnames {
241 my ($self, $idx_info, $table_cols_by_colno) = @_;
242
116431d6 243 return [ map $table_cols_by_colno->{$_}, grep $_, map $idx_info->{$_}, map "part$_", (1..16) ];
bc5afe55 244}
245
246sub _colnames_by_colno {
247 my ($self, $table) = @_;
248
c4a69b87 249 local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
bc5afe55 250
c4a69b87 251 my $db = $table->database;
252
253 my $sth = $self->dbh->prepare(<<"EOF");
254SELECT c.colname, c.colno
255FROM ${db}:informix.syscolumns c
256JOIN ${db}:informix.systables t
257 ON c.tabid = t.tabid
258WHERE t.tabname = ?
bc5afe55 259EOF
260 $sth->execute($table);
261 my $cols = $sth->fetchall_hashref('colno');
116431d6 262 $cols = { map +($_, $self->_lc($cols->{$_}{colname})), keys %$cols };
bc5afe55 263
264 return $cols;
265}
266
267sub _table_pk_info {
268 my ($self, $table) = @_;
269
270 my $pk = (values %{ $self->_constraints_for($table, 'P') || {} })[0];
271
272 return $pk;
273}
274
275sub _table_uniq_info {
276 my ($self, $table) = @_;
277
278 my $constraints = $self->_constraints_for($table, 'U');
279
6c4f5a4a 280 return [ map { [ $_ => $constraints->{$_} ] } sort keys %$constraints ];
bc5afe55 281}
282
283sub _table_fk_info {
284 my ($self, $table) = @_;
285
286 my $local_columns = $self->_constraints_for($table, 'R');
287
c4a69b87 288 local $self->dbh->{FetchHashKeyName} = 'NAME_lc';
289
290 my $db = $table->database;
291
292 my $sth = $self->dbh->prepare(<<"EOF");
293SELECT c.constrname local_constraint, rt.tabname remote_table, rtrim(rt.owner) remote_owner, rc.constrname remote_constraint, ri.*
294FROM ${db}:informix.sysconstraints c
295JOIN ${db}:informix.systables t
296 ON c.tabid = t.tabid
297JOIN ${db}:informix.sysreferences r
298 ON c.constrid = r.constrid
299JOIN ${db}:informix.sysconstraints rc
300 ON rc.constrid = r.primary
301JOIN ${db}:informix.systables rt
302 ON r.ptabid = rt.tabid
303JOIN ${db}:informix.sysindexes ri
304 ON rc.idxname = ri.idxname
305WHERE t.tabname = ? and c.constrtype = 'R'
bc5afe55 306EOF
307 $sth->execute($table);
308 my $remotes = $sth->fetchall_hashref('local_constraint');
309 $sth->finish;
310
311 my @rels;
312
313 while (my ($local_constraint, $remote_info) = each %$remotes) {
c4a69b87 314 my $remote_table = DBIx::Class::Schema::Loader::Table::Informix->new(
315 loader => $self,
316 name => $remote_info->{remote_table},
317 database => $db,
318 schema => $remote_info->{remote_owner},
319 );
320
bc5afe55 321 push @rels, {
c4a69b87 322 local_columns => $local_columns->{$local_constraint},
323 remote_columns => $self->_idx_colnames($remote_info, $self->_colnames_by_colno($remote_table)),
324 remote_table => $remote_table,
bc5afe55 325 };
326 }
327
328 return \@rels;
329}
330
f916de47 331# This is directly from http://www.ibm.com/developerworks/data/zones/informix/library/techarticle/0305parker/0305parker.html
332# it doesn't work at all
333sub _informix_datetime_precision {
334 my @date_type = qw/DUMMY year month day hour minute second fraction(1) fraction(2) fraction(3) fraction(4) fraction(5)/;
335 my @start_end = ( [], [1,5],[5,7],[7,9],[9,11],[11,13],[13,15],[15,16], [16,17], [17,18], [18,19], [19,20] );
336
337 my ($self, $collength) = @_;
338
339 my $i = ($collength % 16) + 1;
340 my $j = int(($collength % 256) / 16) + 1;
341 my $k = int($collength / 256);
342
343 my $len = $start_end[$i][1] - $start_end[$j][0];
344 $len = $k - $len;
345
346 if ($len == 0 || $j > 11) {
347 return $date_type[$j] . ' to ' . $date_type[$i];
348 }
349
350 $k = $start_end[$j][1] - $start_end[$j][0];
351 $k += $len;
352
353 return $date_type[$j] . "($k) to " . $date_type[$i];
354}
355
bc5afe55 356sub _columns_info_for {
357 my $self = shift;
358 my ($table) = @_;
359
360 my $result = $self->next::method(@_);
361
c4a69b87 362 my $db = $table->database;
bc5afe55 363
c4a69b87 364 my $sth = $self->dbh->prepare(<<"EOF");
365SELECT c.colname, c.coltype, c.collength, c.colmin, d.type deflt_type, d.default deflt
366FROM ${db}:informix.syscolumns c
367JOIN ${db}:informix.systables t
368 ON c.tabid = t.tabid
369LEFT JOIN ${db}:informix.sysdefaults d
370 ON t.tabid = d.tabid AND c.colno = d.colno
371WHERE t.tabname = ?
bc5afe55 372EOF
373 $sth->execute($table);
374 my $cols = $sth->fetchall_hashref('colname');
375 $sth->finish;
376
377 while (my ($col, $info) = each %$cols) {
c7e6dc1f 378 $col = $self->_lc($col);
379
bc5afe55 380 my $type = $info->{coltype} % 256;
381
382 if ($type == 6) { # SERIAL
383 $result->{$col}{is_auto_increment} = 1;
384 }
eaf7c54e 385 elsif ($type == 7) {
386 $result->{$col}{data_type} = 'date';
387 }
388 elsif ($type == 10) {
389 $result->{$col}{data_type} = 'datetime year to fraction(5)';
390 # this doesn't work yet
f916de47 391# $result->{$col}{data_type} = 'datetime ' . $self->_informix_datetime_precision($info->{collength});
c7e6dc1f 392 }
eaf7c54e 393 elsif ($type == 17 || $type == 52) {
394 $result->{$col}{data_type} = 'bigint';
395 }
396 elsif ($type == 40) {
397 $result->{$col}{data_type} = 'lvarchar';
398 $result->{$col}{size} = $info->{collength};
399 }
400 elsif ($type == 12) {
401 $result->{$col}{data_type} = 'text';
402 }
403 elsif ($type == 11) {
404 $result->{$col}{data_type} = 'bytea';
405 $result->{$col}{original}{data_type} = 'byte';
406 }
407 elsif ($type == 41) {
408 # XXX no way to distinguish opaque types boolean, blob and clob
409 $result->{$col}{data_type} = 'blob' unless $result->{$col}{data_type} eq 'smallint';
410 }
411 elsif ($type == 21) {
412 $result->{$col}{data_type} = 'list';
413 }
414 elsif ($type == 20) {
415 $result->{$col}{data_type} = 'multiset';
416 }
417 elsif ($type == 19) {
418 $result->{$col}{data_type} = 'set';
419 }
420 elsif ($type == 15) {
c7e6dc1f 421 $result->{$col}{data_type} = 'nchar';
422 }
423 elsif ($type == 16) {
424 $result->{$col}{data_type} = 'nvarchar';
425 }
426 # XXX untested!
427 elsif ($info->{coltype} == 2061) {
428 $result->{$col}{data_type} = 'idssecuritylabel';
bc5afe55 429 }
430
eaf7c54e 431 my $data_type = $result->{$col}{data_type};
432
433 if ($data_type !~ /^(?:[nl]?(?:var)?char|decimal)\z/i) {
434 delete $result->{$col}{size};
435 }
436
437 if (lc($data_type) eq 'decimal') {
438 no warnings 'uninitialized';
439
440 $result->{$col}{data_type} = 'numeric';
441
442 my @size = @{ $result->{$col}{size} || [] };
443
444 if ($size[0] == 16 && $size[1] == -4) {
445 delete $result->{$col}{size};
446 }
447 elsif ($size[0] == 16 && $size[1] == 2) {
448 $result->{$col}{data_type} = 'money';
449 delete $result->{$col}{size};
450 }
451 }
452 elsif (lc($data_type) eq 'smallfloat') {
453 $result->{$col}{data_type} = 'real';
454 }
455 elsif (lc($data_type) eq 'float') {
456 $result->{$col}{data_type} = 'double precision';
457 }
458 elsif ($data_type =~ /^n?(?:var)?char\z/i) {
459 $result->{$col}{size} = $result->{$col}{size}[0];
460 }
461
c7e6dc1f 462 # XXX colmin doesn't work for min size of varchar columns, it's NULL
463# if (lc($data_type) eq 'varchar') {
464# $result->{$col}{size}[1] = $info->{colmin};
465# }
494e0205 466
bc5afe55 467 my ($default_type, $default) = @{$info}{qw/deflt_type deflt/};
468
469 next unless $default_type;
470
471 if ($default_type eq 'C') {
c7e6dc1f 472 my $current = 'current year to fraction(5)';
bc5afe55 473 $result->{$col}{default_value} = \$current;
474 }
475 elsif ($default_type eq 'T') {
c7e6dc1f 476 my $today = 'today';
bc5afe55 477 $result->{$col}{default_value} = \$today;
478 }
479 else {
5cd983b7 480 $default = (split ' ', $default, 2)[-1];
25e1e7bf 481
482 $default =~ s/\s+\z// if looks_like_number $default;
bc5afe55 483
484 # remove trailing 0s in floating point defaults
a60e0f45 485 # disabled, this is unsafe since it might be a varchar default
486 #$default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/;
bc5afe55 487
488 $result->{$col}{default_value} = $default;
489 }
490 }
491
492 return $result;
493}
494
495=head1 SEE ALSO
496
497L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
498L<DBIx::Class::Schema::Loader::DBI>
499
b87ab391 500=head1 AUTHORS
bc5afe55 501
b87ab391 502See L<DBIx::Class::Schema::Loader/AUTHORS>.
bc5afe55 503
504=head1 LICENSE
505
506This library is free software; you can redistribute it and/or modify it under
507the same terms as Perl itself.
508
509=cut
510
5111;
512# vim:et sw=4 sts=4 tw=0: