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 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.07001';
  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     }
  32     elsif ($self->preserve_case) {
  33         $self->schema->storage->sql_maker->quote_char('"');
  34         $self->schema->storage->sql_maker->name_sep('.');
  35     }
  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 # This is directly from http://www.ibm.com/developerworks/data/zones/informix/library/techarticle/0305parker/0305parker.html
 158 # it doesn't work at all
 159 sub _informix_datetime_precision {
 160     my @date_type = qw/DUMMY year  month day   hour   minute  second  fraction(1) fraction(2) fraction(3) fraction(4) fraction(5)/;
 161     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]    );
 162
 163     my ($self, $collength) = @_;
 164
 165     my $i = ($collength % 16) + 1;
 166     my $j = int(($collength % 256) / 16) + 1;
 167     my $k = int($collength / 256);
 168
 169     my $len = $start_end[$i][1] - $start_end[$j][0];
 170     $len = $k - $len;
 171
 172     if ($len == 0 || $j > 11) {
 173         return $date_type[$j] . ' to ' . $date_type[$i];
 174     }
 175
 176     $k  = $start_end[$j][1] - $start_end[$j][0];
 177     $k += $len;
 178
 179     return $date_type[$j] . "($k) to " . $date_type[$i];
 180 }
 181
 182 sub _columns_info_for {
 183     my $self = shift;
 184     my ($table) = @_;
 185
 186     my $result = $self->next::method(@_);
 187
 188     my $dbh = $self->schema->storage->dbh;
 189     local $dbh->{FetchHashKeyName} = 'NAME_lc';
 190
 191     my $sth = $dbh->prepare(<<'EOF');
 192 select c.colname, c.coltype, c.collength, c.colmin, d.type deflt_type, d.default deflt
 193 from syscolumns c
 194 join systables t on c.tabid = t.tabid
 195 left join sysdefaults d on t.tabid = d.tabid and c.colno = d.colno
 196 where t.tabname = ?
 197 EOF
 198     $sth->execute($table);
 199     my $cols = $sth->fetchall_hashref('colname');
 200     $sth->finish;
 201
 202     while (my ($col, $info) = each %$cols) {
 203         $col = $self->_lc($col);
 204
 205         my $type = $info->{coltype} % 256;
 206
 207         if ($type == 6) { # SERIAL
 208             $result->{$col}{is_auto_increment} = 1;
 209         }
 210
 211         my $data_type = $result->{$col}{data_type};
 212
 213         if (looks_like_number $data_type) {
 214             if ($type == 7) {
 215                 $result->{$col}{data_type} = 'date';
 216             }
 217             elsif ($type == 10) {
 218                 $result->{$col}{data_type} = 'datetime year to fraction(5)';
 219                 # this doesn't work yet
 220 #                $result->{$col}{data_type} = 'datetime ' . $self->_informix_datetime_precision($info->{collength});
 221             }
 222             elsif ($type == 17 || $type == 52) {
 223                 $result->{$col}{data_type} = 'bigint';
 224             }
 225             elsif ($type == 40) {
 226                 $result->{$col}{data_type} = 'lvarchar';
 227                 $result->{$col}{size}      = $info->{collength};
 228             }
 229             elsif ($type == 12) {
 230                 $result->{$col}{data_type} = 'text';
 231             }
 232             elsif ($type == 11) {
 233                 $result->{$col}{data_type}           = 'bytea';
 234                 $result->{$col}{original}{data_type} = 'byte';
 235             }
 236             elsif ($type == 41) {
 237                 # XXX no way to distinguish opaque types boolean, blob and clob
 238                 $result->{$col}{data_type} = 'blob';
 239             }
 240             elsif ($type == 21) {
 241                 $result->{$col}{data_type} = 'list';
 242             }
 243             elsif ($type == 20) {
 244                 $result->{$col}{data_type} = 'multiset';
 245             }
 246             elsif ($type == 19) {
 247                 $result->{$col}{data_type} = 'set';
 248             }
 249         }
 250
 251         if ($type == 15) {
 252             $result->{$col}{data_type} = 'nchar';
 253         }
 254         elsif ($type == 16) {
 255             $result->{$col}{data_type} = 'nvarchar';
 256         }
 257         # XXX untested!
 258         elsif ($info->{coltype} == 2061) {
 259             $result->{$col}{data_type} = 'idssecuritylabel';
 260         }
 261
 262         # XXX colmin doesn't work for min size of varchar columns, it's NULL
 263 #        if (lc($data_type) eq 'varchar') {
 264 #            $result->{$col}{size}[1] = $info->{colmin};
 265 #        }
 266
 267         my ($default_type, $default) = @{$info}{qw/deflt_type deflt/};
 268
 269         next unless $default_type;
 270
 271         if ($default_type eq 'C') {
 272             my $current = 'current year to fraction(5)';
 273             $result->{$col}{default_value} = \$current;
 274         }
 275         elsif ($default_type eq 'T') {
 276             my $today = 'today';
 277             $result->{$col}{default_value} = \$today;
 278         }
 279         else {
 280             $default = (split ' ', $default, 2)[-1];
 281
 282             $default =~ s/\s+\z// if looks_like_number $default;
 283
 284             # remove trailing 0s in floating point defaults
 285             # disabled, this is unsafe since it might be a varchar default
 286             #$default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/;
 287
 288             $result->{$col}{default_value} = $default;
 289         }
 290     }
 291
 292     # fix up data_types some more
 293     while (my ($col, $info) = each %$result) {
 294         my $data_type = $info->{data_type};
 295
 296         if ($data_type !~ /^(?:[nl]?(?:var)?char|decimal)\z/i) {
 297             delete $info->{size};
 298         }
 299
 300         if (lc($data_type) eq 'decimal') {
 301             no warnings 'uninitialized';
 302
 303             $info->{data_type} = 'numeric';
 304
 305             my @size = @{ $info->{size} || [] };
 306
 307             if ($size[0] == 16 && $size[1] == -4) {
 308                 delete $info->{size};
 309             }
 310             elsif ($size[0] == 16 && $size[1] == 2) {
 311                 $info->{data_type} = 'money';
 312                 delete $info->{size};
 313             }
 314         }
 315         elsif (lc($data_type) eq 'smallfloat') {
 316             $info->{data_type} = 'real';
 317         }
 318         elsif (lc($data_type) eq 'float') {
 319             $info->{data_type} = 'double precision';
 320         }
 321         elsif ($data_type =~ /^n?(?:var)?char\z/i) {
 322             $info->{size} = $info->{size}[0];
 323         }
 324     }
 325
 326     return $result;
 327 }
 328
 329 =head1 SEE ALSO
 330
 331 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 332 L<DBIx::Class::Schema::Loader::DBI>
 333
 334 =head1 AUTHOR
 335
 336 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 337
 338 =head1 LICENSE
 339
 340 This library is free software; you can redistribute it and/or modify it under
 341 the same terms as Perl itself.
 342
 343 =cut
 344
 345 1;
 346 # vim:et sw=4 sts=4 tw=0: