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.07039';
  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, @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         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
 134 sub _table_uniq_info {
 135     my ($self, $table) = @_;
 136
 137     my $sth = $self->dbh->prepare(<<'EOF');
 138 SELECT rc.rdb$constraint_name, iseg.rdb$field_name
 139 FROM rdb$relation_constraints rc
 140 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
 141 WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ?
 142 ORDER BY iseg.rdb$field_position
 143 EOF
 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
 157 sub _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');
 170 SELECT t.rdb$trigger_source
 171 FROM rdb$triggers t
 172 WHERE t.rdb$relation_name = ?
 173 AND t.rdb$system_flag = 0 -- user defined
 174 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
 175 EOF
 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');
 196 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
 197 FROM rdb$fields f
 198 JOIN rdb$relation_fields rf ON rf.rdb$field_source = f.rdb$field_name
 199 LEFT JOIN rdb$types t  ON f.rdb$field_type     = t.rdb$type  AND t.rdb$field_name  = 'RDB$FIELD_TYPE'
 200 LEFT JOIN rdb$types st ON f.rdb$field_sub_type = st.rdb$type AND st.rdb$field_name = 'RDB$FIELD_SUB_TYPE'
 201 WHERE rf.rdb$relation_name = ?
 202     AND rf.rdb$field_name  = ?
 203 EOF
 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');
 290 SELECT rf.rdb$default_source
 291 FROM rdb$relation_fields rf
 292 WHERE rf.rdb$relation_name = ?
 293 AND rf.rdb$field_name = ?
 294 EOF
 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
 316 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 317 L<DBIx::Class::Schema::Loader::DBI>
 318
 319 =head1 AUTHOR
 320
 321 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 322
 323 =head1 LICENSE
 324
 325 This library is free software; you can redistribute it and/or modify it under
 326 the same terms as Perl itself.
 327
 328 =cut
 329
 330 1;
 331 # vim:et sw=4 sts=4 tw=0: