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