X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FSchema%2FLoader%2FDBI%2FInterBase.pm;h=8329f6aab9eb7c197e1d8c14b10c3d91d6158bc2;hb=306bf770bf08b06f92863808b1938f2fc704acb0;hp=ced9b45a6e01c9d5678cae301801c35d06d07a7c;hpb=e94ccbea965501f951f77e650f5b0e589a967112;p=dbsrgits%2FDBIx-Class-Schema-Loader.git

diff --git a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm
index ced9b45..8329f6a 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm
@@ -2,13 +2,16 @@ package DBIx::Class::Schema::Loader::DBI::InterBase;
 
 use strict;
 use warnings;
-use mro 'c3';
 use base qw/DBIx::Class::Schema::Loader::DBI/;
+use mro 'c3';
 use Carp::Clan qw/^DBIx::Class/;
 use List::Util 'first';
 use namespace::clean;
+use DBIx::Class::Schema::Loader::Table ();
+
+our $VERSION = '0.07047';
 
-our $VERSION = '0.07006';
+sub _supports_db_schema { 0 }
 
 =head1 NAME
 
@@ -22,7 +25,7 @@ See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
 =head1 COLUMN NAME CASE ISSUES
 
 By default column names from unquoted DDL will be generated in lowercase, for
-consistency with other backends. 
+consistency with other backends.
 
 Set the L<preserve_case|DBIx::Class::Schema::Loader::Base/preserve_case> option
 to true if you would like to have column names in the internal case, which is
@@ -48,40 +51,33 @@ sub _setup {
     $self->next::method(@_);
 
     if (not defined $self->preserve_case) {
-        warn <<'EOF';
-
-WARNING: Assuming unquoted Firebird DDL, see
-perldoc DBIx::Class::Schema::Loader::DBI::InterBase
-and the 'preserve_case' option in
-perldoc DBIx::Class::Schema::Loader::Base
-for more information.
-
-EOF
         $self->preserve_case(0);
     }
-
-    if ($self->preserve_case) {
+    elsif ($self->preserve_case) {
         $self->schema->storage->sql_maker->quote_char('"');
         $self->schema->storage->sql_maker->name_sep('.');
     }
-    else {
-        $self->schema->storage->sql_maker->quote_char(undef);
-        $self->schema->storage->sql_maker->name_sep(undef);
+
+    if ($self->db_schema) {
+        carp "db_schema is not supported on Firebird";
+
+        if ($self->db_schema->[0] eq '%') {
+            $self->db_schema(undef);
+        }
     }
 }
 
 sub _table_pk_info {
     my ($self, $table) = @_;
 
-    my $dbh = $self->schema->storage->dbh;
-    my $sth = $dbh->prepare(<<'EOF');
+    my $sth = $self->dbh->prepare(<<'EOF');
 SELECT iseg.rdb$field_name
 FROM rdb$relation_constraints rc
 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
 WHERE rc.rdb$constraint_type = 'PRIMARY KEY' and rc.rdb$relation_name = ?
 ORDER BY iseg.rdb$field_position
 EOF
-    $sth->execute($table);
+    $sth->execute($table->name);
 
     my @keydata;
 
@@ -98,8 +94,7 @@ sub _table_fk_info {
     my ($self, $table) = @_;
 
     my ($local_cols, $remote_cols, $remote_table, @rels);
-    my $dbh = $self->schema->storage->dbh;
-    my $sth = $dbh->prepare(<<'EOF');
+    my $sth = $self->dbh->prepare(<<'EOF');
 SELECT rc.rdb$constraint_name fk, iseg.rdb$field_name local_col, ri.rdb$relation_name remote_tab, riseg.rdb$field_name remote_col
 FROM rdb$relation_constraints rc
 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
@@ -109,17 +104,24 @@ JOIN rdb$index_segments riseg ON iseg.rdb$field_position = riseg.rdb$field_posit
 WHERE rc.rdb$constraint_type = 'FOREIGN KEY' and rc.rdb$relation_name = ?
 ORDER BY iseg.rdb$field_position
 EOF
-    $sth->execute($table);
+    $sth->execute($table->name);
 
     while (my ($fk, $local_col, $remote_tab, $remote_col) = $sth->fetchrow_array) {
         s/^\s+//, s/\s+\z// for $fk, $local_col, $remote_tab, $remote_col;
 
         push @{$local_cols->{$fk}},  $self->_lc($local_col);
         push @{$remote_cols->{$fk}}, $self->_lc($remote_col);
-        $remote_table->{$fk} = $remote_tab;
+        $remote_table->{$fk} = DBIx::Class::Schema::Loader::Table->new(
+            loader => $self,
+            name   => $remote_tab,
+            ($self->db_schema ? (
+                schema        => $self->db_schema->[0],
+                ignore_schema => 1,
+            ) : ()),
+        );
     }
 
-    foreach my $fk (keys %$remote_table) {
+    foreach my $fk (sort keys %$remote_table) {
         push @rels, {
             local_columns => $local_cols->{$fk},
             remote_columns => $remote_cols->{$fk},
@@ -132,15 +134,14 @@ EOF
 sub _table_uniq_info {
     my ($self, $table) = @_;
 
-    my $dbh = $self->schema->storage->dbh;
-    my $sth = $dbh->prepare(<<'EOF');
+    my $sth = $self->dbh->prepare(<<'EOF');
 SELECT rc.rdb$constraint_name, iseg.rdb$field_name
 FROM rdb$relation_constraints rc
 JOIN rdb$index_segments iseg ON rc.rdb$index_name = iseg.rdb$index_name
 WHERE rc.rdb$constraint_type = 'UNIQUE' and rc.rdb$relation_name = ?
 ORDER BY iseg.rdb$field_position
 EOF
-    $sth->execute($table);
+    $sth->execute($table->name);
 
     my $constraints;
     while (my ($constraint_name, $column) = $sth->fetchrow_array) {
@@ -149,8 +150,7 @@ EOF
         push @{$constraints->{$constraint_name}}, $self->_lc($column);
     }
 
-    my @uniqs = map { [ $_ => $constraints->{$_} ] } keys %$constraints;
-    return \@uniqs;
+    return [ map { [ $_ => $constraints->{$_} ] } sort keys %$constraints ];
 }
 
 sub _columns_info_for {
@@ -159,20 +159,20 @@ sub _columns_info_for {
 
     my $result = $self->next::method(@_);
 
-    my $dbh = $self->schema->storage->dbh;
-
-    local $dbh->{LongReadLen} = 100000;
-    local $dbh->{LongTruncOk} = 1;
+    local $self->dbh->{LongReadLen} = 100000;
+    local $self->dbh->{LongTruncOk} = 1;
 
     while (my ($column, $info) = each %$result) {
-        my $sth = $dbh->prepare(<<'EOF');
+        my $data_type = $info->{data_type};
+
+        my $sth = $self->dbh->prepare(<<'EOF');
 SELECT t.rdb$trigger_source
 FROM rdb$triggers t
 WHERE t.rdb$relation_name = ?
 AND t.rdb$system_flag = 0 -- user defined
 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
 EOF
-        $sth->execute($table);
+        $sth->execute($table->name);
 
         while (my ($trigger) = $sth->fetchrow_array) {
             my @trig_cols = map { /^"([^"]+)/ ? $1 : uc($_) } $trigger =~ /new\.("?\w+"?)/ig;
@@ -191,8 +191,8 @@ EOF
         }
 
 # fix up types
-        $sth = $dbh->prepare(<<'EOF');
-SELECT f.rdb$field_precision, f.rdb$field_scale, f.rdb$field_type, f.rdb$field_sub_type, t.rdb$type_name, st.rdb$type_name
+        $sth = $self->dbh->prepare(<<'EOF');
+SELECT f.rdb$field_precision, f.rdb$field_scale, f.rdb$field_type, f.rdb$field_sub_type, f.rdb$character_set_id, f.rdb$character_length, t.rdb$type_name, st.rdb$type_name
 FROM rdb$fields f
 JOIN rdb$relation_fields rf ON rf.rdb$field_source = f.rdb$field_name
 LEFT JOIN rdb$types t  ON f.rdb$field_type     = t.rdb$type  AND t.rdb$field_name  = 'RDB$FIELD_TYPE'
@@ -200,15 +200,15 @@ LEFT JOIN rdb$types st ON f.rdb$field_sub_type = st.rdb$type AND st.rdb$field_na
 WHERE rf.rdb$relation_name = ?
     AND rf.rdb$field_name  = ?
 EOF
-        $sth->execute($table, $self->_uc($column));
-        my ($precision, $scale, $type_num, $sub_type_num, $type_name, $sub_type_name) = $sth->fetchrow_array;
+        $sth->execute($table->name, $self->_uc($column));
+        my ($precision, $scale, $type_num, $sub_type_num, $char_set_id, $char_length, $type_name, $sub_type_name) = $sth->fetchrow_array;
         $scale = -$scale if $scale && $scale < 0;
 
         if ($type_name && $sub_type_name) {
             s/\s+\z// for $type_name, $sub_type_name;
 
             # fixups primarily for DBD::InterBase
-            if ($info->{data_type} =~ /^(?:integer|int|smallint|bigint|-9581)\z/) {
+            if ($data_type =~ /^(?:integer|int|smallint|bigint|-9581)\z/) {
                 if ($precision && $type_name =~ /^(?:LONG|INT64)\z/ && $sub_type_name eq 'BLR') {
                     $info->{data_type} = 'decimal';
                 }
@@ -225,12 +225,19 @@ EOF
                     $info->{data_type} = 'blob';
                 }
                 elsif ($sub_type_name eq 'TEXT') {
-                    $info->{data_type} = 'blob sub_type text';
+                    if (defined $char_set_id && $char_set_id == 3) {
+                        $info->{data_type} = 'blob sub_type text character set unicode_fss';
+                    }
+                    else {
+                        $info->{data_type} = 'blob sub_type text';
+                    }
                 }
             }
         }
 
-        if ($info->{data_type} =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) {
+        $data_type = $info->{data_type};
+
+        if ($data_type =~ /^(?:decimal|numeric)\z/ && defined $precision && defined $scale) {
             if ($precision == 9 && $scale == 0) {
                 delete $info->{size};
             }
@@ -239,47 +246,52 @@ EOF
             }
         }
 
-        if ($info->{data_type} eq '11') {
+        if ($data_type eq '11') {
             $info->{data_type} = 'timestamp';
         }
-        elsif ($info->{data_type} eq '10') {
+        elsif ($data_type eq '10') {
             $info->{data_type} = 'time';
         }
-        elsif ($info->{data_type} eq '9') {
+        elsif ($data_type eq '9') {
             $info->{data_type} = 'date';
         }
-        elsif ($info->{data_type} eq 'character varying') {
+        elsif ($data_type eq 'character varying') {
             $info->{data_type} = 'varchar';
         }
-        elsif ($info->{data_type} eq 'character') {
+        elsif ($data_type eq 'character') {
             $info->{data_type} = 'char';
         }
-        elsif ($info->{data_type} eq 'float') {
+        elsif ($data_type eq 'float') {
             $info->{data_type} = 'real';
         }
-        elsif ($info->{data_type} eq 'int64' || $info->{data_type} eq '-9581') {
+        elsif ($data_type eq 'int64' || $data_type eq '-9581') {
             # the constant is just in case, the query should pick up the type
             $info->{data_type} = 'bigint';
         }
 
-        # DBD::InterBase sets scale to '0' for some reason for char types
-        if ($info->{data_type} =~ /^(?:char|varchar)\z/ && ref($info->{size}) eq 'ARRAY') {
-            $info->{size} = $info->{size}[0];
+        $data_type = $info->{data_type};
+
+        if ($data_type =~ /^(?:char|varchar)\z/) {
+            $info->{size} = $char_length;
+
+            if (defined $char_set_id && $char_set_id == 3) {
+                $info->{data_type} .= '(x) character set unicode_fss';
+            }
         }
-        elsif ($info->{data_type} !~ /^(?:char|varchar|numeric|decimal)\z/) {
+        elsif ($data_type !~ /^(?:numeric|decimal)\z/) {
             delete $info->{size};
         }
 
 # get default
         delete $info->{default_value} if $info->{default_value} && $info->{default_value} eq 'NULL';
 
-        $sth = $dbh->prepare(<<'EOF');
+        $sth = $self->dbh->prepare(<<'EOF');
 SELECT rf.rdb$default_source
 FROM rdb$relation_fields rf
 WHERE rf.rdb$relation_name = ?
 AND rf.rdb$field_name = ?
 EOF
-        $sth->execute($table, $self->_uc($column));
+        $sth->execute($table->name, $self->_uc($column));
         my ($default_src) = $sth->fetchrow_array;
 
         if ($default_src && (my ($def) = $default_src =~ /^DEFAULT \s+ (\S+)/ix)) {
@@ -298,14 +310,24 @@ EOF
     return $result;
 }
 
+sub _view_definition {
+    my ($self, $view) = @_;
+
+    return scalar $self->schema->storage->dbh->selectrow_array(<<'EOF', {}, $view->name);
+SELECT rdb$view_source
+FROM rdb$relations
+WHERE rdb$relation_name = ?
+EOF
+}
+
 =head1 SEE ALSO
 
 L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
 L<DBIx::Class::Schema::Loader::DBI>
 
-=head1 AUTHOR
+=head1 AUTHORS
 
-See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+See L<DBIx::Class::Schema::Loader/AUTHORS>.
 
 =head1 LICENSE