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