lib/DBIx/Class/Schema/Loader/DBI/Informix.pm

   1 package DBIx::Class::Schema::Loader::DBI::Informix;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/DBIx::Class::Schema::Loader::DBI/;
   6 use mro 'c3';
   7 use Scalar::Util 'looks_like_number';
   8 use List::MoreUtils 'any';
   9 use Try::Tiny;
  10 use namespace::clean;
  11 use DBIx::Class::Schema::Loader::Table::Informix ();
  12
  13 our $VERSION = '0.07038';
  14
  15 =head1 NAME
  16
  17 DBIx::Class::Schema::Loader::DBI::Informix - DBIx::Class::Schema::Loader::DBI
  18 Informix Implementation.
  19
  20 =head1 DESCRIPTION
  21
  22 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
  23
  24 =cut
  25
  26 sub _build_name_sep { '.' }
  27
  28 sub _system_databases {
  29     return (qw/
  30         sysmaster sysutils sysuser sysadmin
  31     /);
  32 }
  33
  34 sub _current_db {
  35     my $self = shift;
  36
  37     my ($current_db) = $self->dbh->selectrow_array(<<'EOF');
  38 SELECT rtrim(ODB_DBName)
  39 FROM sysmaster:informix.SysOpenDB
  40 WHERE ODB_SessionID = (
  41         SELECT DBINFO('sessionid')
  42         FROM informix.SysTables
  43         WHERE TabID = 1
  44     ) and ODB_IsCurrent = 'Y'
  45 EOF
  46
  47     return $current_db;
  48 }
  49
  50 sub _owners {
  51     my ($self, $db) = @_;
  52
  53     my ($owners) = $self->dbh->selectcol_arrayref(<<"EOF");
  54 SELECT distinct(rtrim(owner))
  55 FROM ${db}:informix.systables
  56 EOF
  57
  58     my @owners = grep $_ && $_ ne 'informix' && !/^\d/, @$owners;
  59
  60     return @owners;
  61 }
  62
  63 sub _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');
  88 SELECT rtrim(name)
  89 FROM sysmaster:sysdatabases
  90 EOF
  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') ];
 146 SELECT rtrim(username)
 147 FROM sysmaster:syssessions
 148 WHERE sid = DBINFO('sessionid')
 149 EOF
 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
 181 sub _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);
 189 select tabname
 190 FROM ${db}:informix.systables
 191 WHERE rtrim(owner) = ?
 192 EOF
 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
 210 sub _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");
 218 SELECT c.constrname, i.*
 219 FROM ${db}:informix.sysconstraints c
 220 JOIN ${db}:informix.systables t
 221     ON t.tabid = c.tabid
 222 JOIN ${db}:informix.sysindexes i
 223     ON c.idxname = i.idxname
 224 WHERE t.tabname = ? and c.constrtype = ?
 225 EOF
 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
 240 sub _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
 246 sub _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");
 254 SELECT c.colname, c.colno
 255 FROM ${db}:informix.syscolumns c
 256 JOIN ${db}:informix.systables t
 257     ON c.tabid = t.tabid
 258 WHERE t.tabname = ?
 259 EOF
 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
 267 sub _table_pk_info {
 268     my ($self, $table) = @_;
 269
 270     my $pk = (values %{ $self->_constraints_for($table, 'P') || {} })[0];
 271
 272     return $pk;
 273 }
 274
 275 sub _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
 284 sub _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");
 294 SELECT c.constrname local_constraint, rt.tabname remote_table, rtrim(rt.owner) remote_owner, rc.constrname remote_constraint, ri.*
 295 FROM ${db}:informix.sysconstraints c
 296 JOIN ${db}:informix.systables t
 297     ON c.tabid = t.tabid
 298 JOIN ${db}:informix.sysreferences r
 299     ON c.constrid = r.constrid
 300 JOIN ${db}:informix.sysconstraints rc
 301     ON rc.constrid = r.primary
 302 JOIN ${db}:informix.systables rt
 303     ON r.ptabid = rt.tabid
 304 JOIN ${db}:informix.sysindexes ri
 305     ON rc.idxname = ri.idxname
 306 WHERE t.tabname = ? and c.constrtype = 'R'
 307 EOF
 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
 334 sub _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
 357 sub _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");
 366 SELECT c.colname, c.coltype, c.collength, c.colmin, d.type deflt_type, d.default deflt
 367 FROM ${db}:informix.syscolumns c
 368 JOIN ${db}:informix.systables t
 369     ON c.tabid = t.tabid
 370 LEFT JOIN ${db}:informix.sysdefaults d
 371     ON t.tabid = d.tabid AND c.colno = d.colno
 372 WHERE t.tabname = ?
 373 EOF
 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
 498 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 499 L<DBIx::Class::Schema::Loader::DBI>
 500
 501 =head1 AUTHOR
 502
 503 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 504
 505 =head1 LICENSE
 506
 507 This library is free software; you can redistribute it and/or modify it under
 508 the same terms as Perl itself.
 509
 510 =cut
 511
 512 1;
 513 # vim:et sw=4 sts=4 tw=0: