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.06000';
+sub _supports_db_schema { 0 }
=head1 NAME
=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.
=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;
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
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},
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) {
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 {
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;
}
# 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'
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';
}
$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};
}
}
}
- 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)) {
$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
projects / dbsrgits/DBIx-Class-Schema-Loader.git / blobdiff