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.06000';
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 $self->unquoted_ddl) {
62 $self->schema->storage->sql_maker->quote_char('"');
65 $self->schema->storage->sql_maker->quote_char(undef);
70 my ($self, $name) = @_;
72 return $self->unquoted_ddl ? lc($name) : $name;
76 my ($self, $name) = @_;
78 return $self->unquoted_ddl ? uc($name) : $name;
82 my ($self, $table) = @_;
84 my $dbh = $self->schema->storage->dbh;
85 my $sth = $dbh->prepare(<<'EOF');
86 SELECT iseg.rdb$field_name
87 FROM rdb$relation_constraints rc
88 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
89 WHERE rc.rdb$constraint_type = 'PRIMARY KEY' and rc.rdb$relation_name = ?
90 ORDER BY iseg.rdb$field_position
92 $sth->execute($table);
96 while (my ($col) = $sth->fetchrow_array) {
97 s/^\s+//, s/\s+\z// for $col;
99 push @keydata, $self->_lc($col);
106 my ($self, $table) = @_;
108 my ($local_cols, $remote_cols, $remote_table, @rels);
109 my $dbh = $self->schema->storage->dbh;
110 my $sth = $dbh->prepare(<<'EOF');
111 SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col
112 FROM rdb$relation_constraints rc
113 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
114 JOIN rdb$indices li ON rc.rdb$index_name = li.rdb$index_name
115 JOIN rdb$indices ri ON li.rdb$foreign_key = ri.rdb$index_name
116 JOIN rdb$index_segments riseg ON iseg.rdb$field_position = riseg.rdb$field_position and ri.rdb$index_name = riseg.rdb$index_name
117 WHERE rc.rdb$constraint_type = 'FOREIGN KEY' and rc.rdb$relation_name = ?
118 ORDER BY iseg.rdb$field_position
120 $sth->execute($table);
122 while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) {
123 s/^\s+//, s/\s+\z// for $fk, $local_col, $remote_tab, $remote_col;
125 push @{$local_cols->{$fk}}, $self->_lc($local_col);
126 push @{$remote_cols->{$fk}}, $self->_lc($remote_col);
127 $remote_table->{$fk} = $remote_tab;
130 foreach my $fk (keys %$remote_table) {
132 local_columns => $local_cols->{$fk},
133 remote_columns => $remote_cols->{$fk},
134 remote_table => $remote_table->{$fk},
140 sub _table_uniq_info {
141 my ($self, $table) = @_;
143 my $dbh = $self->schema->storage->dbh;
144 my $sth = $dbh->prepare(<<'EOF');
145 SELECT rc.rdb$constraint_name, iseg.rdb$field_name
146 FROM rdb$relation_constraints rc
147 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
148 WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ?
149 ORDER BY iseg.rdb$field_position
151 $sth->execute($table);
154 while (my ($constraint_name, $column) = $sth->fetchrow_array) {
155 s/^\s+//, s/\s+\z// for $constraint_name, $column;
157 push @{$constraints->{$constraint_name}}, $self->_lc($column);
160 my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
164 sub _extra_column_info {
165 my ($self, $table, $column, $info, $dbi_info) = @_;
168 my $dbh = $self->schema->storage->dbh;
170 local $dbh->{LongReadLen} = 100000;
171 local $dbh->{LongTruncOk} = 1;
173 my $sth = $dbh->prepare(<<'EOF');
174 SELECT t.rdb$trigger_source
176 WHERE t.rdb$relation_name = ?
177 AND t.rdb$system_flag = 0 -- user defined
178 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
180 $sth->execute($table);
182 while (my ($trigger) = $sth->fetchrow_array) {
183 my @trig_cols = map {
184 /^"([^"]+)/ ? $1 : uc($1)
185 } $trigger =~ /new\.("?\w+"?)/ig;
187 my ($quoted, $generator) = $trigger =~
188 /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
191 $generator = uc $generator unless $quoted;
193 if (first { $self->_uc($_) eq $self->_uc($column) } @trig_cols) {
194 $extra_info{is_auto_increment} = 1;
195 $extra_info{sequence} = $generator;
201 # fix up DT types, no idea which other types are fucked
202 if ($info->{data_type} eq '11') {
203 $extra_info{data_type} = 'TIMESTAMP';
205 elsif ($info->{data_type} eq '9') {
206 $extra_info{data_type} = 'DATE';
210 $sth = $dbh->prepare(<<'EOF');
211 SELECT rf.rdb$default_source
212 FROM rdb$relation_fields rf
213 WHERE rf.rdb$relation_name = ?
214 AND rf.rdb$field_name = ?
216 $sth->execute($table, $self->_uc($column));
217 my ($default_src) = $sth->fetchrow_array;
219 if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
220 if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
221 $extra_info{default_value} = $quoted;
224 $extra_info{default_value} = $def =~ /^\d/ ? $def : \$def;
233 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
234 L<DBIx::Class::Schema::Loader::DBI>
238 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
242 This library is free software; you can redistribute it and/or modify it under
243 the same terms as Perl itself.