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.07000';
  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 }
  33
  34 sub _tables_list {
  35     my ($self, $opts) = @_;
  36
  37     my $dbh = $self->schema->storage->dbh;
  38     my $sth = $dbh->prepare(<<'EOF');
  39 select tabname from systables t
  40 where t.owner <> 'informix' and t.owner <> '' and t.tabname <> ' VERSION'
  41 EOF
  42     $sth->execute;
  43
  44     my @tables = map @$_, @{ $sth->fetchall_arrayref };
  45
  46     return $self->_filter_tables(\@tables, $opts);
  47 }
  48
  49 sub _constraints_for {
  50     my ($self, $table, $type) = @_;
  51
  52     my $dbh = $self->schema->storage->dbh;
  53     local $dbh->{FetchHashKeyName} = 'NAME_lc';
  54
  55     my $sth = $dbh->prepare(<<'EOF');
  56 select c.constrname, i.*
  57 from sysconstraints c
  58 join systables t on t.tabid = c.tabid
  59 join sysindexes i on c.idxname = i.idxname
  60 where t.tabname = ? and c.constrtype = ?
  61 EOF
  62     $sth->execute($table, $type);
  63     my $indexes = $sth->fetchall_hashref('constrname');
  64     $sth->finish;
  65
  66     my $cols = $self->_colnames_by_colno($table);
  67
  68     my $constraints;
  69     while (my ($constr_name, $idx_def) = each %$indexes) {
  70         $constraints->{$constr_name} = $self->_idx_colnames($idx_def, $cols);
  71     }
  72
  73     return $constraints;
  74 }
  75
  76 sub _idx_colnames {
  77     my ($self, $idx_info, $table_cols_by_colno) = @_;
  78
  79     return [ map $self->_lc($table_cols_by_colno->{$_}), grep $_, map $idx_info->{$_}, map "part$_", (1..16) ];
  80 }
  81
  82 sub _colnames_by_colno {
  83     my ($self, $table) = @_;
  84
  85     my $dbh = $self->schema->storage->dbh;
  86     local $dbh->{FetchHashKeyName} = 'NAME_lc';
  87
  88     my $sth = $dbh->prepare(<<'EOF');
  89 select c.colname, c.colno
  90 from syscolumns c
  91 join systables t on c.tabid = t.tabid
  92 where t.tabname = ?
  93 EOF
  94     $sth->execute($table);
  95     my $cols = $sth->fetchall_hashref('colno');
  96     $cols = { map +($_, $cols->{$_}{colname}), keys %$cols };
  97
  98     return $cols;
  99 }
 100
 101 sub _table_pk_info {
 102     my ($self, $table) = @_;
 103
 104     my $pk = (values %{ $self->_constraints_for($table, 'P') || {} })[0];
 105
 106     return $pk;
 107 }
 108
 109 sub _table_uniq_info {
 110     my ($self, $table) = @_;
 111
 112     my $constraints = $self->_constraints_for($table, 'U');
 113
 114     my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
 115     return \@uniqs;
 116 }
 117
 118 sub _table_fk_info {
 119     my ($self, $table) = @_;
 120
 121     my $local_columns = $self->_constraints_for($table, 'R');
 122
 123     my $dbh = $self->schema->storage->dbh;
 124     local $dbh->{FetchHashKeyName} = 'NAME_lc';
 125
 126     my $sth = $dbh->prepare(<<'EOF');
 127 select c.constrname local_constraint, rt.tabname remote_table, rc.constrname remote_constraint, ri.*
 128 from sysconstraints c
 129 join systables t on c.tabid = t.tabid
 130 join sysreferences r on c.constrid = r.constrid
 131 join sysconstraints rc on rc.constrid = r.primary
 132 join systables rt on r.ptabid = rt.tabid
 133 join sysindexes ri on rc.idxname = ri.idxname
 134 where t.tabname = ? and c.constrtype = 'R'
 135 EOF
 136     $sth->execute($table);
 137     my $remotes = $sth->fetchall_hashref('local_constraint');
 138     $sth->finish;
 139
 140     my @rels;
 141
 142     while (my ($local_constraint, $remote_info) = each %$remotes) {
 143         push @rels, {
 144             local_columns => $local_columns->{$local_constraint},
 145             remote_columns => $self->_idx_colnames($remote_info, $self->_colnames_by_colno($remote_info->{remote_table})),
 146             remote_table => $remote_info->{remote_table},
 147         };
 148     }
 149
 150     return \@rels;
 151 }
 152
 153 sub _columns_info_for {
 154     my $self = shift;
 155     my ($table) = @_;
 156
 157     my $result = $self->next::method(@_);
 158
 159     my $dbh = $self->schema->storage->dbh;
 160     local $dbh->{FetchHashKeyName} = 'NAME_lc';
 161
 162     my $sth = $dbh->prepare(<<'EOF');
 163 select c.colname, c.coltype, d.type deflt_type, d.default deflt
 164 from syscolumns c
 165 join systables t on c.tabid = t.tabid
 166 left join sysdefaults d on t.tabid = d.tabid and c.colno = d.colno
 167 where t.tabname = ?
 168 EOF
 169     $sth->execute($table);
 170     my $cols = $sth->fetchall_hashref('colname');
 171     $sth->finish;
 172
 173     while (my ($col, $info) = each %$cols) {
 174         my $type = $info->{coltype} % 256;
 175
 176         if ($type == 6) { # SERIAL
 177             $result->{$col}{is_auto_increment} = 1;
 178         }
 179
 180         if (looks_like_number $result->{$col}{data_type}) {
 181             if ($type == 7) {
 182                 $result->{$col}{data_type} = 'date';
 183             }
 184             elsif ($type == 10) {
 185                 $result->{$col}{data_type} = 'datetime';
 186             }
 187         }
 188
 189         my ($default_type, $default) = @{$info}{qw/deflt_type deflt/};
 190
 191         next unless $default_type;
 192
 193         if ($default_type eq 'C') {
 194             my $current = 'CURRENT YEAR TO FRACTION(5)';
 195             $result->{$col}{default_value} = \$current;
 196         }
 197         elsif ($default_type eq 'T') {
 198             my $today = 'TODAY';
 199             $result->{$col}{default_value} = \$today;
 200         }
 201         else {
 202             $default = (split ' ', $default, 2)[-1];
 203
 204             $default =~ s/\s+\z// if looks_like_number $default;
 205
 206             # remove trailing 0s in floating point defaults
 207             $default =~ s/0+\z// if $default =~ /^\d+\.\d+\z/;
 208
 209             $result->{$col}{default_value} = $default;
 210         }
 211     }
 212
 213     return $result;
 214 }
 215
 216 =head1 SEE ALSO
 217
 218 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 219 L<DBIx::Class::Schema::Loader::DBI>
 220
 221 =head1 AUTHOR
 222
 223 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 224
 225 =head1 LICENSE
 226
 227 This library is free software; you can redistribute it and/or modify it under
 228 the same terms as Perl itself.
 229
 230 =cut
 231
 232 1;
 233 # vim:et sw=4 sts=4 tw=0: