lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm

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