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