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=8976058be9c881cce563d96d82f17c7e97b281b5;hpb=9990e58f49603b81e3c1195c0e83595b0333c8df;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 8976058..8329f6a 100644
--- a/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm
+++ b/lib/DBIx/Class/Schema/Loader/DBI/InterBase.pm
@@ -2,17 +2,16 @@ package DBIx::Class::Schema::Loader::DBI::InterBase;
 
 use strict;
 use warnings;
-use namespace::autoclean;
-use Class::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 ();
 
-__PACKAGE__->mk_group_ro_accessors('simple', qw/
-    unquoted_ddl
-/);
+our $VERSION = '0.07047';
 
-our $VERSION = '0.07000';
+sub _supports_db_schema { 0 }
 
 =head1 NAME
 
@@ -21,21 +20,22 @@ Firebird Implementation.
 
 =head1 DESCRIPTION
 
-See L<DBIx::Class::Schema::Loader::Base> for available options.
+See L<DBIx::Class::Schema::Loader> and L<DBIx::Class::Schema::Loader::Base>.
 
-By default column names from unquoted DDL will be generated in uppercase, as
-that is the only way they will work with quoting on.
+=head1 COLUMN NAME CASE ISSUES
 
-See the L</unquoted_ddl> option in this driver if you would like to have
-lowercase column names.
+By default column names from unquoted DDL will be generated in lowercase, for
+consistency with other backends.
 
-=head1 DRIVER OPTIONS
+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
+uppercase for DDL that uses unquoted identifiers.
 
-=head2 unquoted_ddl
+Do not use quoting (the L<quote_char|DBIx::Class::Storage::DBI/quote_char>
+option in L<connect_info|DBIx::Class::Storage::DBI/connect_info> when in the
+default C<< preserve_case => 0 >> mode.
 
-Set this loader option if your DDL uses unquoted identifiers and you will not
-use quoting (the L<quote_char|DBIx::Class::Storage::DBI/quote_char> option in
-L<connect_info|DBIx::Class::Storage::DBI/connect_info>.)
+Be careful to also not use any SQL reserved words in your DDL.
 
 This will generate lowercase column names (as opposed to the actual uppercase
 names) in your Result classes that will only work with quoting off.
@@ -45,61 +45,39 @@ will not work with quoting turned off.
 
 =cut
 
-sub _is_case_sensitive {
-    my $self = shift;
-
-    return $self->unquoted_ddl ? 0 : 1;
-}
-
 sub _setup {
     my $self = shift;
 
-    $self->next::method;
-
-    $self->schema->storage->sql_maker->name_sep('.');
-
-    if (not defined $self->unquoted_ddl) {
-        warn <<'EOF';
-
-WARNING: Assuming mixed-case Firebird DDL, see the unquoted_ddl option in
-perldoc DBIx::Class::Schema::Loader::DBI::InterBase
-for more information.
+    $self->next::method(@_);
 
-EOF
+    if (not defined $self->preserve_case) {
+        $self->preserve_case(0);
     }
-
-    if (not $self->unquoted_ddl) {
+    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);
-    }
-}
-
-sub _lc {
-    my ($self, $name) = @_;
-
-    return $self->unquoted_ddl ? lc($name) : $name;
-}
 
-sub _uc {
-    my ($self, $name) = @_;
+    if ($self->db_schema) {
+        carp "db_schema is not supported on Firebird";
 
-    return $self->unquoted_ddl ? uc($name) : $name;
+        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;
 
@@ -116,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
@@ -127,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},
@@ -150,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) {
@@ -167,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 {
@@ -177,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;
@@ -209,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'
@@ -218,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';
                 }
@@ -243,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};
             }
@@ -257,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 'real') {
-            $info->{data_type} = '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)) {
@@ -305,22 +299,35 @@ EOF
                 $info->{default_value} = $quoted;
             }
             else {
-                $info->{default_value} = $def =~ /^\d/ ? $def : \$def;
+                $info->{default_value} = $def =~ /^-?\d/ ? $def : \$def;
             }
         }
+
+        ${ $info->{default_value} } = 'current_timestamp'
+            if ref $info->{default_value} && ${ $info->{default_value} } eq 'CURRENT_TIMESTAMP';
     }
 
     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