1package DBIx::Class::Schema::Loader::DBI::DB2; 2 3use strict; 4use warnings; 5use base qw/ 6 DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault 7 DBIx::Class::Schema::Loader::DBI 8/; 9use mro 'c3'; 10 11use List::MoreUtils 'any'; 12use namespace::clean; 13 14use DBIx::Class::Schema::Loader::Table (); 15 16our $VERSION = '0.07033'; 17 18=head1 NAME 19 20DBIx::Class::Schema::Loader::DBI::DB2 - DBIx::Class::Schema::Loader::DBI DB2 Implementation. 21 22=head1 DESCRIPTION 23 24See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>. 25 26=cut 27 28sub _system_schemas { 29 my $self = shift; 30 31 return ($self->next::method(@_), qw/ 32 SYSCAT SYSIBM SYSIBMADM SYSPUBLIC SYSSTAT SYSTOOLS 33 /); 34} 35 36sub _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; 44SELECT CURRENT_SCHEMA FROM sysibm${ns}sysdummy1 45EOF 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 56sub _table_uniq_info { 57 my ($self, $table) = @_; 58 59 my @uniqs; 60 61 my $sth = $self->{_cache}->{db2_uniq} ||= $self->dbh->prepare(<<'EOF'); 62SELECT kcu.colname, kcu.constname, kcu.colseq 63FROM syscat.tabconst as tc 64JOIN syscat.keycoluse as kcu 65 ON tc.constname = kcu.constname 66 AND tc.tabschema = kcu.tabschema 67 AND tc.tabname = kcu.tabname 68WHERE tc.tabschema = ? and tc.tabname = ? and tc.type = 'U' 69EOF 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 (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 89sub _table_fk_info { 90 my ($self, $table) = @_; 91 92 my $sth = $self->{_cache}->{db2_fk} ||= $self->dbh->prepare(<<'EOF'); 93SELECT tc.constname, sr.reftabschema, sr.reftabname, 94 kcu.colname, rkcu.colname, kcu.colseq, 95 sr.deleterule, sr.updaterule 96FROM syscat.tabconst tc 97JOIN syscat.keycoluse kcu 98 ON tc.constname = kcu.constname 99 AND tc.tabschema = kcu.tabschema 100 AND tc.tabname = kcu.tabname 101JOIN syscat.references sr 102 ON tc.constname = sr.constname 103 AND tc.tabschema = sr.tabschema 104 AND tc.tabname = sr.tabname 105JOIN syscat.keycoluse rkcu 106 ON sr.refkeyname = rkcu.constname 107 AND kcu.colseq = rkcu.colseq 108WHERE tc.tabschema = ? 109 AND tc.tabname = ? 110 AND tc.type = 'F'; 111EOF 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 156sub _dbh_tables { 157 my ($self, $schema) = @_; 158 159 return $self->dbh->tables($schema ? { TABLE_SCHEM => $schema } : undef); 160} 161 162sub _columns_info_for { 163 my $self = shift; 164 my ($table) = @_; 165 166 my $result = $self->next::method(@_); 167 168 while (my ($col, $info) = each %$result) { 169 # check for identities 170 my $sth = $self->dbh->prepare_cached( 171 q{ 172 SELECT COUNT(*) 173 FROM syscat.columns 174 WHERE tabschema = ? AND tabname = ? AND colname = ? 175 AND identity = 'Y' AND generated != '' 176 }, 177 {}, 1); 178 $sth->execute($table->schema, $table->name, $self->_uc($col)); 179 if ($sth->fetchrow_array) { 180 $info->{is_auto_increment} = 1; 181 } 182 183 my $data_type = $info->{data_type}; 184 185 if ($data_type !~ /^(?:(?:var)?(?:char|graphic)|decimal)\z/i) { 186 delete $info->{size}; 187 } 188 189 if ($data_type eq 'double') { 190 $info->{data_type} = 'double precision'; 191 } 192 elsif ($data_type eq 'decimal') { 193 no warnings 'uninitialized'; 194 195 $info->{data_type} = 'numeric'; 196 197 my @size = @{ $info->{size} || [] }; 198 199 if ($size[0] == 5 && $size[1] == 0) { 200 delete $info->{size}; 201 } 202 } 203 elsif ($data_type =~ /^(?:((?:var)?char) \(\) for bit data|(long varchar) for bit data)\z/i) { 204 my $base_type = lc($1 || $2); 205 206 (my $original_type = $data_type) =~ s/[()]+ //; 207 208 $info->{original}{data_type} = $original_type; 209 210 if ($base_type eq 'long varchar') { 211 $info->{data_type} = 'blob'; 212 } 213 else { 214 if ($base_type eq 'char') { 215 $info->{data_type} = 'binary'; 216 } 217 elsif ($base_type eq 'varchar') { 218 $info->{data_type} = 'varbinary'; 219 } 220 221 my ($size) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $self->_uc($col)); 222SELECT length 223FROM syscat.columns 224WHERE tabschema = ? AND tabname = ? AND colname = ? 225EOF 226 227 $info->{size} = $size if $size; 228 } 229 } 230 231 if ((eval { lc ${ $info->{default_value} } }||'') =~ /^current (date|time(?:stamp)?)\z/i) { 232 my $type = lc($1); 233 234 ${ $info->{default_value} } = 'current_timestamp'; 235 236 my $orig_deflt = "current $type"; 237 $info->{original}{default_value} = \$orig_deflt; 238 } 239 } 240 241 return $result; 242} 243 244=head1 SEE ALSO 245 246L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, 247L<DBIx::Class::Schema::Loader::DBI> 248 249=head1 AUTHOR 250 251See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. 252 253=head1 LICENSE 254 255This library is free software; you can redistribute it and/or modify it under 256the same terms as Perl itself. 257 258=cut 259 2601; 261# vim:et sts=4 sw=4 tw=0: 262