1 package DBIx::Class::Schema::Loader::DBI::DB2;
6 DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault
7 DBIx::Class::Schema::Loader::DBI
14 use DBIx::Class::Schema::Loader::Table ();
16 our $VERSION = '0.07045';
20 DBIx::Class::Schema::Loader::DBI::DB2 - DBIx::Class::Schema::Loader::DBI DB2 Implementation.
24 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
31 return ($self->next::method(@_), qw/
32 SYSCAT SYSIBM SYSIBMADM SYSPUBLIC SYSSTAT SYSTOOLS
39 $self->next::method(@_);
41 my $ns = $self->name_sep;
43 $self->db_schema([ $self->dbh->selectrow_array(<<"EOF", {}) ]) unless $self->db_schema;
44 SELECT CURRENT_SCHEMA FROM sysibm${ns}sysdummy1
47 if (not defined $self->preserve_case) {
48 $self->preserve_case(0);
50 elsif ($self->preserve_case) {
51 $self->schema->storage->sql_maker->quote_char('"');
52 $self->schema->storage->sql_maker->name_sep($ns);
56 sub _table_uniq_info {
57 my ($self, $table) = @_;
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'
71 $sth->execute($table->schema, $table->name);
74 while(my $row = $sth->fetchrow_arrayref) {
75 my ($col, $constname, $seq) = @$row;
76 push(@{$keydata{$constname}}, [ $seq, $self->_lc($col) ]);
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 ]);
90 my ($self, $table) = @_;
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 = ?
114 $sth->execute($table->schema, $table->name);
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;
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 })) {
136 $rels{$fk}{remote_table} = DBIx::Class::Schema::Loader::Table->new(
138 name => $remote_table,
139 schema => $remote_schema,
143 $rels{$fk}{local_columns}[$colseq-1] = $self->_lc($local_col);
144 $rels{$fk}{remote_columns}[$colseq-1] = $self->_lc($remote_col);
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
153 return [ values %rels ];
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.
162 my ($self, $schema) = @_;
164 return $self->dbh->tables($schema ? { TABLE_SCHEM => $schema, TABLE_NAME => '%' } : undef);
167 sub _dbh_table_info {
170 local $^W = 0; # shut up undef warning from DBD::DB2
172 $self->next::method(@_);
175 sub _columns_info_for {
179 my $result = $self->next::method(@_);
181 while (my ($col, $info) = each %$result) {
182 # check for identities
183 my $sth = $self->dbh->prepare_cached(
187 WHERE tabschema = ? AND tabname = ? AND colname = ?
188 AND identity = 'Y' AND generated != ''
191 $sth->execute($table->schema, $table->name, $self->_uc($col));
192 if ($sth->fetchrow_array) {
193 $info->{is_auto_increment} = 1;
196 my $data_type = $info->{data_type};
198 if ($data_type !~ /^(?:(?:var)?(?:char|graphic)|decimal)\z/i) {
199 delete $info->{size};
202 if ($data_type eq 'double') {
203 $info->{data_type} = 'double precision';
205 elsif ($data_type eq 'decimal') {
206 no warnings 'uninitialized';
208 $info->{data_type} = 'numeric';
210 my @size = @{ $info->{size} || [] };
212 if ($size[0] == 5 && $size[1] == 0) {
213 delete $info->{size};
216 elsif ($data_type =~ /^(?:((?:var)?char) \(\) for bit data|(long varchar) for bit data)\z/i) {
217 my $base_type = lc($1 || $2);
219 (my $original_type = $data_type) =~ s/[()]+ //;
221 $info->{original}{data_type} = $original_type;
223 if ($base_type eq 'long varchar') {
224 $info->{data_type} = 'blob';
227 if ($base_type eq 'char') {
228 $info->{data_type} = 'binary';
230 elsif ($base_type eq 'varchar') {
231 $info->{data_type} = 'varbinary';
234 my ($size) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $self->_uc($col));
237 WHERE tabschema = ? AND tabname = ? AND colname = ?
240 $info->{size} = $size if $size;
244 if ((eval { lc ${ $info->{default_value} } }||'') =~ /^current (date|time(?:stamp)?)\z/i) {
247 ${ $info->{default_value} } = 'current_timestamp';
249 my $orig_deflt = "current $type";
250 $info->{original}{default_value} = \$orig_deflt;
259 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
260 L<DBIx::Class::Schema::Loader::DBI>
264 See L<DBIx::Class::Schema::Loader/AUTHORS>.
268 This library is free software; you can redistribute it and/or modify it under
269 the same terms as Perl itself.
274 # vim:et sts=4 sw=4 tw=0: