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 our $VERSION = '0.07000';
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 uppercase, as
25 that is the only way they will work with quoting on.
27 See the L<preserve_case|DBIx::Class::Schema::Loader::Base/preserve_case> option
28 to false if you would like to have lowercase column names.
30 Setting this option is a good idea if your DDL uses unquoted identifiers and
31 you will not use quoting (the
32 L<quote_char|DBIx::Class::Storage::DBI/quote_char> option in
33 L<connect_info|DBIx::Class::Storage::DBI/connect_info>.)
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.
43 B<NOTE:> This option used to be called C<unquoted_ddl> but has been removed in
44 favor of the more generic option.
51 $self->next::method(@_);
53 $self->schema->storage->sql_maker->name_sep('.');
55 if (not defined $self->preserve_case) {
58 WARNING: Assuming mixed-case Firebird DDL, see
59 perldoc DBIx::Class::Schema::Loader::DBI::InterBase
60 and the 'preserve_case' option in
61 perldoc DBIx::Class::Schema::Loader::Base
65 $self->preserve_case(1);
68 if ($self->preserve_case) {
69 $self->schema->storage->sql_maker->quote_char('"');
72 $self->schema->storage->sql_maker->quote_char(undef);
77 my ($self, $table) = @_;
79 my $dbh = $self->schema->storage->dbh;
80 my $sth = $dbh->prepare(<<'EOF');
81 SELECT iseg.rdb$field_name
82 FROM rdb$relation_constraints rc
83 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
84 WHERE rc.rdb$constraint_type = 'PRIMARY KEY' and rc.rdb$relation_name = ?
85 ORDER BY iseg.rdb$field_position
87 $sth->execute($table);
91 while (my ($col) = $sth->fetchrow_array) {
92 s/^\s+//, s/\s+\z// for $col;
94 push @keydata, $self->_lc($col);
101 my ($self, $table) = @_;
103 my ($local_cols, $remote_cols, $remote_table, @rels);
104 my $dbh = $self->schema->storage->dbh;
105 my $sth = $dbh->prepare(<<'EOF');
106 SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col
107 FROM rdb$relation_constraints rc
108 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
109 JOIN rdb$indices li ON rc.rdb$index_name = li.rdb$index_name
110 JOIN rdb$indices ri ON li.rdb$foreign_key = ri.rdb$index_name
111 JOIN rdb$index_segments riseg ON iseg.rdb$field_position = riseg.rdb$field_position and ri.rdb$index_name = riseg.rdb$index_name
112 WHERE rc.rdb$constraint_type = 'FOREIGN KEY' and rc.rdb$relation_name = ?
113 ORDER BY iseg.rdb$field_position
115 $sth->execute($table);
117 while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) {
118 s/^\s+//, s/\s+\z// for $fk, $local_col, $remote_tab, $remote_col;
120 push @{$local_cols->{$fk}}, $self->_lc($local_col);
121 push @{$remote_cols->{$fk}}, $self->_lc($remote_col);
122 $remote_table->{$fk} = $remote_tab;
125 foreach my $fk (keys %$remote_table) {
127 local_columns => $local_cols->{$fk},
128 remote_columns => $remote_cols->{$fk},
129 remote_table => $remote_table->{$fk},
135 sub _table_uniq_info {
136 my ($self, $table) = @_;
138 my $dbh = $self->schema->storage->dbh;
139 my $sth = $dbh->prepare(<<'EOF');
140 SELECT rc.rdb$constraint_name, iseg.rdb$field_name
141 FROM rdb$relation_constraints rc
142 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
143 WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ?
144 ORDER BY iseg.rdb$field_position
146 $sth->execute($table);
149 while (my ($constraint_name, $column) = $sth->fetchrow_array) {
150 s/^\s+//, s/\s+\z// for $constraint_name, $column;
152 push @{$constraints->{$constraint_name}}, $self->_lc($column);
155 my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
159 sub _columns_info_for {
163 my $result = $self->next::method(@_);
165 my $dbh = $self->schema->storage->dbh;
167 local $dbh->{LongReadLen} = 100000;
168 local $dbh->{LongTruncOk} = 1;
170 while (my ($column, $info) = each %$result) {
171 my $sth = $dbh->prepare(<<'EOF');
172 SELECT t.rdb$trigger_source
174 WHERE t.rdb$relation_name = ?
175 AND t.rdb$system_flag = 0 -- user defined
176 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
178 $sth->execute($table);
180 while (my ($trigger) = $sth->fetchrow_array) {
181 my @trig_cols = map { /^"([^"]+)/ ? $1 : uc($_) } $trigger =~ /new\.("?\w+"?)/ig;
183 my ($quoted, $generator) = $trigger =~ /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
186 $generator = uc $generator unless $quoted;
188 if (first { $self->_uc($_) eq $self->_uc($column) } @trig_cols) {
189 $info->{is_auto_increment} = 1;
190 $info->{sequence} = $generator;
197 $sth = $dbh->prepare(<<'EOF');
198 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
200 JOIN rdb$relation_fields rf ON rf.rdb$field_source = f.rdb$field_name
201 LEFT JOIN rdb$types t ON f.rdb$field_type = t.rdb$type AND t.rdb$field_name = 'RDB$FIELD_TYPE'
202 LEFT JOIN rdb$types st ON f.rdb$field_sub_type = st.rdb$type AND st.rdb$field_name = 'RDB$FIELD_SUB_TYPE'
203 WHERE rf.rdb$relation_name = ?
204 AND rf.rdb$field_name = ?
206 $sth->execute($table, $self->_uc($column));
207 my ($precision, $scale, $type_num, $sub_type_num, $type_name, $sub_type_name) = $sth->fetchrow_array;
208 $scale = -$scale if $scale && $scale < 0;
210 if ($type_name && $sub_type_name) {
211 s/\s+\z// for $type_name, $sub_type_name;
213 # fixups primarily for DBD::InterBase
214 if ($info->{data_type} =~ /^(?:integer|int|smallint|bigint|-9581)\z/) {
215 if ($precision && $type_name =~ /^(?:LONG|INT64)\z/ && $sub_type_name eq 'BLR') {
216 $info->{data_type} = 'decimal';
218 elsif ($precision && $type_name =~ /^(?:LONG|SHORT|INT64)\z/ && $sub_type_name eq 'TEXT') {
219 $info->{data_type} = 'numeric';
221 elsif ((not $precision) && $type_name eq 'INT64' && $sub_type_name eq 'BINARY') {
222 $info->{data_type} = 'bigint';
225 # ODBC makes regular blobs sub_type blr
226 elsif ($type_name eq 'BLOB') {
227 if ($sub_type_name eq 'BINARY') {
228 $info->{data_type} = 'blob';
230 elsif ($sub_type_name eq 'TEXT') {
231 $info->{data_type} = 'blob sub_type text';
236 if ($info->{data_type} =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) {
237 if ($precision == 9 && $scale == 0) {
238 delete $info->{size};
241 $info->{size} = [$precision, $scale];
245 if ($info->{data_type} eq '11') {
246 $info->{data_type} = 'timestamp';
248 elsif ($info->{data_type} eq '10') {
249 $info->{data_type} = 'time';
251 elsif ($info->{data_type} eq '9') {
252 $info->{data_type} = 'date';
254 elsif ($info->{data_type} eq 'character varying') {
255 $info->{data_type} = 'varchar';
257 elsif ($info->{data_type} eq 'character') {
258 $info->{data_type} = 'char';
260 elsif ($info->{data_type} eq 'real') {
261 $info->{data_type} = 'float';
263 elsif ($info->{data_type} eq 'int64' || $info->{data_type} eq '-9581') {
264 # the constant is just in case, the query should pick up the type
265 $info->{data_type} = 'bigint';
268 # DBD::InterBase sets scale to '0' for some reason for char types
269 if ($info->{data_type} =~ /^(?:char|varchar)\z/ && ref($info->{size}) eq 'ARRAY') {
270 $info->{size} = $info->{size}[0];
272 elsif ($info->{data_type} !~ /^(?:char|varchar|numeric|decimal)\z/) {
273 delete $info->{size};
277 delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL';
279 $sth = $dbh->prepare(<<'EOF');
280 SELECT rf.rdb$default_source
281 FROM rdb$relation_fields rf
282 WHERE rf.rdb$relation_name = ?
283 AND rf.rdb$field_name = ?
285 $sth->execute($table, $self->_uc($column));
286 my ($default_src) = $sth->fetchrow_array;
288 if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
289 if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
290 $info->{default_value} = $quoted;
293 $info->{default_value} = $def =~ /^\d/ ? $def : \$def;
297 ${ $info->{default_value} } = 'current_timestamp'
298 if ref $info->{default_value} && ${ $info->{default_value} } eq 'CURRENT_TIMESTAMP';
306 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
307 L<DBIx::Class::Schema::Loader::DBI>
311 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
315 This library is free software; you can redistribute it and/or modify it under
316 the same terms as Perl itself.
321 # vim:et sw=4 sts=4 tw=0: