1package DBIx::Class::Schema::Loader::DBI::InterBase; 2 3use strict; 4use warnings; 5use base qw/DBIx::Class::Schema::Loader::DBI/; 6use mro 'c3'; 7use Carp::Clan qw/^DBIx::Class/; 8use List::Util 'first'; 9use namespace::clean; 10use DBIx::Class::Schema::Loader::Table (); 11 12our $VERSION = '0.07033'; 13 14sub _supports_db_schema { 0 } 15 16=head1 NAME 17 18DBIx::Class::Schema::Loader::DBI::InterBase - DBIx::Class::Schema::Loader::DBI 19Firebird Implementation. 20 21=head1 DESCRIPTION 22 23See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>. 24 25=head1 COLUMN NAME CASE ISSUES 26 27By default column names from unquoted DDL will be generated in lowercase, for 28consistency with other backends. 29 30Set the L<preserve_case|DBIx::Class::Schema::Loader::Base/preserve_case> option 31to true if you would like to have column names in the internal case, which is 32uppercase for DDL that uses unquoted identifiers. 33 34Do not use quoting (the L<quote_char|DBIx::Class::Storage::DBI/quote_char> 35option in L<connect_info|DBIx::Class::Storage::DBI/connect_info> when in the 36default C<< preserve_case => 0 >> mode. 37 38Be careful to also not use any SQL reserved words in your DDL. 39 40This will generate lowercase column names (as opposed to the actual uppercase 41names) in your Result classes that will only work with quoting off. 42 43Mixed-case table and column names will be ignored when this option is on and 44will not work with quoting turned off. 45 46=cut 47 48sub _setup { 49 my $self = shift; 50 51 $self->next::method(@_); 52 53 if (not defined $self->preserve_case) { 54 $self->preserve_case(0); 55 } 56 elsif ($self->preserve_case) { 57 $self->schema->storage->sql_maker->quote_char('"'); 58 $self->schema->storage->sql_maker->name_sep('.'); 59 } 60 61 if ($self->db_schema) { 62 carp "db_schema is not supported on Firebird"; 63 64 if ($self->db_schema->[0] eq '%') { 65 $self->db_schema(undef); 66 } 67 } 68} 69 70sub _table_pk_info { 71 my ($self, $table) = @_; 72 73 my $sth = $self->dbh->prepare(<<'EOF'); 74SELECT iseg.rdb$field_name 75FROM rdb$relation_constraints rc 76JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name 77WHERE rc.rdb$constraint_type = 'PRIMARY KEY' and rc.rdb$relation_name = ? 78ORDER BY iseg.rdb$field_position 79EOF 80 $sth->execute($table->name); 81 82 my @keydata; 83 84 while (my ($col) = $sth->fetchrow_array) { 85 s/^\s+//, s/\s+\z// for $col; 86 87 push @keydata, $self->_lc($col); 88 } 89 90 return \@keydata; 91} 92 93sub _table_fk_info { 94 my ($self, $table) = @_; 95 96 my ($local_cols, $remote_cols, $remote_table, @rels); 97 my $sth = $self->dbh->prepare(<<'EOF'); 98SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col 99FROM rdb$relation_constraints rc 100JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name 101JOIN rdb$indices li ON rc.rdb$index_name = li.rdb$index_name 102JOIN rdb$indices ri ON li.rdb$foreign_key = ri.rdb$index_name 103JOIN rdb$index_segments riseg ON iseg.rdb$field_position = riseg.rdb$field_position and ri.rdb$index_name = riseg.rdb$index_name 104WHERE rc.rdb$constraint_type = 'FOREIGN KEY' and rc.rdb$relation_name = ? 105ORDER BY iseg.rdb$field_position 106EOF 107 $sth->execute($table->name); 108 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; 111 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( 115 loader => $self, 116 name => $remote_tab, 117 ($self->db_schema ? ( 118 schema => $self->db_schema->[0], 119 ignore_schema => 1, 120 ) : ()), 121 ); 122 } 123 124 foreach my $fk (keys %$remote_table) { 125 push @rels, { 126 local_columns => $local_cols->{$fk}, 127 remote_columns => $remote_cols->{$fk}, 128 remote_table => $remote_table->{$fk}, 129 }; 130 } 131 return \@rels; 132} 133 134sub _table_uniq_info { 135 my ($self, $table) = @_; 136 137 my $sth = $self->dbh->prepare(<<'EOF'); 138SELECT rc.rdb$constraint_name, iseg.rdb$field_name 139FROM rdb$relation_constraints rc 140JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name 141WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ? 142ORDER BY iseg.rdb$field_position 143EOF 144 $sth->execute($table->name); 145 146 my $constraints; 147 while (my ($constraint_name, $column) = $sth->fetchrow_array) { 148 s/^\s+//, s/\s+\z// for $constraint_name, $column; 149 150 push @{$constraints->{$constraint_name}}, $self->_lc($column); 151 } 152 153 my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints; 154 return \@uniqs; 155} 156 157sub _columns_info_for { 158 my $self = shift; 159 my ($table) = @_; 160 161 my $result = $self->next::method(@_); 162 163 local $self->dbh->{LongReadLen} = 100000; 164 local $self->dbh->{LongTruncOk} = 1; 165 166 while (my ($column, $info) = each %$result) { 167 my $data_type = $info->{data_type}; 168 169 my $sth = $self->dbh->prepare(<<'EOF'); 170SELECT t.rdb$trigger_source 171FROM rdb$triggers t 172WHERE t.rdb$relation_name = ? 173AND t.rdb$system_flag = 0 -- user defined 174AND t.rdb$trigger_type = 1 -- BEFORE INSERT 175EOF 176 $sth->execute($table->name); 177 178 while (my ($trigger) = $sth->fetchrow_array) { 179 my @trig_cols = map { /^"([^"]+)/ ? $1 : uc($_) } $trigger =~ /new\.("?\w+"?)/ig; 180 181 my ($quoted, $generator) = $trigger =~ /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix; 182 183 if ($generator) { 184 $generator = uc $generator unless $quoted; 185 186 if (first { $self->_uc($_) eq $self->_uc($column) } @trig_cols) { 187 $info->{is_auto_increment} = 1; 188 $info->{sequence} = $generator; 189 last; 190 } 191 } 192 } 193 194# fix up types 195 $sth = $self->dbh->prepare(<<'EOF'); 196SELECT 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 197FROM rdb$fields f 198JOIN rdb$relation_fields rf ON rf.rdb$field_source = f.rdb$field_name 199LEFT JOIN rdb$types t ON f.rdb$field_type = t.rdb$type AND t.rdb$field_name = 'RDB$FIELD_TYPE' 200LEFT JOIN rdb$types st ON f.rdb$field_sub_type = st.rdb$type AND st.rdb$field_name = 'RDB$FIELD_SUB_TYPE' 201WHERE rf.rdb$relation_name = ? 202 AND rf.rdb$field_name = ? 203EOF 204 $sth->execute($table->name, $self->_uc($column)); 205 my ($precision, $scale, $type_num, $sub_type_num, $char_set_id, $char_length, $type_name, $sub_type_name) = $sth->fetchrow_array; 206 $scale = -$scale if $scale && $scale < 0; 207 208 if ($type_name && $sub_type_name) { 209 s/\s+\z// for $type_name, $sub_type_name; 210 211 # fixups primarily for DBD::InterBase 212 if ($data_type =~ /^(?:integer|int|smallint|bigint|-9581)\z/) { 213 if ($precision && $type_name =~ /^(?:LONG|INT64)\z/ && $sub_type_name eq 'BLR') { 214 $info->{data_type} = 'decimal'; 215 } 216 elsif ($precision && $type_name =~ /^(?:LONG|SHORT|INT64)\z/ && $sub_type_name eq 'TEXT') { 217 $info->{data_type} = 'numeric'; 218 } 219 elsif ((not $precision) && $type_name eq 'INT64' && $sub_type_name eq 'BINARY') { 220 $info->{data_type} = 'bigint'; 221 } 222 } 223 # ODBC makes regular blobs sub_type blr 224 elsif ($type_name eq 'BLOB') { 225 if ($sub_type_name eq 'BINARY') { 226 $info->{data_type} = 'blob'; 227 } 228 elsif ($sub_type_name eq 'TEXT') { 229 if (defined $char_set_id && $char_set_id == 3) { 230 $info->{data_type} = 'blob sub_type text character set unicode_fss'; 231 } 232 else { 233 $info->{data_type} = 'blob sub_type text'; 234 } 235 } 236 } 237 } 238 239 $data_type = $info->{data_type}; 240 241 if ($data_type =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) { 242 if ($precision == 9 && $scale == 0) { 243 delete $info->{size}; 244 } 245 else { 246 $info->{size} = [$precision, $scale]; 247 } 248 } 249 250 if ($data_type eq '11') { 251 $info->{data_type} = 'timestamp'; 252 } 253 elsif ($data_type eq '10') { 254 $info->{data_type} = 'time'; 255 } 256 elsif ($data_type eq '9') { 257 $info->{data_type} = 'date'; 258 } 259 elsif ($data_type eq 'character varying') { 260 $info->{data_type} = 'varchar'; 261 } 262 elsif ($data_type eq 'character') { 263 $info->{data_type} = 'char'; 264 } 265 elsif ($data_type eq 'float') { 266 $info->{data_type} = 'real'; 267 } 268 elsif ($data_type eq 'int64' || $data_type eq '-9581') { 269 # the constant is just in case, the query should pick up the type 270 $info->{data_type} = 'bigint'; 271 } 272 273 $data_type = $info->{data_type}; 274 275 if ($data_type =~ /^(?:char|varchar)\z/) { 276 $info->{size} = $char_length; 277 278 if (defined $char_set_id && $char_set_id == 3) { 279 $info->{data_type} .= '(x) character set unicode_fss'; 280 } 281 } 282 elsif ($data_type !~ /^(?:numeric|decimal)\z/) { 283 delete $info->{size}; 284 } 285 286# get default 287 delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL'; 288 289 $sth = $self->dbh->prepare(<<'EOF'); 290SELECT rf.rdb$default_source 291FROM rdb$relation_fields rf 292WHERE rf.rdb$relation_name = ? 293AND rf.rdb$field_name = ? 294EOF 295 $sth->execute($table->name, $self->_uc($column)); 296 my ($default_src) = $sth->fetchrow_array; 297 298 if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) { 299 if (my ($quoted) = $def =~ /^'(.*?)'\z/) { 300 $info->{default_value} = $quoted; 301 } 302 else { 303 $info->{default_value} = $def =~ /^-?\d/ ? $def : \$def; 304 } 305 } 306 307 ${ $info->{default_value} } = 'current_timestamp' 308 if ref $info->{default_value} && ${ $info->{default_value} } eq 'CURRENT_TIMESTAMP'; 309 } 310 311 return $result; 312} 313 314=head1 SEE ALSO 315 316L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>, 317L<DBIx::Class::Schema::Loader::DBI> 318 319=head1 AUTHOR 320 321See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>. 322 323=head1 LICENSE 324 325This library is free software; you can redistribute it and/or modify it under 326the same terms as Perl itself. 327 328=cut 329 3301; 331# vim:et sw=4 sts=4 tw=0: 332