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.06000';
  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 $self->unquoted_ddl) {
  62         $self->schema->storage->sql_maker->quote_char('"');
  63     }
  64     else {
  65         $self->schema->storage->sql_maker->quote_char(undef);
  66     }
  67 }
  68
  69 sub _lc {
  70     my ($self, $name) = @_;
  71
  72     return $self->unquoted_ddl ? lc($name) : $name;
  73 }
  74
  75 sub _uc {
  76     my ($self, $name) = @_;
  77
  78     return $self->unquoted_ddl ? uc($name) : $name;
  79 }
  80
  81 sub _table_pk_info {
  82     my ($self, $table) = @_;
  83
  84     my $dbh = $self->schema->storage->dbh;
  85     my $sth = $dbh->prepare(<<'EOF');
  86 SELECT iseg.rdb$field_name
  87 FROM rdb$relation_constraints rc
  88 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
  89 WHERE rc.rdb$constraint_type = 'PRIMARY KEY' and rc.rdb$relation_name = ?
  90 ORDER BY iseg.rdb$field_position
  91 EOF
  92     $sth->execute($table);
  93
  94     my @keydata;
  95
  96     while (my ($col) = $sth->fetchrow_array) {
  97         s/^\s+//, s/\s+\z// for $col;
  98
  99         push @keydata, $self->_lc($col);
 100     }
 101
 102     return \@keydata;
 103 }
 104
 105 sub _table_fk_info {
 106     my ($self, $table) = @_;
 107
 108     my ($local_cols, $remote_cols, $remote_table, @rels);
 109     my $dbh = $self->schema->storage->dbh;
 110     my $sth = $dbh->prepare(<<'EOF');
 111 SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col
 112 FROM rdb$relation_constraints rc
 113 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
 114 JOIN rdb$indices li ON rc.rdb$index_name = li.rdb$index_name
 115 JOIN rdb$indices ri ON li.rdb$foreign_key = ri.rdb$index_name
 116 JOIN rdb$index_segments riseg ON iseg.rdb$field_position = riseg.rdb$field_position and ri.rdb$index_name = riseg.rdb$index_name
 117 WHERE rc.rdb$constraint_type = 'FOREIGN KEY' and rc.rdb$relation_name = ?
 118 ORDER BY iseg.rdb$field_position
 119 EOF
 120     $sth->execute($table);
 121
 122     while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) {
 123         s/^\s+//, s/\s+\z// for $fk, $local_col, $remote_tab, $remote_col;
 124
 125         push @{$local_cols->{$fk}},  $self->_lc($local_col);
 126         push @{$remote_cols->{$fk}}, $self->_lc($remote_col);
 127         $remote_table->{$fk} = $remote_tab;
 128     }
 129
 130     foreach my $fk (keys %$remote_table) {
 131         push @rels, {
 132             local_columns => $local_cols->{$fk},
 133             remote_columns => $remote_cols->{$fk},
 134             remote_table => $remote_table->{$fk},
 135         };
 136     }
 137     return \@rels;
 138 }
 139
 140 sub _table_uniq_info {
 141     my ($self, $table) = @_;
 142
 143     my $dbh = $self->schema->storage->dbh;
 144     my $sth = $dbh->prepare(<<'EOF');
 145 SELECT rc.rdb$constraint_name, iseg.rdb$field_name
 146 FROM rdb$relation_constraints rc
 147 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
 148 WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ?
 149 ORDER BY iseg.rdb$field_position
 150 EOF
 151     $sth->execute($table);
 152
 153     my $constraints;
 154     while (my ($constraint_name, $column) = $sth->fetchrow_array) {
 155         s/^\s+//, s/\s+\z// for $constraint_name, $column;
 156
 157         push @{$constraints->{$constraint_name}}, $self->_lc($column);
 158     }
 159
 160     my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
 161     return \@uniqs;
 162 }
 163
 164 sub _extra_column_info {
 165     my ($self, $table, $column, $info, $dbi_info) = @_;
 166     my %extra_info;
 167
 168     my $dbh = $self->schema->storage->dbh;
 169
 170     local $dbh->{LongReadLen} = 100000;
 171     local $dbh->{LongTruncOk} = 1;
 172
 173     my $sth = $dbh->prepare(<<'EOF');
 174 SELECT t.rdb$trigger_source
 175 FROM rdb$triggers t
 176 WHERE t.rdb$relation_name = ?
 177 AND t.rdb$system_flag = 0 -- user defined
 178 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
 179 EOF
 180     $sth->execute($table);
 181
 182     while (my ($trigger) = $sth->fetchrow_array) {
 183         my @trig_cols = map {
 184             /^"([^"]+)/ ? $1 : uc($1)
 185         } $trigger =~ /new\.("?\w+"?)/ig;
 186
 187         my ($quoted, $generator) = $trigger =~
 188 /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
 189
 190         if ($generator) {
 191             $generator = uc $generator unless $quoted;
 192
 193             if (first { $self->_uc($_) eq $self->_uc($column) } @trig_cols) {
 194                 $extra_info{is_auto_increment} = 1;
 195                 $extra_info{sequence}          = $generator;
 196                 last;
 197             }
 198         }
 199     }
 200
 201 # fix up DT types, no idea which other types are fucked
 202     if ($info->{data_type} eq '11') {
 203         $extra_info{data_type} = 'TIMESTAMP';
 204     }
 205     elsif ($info->{data_type} eq '9') {
 206         $extra_info{data_type} = 'DATE';
 207     }
 208
 209 # get default
 210     $sth = $dbh->prepare(<<'EOF');
 211 SELECT rf.rdb$default_source
 212 FROM rdb$relation_fields rf
 213 WHERE rf.rdb$relation_name = ?
 214 AND rf.rdb$field_name = ?
 215 EOF
 216     $sth->execute($table, $self->_uc($column));
 217     my ($default_src) = $sth->fetchrow_array;
 218
 219     if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
 220         if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
 221             $extra_info{default_value} = $quoted;
 222         }
 223         else {
 224             $extra_info{default_value} = $def =~ /^\d/ ? $def : \$def;
 225         }
 226     }
 227
 228     return \%extra_info;
 229 }
 230
 231 =head1 SEE ALSO
 232
 233 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 234 L<DBIx::Class::Schema::Loader::DBI>
 235
 236 =head1 AUTHOR
 237
 238 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 239
 240 =head1 LICENSE
 241
 242 This library is free software; you can redistribute it and/or modify it under
 243 the same terms as Perl itself.
 244
 245 =cut
 246
 247 1;