X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FDBI%2FInterBase.pm;h=4c6a61ded6bc8b0209178709cfe0bfdc1a1d078e;hb=900628605efdbced5dcfdbbab0022b204aa93e14;hp=3dd27cac1c95635fcafdaab8b27de384e879ca7e;hpb=6e566cc4a06b1661597200611a03320f969e2566;p=dbsrgits%2FDBIx-Class-Schema-Loader.git diff --git a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm index 3dd27ca..4c6a61d 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm @@ -2,13 +2,16 @@ package DBIx::Class::Schema::Loader::DBI::InterBase; use strict; use warnings; -use namespace::autoclean; -use Class::C3; use base qw/DBIx::Class::Schema::Loader::DBI/; +use mro 'c3'; use Carp::Clan qw/^DBIx::Class/; use List::Util 'first'; +use namespace::clean; +use DBIx::Class::Schema::Loader::Table (); -our $VERSION = '0.07000'; +our $VERSION = '0.07044'; + +sub _supports_db_schema { 0 } =head1 NAME @@ -21,16 +24,16 @@ See L and L. =head1 COLUMN NAME CASE ISSUES -By default column names from unquoted DDL will be generated in uppercase, as -that is the only way they will work with quoting on. +By default column names from unquoted DDL will be generated in lowercase, for +consistency with other backends. -See the L option -to false if you would like to have lowercase column names. +Set the L option +to true if you would like to have column names in the internal case, which is +uppercase for DDL that uses unquoted identifiers. -Setting this option is a good idea if your DDL uses unquoted identifiers and -you will not use quoting (the -L option in -L.) +Do not use quoting (the L +option in L when in the +default C<< preserve_case => 0 >> mode. Be careful to also not use any SQL reserved words in your DDL. @@ -40,9 +43,6 @@ names) in your Result classes that will only work with quoting off. Mixed-case table and column names will be ignored when this option is on and will not work with quoting turned off. -B This option used to be called C but has been removed in -favor of the more generic option. - =cut sub _setup { @@ -50,41 +50,34 @@ sub _setup { $self->next::method(@_); - $self->schema->storage->sql_maker->name_sep('.'); - if (not defined $self->preserve_case) { - warn <<'EOF'; - -WARNING: Assuming mixed-case Firebird DDL, see -perldoc DBIx::Class::Schema::Loader::DBI::InterBase -and the 'preserve_case' option in -perldoc DBIx::Class::Schema::Loader::Base -for more information. - -EOF - $self->preserve_case(1); + $self->preserve_case(0); } - - if ($self->preserve_case) { + elsif ($self->preserve_case) { $self->schema->storage->sql_maker->quote_char('"'); + $self->schema->storage->sql_maker->name_sep('.'); } - else { - $self->schema->storage->sql_maker->quote_char(undef); + + if ($self->db_schema) { + carp "db_schema is not supported on Firebird"; + + if ($self->db_schema->[0] eq '%') { + $self->db_schema(undef); + } } } sub _table_pk_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(<<'EOF'); + my $sth = $self->dbh->prepare(<<'EOF'); SELECT iseg.rdb$field_name FROM rdb$relation_constraints rc JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name WHERE rc.rdb$constraint_type = 'PRIMARY KEY' and rc.rdb$relation_name = ? ORDER BY iseg.rdb$field_position EOF - $sth->execute($table); + $sth->execute($table->name); my @keydata; @@ -101,8 +94,7 @@ sub _table_fk_info { my ($self, $table) = @_; my ($local_cols, $remote_cols, $remote_table, @rels); - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(<<'EOF'); + my $sth = $self->dbh->prepare(<<'EOF'); SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col FROM rdb$relation_constraints rc JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name @@ -112,17 +104,24 @@ JOIN rdb$index_segments riseg ON iseg.rdb$field_position = riseg.rdb$field_posit WHERE rc.rdb$constraint_type = 'FOREIGN KEY' and rc.rdb$relation_name = ? ORDER BY iseg.rdb$field_position EOF - $sth->execute($table); + $sth->execute($table->name); while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) { s/^\s+//, s/\s+\z// for $fk, $local_col, $remote_tab, $remote_col; push @{$local_cols->{$fk}}, $self->_lc($local_col); push @{$remote_cols->{$fk}}, $self->_lc($remote_col); - $remote_table->{$fk} = $remote_tab; + $remote_table->{$fk} = DBIx::Class::Schema::Loader::Table->new( + loader => $self, + name => $remote_tab, + ($self->db_schema ? ( + schema => $self->db_schema->[0], + ignore_schema => 1, + ) : ()), + ); } - foreach my $fk (keys %$remote_table) { + foreach my $fk (sort keys %$remote_table) { push @rels, { local_columns => $local_cols->{$fk}, remote_columns => $remote_cols->{$fk}, @@ -135,15 +134,14 @@ EOF sub _table_uniq_info { my ($self, $table) = @_; - my $dbh = $self->schema->storage->dbh; - my $sth = $dbh->prepare(<<'EOF'); + my $sth = $self->dbh->prepare(<<'EOF'); SELECT rc.rdb$constraint_name, iseg.rdb$field_name FROM rdb$relation_constraints rc JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ? ORDER BY iseg.rdb$field_position EOF - $sth->execute($table); + $sth->execute($table->name); my $constraints; while (my ($constraint_name, $column) = $sth->fetchrow_array) { @@ -152,8 +150,7 @@ EOF push @{$constraints->{$constraint_name}}, $self->_lc($column); } - my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints; - return \@uniqs; + return [ map { [ $_ => $constraints->{$_} ] } sort keys %$constraints ]; } sub _columns_info_for { @@ -162,20 +159,20 @@ sub _columns_info_for { my $result = $self->next::method(@_); - my $dbh = $self->schema->storage->dbh; - - local $dbh->{LongReadLen} = 100000; - local $dbh->{LongTruncOk} = 1; + local $self->dbh->{LongReadLen} = 100000; + local $self->dbh->{LongTruncOk} = 1; while (my ($column, $info) = each %$result) { - my $sth = $dbh->prepare(<<'EOF'); + my $data_type = $info->{data_type}; + + my $sth = $self->dbh->prepare(<<'EOF'); SELECT t.rdb$trigger_source FROM rdb$triggers t WHERE t.rdb$relation_name = ? AND t.rdb$system_flag = 0 -- user defined AND t.rdb$trigger_type = 1 -- BEFORE INSERT EOF - $sth->execute($table); + $sth->execute($table->name); while (my ($trigger) = $sth->fetchrow_array) { my @trig_cols = map { /^"([^"]+)/ ? $1 : uc($_) } $trigger =~ /new\.("?\w+"?)/ig; @@ -194,8 +191,8 @@ EOF } # fix up types - $sth = $dbh->prepare(<<'EOF'); -SELECT f.rdb$field_precision, f.rdb$field_scale, f.rdb$field_type, f.rdb$field_sub_type, t.rdb$type_name, st.rdb$type_name + $sth = $self->dbh->prepare(<<'EOF'); +SELECT f.rdb$field_precision, f.rdb$field_scale, f.rdb$field_type, f.rdb$field_sub_type, f.rdb$character_set_id, f.rdb$character_length, t.rdb$type_name, st.rdb$type_name FROM rdb$fields f JOIN rdb$relation_fields rf ON rf.rdb$field_source = f.rdb$field_name LEFT JOIN rdb$types t ON f.rdb$field_type = t.rdb$type AND t.rdb$field_name = 'RDB$FIELD_TYPE' @@ -203,15 +200,15 @@ LEFT JOIN rdb$types st ON f.rdb$field_sub_type = st.rdb$type AND st.rdb$field_na WHERE rf.rdb$relation_name = ? AND rf.rdb$field_name = ? EOF - $sth->execute($table, $self->_uc($column)); - my ($precision, $scale, $type_num, $sub_type_num, $type_name, $sub_type_name) = $sth->fetchrow_array; + $sth->execute($table->name, $self->_uc($column)); + my ($precision, $scale, $type_num, $sub_type_num, $char_set_id, $char_length, $type_name, $sub_type_name) = $sth->fetchrow_array; $scale = -$scale if $scale && $scale < 0; if ($type_name && $sub_type_name) { s/\s+\z// for $type_name, $sub_type_name; # fixups primarily for DBD::InterBase - if ($info->{data_type} =~ /^(?:integer|int|smallint|bigint|-9581)\z/) { + if ($data_type =~ /^(?:integer|int|smallint|bigint|-9581)\z/) { if ($precision && $type_name =~ /^(?:LONG|INT64)\z/ && $sub_type_name eq 'BLR') { $info->{data_type} = 'decimal'; } @@ -228,12 +225,19 @@ EOF $info->{data_type} = 'blob'; } elsif ($sub_type_name eq 'TEXT') { - $info->{data_type} = 'blob sub_type text'; + if (defined $char_set_id && $char_set_id == 3) { + $info->{data_type} = 'blob sub_type text character set unicode_fss'; + } + else { + $info->{data_type} = 'blob sub_type text'; + } } } } - if ($info->{data_type} =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) { + $data_type = $info->{data_type}; + + if ($data_type =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) { if ($precision == 9 && $scale == 0) { delete $info->{size}; } @@ -242,47 +246,52 @@ EOF } } - if ($info->{data_type} eq '11') { + if ($data_type eq '11') { $info->{data_type} = 'timestamp'; } - elsif ($info->{data_type} eq '10') { + elsif ($data_type eq '10') { $info->{data_type} = 'time'; } - elsif ($info->{data_type} eq '9') { + elsif ($data_type eq '9') { $info->{data_type} = 'date'; } - elsif ($info->{data_type} eq 'character varying') { + elsif ($data_type eq 'character varying') { $info->{data_type} = 'varchar'; } - elsif ($info->{data_type} eq 'character') { + elsif ($data_type eq 'character') { $info->{data_type} = 'char'; } - elsif ($info->{data_type} eq 'real') { - $info->{data_type} = 'float'; + elsif ($data_type eq 'float') { + $info->{data_type} = 'real'; } - elsif ($info->{data_type} eq 'int64' || $info->{data_type} eq '-9581') { + elsif ($data_type eq 'int64' || $data_type eq '-9581') { # the constant is just in case, the query should pick up the type $info->{data_type} = 'bigint'; } - # DBD::InterBase sets scale to '0' for some reason for char types - if ($info->{data_type} =~ /^(?:char|varchar)\z/ && ref($info->{size}) eq 'ARRAY') { - $info->{size} = $info->{size}[0]; + $data_type = $info->{data_type}; + + if ($data_type =~ /^(?:char|varchar)\z/) { + $info->{size} = $char_length; + + if (defined $char_set_id && $char_set_id == 3) { + $info->{data_type} .= '(x) character set unicode_fss'; + } } - elsif ($info->{data_type} !~ /^(?:char|varchar|numeric|decimal)\z/) { + elsif ($data_type !~ /^(?:numeric|decimal)\z/) { delete $info->{size}; } # get default delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL'; - $sth = $dbh->prepare(<<'EOF'); + $sth = $self->dbh->prepare(<<'EOF'); SELECT rf.rdb$default_source FROM rdb$relation_fields rf WHERE rf.rdb$relation_name = ? AND rf.rdb$field_name = ? EOF - $sth->execute($table, $self->_uc($column)); + $sth->execute($table->name, $self->_uc($column)); my ($default_src) = $sth->fetchrow_array; if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) { @@ -290,7 +299,7 @@ EOF $info->{default_value} = $quoted; } else { - $info->{default_value} = $def =~ /^\d/ ? $def : \$def; + $info->{default_value} = $def =~ /^-?\d/ ? $def : \$def; } } @@ -306,9 +315,9 @@ EOF L, L, L -=head1 AUTHOR +=head1 AUTHORS -See L and L. +See L. =head1 LICENSE