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