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

   1 package DBIx::Class::Schema::Loader::DBI::DB2;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/
   6     DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault
   7     DBIx::Class::Schema::Loader::DBI
   8 /;
   9 use mro 'c3';
  10 use List::Util 'any';
  11 use DBIx::Class::Schema::Loader::Table ();
  12 use namespace::clean;
  13
  14 our $VERSION = '0.07047';
  15
  16 =head1 NAME
  17
  18 DBIx::Class::Schema::Loader::DBI::DB2 - DBIx::Class::Schema::Loader::DBI DB2 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 _system_schemas {
  27     my $self = shift;
  28
  29     return ($self->next::method(@_), qw/
  30         SYSCAT SYSIBM SYSIBMADM SYSPUBLIC SYSSTAT SYSTOOLS
  31     /);
  32 }
  33
  34 sub _setup {
  35     my $self = shift;
  36
  37     $self->next::method(@_);
  38
  39     my $ns = $self->name_sep;
  40
  41     $self->db_schema([ $self->dbh->selectrow_array(<<"EOF", {}) ]) unless $self->db_schema;
  42 SELECT CURRENT_SCHEMA FROM sysibm${ns}sysdummy1
  43 EOF
  44
  45     if (not defined $self->preserve_case) {
  46         $self->preserve_case(0);
  47     }
  48     elsif ($self->preserve_case) {
  49         $self->schema->storage->sql_maker->quote_char('"');
  50         $self->schema->storage->sql_maker->name_sep($ns);
  51     }
  52 }
  53
  54 sub _table_uniq_info {
  55     my ($self, $table) = @_;
  56
  57     my @uniqs;
  58
  59     my $sth = $self->{_cache}->{db2_uniq} ||= $self->dbh->prepare(<<'EOF');
  60 SELECT kcu.colname, kcu.constname, kcu.colseq
  61 FROM syscat.tabconst as tc
  62 JOIN syscat.keycoluse as kcu
  63     ON tc.constname = kcu.constname
  64         AND tc.tabschema = kcu.tabschema
  65         AND tc.tabname   = kcu.tabname
  66 WHERE tc.tabschema = ? and tc.tabname = ? and tc.type = 'U'
  67 EOF
  68
  69     $sth->execute($table->schema, $table->name);
  70
  71     my %keydata;
  72     while(my $row = $sth->fetchrow_arrayref) {
  73         my ($col, $constname, $seq) = @$row;
  74         push(@{$keydata{$constname}}, [ $seq, $self->_lc($col) ]);
  75     }
  76     foreach my $keyname (sort keys %keydata) {
  77         my @ordered_cols = map { $_->[1] } sort { $a->[0] <=> $b->[0] }
  78             @{$keydata{$keyname}};
  79         push(@uniqs, [ $keyname => \@ordered_cols ]);
  80     }
  81
  82     $sth->finish;
  83
  84     return \@uniqs;
  85 }
  86
  87 sub _table_fk_info {
  88     my ($self, $table) = @_;
  89
  90     my $sth = $self->{_cache}->{db2_fk} ||= $self->dbh->prepare(<<'EOF');
  91 SELECT tc.constname, sr.reftabschema, sr.reftabname,
  92        kcu.colname, rkcu.colname, kcu.colseq,
  93        sr.deleterule, sr.updaterule
  94 FROM syscat.tabconst tc
  95 JOIN syscat.keycoluse kcu
  96     ON tc.constname = kcu.constname
  97         AND tc.tabschema = kcu.tabschema
  98         AND tc.tabname = kcu.tabname
  99 JOIN syscat.references sr
 100     ON tc.constname = sr.constname
 101         AND tc.tabschema = sr.tabschema
 102         AND tc.tabname = sr.tabname
 103 JOIN syscat.keycoluse rkcu
 104     ON sr.refkeyname = rkcu.constname
 105         AND sr.reftabschema = rkcu.tabschema
 106         AND sr.reftabname = rkcu.tabname
 107         AND kcu.colseq = rkcu.colseq
 108 WHERE tc.tabschema = ?
 109     AND tc.tabname = ?
 110     AND tc.type = 'F';
 111 EOF
 112     $sth->execute($table->schema, $table->name);
 113
 114     my %rels;
 115
 116     my %rules = (
 117         A => 'NO ACTION',
 118         C => 'CASCADE',
 119         N => 'SET NULL',
 120         R => 'RESTRICT',
 121     );
 122
 123     COLS: while (my @row = $sth->fetchrow_array) {
 124         my ($fk, $remote_schema, $remote_table, $local_col, $remote_col,
 125             $colseq, $delete_rule, $update_rule) = @row;
 126
 127         if (not exists $rels{$fk}) {
 128             if ($self->db_schema && $self->db_schema->[0] ne '%'
 129                 && (not any { $_ eq $remote_schema } @{ $self->db_schema })) {
 130
 131                 next COLS;
 132             }
 133
 134             $rels{$fk}{remote_table} = DBIx::Class::Schema::Loader::Table->new(
 135                 loader  => $self,
 136                 name    => $remote_table,
 137                 schema  => $remote_schema,
 138             );
 139         }
 140
 141         $rels{$fk}{local_columns}[$colseq-1]  = $self->_lc($local_col);
 142         $rels{$fk}{remote_columns}[$colseq-1] = $self->_lc($remote_col);
 143
 144         $rels{$fk}{attrs} ||= {
 145             on_delete     => $rules{$delete_rule},
 146             on_update     => $rules{$update_rule},
 147             is_deferrable => 1, # DB2 has no deferrable constraints
 148         };
 149     }
 150
 151     return [ values %rels ];
 152 }
 153
 154
 155 # DBD::DB2 doesn't follow the DBI API for ->tables (pre 1.85), but since its
 156 # backwards compatible we don't change it.
 157 # DBD::DB2 1.85 and beyond default TABLE_NAME to '', previously defaulted to
 158 # '%'. so we supply it.
 159 sub _dbh_tables {
 160     my ($self, $schema) = @_;
 161
 162     return $self->dbh->tables($schema ? { TABLE_SCHEM => $schema, TABLE_NAME => '%' } : undef);
 163 }
 164
 165 sub _dbh_table_info {
 166     my $self = shift;
 167
 168     local $^W = 0; # shut up undef warning from DBD::DB2
 169
 170     $self->next::method(@_);
 171 }
 172
 173 sub _columns_info_for {
 174     my $self = shift;
 175     my ($table) = @_;
 176
 177     my $result = $self->next::method(@_);
 178
 179     while (my ($col, $info) = each %$result) {
 180         # check for identities
 181         my $sth = $self->dbh->prepare_cached(
 182             q{
 183                 SELECT COUNT(*)
 184                 FROM syscat.columns
 185                 WHERE tabschema = ? AND tabname = ? AND colname = ?
 186                 AND identity = 'Y' AND generated != ''
 187             },
 188             {}, 1);
 189         $sth->execute($table->schema, $table->name, $self->_uc($col));
 190         if ($sth->fetchrow_array) {
 191             $info->{is_auto_increment} = 1;
 192         }
 193
 194         my $data_type = $info->{data_type};
 195
 196         if ($data_type !~ /^(?:(?:var)?(?:char|graphic)|decimal)\z/i) {
 197             delete $info->{size};
 198         }
 199
 200         if ($data_type eq 'double') {
 201             $info->{data_type} = 'double precision';
 202         }
 203         elsif ($data_type eq 'decimal') {
 204             no warnings 'uninitialized';
 205
 206             $info->{data_type} = 'numeric';
 207
 208             my @size = @{ $info->{size} || [] };
 209
 210             if ($size[0] == 5 && $size[1] == 0) {
 211                 delete $info->{size};
 212             }
 213         }
 214         elsif ($data_type =~ /^(?:((?:var)?char) \(\) for bit data|(long varchar) for bit data)\z/i) {
 215             my $base_type = lc($1 || $2);
 216
 217             (my $original_type = $data_type) =~ s/[()]+ //;
 218
 219             $info->{original}{data_type} = $original_type;
 220
 221             if ($base_type eq 'long varchar') {
 222                 $info->{data_type} = 'blob';
 223             }
 224             else {
 225                 if ($base_type eq 'char') {
 226                     $info->{data_type} = 'binary';
 227                 }
 228                 elsif ($base_type eq 'varchar') {
 229                     $info->{data_type} = 'varbinary';
 230                 }
 231
 232                 my ($size) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $self->_uc($col));
 233 SELECT length
 234 FROM syscat.columns
 235 WHERE tabschema = ? AND tabname = ? AND colname = ?
 236 EOF
 237
 238                 $info->{size} = $size if $size;
 239             }
 240         }
 241
 242         if ((eval { lc ${ $info->{default_value} } }||'') =~ /^current (date|time(?:stamp)?)\z/i) {
 243             my $type = lc($1);
 244
 245             ${ $info->{default_value} } = 'current_timestamp';
 246
 247             my $orig_deflt = "current $type";
 248             $info->{original}{default_value} = \$orig_deflt;
 249         }
 250     }
 251
 252     return $result;
 253 }
 254
 255 =head1 SEE ALSO
 256
 257 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 258 L<DBIx::Class::Schema::Loader::DBI>
 259
 260 =head1 AUTHORS
 261
 262 See L<DBIx::Class::Schema::Loader/AUTHORS>.
 263
 264 =head1 LICENSE
 265
 266 This library is free software; you can redistribute it and/or modify it under
 267 the same terms as Perl itself.
 268
 269 =cut
 270
 271 1;
 272 # vim:et sts=4 sw=4 tw=0: