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.05003';
  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::Base> for available options.
  21
  22 =cut
  23
  24 sub _is_case_sensitive { 1 }
  25
  26 sub _setup {
  27     my $self = shift;
  28
  29     $self->schema->storage->sql_maker->quote_char('"');
  30     $self->schema->storage->sql_maker->name_sep('.');
  31 }
  32
  33 sub _table_pk_info {
  34     my ($self, $table) = @_;
  35
  36     my $dbh = $self->schema->storage->dbh;
  37     my $sth = $dbh->prepare(<<'EOF');
  38 SELECT iseg.rdb$field_name
  39 FROM rdb$relation_constraints rc
  40 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
  41 WHERE rc.rdb$constraint_type = 'PRIMARY KEY' and rc.rdb$relation_name = ?
  42 ORDER BY iseg.rdb$field_position
  43 EOF
  44     $sth->execute($table);
  45
  46     my @keydata;
  47
  48     while (my ($col) = $sth->fetchrow_array) {
  49         s/^\s+//, s/\s+\z// for $col;
  50
  51         push @keydata, $col;
  52     }
  53
  54     return \@keydata;
  55 }
  56
  57 sub _table_fk_info {
  58     my ($self, $table) = @_;
  59
  60     my ($local_cols, $remote_cols, $remote_table, @rels);
  61     my $dbh = $self->schema->storage->dbh;
  62     my $sth = $dbh->prepare(<<'EOF');
  63 SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col
  64 FROM rdb$relation_constraints rc
  65 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
  66 JOIN rdb$indices li ON rc.rdb$index_name = li.rdb$index_name
  67 JOIN rdb$indices ri ON li.rdb$foreign_key = ri.rdb$index_name
  68 JOIN rdb$index_segments riseg ON iseg.rdb$field_position = riseg.rdb$field_position and ri.rdb$index_name = riseg.rdb$index_name
  69 WHERE rc.rdb$constraint_type = 'FOREIGN KEY' and rc.rdb$relation_name = ?
  70 ORDER BY iseg.rdb$field_position
  71 EOF
  72     $sth->execute($table);
  73
  74     while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) {
  75         s/^\s+//, s/\s+\z// for $fk, $local_col, $remote_tab, $remote_col;
  76
  77         push @{$local_cols->{$fk}},  $local_col;
  78         push @{$remote_cols->{$fk}}, $remote_col;
  79         $remote_table->{$fk} = $remote_tab;
  80     }
  81
  82     foreach my $fk (keys %$remote_table) {
  83         push @rels, {
  84             local_columns => $local_cols->{$fk},
  85             remote_columns => $remote_cols->{$fk},
  86             remote_table => $remote_table->{$fk},
  87         };
  88     }
  89     return \@rels;
  90 }
  91
  92 sub _table_uniq_info {
  93     my ($self, $table) = @_;
  94
  95     my $dbh = $self->schema->storage->dbh;
  96     my $sth = $dbh->prepare(<<'EOF');
  97 SELECT rc.rdb$constraint_name, iseg.rdb$field_name
  98 FROM rdb$relation_constraints rc
  99 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
 100 WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ?
 101 ORDER BY iseg.rdb$field_position
 102 EOF
 103     $sth->execute($table);
 104
 105     my $constraints;
 106     while (my ($constraint_name, $column) = $sth->fetchrow_array) {
 107         s/^\s+//, s/\s+\z// for $constraint_name, $column;
 108
 109         push @{$constraints->{$constraint_name}}, $column;
 110     }
 111
 112     my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
 113     return \@uniqs;
 114 }
 115
 116 sub _extra_column_info {
 117     my ($self, $table, $column, $info, $dbi_info) = @_;
 118     my %extra_info;
 119
 120     my $dbh = $self->schema->storage->dbh;
 121
 122     local $dbh->{LongReadLen} = 100000;
 123     local $dbh->{LongTruncOk} = 1;
 124
 125     my $sth = $dbh->prepare(<<'EOF');
 126 SELECT t.rdb$trigger_source
 127 FROM rdb$triggers t
 128 WHERE t.rdb$relation_name = ?
 129 AND t.rdb$system_flag = 0 -- user defined
 130 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
 131 EOF
 132     $sth->execute($table);
 133
 134     while (my ($trigger) = $sth->fetchrow_array) {
 135         my @trig_cols = map {
 136             /^"([^"]+)/ ? $1 : uc($1)
 137         } $trigger =~ /new\.("?\w+"?)/ig;
 138
 139         my ($quoted, $generator) = $trigger =~
 140 /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
 141
 142         if ($generator) {
 143             $generator = uc $generator unless $quoted;
 144
 145             if (first { $_ eq $column } @trig_cols) {
 146                 $extra_info{is_auto_increment} = 1;
 147                 $extra_info{sequence}          = $generator;
 148                 last;
 149             }
 150         }
 151     }
 152
 153 # fix up DT types, no idea which other types are fucked
 154     if ($info->{data_type} eq '11') {
 155         $extra_info{data_type} = 'TIMESTAMP';
 156     }
 157     elsif ($info->{data_type} eq '9') {
 158         $extra_info{data_type} = 'DATE';
 159     }
 160
 161 # get default
 162     $sth = $dbh->prepare(<<'EOF');
 163 SELECT rf.rdb$default_source
 164 FROM rdb$relation_fields rf
 165 WHERE rf.rdb$relation_name = ?
 166 AND rf.rdb$field_name = ?
 167 EOF
 168     $sth->execute($table, $column);
 169     my ($default_src) = $sth->fetchrow_array;
 170
 171     if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
 172         if (my ($quoted) = $def =~ /^'(.*?)'\z/) {
 173             $extra_info{default_value} = $quoted;
 174         }
 175         else {
 176             $extra_info{default_value} = $def =~ /^\d/ ? $def : \$def;
 177         }
 178     }
 179
 180     return \%extra_info;
 181 }
 182
 183 =head1 SEE ALSO
 184
 185 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 186 L<DBIx::Class::Schema::Loader::DBI>
 187
 188 =head1 AUTHOR
 189
 190 See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
 191
 192 =head1 LICENSE
 193
 194 This library is free software; you can redistribute it and/or modify it under
 195 the same terms as Perl itself.
 196
 197 =cut
 198
 199 1;