1package DBIx::Class::Schema::Loader::DBI::Informix; 2 3use strict; 4use warnings; 5use base qw/DBIx::Class::Schema::Loader::DBI/; 6use mro 'c3'; 7use Scalar::Util 'looks_like_number'; 8use List::MoreUtils 'any'; 9use Try::Tiny; 10use namespace::clean; 11use DBIx::Class::Schema::Loader::Table::Informix (); 12 13our $VERSION = '0.07033'; 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 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 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 } 71 elsif ($self->preserve_case) { 72 $self->schema->storage->sql_maker->quote_char('"'); 73 $self->schema->storage->sql_maker->name_sep('.'); 74 } 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 } 179} 180 181sub _tables_list { 182 my ($self, $opts) = @_; 183 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) = ? 192EOF 193 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 } 206 207 return $self->_filter_tables(\@tables, $opts); 208} 209 210sub _constraints_for { 211 my ($self, $table, $type) = @_; 212 213 local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; 214 215 my $db = $table->database; 216 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 = ? 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 243 return [ map $table_cols_by_colno->{$_}, grep $_, map $idx_info->{$_}, map "part$_", (1..16) ]; 244} 245 246sub _colnames_by_colno { 247 my ($self, $table) = @_; 248 249 local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; 250 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 = ? 259EOF 260 $sth->execute($table); 261 my $cols = $sth->fetchall_hashref('colno'); 262 $cols = { map +($_, $self->_lc($cols->{$_}{colname})), keys %$cols }; 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 280 my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints; 281 return \@uniqs; 282} 283 284sub _table_fk_info { 285 my ($self, $table) = @_; 286 287 my $local_columns = $self->_constraints_for($table, 'R'); 288 289 local $self->dbh->{FetchHashKeyName} = 'NAME_lc'; 290 291 my $db = $table->database; 292 293 my $sth = $self->dbh->prepare(<<"EOF"); 294SELECT c.constrname local_constraint, rt.tabname remote_table, rtrim(rt.owner) remote_owner, rc.constrname remote_constraint, ri.* 295FROM ${db}:informix.sysconstraints c 296JOIN ${db}:informix.systables t 297 ON c.tabid = t.tabid 298JOIN ${db}:informix.sysreferences r 299 ON c.constrid = r.constrid 300JOIN ${db}:informix.sysconstraints rc 301 ON rc.constrid = r.primary 302JOIN ${db}:informix.systables rt 303 ON r.ptabid = rt.tabid 304JOIN ${db}:informix.sysindexes ri 305 ON rc.idxname = ri.idxname 306WHERE t.tabname = ? and c.constrtype = 'R' 307EOF 308 $sth->execute($table); 309 my $remotes = $sth->fetchall_hashref('local_constraint'); 310 $sth->finish; 311 312 my @rels; 313 314 while (my ($local_constraint, $remote_info) = each %$remotes) { 315 my $remote_table = DBIx::Class::Schema::Loader::Table::Informix->new( 316 loader => $self, 317 name => $remote_info->{remote_table}, 318 database => $db, 319 schema => $remote_info->{remote_owner}, 320 ); 321 322 push @rels, { 323 local_columns => $local_columns->{$local_constraint}, 324 remote_columns => $self->_idx_colnames($remote_info, $self->_colnames_by_colno($remote_table)), 325 remote_table => $remote_table, 326 }; 327 } 328 329 return \@rels; 330} 331 332# This is directly from http://www.ibm.com/developerworks/data/zones/informix/library/techarticle/0305parker/0305parker.html 333# it doesn't work at all 334sub _informix_datetime_precision { 335 my @date_type = qw/DUMMY year month day hour minute second fraction(1) fraction(2) fraction(3) fraction(4) fraction(5)/; 336 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] ); 337 338 my ($self, $collength) = @_; 339 340 my $i = ($collength % 16) + 1; 341 my $j = int(($collength % 256) / 16) + 1; 342 my $k = int($collength / 256); 343 344 my $len = $start_end[$i][1] - $start_end[$j][0]; 345 $len = $k - $len; 346 347 if ($len == 0 || $j > 11) { 348 return $date_type[$j] . ' to ' . $date_type[$i]; 349 } 350 351 $k = $start_end[$j][1] - $start_end[$j][0]; 352 $k += $len; 353 354 return $date_type[$j] . "($k) to " . $date_type[$i]; 355} 356 357sub _columns_info_for { 358 my $self = shift; 359 my ($table) = @_; 360 361 my $result = $self->next::method(@_); 362 363 my $db = $table->database; 364 365 my $sth = $self->dbh->prepare(<<"EOF"); 366SELECT c.colname, c.coltype, c.collength, c.colmin, d.type deflt_type, d.default deflt 367FROM ${db}:informix.syscolumns c 368JOIN ${db}:informix.systables t 369 ON c.tabid = t.tabid 370LEFT JOIN ${db}:informix.sysdefaults d 371 ON t.tabid = d.tabid AND c.colno = d.colno 372WHERE t.tabname = ? 373EOF 374 $sth->execute($table); 375 my $cols = $sth->fetchall_hashref('colname'); 376 $sth->finish; 377 378 while (my ($col, $info) = each %$cols) { 379 $col = $self->_lc($col); 380 381 my $type = $info->{coltype} % 256; 382 383 if ($type == 6) { # SERIAL 384 $result->{$col}{is_auto_increment} = 1; 385 } 386 elsif ($type == 7) { 387 $result->{$col}{data_type} = 'date'; 388 } 389 elsif ($type == 10) { 390 $result->{$col}{data_type} = 'datetime year to fraction(5)'; 391 # this doesn't work yet 392# $result->{$col}{data_type} = 'datetime ' . $self->_informix_datetime_precision($info->{collength}); 393 } 394 elsif ($type == 17 || $type == 52) { 395 $result->{$col}{data_type} = 'bigint'; 396 } 397 elsif ($type == 40) { 398 $result->{$col}{data_type} = 'lvarchar'; 399 $result->{$col}{size} = $info->{collength}; 400 } 401 elsif ($type == 12) { 402 $result->{$col}{data_type} = 'text'; 403 } 404 elsif ($type == 11) { 405 $result->{$col}{data_type} = 'bytea'; 406 $result->{$col}{original}{data_type} = 'byte'; 407 } 408 elsif ($type == 41) { 409 # XXX no way to distinguish opaque types boolean, blob and clob 410 $result->{$col}{data_type} = 'blob' unless $result->{$col}{data_type} eq 'smallint'; 411 } 412 elsif ($type == 21) { 413 $result->{$col}{data_type} = 'list'; 414 } 415 elsif ($type == 20) { 416 $result->{$col}{data_type} = 'multiset'; 417 } 418 elsif ($type == 19) { 419 $result->{$col}{data_type} = 'set'; 420 } 421 elsif ($type == 15) { 422 $result->{$col}{data_type} = 'nchar'; 423 } 424 elsif ($type == 16) { 425 $result->{$col}{data_type} = 'nvarchar'; 426 } 427 # XXX untested! 428 elsif ($info->{coltype} == 2061) { 429 $result->{$col}{data_type} = 'idssecuritylabel'; 430 } 431 432 my $data_type = $result->{$col}{data_type}; 433 434 if ($data_type !~ /^(?:[nl]?(?:var)?char|decimal)\z/i) { 435 delete $result->{$col}{size}; 436 } 437 438 if (lc($data_type) eq 'decimal') { 439 no warnings 'uninitialized'; 440 441 $result->{$col}{data_type} = 'numeric'; 442 443 my @size = @{ $result->{$col}{size} || [] }; 444 445 if ($size[0] == 16 && $size[1] == -4) { 446 delete $result->{$col}{size}; 447 } 448 elsif ($size[0] == 16 && $size[1] == 2) { 449 $result->{$col}{data_type} = 'money'; 450 delete $result->{$col}{size}; 451 } 452 } 453 elsif (lc($data_type) eq 'smallfloat') { 454 $result->{$col}{data_type} = 'real'; 455 } 456 elsif (lc($data_type) eq 'float') { 457 $result->{$col}{data_type} = 'double precision'; 458 } 459 elsif ($data_type =~ /^n?(?:var)?char\z/i) { 460 $result->{$col}{size} = $result->{$col}{size}[0]; 461 } 462 463 # XXX colmin doesn't work for min size of varchar columns, it's NULL 464# if (lc($data_type) eq 'varchar') { 465# $result->{$col}{size}[1] = $info->{colmin}; 466# } 467 468 my ($default_type, $default) = @{$info}{qw/deflt_type deflt/}; 469 470 next unless $default_type; 471 472 if ($default_type eq 'C') { 473 my $current = 'current year to fraction(5)'; 474 $result->{$col}{default_value} = \$current; 475 } 476 elsif ($default_type eq 'T') { 477 my $today = 'today'; 478 $result->{$col}{default_value} = \$today; 479 } 480 else { 481 $default = (split ' ', $default, 2)[-1]; 482 483 $default =~ s/\s+\z// if looks_like_number $default; 484 485 # remove trailing 0s in floating point defaults 486 # disabled, this is unsafe since it might be a varchar default 487 #$default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/; 488 489 $result->{$col}{default_value} = $default; 490 } 491 } 492 493 return $result; 494} 495 496=head1 SEE ALSO 497 498L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, 499L<DBIx::Class::Schema::Loader::DBI> 500 501=head1 AUTHOR 502 503See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. 504 505=head1 LICENSE 506 507This library is free software; you can redistribute it and/or modify it under 508the same terms as Perl itself. 509 510=cut 511 5121; 513# vim:et sw=4 sts=4 tw=0: 514