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