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=3909efd38c384e4eb91cf2a327234306aa32712a;hpb=3ddb05da3f2f894c54de354ac7153a4de6596c69;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 3909efd..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_03'; +our $VERSION = '0.07003'; =head1 NAME @@ -27,6 +30,23 @@ See L. =cut +sub _setup { + my $self = shift; + + $self->next::method(@_); + + 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 { my ($self, $table) = @_; @@ -37,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] } @@ -59,31 +80,119 @@ sub _table_uniq_info { return \@uniqs; } -sub _tables_list { - my $self = shift; - return map lc, $self->next::method; +# DBD::DB2 doesn't follow the DBI API for ->tables +sub _tables_list { + my ($self, $opts) = @_; + + my $dbh = $self->schema->storage->dbh; + 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 $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); + my $self = shift; + my ($table) = @_; + + my $result = $self->next::method($self->_uc($table)); + + my $dbh = $self->schema->storage->dbh; + + 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 $result; } =head1 SEE ALSO @@ -91,6 +200,16 @@ sub _columns_info_for { L, L, L +=head1 AUTHOR + +See L and 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: