1 package DBIx::Class::Schema::Loader::DBI::InterBase;
6 use base qw/DBIx::Class::Schema::Loader::DBI/;
7 use Carp::Clan qw/^DBIx::Class/;
8 use List::Util 'first';
11 our $VERSION = '0.07010';
15 DBIx::Class::Schema::Loader::DBI::InterBase - DBIx::Class::Schema::Loader::DBI
16 Firebird Implementation.
20 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
22 =head1 COLUMN NAME CASE ISSUES
24 By default column names from unquoted DDL will be generated in lowercase, for
25 consistency with other backends.
27 Set the L<preserve_case|DBIx::Class::Schema::Loader::Base/preserve_case> option
28 to true if you would like to have column names in the internal case, which is
29 uppercase for DDL that uses unquoted identifiers.
31 Do not use quoting (the L<quote_char|DBIx::Class::Storage::DBI/quote_char>
32 option in L<connect_info|DBIx::Class::Storage::DBI/connect_info> when in the
33 default C<< preserve_case => 0 >> mode.
35 Be careful to also not use any SQL reserved words in your DDL.
37 This will generate lowercase column names (as opposed to the actual uppercase
38 names) in your Result classes that will only work with quoting off.
40 Mixed-case table and column names will be ignored when this option is on and
41 will not work with quoting turned off.
48 $self->next::method(@_);
50 if (not defined $self->preserve_case) {
53 WARNING: Assuming unquoted Firebird DDL, see
54 perldoc DBIx::Class::Schema::Loader::DBI::InterBase
55 and the 'preserve_case' option in
56 perldoc DBIx::Class::Schema::Loader::Base
60 $self->preserve_case(0);
63 if ($self->preserve_case) {
64 $self->schema->storage->sql_maker->quote_char('"');
65 $self->schema->storage->sql_maker->name_sep('.');
68 $self->schema->storage->sql_maker->quote_char(undef);
69 $self->schema->storage->sql_maker->name_sep(undef);
74 my ($self, $table) = @_;
76 my $dbh = $self->schema->storage->dbh;
77 my $sth = $dbh->prepare(<<'EOF');
78 SELECT iseg.rdb$field_name
79 FROM rdb$relation_constraints rc
80 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
81 WHERE rc.rdb$constraint_type = 'PRIMARY KEY' and rc.rdb$relation_name = ?
82 ORDER BY iseg.rdb$field_position
84 $sth->execute($table);
88 while (my ($col) = $sth->fetchrow_array) {
89 s/^\s+//, s/\s+\z// for $col;
91 push @keydata, $self->_lc($col);
98 my ($self, $table) = @_;
100 my ($local_cols, $remote_cols, $remote_table, @rels);
101 my $dbh = $self->schema->storage->dbh;
102 my $sth = $dbh->prepare(<<'EOF');
103 SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col
104 FROM rdb$relation_constraints rc
105 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
106 JOIN rdb$indices li ON rc.rdb$index_name = li.rdb$index_name
107 JOIN rdb$indices ri ON li.rdb$foreign_key = ri.rdb$index_name
108 JOIN rdb$index_segments riseg ON iseg.rdb$field_position = riseg.rdb$field_position and ri.rdb$index_name = riseg.rdb$index_name
109 WHERE rc.rdb$constraint_type = 'FOREIGN KEY' and rc.rdb$relation_name = ?
110 ORDER BY iseg.rdb$field_position
112 $sth->execute($table);
114 while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) {
115 s/^\s+//, s/\s+\z// for $fk, $local_col, $remote_tab, $remote_col;
117 push @{$local_cols->{$fk}}, $self->_lc($local_col);
118 push @{$remote_cols->{$fk}}, $self->_lc($remote_col);
119 $remote_table->{$fk} = $remote_tab;
122 foreach my $fk (keys %$remote_table) {
124 local_columns => $local_cols->{$fk},
125 remote_columns => $remote_cols->{$fk},
126 remote_table => $remote_table->{$fk},
132 sub _table_uniq_info {
133 my ($self, $table) = @_;
135 my $dbh = $self->schema->storage->dbh;
136 my $sth = $dbh->prepare(<<'EOF');
137 SELECT rc.rdb$constraint_name, iseg.rdb$field_name
138 FROM rdb$relation_constraints rc
139 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
140 WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ?
141 ORDER BY iseg.rdb$field_position
143 $sth->execute($table);
146 while (my ($constraint_name, $column) = $sth->fetchrow_array) {
147 s/^\s+//, s/\s+\z// for $constraint_name, $column;
149 push @{$constraints->{$constraint_name}}, $self->_lc($column);
152 my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
156 sub _columns_info_for {
160 my $result = $self->next::method(@_);
162 my $dbh = $self->schema->storage->dbh;
164 local $dbh->{LongReadLen} = 100000;
165 local $dbh->{LongTruncOk} = 1;
167 while (my ($column, $info) = each %$result) {
168 my $sth = $dbh->prepare(<<'EOF');
169 SELECT t.rdb$trigger_source
171 WHERE t.rdb$relation_name = ?
172 AND t.rdb$system_flag = 0 -- user defined
173 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
175 $sth->execute($table);
177 while (my ($trigger) = $sth->fetchrow_array) {
178 my @trig_cols = map { /^"([^"]+)/ ? $1 : uc($_) } $trigger =~ /new\.("?\w+"?)/ig;
180 my ($quoted, $generator) = $trigger =~ /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
183 $generator = uc $generator unless $quoted;
185 if (first { $self->_uc($_) eq $self->_uc($column) } @trig_cols) {
186 $info->{is_auto_increment} = 1;
187 $info->{sequence} = $generator;
194 $sth = $dbh->prepare(<<'EOF');
195 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
197 JOIN rdb$relation_fields rf ON rf.rdb$field_source = f.rdb$field_name
198 LEFT JOIN rdb$types t ON f.rdb$field_type = t.rdb$type AND t.rdb$field_name = 'RDB$FIELD_TYPE'
199 LEFT JOIN rdb$types st ON f.rdb$field_sub_type = st.rdb$type AND st.rdb$field_name = 'RDB$FIELD_SUB_TYPE'
200 WHERE rf.rdb$relation_name = ?
201 AND rf.rdb$field_name = ?
203 $sth->execute($table, $self->_uc($column));
204 my ($precision, $scale, $type_num, $sub_type_num, $char_set_id, $char_length, $type_name, $sub_type_name) = $sth->fetchrow_array;
205 $scale = -$scale if $scale && $scale < 0;
207 if ($type_name && $sub_type_name) {
208 s/\s+\z// for $type_name, $sub_type_name;
210 # fixups primarily for DBD::InterBase
211 if ($info->{data_type} =~ /^(?:integer|int|smallint|bigint|-9581)\z/) {
212 if ($precision && $type_name =~ /^(?:LONG|INT64)\z/ && $sub_type_name eq 'BLR') {
213 $info->{data_type} = 'decimal';
215 elsif ($precision && $type_name =~ /^(?:LONG|SHORT|INT64)\z/ && $sub_type_name eq 'TEXT') {
216 $info->{data_type} = 'numeric';
218 elsif ((not $precision) && $type_name eq 'INT64' && $sub_type_name eq 'BINARY') {
219 $info->{data_type} = 'bigint';
222 # ODBC makes regular blobs sub_type blr
223 elsif ($type_name eq 'BLOB') {
224 if ($sub_type_name eq 'BINARY') {
225 $info->{data_type} = 'blob';
227 elsif ($sub_type_name eq 'TEXT') {
228 if ($char_set_id == 3) {
229 $info->{data_type} = 'blob sub_type text character set unicode_fss';
232 $info->{data_type} = 'blob sub_type text';
238 if ($info->{data_type} =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) {
239 if ($precision == 9 && $scale == 0) {
240 delete $info->{size};
243 $info->{size} = [$precision, $scale];
247 if ($info->{data_type} eq '11') {
248 $info->{data_type} = 'timestamp';
250 elsif ($info->{data_type} eq '10') {
251 $info->{data_type} = 'time';
253 elsif ($info->{data_type} eq '9') {
254 $info->{data_type} = 'date';
256 elsif ($info->{data_type} eq 'character varying') {
257 $info->{data_type} = 'varchar';
259 elsif ($info->{data_type} eq 'character') {
260 $info->{data_type} = 'char';
262 elsif ($info->{data_type} eq 'float') {
263 $info->{data_type} = 'real';
265 elsif ($info->{data_type} eq 'int64' || $info->{data_type} eq '-9581') {
266 # the constant is just in case, the query should pick up the type
267 $info->{data_type} = 'bigint';
270 if ($info->{data_type} =~ /^(?:char|varchar)\z/) {
271 $info->{size} = $char_length;
273 if ($char_set_id == 3) {
274 $info->{data_type} .= '(x) character set unicode_fss';
277 elsif ($info->{data_type} !~ /^(?:numeric|decimal)\z/) {
278 delete $info->{size};
282 delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL';
284 $sth = $dbh->prepare(<<'EOF');
285 SELECT rf.rdb$default_source
286 FROM rdb$relation_fields rf
287 WHERE rf.rdb$relation_name = ?
288 AND rf.rdb$field_name = ?
290 $sth->execute($table, $self->_uc($column));
291 my ($default_src) = $sth->fetchrow_array;
293 if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
294 if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
295 $info->{default_value} = $quoted;
298 $info->{default_value} = $def =~ /^-?\d/ ? $def : \$def;
302 ${ $info->{default_value} } = 'current_timestamp'
303 if ref $info->{default_value} && ${ $info->{default_value} } eq 'CURRENT_TIMESTAMP';
311 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
312 L<DBIx::Class::Schema::Loader::DBI>
316 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
320 This library is free software; you can redistribute it and/or modify it under
321 the same terms as Perl itself.
326 # vim:et sw=4 sts=4 tw=0: