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.07048_01';
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, @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);
113 push @{$remote_cols->{$fk}}, $self->_lc($remote_col);
114 $remote_table->{$fk} = DBIx::Class::Schema::Loader::Table->new(
117 ($self->db_schema ? (
118 schema => $self->db_schema->[0],
124 foreach my $fk (sort keys %$remote_table) {
126 local_columns => $local_cols->{$fk},
127 remote_columns => $remote_cols->{$fk},
128 remote_table => $remote_table->{$fk},
134 sub _table_uniq_info {
135 my ($self, $table) = @_;
137 my $sth = $self->dbh->prepare(<<'EOF');
138 SELECT rc.rdb$constraint_name, iseg.rdb$field_name
139 FROM rdb$relation_constraints rc
140 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
141 WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ?
142 ORDER BY iseg.rdb$field_position
144 $sth->execute($table->name);
147 while (my ($constraint_name, $column) = $sth->fetchrow_array) {
148 s/^\s+//, s/\s+\z// for $constraint_name, $column;
150 push @{$constraints->{$constraint_name}}, $self->_lc($column);
153 return [ map { [ $_ => $constraints->{$_} ] } sort keys %$constraints ];
156 sub _columns_info_for {
160 my $result = $self->next::method(@_);
162 local $self->dbh->{LongReadLen} = 100000;
163 local $self->dbh->{LongTruncOk} = 1;
165 while (my ($column, $info) = each %$result) {
166 my $data_type = $info->{data_type};
168 my $sth = $self->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->name);
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 = $self->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->name, $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 ($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 (defined $char_set_id && $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 $data_type = $info->{data_type};
240 if ($data_type =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) {
241 if ($precision == 9 && $scale == 0) {
242 delete $info->{size};
245 $info->{size} = [$precision, $scale];
249 if ($data_type eq '11') {
250 $info->{data_type} = 'timestamp';
252 elsif ($data_type eq '10') {
253 $info->{data_type} = 'time';
255 elsif ($data_type eq '9') {
256 $info->{data_type} = 'date';
258 elsif ($data_type eq 'character varying') {
259 $info->{data_type} = 'varchar';
261 elsif ($data_type eq 'character') {
262 $info->{data_type} = 'char';
264 elsif ($data_type eq 'float') {
265 $info->{data_type} = 'real';
267 elsif ($data_type eq 'int64' || $data_type eq '-9581') {
268 # the constant is just in case, the query should pick up the type
269 $info->{data_type} = 'bigint';
272 $data_type = $info->{data_type};
274 if ($data_type =~ /^(?:char|varchar)\z/) {
275 $info->{size} = $char_length;
277 if (defined $char_set_id && $char_set_id == 3) {
278 $info->{data_type} .= '(x) character set unicode_fss';
281 elsif ($data_type !~ /^(?:numeric|decimal)\z/) {
282 delete $info->{size};
286 delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL';
288 $sth = $self->dbh->prepare(<<'EOF');
289 SELECT rf.rdb$default_source
290 FROM rdb$relation_fields rf
291 WHERE rf.rdb$relation_name = ?
292 AND rf.rdb$field_name = ?
294 $sth->execute($table->name, $self->_uc($column));
295 my ($default_src) = $sth->fetchrow_array;
297 if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
298 if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
299 $info->{default_value} = $quoted;
302 $info->{default_value} = $def =~ /^-?\d/ ? $def : \$def;
306 ${ $info->{default_value} } = 'current_timestamp'
307 if ref $info->{default_value} && ${ $info->{default_value} } eq 'CURRENT_TIMESTAMP';
313 sub _view_definition {
314 my ($self, $view) = @_;
316 return scalar $self->schema->storage->dbh->selectrow_array(<<'EOF', {}, $view->name);
317 SELECT rdb$view_source
319 WHERE rdb$relation_name = ?
325 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
326 L<DBIx::Class::Schema::Loader::DBI>
330 See L<DBIx::Class::Schema::Loader/AUTHORS>.
334 This library is free software; you can redistribute it and/or modify it under
335 the same terms as Perl itself.
340 # vim:et sw=4 sts=4 tw=0: