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