1 package DBIx::Class::Schema::Loader::DBI::InterBase;
5 use base qw/DBIx::Class::Schema::Loader::DBI/;
7 use Carp::Clan qw/^DBIx::Class/;
8 use List::Util 'first';
10 use DBIx::Class::Schema::Loader::Table ();
12 our $VERSION = '0.07033';
14 sub _supports_db_schema { 0 }
18 DBIx::Class::Schema::Loader::DBI::InterBase - DBIx::Class::Schema::Loader::DBI
19 Firebird Implementation.
23 See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
25 =head1 COLUMN NAME CASE ISSUES
27 By default column names from unquoted DDL will be generated in lowercase, for
28 consistency with other backends.
30 Set the L<preserve_case|DBIx::Class::Schema::Loader::Base/preserve_case> option
31 to true if you would like to have column names in the internal case, which is
32 uppercase for DDL that uses unquoted identifiers.
34 Do not use quoting (the L<quote_char|DBIx::Class::Storage::DBI/quote_char>
35 option in L<connect_info|DBIx::Class::Storage::DBI/connect_info> when in the
36 default C<< preserve_case => 0 >> mode.
38 Be careful to also not use any SQL reserved words in your DDL.
40 This will generate lowercase column names (as opposed to the actual uppercase
41 names) in your Result classes that will only work with quoting off.
43 Mixed-case table and column names will be ignored when this option is on and
44 will not work with quoting turned off.
51 $self->next::method(@_);
53 if (not defined $self->preserve_case) {
54 $self->preserve_case(0);
56 elsif ($self->preserve_case) {
57 $self->schema->storage->sql_maker->quote_char('"');
58 $self->schema->storage->sql_maker->name_sep('.');
61 if ($self->db_schema) {
62 carp "db_schema is not supported on Firebird";
64 if ($self->db_schema->[0] eq '%') {
65 $self->db_schema(undef);
71 my ($self, $table) = @_;
73 my $sth = $self->dbh->prepare(<<'EOF');
74 SELECT iseg.rdb$field_name
75 FROM rdb$relation_constraints rc
76 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
77 WHERE rc.rdb$constraint_type = 'PRIMARY KEY' and rc.rdb$relation_name = ?
78 ORDER BY iseg.rdb$field_position
80 $sth->execute($table->name);
84 while (my ($col) = $sth->fetchrow_array) {
85 s/^\s+//, s/\s+\z// for $col;
87 push @keydata, $self->_lc($col);
94 my ($self, $table) = @_;
96 my ($local_cols, $remote_cols, $remote_table, $attrs, @rels);
97 my $sth = $self->dbh->prepare(<<'EOF');
98 SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col
99 FROM rdb$relation_constraints rc
100 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
101 JOIN rdb$indices li ON rc.rdb$index_name = li.rdb$index_name
102 JOIN rdb$indices ri ON li.rdb$foreign_key = ri.rdb$index_name
103 JOIN rdb$index_segments riseg ON iseg.rdb$field_position = riseg.rdb$field_position and ri.rdb$index_name = riseg.rdb$index_name
104 WHERE rc.rdb$constraint_type = 'FOREIGN KEY' and rc.rdb$relation_name = ?
105 ORDER BY iseg.rdb$field_position
107 $sth->execute($table->name);
109 while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) {
110 s/^\s+//, s/\s+\z// for $fk, $local_col, $remote_tab, $remote_col;
112 push @{$local_cols->{$fk}}, $self->_lc($local_col);
114 push @{$remote_cols->{$fk}}, $self->_lc($remote_col);
116 $remote_table->{$fk} = DBIx::Class::Schema::Loader::Table->new(
119 ($self->db_schema ? (
120 schema => $self->db_schema->[0],
126 local $self->dbh->{LongReadLen} = 100_000;
127 local $self->dbh->{LongTruncOk} = 1;
134 $sth = $self->dbh->prepare_cached(<<'EOF');
135 select rdb$trigger_blr, rdb$trigger_type
137 where rdb$trigger_type in (4,6)
138 and rdb$system_flag > 0
139 and rdb$relation_name = ?
142 foreach my $fk (keys %$remote_table) {
143 my $uk_table = $remote_table->{$fk};
145 $sth->execute($uk_table);
147 while (my ($blr, $type) = $sth->fetchrow_array) {
148 $type = $RULE_FOR{$type};
150 print STDERR "GOT $type:\n";
152 print STDERR Dumper($blr), "\n";
156 foreach my $fk (keys %$remote_table) {
158 local_columns => $local_cols->{$fk},
159 remote_columns => $remote_cols->{$fk},
160 remote_table => $remote_table->{$fk},
166 sub _table_uniq_info {
167 my ($self, $table) = @_;
169 my $sth = $self->dbh->prepare(<<'EOF');
170 SELECT rc.rdb$constraint_name, iseg.rdb$field_name
171 FROM rdb$relation_constraints rc
172 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
173 WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ?
174 ORDER BY iseg.rdb$field_position
176 $sth->execute($table->name);
179 while (my ($constraint_name, $column) = $sth->fetchrow_array) {
180 s/^\s+//, s/\s+\z// for $constraint_name, $column;
182 push @{$constraints->{$constraint_name}}, $self->_lc($column);
185 my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
189 sub _columns_info_for {
193 my $result = $self->next::method(@_);
195 local $self->dbh->{LongReadLen} = 100000;
196 local $self->dbh->{LongTruncOk} = 1;
198 while (my ($column, $info) = each %$result) {
199 my $data_type = $info->{data_type};
201 my $sth = $self->dbh->prepare(<<'EOF');
202 SELECT t.rdb$trigger_source
204 WHERE t.rdb$relation_name = ?
205 AND t.rdb$system_flag = 0 -- user defined
206 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
208 $sth->execute($table->name);
210 while (my ($trigger) = $sth->fetchrow_array) {
211 my @trig_cols = map { /^"([^"]+)/ ? $1 : uc($_) } $trigger =~ /new\.("?\w+"?)/ig;
213 my ($quoted, $generator) = $trigger =~ /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
216 $generator = uc $generator unless $quoted;
218 if (first { $self->_uc($_) eq $self->_uc($column) } @trig_cols) {
219 $info->{is_auto_increment} = 1;
220 $info->{sequence} = $generator;
227 $sth = $self->dbh->prepare(<<'EOF');
228 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
230 JOIN rdb$relation_fields rf ON rf.rdb$field_source = f.rdb$field_name
231 LEFT JOIN rdb$types t ON f.rdb$field_type = t.rdb$type AND t.rdb$field_name = 'RDB$FIELD_TYPE'
232 LEFT JOIN rdb$types st ON f.rdb$field_sub_type = st.rdb$type AND st.rdb$field_name = 'RDB$FIELD_SUB_TYPE'
233 WHERE rf.rdb$relation_name = ?
234 AND rf.rdb$field_name = ?
236 $sth->execute($table->name, $self->_uc($column));
237 my ($precision, $scale, $type_num, $sub_type_num, $char_set_id, $char_length, $type_name, $sub_type_name) = $sth->fetchrow_array;
238 $scale = -$scale if $scale && $scale < 0;
240 if ($type_name && $sub_type_name) {
241 s/\s+\z// for $type_name, $sub_type_name;
243 # fixups primarily for DBD::InterBase
244 if ($data_type =~ /^(?:integer|int|smallint|bigint|-9581)\z/) {
245 if ($precision && $type_name =~ /^(?:LONG|INT64)\z/ && $sub_type_name eq 'BLR') {
246 $info->{data_type} = 'decimal';
248 elsif ($precision && $type_name =~ /^(?:LONG|SHORT|INT64)\z/ && $sub_type_name eq 'TEXT') {
249 $info->{data_type} = 'numeric';
251 elsif ((not $precision) && $type_name eq 'INT64' && $sub_type_name eq 'BINARY') {
252 $info->{data_type} = 'bigint';
255 # ODBC makes regular blobs sub_type blr
256 elsif ($type_name eq 'BLOB') {
257 if ($sub_type_name eq 'BINARY') {
258 $info->{data_type} = 'blob';
260 elsif ($sub_type_name eq 'TEXT') {
261 if (defined $char_set_id && $char_set_id == 3) {
262 $info->{data_type} = 'blob sub_type text character set unicode_fss';
265 $info->{data_type} = 'blob sub_type text';
271 $data_type = $info->{data_type};
273 if ($data_type =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) {
274 if ($precision == 9 && $scale == 0) {
275 delete $info->{size};
278 $info->{size} = [$precision, $scale];
282 if ($data_type eq '11') {
283 $info->{data_type} = 'timestamp';
285 elsif ($data_type eq '10') {
286 $info->{data_type} = 'time';
288 elsif ($data_type eq '9') {
289 $info->{data_type} = 'date';
291 elsif ($data_type eq 'character varying') {
292 $info->{data_type} = 'varchar';
294 elsif ($data_type eq 'character') {
295 $info->{data_type} = 'char';
297 elsif ($data_type eq 'float') {
298 $info->{data_type} = 'real';
300 elsif ($data_type eq 'int64' || $data_type eq '-9581') {
301 # the constant is just in case, the query should pick up the type
302 $info->{data_type} = 'bigint';
305 $data_type = $info->{data_type};
307 if ($data_type =~ /^(?:char|varchar)\z/) {
308 $info->{size} = $char_length;
310 if (defined $char_set_id && $char_set_id == 3) {
311 $info->{data_type} .= '(x) character set unicode_fss';
314 elsif ($data_type !~ /^(?:numeric|decimal)\z/) {
315 delete $info->{size};
319 delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL';
321 $sth = $self->dbh->prepare(<<'EOF');
322 SELECT rf.rdb$default_source
323 FROM rdb$relation_fields rf
324 WHERE rf.rdb$relation_name = ?
325 AND rf.rdb$field_name = ?
327 $sth->execute($table->name, $self->_uc($column));
328 my ($default_src) = $sth->fetchrow_array;
330 if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
331 if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
332 $info->{default_value} = $quoted;
335 $info->{default_value} = $def =~ /^-?\d/ ? $def : \$def;
339 ${ $info->{default_value} } = 'current_timestamp'
340 if ref $info->{default_value} && ${ $info->{default_value} } eq 'CURRENT_TIMESTAMP';
348 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
349 L<DBIx::Class::Schema::Loader::DBI>
353 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
357 This library is free software; you can redistribute it and/or modify it under
358 the same terms as Perl itself.
363 # vim:et sw=4 sts=4 tw=0: