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.07007';
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, 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, $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 $info->{data_type} = 'blob sub_type text';
233 if ($info->{data_type} =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) {
234 if ($precision == 9 && $scale == 0) {
235 delete $info->{size};
238 $info->{size} = [$precision, $scale];
242 if ($info->{data_type} eq '11') {
243 $info->{data_type} = 'timestamp';
245 elsif ($info->{data_type} eq '10') {
246 $info->{data_type} = 'time';
248 elsif ($info->{data_type} eq '9') {
249 $info->{data_type} = 'date';
251 elsif ($info->{data_type} eq 'character varying') {
252 $info->{data_type} = 'varchar';
254 elsif ($info->{data_type} eq 'character') {
255 $info->{data_type} = 'char';
257 elsif ($info->{data_type} eq 'float') {
258 $info->{data_type} = 'real';
260 elsif ($info->{data_type} eq 'int64' || $info->{data_type} eq '-9581') {
261 # the constant is just in case, the query should pick up the type
262 $info->{data_type} = 'bigint';
265 # DBD::InterBase sets scale to '0' for some reason for char types
266 if ($info->{data_type} =~ /^(?:char|varchar)\z/ && ref($info->{size}) eq 'ARRAY') {
267 $info->{size} = $info->{size}[0];
269 elsif ($info->{data_type} !~ /^(?:char|varchar|numeric|decimal)\z/) {
270 delete $info->{size};
274 delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL';
276 $sth = $dbh->prepare(<<'EOF');
277 SELECT rf.rdb$default_source
278 FROM rdb$relation_fields rf
279 WHERE rf.rdb$relation_name = ?
280 AND rf.rdb$field_name = ?
282 $sth->execute($table, $self->_uc($column));
283 my ($default_src) = $sth->fetchrow_array;
285 if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
286 if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
287 $info->{default_value} = $quoted;
290 $info->{default_value} = $def =~ /^-?\d/ ? $def : \$def;
294 ${ $info->{default_value} } = 'current_timestamp'
295 if ref $info->{default_value} && ${ $info->{default_value} } eq 'CURRENT_TIMESTAMP';
303 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
304 L<DBIx::Class::Schema::Loader::DBI>
308 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
312 This library is free software; you can redistribute it and/or modify it under
313 the same terms as Perl itself.
318 # vim:et sw=4 sts=4 tw=0: