X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=dbsrgits%2FDBIx-Class-Schema-Loader.git;a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FDBI%2FDB2.pm;h=9de0e70c92f0a40f5925375dc66b2804a0efa037;hp=01fbd1c4b565b6866a0c939691746e2c49dcde37;hb=306bf770bf08b06f92863808b1938f2fc704acb0;hpb=072d5aae0d2a53b1a6d5bac18dbeac3a5b3d61c2 diff --git a/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm b/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm index 01fbd1c..9de0e70 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm @@ -2,120 +2,256 @@ package DBIx::Class::Schema::Loader::DBI::DB2; use strict; use warnings; -use base 'DBIx::Class::Schema::Loader::DBI'; -use Carp::Clan qw/^DBIx::Class/; -use Class::C3; +use base qw/ + DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault + DBIx::Class::Schema::Loader::DBI +/; +use mro 'c3'; -our $VERSION = '0.04999_04'; +use List::Util 'any'; +use namespace::clean; + +use DBIx::Class::Schema::Loader::Table (); + +our $VERSION = '0.07047'; =head1 NAME DBIx::Class::Schema::Loader::DBI::DB2 - DBIx::Class::Schema::Loader::DBI DB2 Implementation. -=head1 SYNOPSIS +=head1 DESCRIPTION - package My::Schema; - use base qw/DBIx::Class::Schema::Loader/; +See L and L. - __PACKAGE__->loader_options( db_schema => "MYSCHEMA" ); +=cut - 1; +sub _system_schemas { + my $self = shift; -=head1 DESCRIPTION + return ($self->next::method(@_), qw/ + SYSCAT SYSIBM SYSIBMADM SYSPUBLIC SYSSTAT SYSTOOLS + /); +} -See L. +sub _setup { + my $self = shift; -=cut + $self->next::method(@_); + + my $ns = $self->name_sep; + + $self->db_schema([ $self->dbh->selectrow_array(<<"EOF", {}) ]) unless $self->db_schema; +SELECT CURRENT_SCHEMA FROM sysibm${ns}sysdummy1 +EOF + + if (not defined $self->preserve_case) { + $self->preserve_case(0); + } + elsif ($self->preserve_case) { + $self->schema->storage->sql_maker->quote_char('"'); + $self->schema->storage->sql_maker->name_sep($ns); + } +} sub _table_uniq_info { my ($self, $table) = @_; my @uniqs; - my $dbh = $self->schema->storage->dbh; - - my $sth = $self->{_cache}->{db2_uniq} ||= $dbh->prepare( - q{SELECT kcu.COLNAME, kcu.CONSTNAME, kcu.COLSEQ - FROM SYSCAT.TABCONST as tc - JOIN SYSCAT.KEYCOLUSE as kcu ON tc.CONSTNAME = kcu.CONSTNAME - WHERE tc.TABSCHEMA = ? and tc.TABNAME = ? and tc.TYPE = 'U'} - ) or die $DBI::errstr; + my $sth = $self->{_cache}->{db2_uniq} ||= $self->dbh->prepare(<<'EOF'); +SELECT kcu.colname, kcu.constname, kcu.colseq +FROM syscat.tabconst as tc +JOIN syscat.keycoluse as kcu + ON tc.constname = kcu.constname + AND tc.tabschema = kcu.tabschema + AND tc.tabname = kcu.tabname +WHERE tc.tabschema = ? and tc.tabname = ? and tc.type = 'U' +EOF - $sth->execute($self->db_schema, uc $table) or die $DBI::errstr; + $sth->execute($table->schema, $table->name); my %keydata; while(my $row = $sth->fetchrow_arrayref) { my ($col, $constname, $seq) = @$row; - push(@{$keydata{$constname}}, [ $seq, lc $col ]); + push(@{$keydata{$constname}}, [ $seq, $self->_lc($col) ]); } - foreach my $keyname (keys %keydata) { + foreach my $keyname (sort keys %keydata) { my @ordered_cols = map { $_->[1] } sort { $a->[0] <=> $b->[0] } @{$keydata{$keyname}}; push(@uniqs, [ $keyname => \@ordered_cols ]); } $sth->finish; - + return \@uniqs; } -# DBD::DB2 doesn't follow the DBI API for ->tables -sub _tables_list { - my $self = shift; - - my $dbh = $self->schema->storage->dbh; - my @tables = map { lc } $dbh->tables( - $self->db_schema ? { TABLE_SCHEM => $self->db_schema } : undef +sub _table_fk_info { + my ($self, $table) = @_; + + my $sth = $self->{_cache}->{db2_fk} ||= $self->dbh->prepare(<<'EOF'); +SELECT tc.constname, sr.reftabschema, sr.reftabname, + kcu.colname, rkcu.colname, kcu.colseq, + sr.deleterule, sr.updaterule +FROM syscat.tabconst tc +JOIN syscat.keycoluse kcu + ON tc.constname = kcu.constname + AND tc.tabschema = kcu.tabschema + AND tc.tabname = kcu.tabname +JOIN syscat.references sr + ON tc.constname = sr.constname + AND tc.tabschema = sr.tabschema + AND tc.tabname = sr.tabname +JOIN syscat.keycoluse rkcu + ON sr.refkeyname = rkcu.constname + AND sr.reftabschema = rkcu.tabschema + AND sr.reftabname = rkcu.tabname + AND kcu.colseq = rkcu.colseq +WHERE tc.tabschema = ? + AND tc.tabname = ? + AND tc.type = 'F'; +EOF + $sth->execute($table->schema, $table->name); + + my %rels; + + my %rules = ( + A => 'NO ACTION', + C => 'CASCADE', + N => 'SET NULL', + R => 'RESTRICT', ); - s/\Q$self->{_quoter}\E//g for @tables; - s/^.*\Q$self->{_namesep}\E// for @tables; - return @tables; -} + COLS: while (my @row = $sth->fetchrow_array) { + my ($fk, $remote_schema, $remote_table, $local_col, $remote_col, + $colseq, $delete_rule, $update_rule) = @row; -sub _table_pk_info { - my ($self, $table) = @_; - return $self->next::method(uc $table); -} + if (not exists $rels{$fk}) { + if ($self->db_schema && $self->db_schema->[0] ne '%' + && (not any { $_ eq $remote_schema } @{ $self->db_schema })) { -sub _table_fk_info { - my ($self, $table) = @_; + next COLS; + } + + $rels{$fk}{remote_table} = DBIx::Class::Schema::Loader::Table->new( + loader => $self, + name => $remote_table, + schema => $remote_schema, + ); + } - my $rels = $self->next::method(uc $table); + $rels{$fk}{local_columns}[$colseq-1] = $self->_lc($local_col); + $rels{$fk}{remote_columns}[$colseq-1] = $self->_lc($remote_col); - foreach my $rel (@$rels) { - $rel->{remote_table} = lc $rel->{remote_table}; + $rels{$fk}{attrs} ||= { + on_delete => $rules{$delete_rule}, + on_update => $rules{$update_rule}, + is_deferrable => 1, # DB2 has no deferrable constraints + }; } - return $rels; + return [ values %rels ]; } -sub _columns_info_for { - my ($self, $table) = @_; - return $self->next::method(uc $table); + +# DBD::DB2 doesn't follow the DBI API for ->tables (pre 1.85), but since its +# backwards compatible we don't change it. +# DBD::DB2 1.85 and beyond default TABLE_NAME to '', previously defaulted to +# '%'. so we supply it. +sub _dbh_tables { + my ($self, $schema) = @_; + + return $self->dbh->tables($schema ? { TABLE_SCHEM => $schema, TABLE_NAME => '%' } : undef); } -sub _extra_column_info { - my ($self, $info) = @_; - my %extra_info; - - my ($table, $column) = @$info{qw/TABLE_NAME COLUMN_NAME/}; - - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare_cached( - q{ - SELECT COUNT(*) - FROM syscat.columns - WHERE tabschema = ? AND tabname = ? AND colname = ? - AND identity = 'Y' AND generated != '' - }, - {}, 1); - $sth->execute($self->db_schema, $table, $column); - if ($sth->fetchrow_array) { - $extra_info{is_auto_increment} = 1; +sub _dbh_table_info { + my $self = shift; + + local $^W = 0; # shut up undef warning from DBD::DB2 + + $self->next::method(@_); +} + +sub _columns_info_for { + my $self = shift; + my ($table) = @_; + + my $result = $self->next::method(@_); + + while (my ($col, $info) = each %$result) { + # check for identities + my $sth = $self->dbh->prepare_cached( + q{ + SELECT COUNT(*) + FROM syscat.columns + WHERE tabschema = ? AND tabname = ? AND colname = ? + AND identity = 'Y' AND generated != '' + }, + {}, 1); + $sth->execute($table->schema, $table->name, $self->_uc($col)); + if ($sth->fetchrow_array) { + $info->{is_auto_increment} = 1; + } + + my $data_type = $info->{data_type}; + + if ($data_type !~ /^(?:(?:var)?(?:char|graphic)|decimal)\z/i) { + delete $info->{size}; + } + + if ($data_type eq 'double') { + $info->{data_type} = 'double precision'; + } + elsif ($data_type eq 'decimal') { + no warnings 'uninitialized'; + + $info->{data_type} = 'numeric'; + + my @size = @{ $info->{size} || [] }; + + if ($size[0] == 5 && $size[1] == 0) { + delete $info->{size}; + } + } + elsif ($data_type =~ /^(?:((?:var)?char) \(\) for bit data|(long varchar) for bit data)\z/i) { + my $base_type = lc($1 || $2); + + (my $original_type = $data_type) =~ s/[()]+ //; + + $info->{original}{data_type} = $original_type; + + if ($base_type eq 'long varchar') { + $info->{data_type} = 'blob'; + } + else { + if ($base_type eq 'char') { + $info->{data_type} = 'binary'; + } + elsif ($base_type eq 'varchar') { + $info->{data_type} = 'varbinary'; + } + + my ($size) = $self->dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $self->_uc($col)); +SELECT length +FROM syscat.columns +WHERE tabschema = ? AND tabname = ? AND colname = ? +EOF + + $info->{size} = $size if $size; + } + } + + if ((eval { lc ${ $info->{default_value} } }||'') =~ /^current (date|time(?:stamp)?)\z/i) { + my $type = lc($1); + + ${ $info->{default_value} } = 'current_timestamp'; + + my $orig_deflt = "current $type"; + $info->{original}{default_value} = \$orig_deflt; + } } - return \%extra_info; + return $result; } =head1 SEE ALSO @@ -123,6 +259,16 @@ sub _extra_column_info { L, L, L +=head1 AUTHORS + +See L. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + =cut 1; +# vim:et sts=4 sw=4 tw=0: