X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FDBI%2FDB2.pm;h=7edd9490d9982bf16cf06995281fab355287b05f;hb=659817cfc6f8f5dfa8dfcfa2992679d745294e3e;hp=f8c06292fe483711efbf110ce1ab15907836fd57;hpb=be80bba7041914683ec2afd00aaa54d6459cbaee;p=dbsrgits%2FDBIx-Class-Schema-Loader.git diff --git a/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm b/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm index f8c0629..7edd949 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/DB2.pm @@ -2,11 +2,14 @@ package DBIx::Class::Schema::Loader::DBI::DB2; use strict; use warnings; -use base 'DBIx::Class::Schema::Loader::DBI'; +use base qw/ + DBIx::Class::Schema::Loader::DBI::Component::QuotedDefault + DBIx::Class::Schema::Loader::DBI +/; use Carp::Clan qw/^DBIx::Class/; -use Class::C3; +use mro 'c3'; -our $VERSION = '0.04999_10'; +our $VERSION = '0.07003'; =head1 NAME @@ -34,6 +37,14 @@ sub _setup { my $dbh = $self->schema->storage->dbh; $self->{db_schema} ||= $dbh->selectrow_array('VALUES(CURRENT_USER)', {}); + + 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('.'); + } } sub _table_uniq_info { @@ -46,16 +57,17 @@ sub _table_uniq_info { 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 + JOIN SYSCAT.KEYCOLUSE as kcu + ON tc.CONSTNAME = kcu.CONSTNAME AND tc.TABSCHEMA = kcu.TABSCHEMA WHERE tc.TABSCHEMA = ? and tc.TABNAME = ? and tc.TYPE = 'U'} ) or die $DBI::errstr; - $sth->execute($self->db_schema, uc $table) or die $DBI::errstr; + $sth->execute($self->db_schema, $self->_uc($table)) or die $DBI::errstr; 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) { my @ordered_cols = map { $_->[1] } sort { $a->[0] <=> $b->[0] } @@ -70,61 +82,117 @@ sub _table_uniq_info { # DBD::DB2 doesn't follow the DBI API for ->tables sub _tables_list { - my $self = shift; + my ($self, $opts) = @_; my $dbh = $self->schema->storage->dbh; - my @tables = map { lc } $dbh->tables( + my @tables = map $self->_lc($_), $dbh->tables( $self->db_schema ? { TABLE_SCHEM => $self->db_schema } : undef ); s/\Q$self->{_quoter}\E//g for @tables; s/^.*\Q$self->{_namesep}\E// for @tables; - return @tables; + return $self->_filter_tables(\@tables, $opts); } sub _table_pk_info { my ($self, $table) = @_; - return $self->next::method(uc $table); + return $self->next::method($self->_uc($table)); } sub _table_fk_info { my ($self, $table) = @_; - my $rels = $self->next::method(uc $table); + my $rels = $self->next::method($self->_uc($table)); foreach my $rel (@$rels) { - $rel->{remote_table} = lc $rel->{remote_table}; + $rel->{remote_table} = $self->_lc($rel->{remote_table}); } return $rels; } sub _columns_info_for { - my ($self, $table) = @_; - return $self->next::method(uc $table); -} - -sub _extra_column_info { - my ($self, $info) = @_; - my %extra_info; + my $self = shift; + my ($table) = @_; - my ($table, $column) = @$info{qw/TABLE_NAME COLUMN_NAME/}; + my $result = $self->next::method($self->_uc($table)); 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; + + while (my ($col, $info) = each %$result) { + # check for identities + 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, $self->_uc($table), $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) = $dbh->selectrow_array(<<'EOF', {}, $self->db_schema, $self->_uc($table), $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 @@ -134,7 +202,7 @@ L =head1 AUTHOR -See L. +See L and L. =head1 LICENSE @@ -144,3 +212,4 @@ the same terms as Perl itself. =cut 1; +# vim:et sts=4 sw=4 tw=0: