1 package DBIx::Class::Schema::Loader::DBI::InterBase;
5 use namespace::autoclean;
7 use base qw/DBIx::Class::Schema::Loader::DBI/;
8 use Carp::Clan qw/^DBIx::Class/;
9 use List::Util 'first';
11 __PACKAGE__->mk_group_ro_accessors('simple', qw/
15 our $VERSION = '0.06001';
19 DBIx::Class::Schema::Loader::DBI::InterBase - DBIx::Class::Schema::Loader::DBI
20 Firebird Implementation.
24 See L<DBIx::Class::Schema::Loader::Base> for available options.
26 By default column names from unquoted DDL will be generated in uppercase, as
27 that is the only way they will work with quoting on.
29 See the L</unquoted_ddl> option in this driver if you would like to have
30 lowercase column names.
36 Set this loader option if your DDL uses unquoted identifiers and you will not
37 use quoting (the L<quote_char|DBIx::Class::Storage::DBI/quote_char> option in
38 L<connect_info|DBIx::Class::Storage::DBI/connect_info>.)
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.
48 sub _is_case_sensitive {
51 return $self->unquoted_ddl ? 0 : 1;
59 $self->schema->storage->sql_maker->name_sep('.');
61 if (not defined $self->unquoted_ddl) {
64 WARNING: Assuming mixed-case Firebird DDL, see the unquoted_ddl option in
65 perldoc DBIx::Class::Schema::Loader::DBI::InterBase
71 if (not $self->unquoted_ddl) {
72 $self->schema->storage->sql_maker->quote_char('"');
75 $self->schema->storage->sql_maker->quote_char(undef);
80 my ($self, $name) = @_;
82 return $self->unquoted_ddl ? lc($name) : $name;
86 my ($self, $name) = @_;
88 return $self->unquoted_ddl ? uc($name) : $name;
92 my ($self, $table) = @_;
94 my $dbh = $self->schema->storage->dbh;
95 my $sth = $dbh->prepare(<<'EOF');
96 SELECT iseg.rdb$field_name
97 FROM rdb$relation_constraints rc
98 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
99 WHERE rc.rdb$constraint_type = 'PRIMARY KEY' and rc.rdb$relation_name = ?
100 ORDER BY iseg.rdb$field_position
102 $sth->execute($table);
106 while (my ($col) = $sth->fetchrow_array) {
107 s/^\s+//, s/\s+\z// for $col;
109 push @keydata, $self->_lc($col);
116 my ($self, $table) = @_;
118 my ($local_cols, $remote_cols, $remote_table, @rels);
119 my $dbh = $self->schema->storage->dbh;
120 my $sth = $dbh->prepare(<<'EOF');
121 SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col
122 FROM rdb$relation_constraints rc
123 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
124 JOIN rdb$indices li ON rc.rdb$index_name = li.rdb$index_name
125 JOIN rdb$indices ri ON li.rdb$foreign_key = ri.rdb$index_name
126 JOIN rdb$index_segments riseg ON iseg.rdb$field_position = riseg.rdb$field_position and ri.rdb$index_name = riseg.rdb$index_name
127 WHERE rc.rdb$constraint_type = 'FOREIGN KEY' and rc.rdb$relation_name = ?
128 ORDER BY iseg.rdb$field_position
130 $sth->execute($table);
132 while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) {
133 s/^\s+//, s/\s+\z// for $fk, $local_col, $remote_tab, $remote_col;
135 push @{$local_cols->{$fk}}, $self->_lc($local_col);
136 push @{$remote_cols->{$fk}}, $self->_lc($remote_col);
137 $remote_table->{$fk} = $remote_tab;
140 foreach my $fk (keys %$remote_table) {
142 local_columns => $local_cols->{$fk},
143 remote_columns => $remote_cols->{$fk},
144 remote_table => $remote_table->{$fk},
150 sub _table_uniq_info {
151 my ($self, $table) = @_;
153 my $dbh = $self->schema->storage->dbh;
154 my $sth = $dbh->prepare(<<'EOF');
155 SELECT rc.rdb$constraint_name, iseg.rdb$field_name
156 FROM rdb$relation_constraints rc
157 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
158 WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ?
159 ORDER BY iseg.rdb$field_position
161 $sth->execute($table);
164 while (my ($constraint_name, $column) = $sth->fetchrow_array) {
165 s/^\s+//, s/\s+\z// for $constraint_name, $column;
167 push @{$constraints->{$constraint_name}}, $self->_lc($column);
170 my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
174 sub _columns_info_for {
178 my $result = $self->next::method(@_);
180 my $dbh = $self->schema->storage->dbh;
182 local $dbh->{LongReadLen} = 100000;
183 local $dbh->{LongTruncOk} = 1;
185 while (my ($column, $info) = each %$result) {
186 my $sth = $dbh->prepare(<<'EOF');
187 SELECT t.rdb$trigger_source
189 WHERE t.rdb$relation_name = ?
190 AND t.rdb$system_flag = 0 -- user defined
191 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
193 $sth->execute($table);
195 while (my ($trigger) = $sth->fetchrow_array) {
196 my @trig_cols = map { /^"([^"]+)/ ? $1 : uc($_) } $trigger =~ /new\.("?\w+"?)/ig;
198 my ($quoted, $generator) = $trigger =~ /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
201 $generator = uc $generator unless $quoted;
203 if (first { $self->_uc($_) eq $self->_uc($column) } @trig_cols) {
204 $info->{is_auto_increment} = 1;
205 $info->{sequence} = $generator;
212 $sth = $dbh->prepare(<<'EOF');
213 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
215 JOIN rdb$relation_fields rf ON rf.rdb$field_source = f.rdb$field_name
216 LEFT JOIN rdb$types t ON f.rdb$field_type = t.rdb$type AND t.rdb$field_name = 'RDB$FIELD_TYPE'
217 LEFT JOIN rdb$types st ON f.rdb$field_sub_type = st.rdb$type AND st.rdb$field_name = 'RDB$FIELD_SUB_TYPE'
218 WHERE rf.rdb$relation_name = ?
219 AND rf.rdb$field_name = ?
221 $sth->execute($table, $self->_uc($column));
222 my ($precision, $scale, $type_num, $sub_type_num, $type_name, $sub_type_name) = $sth->fetchrow_array;
223 $scale = -$scale if $scale && $scale < 0;
225 if ($type_name && $sub_type_name) {
226 s/\s+\z// for $type_name, $sub_type_name;
228 # fixups primarily for DBD::InterBase
229 if ($info->{data_type} =~ /^(?:integer|int|smallint|bigint|-9581)\z/) {
230 if ($precision && $type_name =~ /^(?:LONG|INT64)\z/ && $sub_type_name eq 'BLR') {
231 $info->{data_type} = 'decimal';
233 elsif ($precision && $type_name =~ /^(?:LONG|SHORT|INT64)\z/ && $sub_type_name eq 'TEXT') {
234 $info->{data_type} = 'numeric';
236 elsif ((not $precision) && $type_name eq 'INT64' && $sub_type_name eq 'BINARY') {
237 $info->{data_type} = 'bigint';
240 # ODBC makes regular blobs sub_type blr
241 elsif ($type_name eq 'BLOB') {
242 if ($sub_type_name eq 'BINARY') {
243 $info->{data_type} = 'blob';
245 elsif ($sub_type_name eq 'TEXT') {
246 $info->{data_type} = 'blob sub_type text';
251 if ($info->{data_type} =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) {
252 if ($precision == 9 && $scale == 0) {
253 delete $info->{size};
256 $info->{size} = [$precision, $scale];
260 if ($info->{data_type} eq '11') {
261 $info->{data_type} = 'timestamp';
263 elsif ($info->{data_type} eq '10') {
264 $info->{data_type} = 'time';
266 elsif ($info->{data_type} eq '9') {
267 $info->{data_type} = 'date';
269 elsif ($info->{data_type} eq 'character varying') {
270 $info->{data_type} = 'varchar';
272 elsif ($info->{data_type} eq 'character') {
273 $info->{data_type} = 'char';
275 elsif ($info->{data_type} eq 'real') {
276 $info->{data_type} = 'float';
278 elsif ($info->{data_type} eq 'int64' || $info->{data_type} eq '-9581') {
279 # the constant is just in case, the query should pick up the type
280 $info->{data_type} = 'bigint';
283 # DBD::InterBase sets scale to '0' for some reason for char types
284 if ($info->{data_type} =~ /^(?:char|varchar)\z/ && ref($info->{size}) eq 'ARRAY') {
285 $info->{size} = $info->{size}[0];
287 elsif ($info->{data_type} !~ /^(?:char|varchar|numeric|decimal)\z/) {
288 delete $info->{size};
292 delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL';
294 $sth = $dbh->prepare(<<'EOF');
295 SELECT rf.rdb$default_source
296 FROM rdb$relation_fields rf
297 WHERE rf.rdb$relation_name = ?
298 AND rf.rdb$field_name = ?
300 $sth->execute($table, $self->_uc($column));
301 my ($default_src) = $sth->fetchrow_array;
303 if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
304 if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
305 $info->{default_value} = $quoted;
308 $info->{default_value} = $def =~ /^\d/ ? $def : \$def;
318 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
319 L<DBIx::Class::Schema::Loader::DBI>
323 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
327 This library is free software; you can redistribute it and/or modify it under
328 the same terms as Perl itself.
333 # vim:et sw=4 sts=4 tw=0: