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 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 _extra_column_info {
 175     my ($self, $table, $column, $info, $dbi_info) = @_;
 176     my %extra_info;
 177
 178     my $dbh = $self->schema->storage->dbh;
 179
 180     local $dbh->{LongReadLen} = 100000;
 181     local $dbh->{LongTruncOk} = 1;
 182
 183     my $sth = $dbh->prepare(<<'EOF');
 184 SELECT t.rdb$trigger_source
 185 FROM rdb$triggers t
 186 WHERE t.rdb$relation_name = ?
 187 AND t.rdb$system_flag = 0 -- user defined
 188 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
 189 EOF
 190     $sth->execute($table);
 191
 192     while (my ($trigger) = $sth->fetchrow_array) {
 193         my @trig_cols = map {
 194             /^"([^"]+)/ ? $1 : uc($1)
 195         } $trigger =~ /new\.("?\w+"?)/ig;
 196
 197         my ($quoted, $generator) = $trigger =~
 198 /(?: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                 $extra_info{is_auto_increment} = 1;
 205                 $extra_info{sequence}          = $generator;
 206                 last;
 207             }
 208         }
 209     }
 210
 211 # fix up DT types, no idea which other types are fucked
 212     if ($info->{data_type} eq '11') {
 213         $extra_info{data_type} = 'TIMESTAMP';
 214     }
 215     elsif ($info->{data_type} eq '9') {
 216         $extra_info{data_type} = 'DATE';
 217     }
 218
 219 # get default
 220     $sth = $dbh->prepare(<<'EOF');
 221 SELECT rf.rdb$default_source
 222 FROM rdb$relation_fields rf
 223 WHERE rf.rdb$relation_name = ?
 224 AND rf.rdb$field_name = ?
 225 EOF
 226     $sth->execute($table, $self->_uc($column));
 227     my ($default_src) = $sth->fetchrow_array;
 228
 229     if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
 230         if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
 231             $extra_info{default_value} = $quoted;
 232         }
 233         else {
 234             $extra_info{default_value} = $def =~ /^\d/ ? $def : \$def;
 235         }
 236     }
 237
 238     return \%extra_info;
 239 }
 240
 241 =head1 SEE ALSO
 242
 243 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 244 L<DBIx::Class::Schema::Loader::DBI>
 245
 246 =head1 AUTHOR
 247
 248 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 249
 250 =head1 LICENSE
 251
 252 This library is free software; you can redistribute it and/or modify it under
 253 the same terms as Perl itself.
 254
 255 =cut
 256
 257 1;