Revision history for Perl extension DBIx::Class::Schema::Loader
+ - fix some errors due to case issues (RT#75805)
+
0.07018 2012-03-27 05:55:10
- skip dbicdump tests on Win32 due to test fails (RT#75732)
- fix undefined warnings for DBDs without schemas
use mro 'c3';
use Try::Tiny;
use List::MoreUtils 'any';
+use Carp::Clan qw/^DBIx::Class/;
use namespace::clean;
use DBIx::Class::Schema::Loader::Table ();
my $col_name = $info->{COLUMN_NAME};
$col_name =~ s/^\"(.*)\"$/$1/;
- $col_name = $self->_lc($col_name);
-
my $extra_info = $self->_extra_column_info(
$table, $col_name, $column_info, $info
) || {};
my $extra_info = $self->_extra_column_info($table, $columns[$i], $column_info, $sth) || {};
$column_info = { %$column_info, %$extra_info };
- $result{ $self->_lc($columns[$i]) } = $column_info;
+ $result{ $columns[$i] } = $column_info;
}
$sth->finish;
}
}
+ # check for instances of the same column name with different case in preserve_case=0 mode
+ if (not $self->preserve_case) {
+ my %lc_colnames;
+
+ foreach my $col (keys %result) {
+ push @{ $lc_colnames{lc $col} }, $col;
+ }
+
+ if (keys %lc_colnames != keys %result) {
+ my @offending_colnames = map @$_, grep @$_ > 1, values %lc_colnames;
+
+ my $offending_colnames = join ", ", map "'$_'", @offending_colnames;
+
+ croak "columns $offending_colnames in table @{[ $table->sql_name ]} collide in preserve_case=0 mode. preserve_case=1 mode required";
+ }
+
+ # apply lowercasing
+ my %lc_result;
+
+ while (my ($col, $info) = each %result) {
+ $lc_result{ $self->_lc($col) } = $info;
+ }
+
+ %result = %lc_result;
+ }
+
return \%result;
}
return $result;
}
-# Trap and ignore OLE warnings from nonexistant comments tables.
-
-sub _table_comment {
- my $self = shift;
-
- my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
-
- local $SIG{__WARN__} = sub {
- $warn_handler->(@_) unless $_[0] =~ /cannot find the input table/;
- };
-
- $self->next::method(@_);
-}
-
-sub _column_comment {
- my $self = shift;
-
- my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
-
- local $SIG{__WARN__} = sub {
- $warn_handler->(@_) unless $_[0] =~ /cannot find the input table/;
- };
-
- $self->next::method(@_);
-}
-
-
=head1 SEE ALSO
L<DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS>,
=cut
-sub _table_comment {
- local $^W = 0; # invalid object warnings
- shift->next::method(@_);
-}
-
-sub _column_comment {
- local $^W = 0; # invalid object warnings
- shift->next::method(@_);
+# Silence ADO "Changed database context" warnings
+sub _switch_db {
+ my $self = shift;
+ my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
+ local $SIG{__WARN__} = sub {
+ $warn_handler->(@_) unless $_[0] =~ /Changed database context/;
+ };
+ return $self->next::method(@_);
}
=head1 SEE ALSO
sub _idx_colnames {
my ($self, $idx_info, $table_cols_by_colno) = @_;
- return [ map $self->_lc($table_cols_by_colno->{$_}), grep $_, map $idx_info->{$_}, map "part$_", (1..16) ];
+ return [ map $table_cols_by_colno->{$_}, grep $_, map $idx_info->{$_}, map "part$_", (1..16) ];
}
sub _colnames_by_colno {
EOF
$sth->execute($table);
my $cols = $sth->fetchall_hashref('colno');
- $cols = { map +($_, $cols->{$_}{colname}), keys %$cols };
+ $cols = { map +($_, $self->_lc($cols->{$_}{colname})), keys %$cols };
return $cols;
}
return grep !/^(?:#|guest|INFORMATION_SCHEMA|sys)/, @$owners;
}
+sub _current_db {
+ my $self = shift;
+ return ($self->dbh->selectrow_array('SELECT db_name()'))[0];
+}
+
+sub _switch_db {
+ my ($self, $db) = @_;
+ $self->dbh->do("use [$db]");
+}
+
sub _setup {
my $self = shift;
$self->next::method(@_);
- my ($current_db) = $self->dbh->selectrow_array('SELECT db_name()');
+ my $current_db = $self->_current_db;
if (ref $self->db_schema eq 'HASH') {
if (keys %{ $self->db_schema } < 2) {
# XXX why does databasepropertyex() not work over DBD::ODBC ?
#
# more on collations here: http://msdn.microsoft.com/en-us/library/ms143515.aspx
- my ($collation_name) =
- eval { $self->dbh->selectrow_array("SELECT collation_name FROM sys.databases WHERE name = @{[ $self->dbh->quote($db) ]}") }
- || eval { $self->dbh->selectrow_array("SELECT CAST(databasepropertyex(@{[ $self->dbh->quote($db) ]}, 'Collation') AS VARCHAR)") };
+
+ my $current_db = $self->_current_db;
+
+ $self->_switch_db($db);
+
+ my $collation_name =
+ (eval { $self->dbh->selectrow_array("SELECT collation_name FROM [$db].sys.databases WHERE name = @{[ $self->dbh->quote($db) ]}") })[0]
+ || (eval { $self->dbh->selectrow_array("SELECT CAST(databasepropertyex(@{[ $self->dbh->quote($db) ]}, 'Collation') AS VARCHAR)") })[0];
+
+ $self->_switch_db($current_db);
if (not $collation_name) {
warn <<"EOF";
my $db = $table->database;
- return $self->dbh->selectcol_arrayref(<<"EOF")
+ my $pk = $self->dbh->selectcol_arrayref(<<"EOF");
SELECT kcu.column_name
FROM [$db].INFORMATION_SCHEMA.TABLE_CONSTRAINTS tc
JOIN [$db].INFORMATION_SCHEMA.KEY_COLUMN_USAGE kcu
AND tc.constraint_type = 'PRIMARY KEY'
ORDER BY kcu.ordinal_position
EOF
+
+ $pk = [ map $self->_lc($_), @$pk ];
+
+ return $pk;
}
sub _table_fk_info {
my %rels;
while (my ($fk, $remote_schema, $remote_table, $col, $remote_col) = $sth->fetchrow_array) {
- push @{ $rels{$fk}{local_columns} }, $col;
- push @{ $rels{$fk}{remote_columns} }, $remote_col;
+ push @{ $rels{$fk}{local_columns} }, $self->_lc($col);
+ push @{ $rels{$fk}{remote_columns} }, $self->_lc($remote_col);
$rels{$fk}{remote_table} = DBIx::Class::Schema::Loader::Table::Sybase->new(
loader => $self,
FROM [$db].INFORMATION_SCHEMA.COLUMNS
WHERE table_name = @{[ $self->dbh->quote($table->name) ]}
AND table_schema = @{[ $self->dbh->quote($table->schema) ]}
- AND column_name = @{[ $self->dbh->quote($col) ]}
+ AND @{[ $self->preserve_case ?
+ "column_name = @{[ $self->dbh->quote($col) ]}"
+ :
+ "lower(column_name) = @{[ $self->dbh->quote(lc $col) ]}" ]}
EOF
$info->{data_type} = $data_type;
FROM [$db].sys.schemas
WHERE name = @{[ $self->dbh->quote($table->schema) ]}
)
-) AND name = @{[ $self->dbh->quote($col) ]}
+) AND @{[ $self->preserve_case ?
+ "name = @{[ $self->dbh->quote($col) ]}"
+ :
+ "lower(name) = @{[ $self->dbh->quote(lc $col) ]}" ]}
EOF
if ($is_identity) {
$info->{is_auto_increment} = 1;
c.relname = ?}
);
- $uniq_sth->execute($table->schema, $table);
+ $uniq_sth->execute($table->schema, $table->name);
while(my $row = $uniq_sth->fetchrow_arrayref) {
my ($tableid, $indexname, $col_nums) = @$row;
$col_nums =~ s/^\s+//;
foreach (@col_nums) {
$attr_sth->execute($tableid, $_);
my $name_aref = $attr_sth->fetchrow_arrayref;
- push(@col_names, $name_aref->[0]) if $name_aref;
+ push(@col_names, $self->_lc($name_aref->[0])) if $name_aref;
}
if(!@col_names) {
}
my ($precision) = $self->schema->storage->dbh
- ->selectrow_array(<<EOF, {}, $table, $col);
+ ->selectrow_array(<<EOF, {}, $table->name, $col);
SELECT datetime_precision
FROM information_schema.columns
WHERE table_name = ? and column_name = ?
elsif ($data_type =~ /^(?:bit(?: varying)?|varbit)\z/i) {
$info->{data_type} = 'varbit' if $data_type =~ /var/i;
- my ($precision) = $self->dbh->selectrow_array(<<EOF, {}, $table, $col);
+ my ($precision) = $self->dbh->selectrow_array(<<EOF, {}, $table->name, $col);
SELECT character_maximum_length
FROM information_schema.columns
WHERE table_name = ? and column_name = ?
$info->{is_auto_increment} = 1;
}
- my ($user_type) = $dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, $col);
+ my ($user_type) = $dbh->selectrow_array(<<'EOF', {}, $table->schema, $table->name, lc($col));
SELECT ut.type_name
FROM systabcol tc
JOIN systab t
ON t.creator = u.user_id
JOIN sysusertype ut
ON tc.user_type = ut.type_id
-WHERE u.user_name = ? AND t.table_name = ? AND tc.column_name = ?
+WHERE u.user_name = ? AND t.table_name = ? AND lower(tc.column_name) = ?
EOF
$info->{data_type} = $user_type if defined $user_type;
ON t.table_id = tc.table_id
JOIN sysuser u
ON t.creator = u.user_id
-WHERE u.user_name = ? AND t.table_name = ? AND tc.column_name = ?
+WHERE u.user_name = ? AND t.table_name = ? AND lower(tc.column_name) = ?
EOF
- $sth->execute($table->schema, $table->name, $col);
+ $sth->execute($table->schema, $table->name, lc($col));
my ($width, $scale) = $sth->fetchrow_array;
$sth->finish;
$sth->execute;
my $cols = $sth->fetchall_hashref('name');
+ # copy and case according to preserve_case mode
+ # no need to check for collisions, SQLite does not allow them
+ my %cols;
+ while (my ($col, $info) = each %$cols) {
+ $cols{ $self->_lc($col) } = $info;
+ }
+
my ($num_pk, $pk_col) = (0);
# SQLite doesn't give us the info we need to do this nicely :(
# If there is exactly one column marked PK, and its type is integer,
# set it is_auto_increment. This isn't 100%, but it's better than the
# alternatives.
while (my ($col_name, $info) = each %$result) {
- if ($cols->{$col_name}{pk}) {
- $num_pk ++;
- if (lc($cols->{$col_name}{type}) eq 'integer') {
+ if ($cols{$col_name}{pk}) {
+ $num_pk++;
+ if (lc($cols{$col_name}{type}) eq 'integer') {
$pk_col = $col_name;
}
}
delete $info->{size} if $data_type !~ /^(?: (?:var)?(?:char(?:acter)?|binary) | bit | year)\z/ix;
# information_schema is available in 5.0+
- my ($precision, $scale, $column_type, $default) = eval { $self->dbh->selectrow_array(<<'EOF', {}, $table, $col) };
+ my ($precision, $scale, $column_type, $default) = eval { $self->dbh->selectrow_array(<<'EOF', {}, $table->name, lc($col)) };
SELECT numeric_precision, numeric_scale, column_type, column_default
FROM information_schema.columns
-WHERE table_name = ? AND column_name = ?
+WHERE table_name = ? AND lower(column_name) = ?
EOF
my $has_information_schema = not $@;
FROM information_schema.tables
WHERE table_schema = schema()
AND table_name = ?
- }, undef, $table);
+ }, undef, $table->name);
};
# InnoDB likes to auto-append crap.
if (not $comment) {
FROM information_schema.columns
WHERE table_schema = schema()
AND table_name = ?
- AND column_name = ?
- }, undef, $table, $column_name);
+ AND lower(column_name) = ?
+ }, undef, $table->name, lc($column_name));
};
}
return $comment;
projects / dbsrgits/DBIx-Class-Schema-Loader.git / commitdiff