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.07047';
  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 (sort 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     return [ map { [ $_ => $constraints->{$_} ] } sort keys %$constraints ];
 154 }
 155
 156 sub _columns_info_for {
 157     my $self = shift;
 158     my ($table) = @_;
 159
 160     my $result = $self->next::method(@_);
 161
 162     local $self->dbh->{LongReadLen} = 100000;
 163     local $self->dbh->{LongTruncOk} = 1;
 164
 165     while (my ($column, $info) = each %$result) {
 166         my $data_type = $info->{data_type};
 167
 168         my $sth = $self->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->name);
 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 = $self->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->name, $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 ($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 (defined $char_set_id && $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         $data_type = $info->{data_type};
 239
 240         if ($data_type =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) {
 241             if ($precision == 9 && $scale == 0) {
 242                 delete $info->{size};
 243             }
 244             else {
 245                 $info->{size} = [$precision, $scale];
 246             }
 247         }
 248
 249         if ($data_type eq '11') {
 250             $info->{data_type} = 'timestamp';
 251         }
 252         elsif ($data_type eq '10') {
 253             $info->{data_type} = 'time';
 254         }
 255         elsif ($data_type eq '9') {
 256             $info->{data_type} = 'date';
 257         }
 258         elsif ($data_type eq 'character varying') {
 259             $info->{data_type} = 'varchar';
 260         }
 261         elsif ($data_type eq 'character') {
 262             $info->{data_type} = 'char';
 263         }
 264         elsif ($data_type eq 'float') {
 265             $info->{data_type} = 'real';
 266         }
 267         elsif ($data_type eq 'int64' || $data_type eq '-9581') {
 268             # the constant is just in case, the query should pick up the type
 269             $info->{data_type} = 'bigint';
 270         }
 271
 272         $data_type = $info->{data_type};
 273
 274         if ($data_type =~ /^(?:char|varchar)\z/) {
 275             $info->{size} = $char_length;
 276
 277             if (defined $char_set_id && $char_set_id == 3) {
 278                 $info->{data_type} .= '(x) character set unicode_fss';
 279             }
 280         }
 281         elsif ($data_type !~ /^(?:numeric|decimal)\z/) {
 282             delete $info->{size};
 283         }
 284
 285 # get default
 286         delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL';
 287
 288         $sth = $self->dbh->prepare(<<'EOF');
 289 SELECT rf.rdb$default_source
 290 FROM rdb$relation_fields rf
 291 WHERE rf.rdb$relation_name = ?
 292 AND rf.rdb$field_name = ?
 293 EOF
 294         $sth->execute($table->name, $self->_uc($column));
 295         my ($default_src) = $sth->fetchrow_array;
 296
 297         if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
 298             if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
 299                 $info->{default_value} = $quoted;
 300             }
 301             else {
 302                 $info->{default_value} = $def =~ /^-?\d/ ? $def : \$def;
 303             }
 304         }
 305
 306         ${ $info->{default_value} } = 'current_timestamp'
 307             if ref $info->{default_value} && ${ $info->{default_value} } eq 'CURRENT_TIMESTAMP';
 308     }
 309
 310     return $result;
 311 }
 312
 313 sub _view_definition {
 314     my ($self, $view) = @_;
 315
 316     return scalar $self->schema->storage->dbh->selectrow_array(<<'EOF', {}, $view->name);
 317 SELECT rdb$view_source
 318 FROM rdb$relations
 319 WHERE rdb$relation_name = ?
 320 EOF
 321 }
 322
 323 =head1 SEE ALSO
 324
 325 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 326 L<DBIx::Class::Schema::Loader::DBI>
 327
 328 =head1 AUTHORS
 329
 330 See L<DBIx::Class::Schema::Loader/AUTHORS>.
 331
 332 =head1 LICENSE
 333
 334 This library is free software; you can redistribute it and/or modify it under
 335 the same terms as Perl itself.
 336
 337 =cut
 338
 339 1;
 340 # vim:et sw=4 sts=4 tw=0: