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.07003';
  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, 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, $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                     $info->{data_type} = 'blob sub_type text';
 229                 }
 230             }
 231         }
 232
 233         if ($info->{data_type} =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) {
 234             if ($precision == 9 && $scale == 0) {
 235                 delete $info->{size};
 236             }
 237             else {
 238                 $info->{size} = [$precision, $scale];
 239             }
 240         }
 241
 242         if ($info->{data_type} eq '11') {
 243             $info->{data_type} = 'timestamp';
 244         }
 245         elsif ($info->{data_type} eq '10') {
 246             $info->{data_type} = 'time';
 247         }
 248         elsif ($info->{data_type} eq '9') {
 249             $info->{data_type} = 'date';
 250         }
 251         elsif ($info->{data_type} eq 'character varying') {
 252             $info->{data_type} = 'varchar';
 253         }
 254         elsif ($info->{data_type} eq 'character') {
 255             $info->{data_type} = 'char';
 256         }
 257         elsif ($info->{data_type} eq 'float') {
 258             $info->{data_type} = 'real';
 259         }
 260         elsif ($info->{data_type} eq 'int64' || $info->{data_type} eq '-9581') {
 261             # the constant is just in case, the query should pick up the type
 262             $info->{data_type} = 'bigint';
 263         }
 264
 265         # DBD::InterBase sets scale to '0' for some reason for char types
 266         if ($info->{data_type} =~ /^(?:char|varchar)\z/ && ref($info->{size}) eq 'ARRAY') {
 267             $info->{size} = $info->{size}[0];
 268         }
 269         elsif ($info->{data_type} !~ /^(?:char|varchar|numeric|decimal)\z/) {
 270             delete $info->{size};
 271         }
 272
 273 # get default
 274         delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL';
 275
 276         $sth = $dbh->prepare(<<'EOF');
 277 SELECT rf.rdb$default_source
 278 FROM rdb$relation_fields rf
 279 WHERE rf.rdb$relation_name = ?
 280 AND rf.rdb$field_name = ?
 281 EOF
 282         $sth->execute($table, $self->_uc($column));
 283         my ($default_src) = $sth->fetchrow_array;
 284
 285         if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
 286             if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
 287                 $info->{default_value} = $quoted;
 288             }
 289             else {
 290                 $info->{default_value} = $def =~ /^-?\d/ ? $def : \$def;
 291             }
 292         }
 293
 294         ${ $info->{default_value} } = 'current_timestamp'
 295             if ref $info->{default_value} && ${ $info->{default_value} } eq 'CURRENT_TIMESTAMP';
 296     }
 297
 298     return $result;
 299 }
 300
 301 =head1 SEE ALSO
 302
 303 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 304 L<DBIx::Class::Schema::Loader::DBI>
 305
 306 =head1 AUTHOR
 307
 308 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 309
 310 =head1 LICENSE
 311
 312 This library is free software; you can redistribute it and/or modify it under
 313 the same terms as Perl itself.
 314
 315 =cut
 316
 317 1;
 318 # vim:et sw=4 sts=4 tw=0: