my $table_class = $self->classes->{$table};
my $table_moniker = $self->monikers->{$table};
- $self->_dbic_stmt($table_class,'table',$table);
+ my $table_name = $table;
+ my $name_sep = $self->schema->storage->sql_maker->name_sep;
+
+ if ($name_sep && $table_name =~ /\Q$name_sep\E/) {
+ $table_name = \ $self->_quote_table_name($table_name);
+ }
+
+ $self->_dbic_stmt($table_class,'table',$table_name);
my $cols = $self->_table_columns($table);
my $col_info;
$self->_dbic_stmt($table_class,'add_columns',@$cols);
}
else {
- my %col_info_lc = map { lc($_), $col_info->{$_} } keys %$col_info;
+ if ($self->_is_case_sensitive) {
+ for my $col (keys %$col_info) {
+ $col_info->{$col}{accessor} = lc $col
+ if $col ne lc($col);
+ }
+ } else {
+ $col_info = { map { lc($_), $col_info->{$_} } keys %$col_info };
+ }
+
my $fks = $self->_table_fk_info($table);
+
for my $fkdef (@$fks) {
for my $col (@{ $fkdef->{local_columns} }) {
- $col_info_lc{$col}->{is_foreign_key} = 1;
+ $col_info->{$col}{is_foreign_key} = 1;
}
}
$self->_dbic_stmt(
$table_class,
'add_columns',
- map { $_, ($col_info_lc{$_}||{}) } @$cols
+ map { $_, ($col_info->{$_}||{}) } @$cols
);
}
push(@{$self->{_ext_storage}->{$class}}, $stmt);
}
+sub _quote_table_name {
+ my ($self, $table) = @_;
+
+ my $qt = $self->schema->storage->sql_maker->quote_char;
+
+ return $table unless $qt;
+
+ if (ref $qt) {
+ return $qt->[0] . $table . $qt->[1];
+ }
+
+ return $qt . $table . $qt;
+}
+
+sub _is_case_sensitive { 0 }
+
=head2 monikers
Returns a hashref of loaded table to moniker mappings. There will
my $dbh = $self->schema->storage->dbh;
my @tables = $dbh->tables(undef, $self->db_schema, $table, $type);
- s/\Q$self->{_quoter}\E//g for @tables;
- s/^.*\Q$self->{_namesep}\E// for @tables;
+ my $qt = qr/\Q$self->{_quoter}\E/;
+
+ if ($self->{_quoter} && $tables[0] =~ /$qt/) {
+ s/.* $qt (?= .* $qt)//xg for @tables;
+ } else {
+ s/^.*\Q$self->{_namesep}\E// for @tables;
+ }
+ s/$qt//g for @tables;
return @tables;
}
my $dbh = $self->schema->storage->dbh;
if($self->{db_schema}) {
- $table = $self->{db_schema} . $self->{_namesep} . $table;
+ $table = $self->{db_schema} . $self->{_namesep} .
+ $self->_quote_table_name($table);
+ } else {
+ $table = $self->_quote_table_name($table);
}
- my $sth = $dbh->prepare($self->schema->storage->sql_maker->select($table, undef, \'1 = 0'));
+ my $sth = $dbh->prepare($self->schema->storage->sql_maker->select(\$table, undef, \'1 = 0'));
$sth->execute;
my $retval = \@{$sth->{NAME_lc}};
$sth->finish;
use strict;
use warnings;
-use base 'DBIx::Class::Schema::Loader::DBI';
+use base qw/
+ DBIx::Class::Schema::Loader::DBI
+ DBIx::Class::Schema::Loader::DBI::Sybase::Common
+/;
use Carp::Clan qw/^DBIx::Class/;
use Class::C3;
my $self = shift;
$self->next::method(@_);
- $self->{db_schema} ||= 'dbo';
+ $self->{db_schema} ||= $self->_build_db_schema;
+ $self->_set_quote_char_and_name_sep;
}
-# DBD::Sybase doesn't implement get_info properly
-#sub _build_quoter { [qw/[ ]/] }
-sub _build_quoter { '"' }
-sub _build_namesep { '.' }
-
sub _table_pk_info {
my ($self, $table) = @_;
my $dbh = $self->schema->storage->dbh;
Justin Hunter C<justin.d.hunter@gmail.com>
+=head1 CONTRIBUTORS
+
+Rafael Kitover <rkitover@cpan.org>
+
=cut
1;
use strict;
use warnings;
-use base 'DBIx::Class::Schema::Loader::DBI';
+use base qw/
+ DBIx::Class::Schema::Loader::DBI
+ DBIx::Class::Schema::Loader::DBI::Sybase::Common
+/;
use Carp::Clan qw/^DBIx::Class/;
use Class::C3;
=cut
+sub _is_case_sensitive { 1 }
+
sub _setup {
my $self = shift;
$self->next::method(@_);
- $self->{db_schema} ||= 'dbo';
+ $self->{db_schema} ||= $self->_build_db_schema;
+ $self->_set_quote_char_and_name_sep;
}
sub _rebless {
my @keydata;
while (my $row = $sth->fetchrow_hashref) {
- push @keydata, lc $row->{column_name};
+ push @keydata, $row->{column_name};
}
return \@keydata;
sub _table_fk_info {
my ($self, $table) = @_;
+ # check if FK_NAME is supported
+
+ my $dbh = $self->schema->storage->dbh;
+ local $dbh->{FetchHashKeyName} = 'NAME_lc';
+ # hide "Object does not exist in this database." when trying to fetch fkeys
+ local $dbh->{syb_err_handler} = sub { return $_[0] == 17461 ? 0 : 1 };
+ my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = '$table'});
+ $sth->execute;
+ my $row = $sth->fetchrow_hashref;
+
+ return unless $row;
+
+ if (exists $row->{fk_name}) {
+ $sth->finish;
+ return $self->_table_fk_info_by_name($table);
+ }
+
+ $sth->finish;
+ return $self->_table_fk_info_builder($table);
+}
+
+sub _table_fk_info_by_name {
+ my ($self, $table) = @_;
my ($local_cols, $remote_cols, $remote_table, @rels);
+
my $dbh = $self->schema->storage->dbh;
+ local $dbh->{FetchHashKeyName} = 'NAME_lc';
# hide "Object does not exist in this database." when trying to fetch fkeys
- $dbh->{syb_err_handler} = sub { return 0 if $_[0] == 17461; };
- my $sth = $dbh->prepare(qq{sp_fkeys \@FKTABLE_NAME = '$table'});
+ local $dbh->{syb_err_handler} = sub { return $_[0] == 17461 ? 0 : 1 };
+ my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = '$table'});
$sth->execute;
while (my $row = $sth->fetchrow_hashref) {
- next unless $row->{FK_NAME};
- my $fk = $row->{FK_NAME};
- push @{$local_cols->{$fk}}, lc $row->{FKCOLUMN_NAME};
- push @{$remote_cols->{$fk}}, lc $row->{PKCOLUMN_NAME};
- $remote_table->{$fk} = $row->{PKTABLE_NAME};
+ my $fk = $row->{fk_name};
+ next unless defined $fk;
+
+ push @{$local_cols->{$fk}}, $row->{fkcolumn_name};
+ push @{$remote_cols->{$fk}}, $row->{pkcolumn_name};
+ $remote_table->{$fk} = $row->{pktable_name};
}
foreach my $fk (keys %$remote_table) {
return \@rels;
}
+sub _table_fk_info_builder {
+ my ($self, $table) = @_;
+
+ my $dbh = $self->schema->storage->dbh;
+ local $dbh->{FetchHashKeyName} = 'NAME_lc';
+ # hide "Object does not exist in this database." when trying to fetch fkeys
+ local $dbh->{syb_err_handler} = sub { return 0 if $_[0] == 17461; };
+ my $sth = $dbh->prepare(qq{sp_fkeys \@fktable_name = '$table'});
+ $sth->execute;
+
+ my @fk_info;
+ while (my $row = $sth->fetchrow_hashref) {
+ (my $ksq = $row->{key_seq}) =~ s/\s+//g;
+
+ my @keys = qw/pktable_name pkcolumn_name fktable_name fkcolumn_name/;
+ my %ds;
+ @ds{@keys} = @{$row}{@keys};
+ $ds{key_seq} = $ksq;
+
+ push @{ $fk_info[$ksq] }, \%ds;
+ }
+
+ my $max_keys = $#fk_info;
+ my @rels;
+ for my $level (reverse 1 .. $max_keys) {
+ my @level_rels;
+ $level_rels[$level] = splice @fk_info, $level, 1;
+ my $count = @{ $level_rels[$level] };
+
+ for my $sub_level (reverse 1 .. $level-1) {
+ my $total = @{ $fk_info[$sub_level] };
+
+ $level_rels[$sub_level] = [
+ splice @{ $fk_info[$sub_level] }, $total-$count, $count
+ ];
+ }
+
+ while (1) {
+ my @rel = map shift @$_, @level_rels[1..$level];
+
+ last unless defined $rel[0];
+
+ my @local_columns = map $_->{fkcolumn_name}, @rel;
+ my @remote_columns = map $_->{pkcolumn_name}, @rel;
+ my $remote_table = $rel[0]->{pktable_name};
+
+ push @rels, {
+ local_columns => \@local_columns,
+ remote_columns => \@remote_columns,
+ remote_table => $remote_table
+ };
+ }
+ }
+
+ return \@rels;
+}
+
sub _table_uniq_info {
my ($self, $table) = @_;
+ local $SIG{__WARN__} = sub {};
+
my $dbh = $self->schema->storage->dbh;
+ local $dbh->{FetchHashKeyName} = 'NAME_lc';
my $sth = $dbh->prepare(qq{sp_helpconstraint \@objname='$table', \@nomsg='nomsg'});
- $sth->execute;
+ eval { $sth->execute };
+ return if $@;
my $constraints;
while (my $row = $sth->fetchrow_hashref) {
- my $type = $row->{constraint_type} || '';
- if ($type =~ /^unique/i) {
- my $name = lc $row->{constraint_name};
- push @{$constraints->{$name}}, ( split /,/, lc $row->{constraint_keys} );
+ if (exists $row->{constraint_type}) {
+ my $type = $row->{constraint_type} || '';
+ if ($type =~ /^unique/i) {
+ my $name = $row->{constraint_name};
+ push @{$constraints->{$name}},
+ ( split /,/, $row->{constraint_keys} );
+ }
+ } else {
+ my $def = $row->{definition} || next;
+ next unless $def =~ /^unique/i;
+ my $name = $row->{name};
+ my ($keys) = $def =~ /\((.*)\)/;
+ $keys =~ s/\s*//g;
+ my @keys = split /,/ => $keys;
+ push @{$constraints->{$name}}, @keys;
}
}
Justin Hunter C<justin.d.hunter@gmail.com>
+=head1 CONTRIBUTORS
+
+Rafael Kitover <rkitover@cpan.org>
+
=cut
1;
--- /dev/null
+package DBIx::Class::Schema::Loader::DBI::Sybase::Common;
+
+use strict;
+use warnings;
+use Carp::Clan qw/^DBIx::Class/;
+use Class::C3;
+
+our $VERSION = '0.04999_06';
+
+=head1 NAME
+
+DBIx::Class::Schema::Loader::DBI::Sybase::Common - Common functions for Sybase
+and MSSQL
+
+=head1 DESCRIPTION
+
+See L<DBIx::Class::Schema::Loader::Base>.
+
+=cut
+
+# DBD::Sybase doesn't implement get_info properly
+sub _build_quoter { '"' }
+sub _build_namesep { '.' }
+
+sub _set_quote_char_and_name_sep {
+ my $self = shift;
+
+ $self->schema->storage->sql_maker->quote_char([qw/[ ]/])
+ unless $self->schema->storage->sql_maker->quote_char;
+
+ $self->schema->storage->sql_maker->name_sep('.')
+ unless $self->schema->storage->sql_maker->name_sep;
+}
+
+sub _build_db_schema {
+ my $self = shift;
+ my $dbh = $self->schema->storage->dbh;
+
+ local $dbh->{FetchHashKeyName} = 'NAME_lc';
+
+ my $test_table = "_loader_test_$$";
+
+ my $db_schema = 'dbo'; # default
+
+ eval {
+ $dbh->do("create table $test_table (id integer)");
+ my $sth = $dbh->prepare('sp_tables');
+ $sth->execute;
+ while (my $row = $sth->fetchrow_hashref) {
+ next unless $row->{table_name} eq $test_table;
+
+ $db_schema = $row->{table_owner};
+ last;
+ }
+ $sth->finish;
+ $dbh->do("drop table $test_table");
+ };
+ my $exception = $@;
+ eval { $dbh->do("drop table $test_table") };
+ carp "Could not determine db_schema, defaulting to $db_schema : $exception"
+ if $exception;
+
+ return $db_schema;
+}
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader::DBI::Sybase>,
+L<DBIx::Class::Schema::Loader::DBI::MSSQL>,
+L<DBIx::Class::Schema::Loader::DBI>
+L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
+
+=head1 AUTHOR
+
+Rafael Kitover <rkitover@cpan.org>
+
+=cut
+
+1;
dsn => $dsn,
user => $user,
password => $password,
+ null => '',
);
if( !$dsn || !$user ) {
use lib qw(t/lib);
use dbixcsl_common_tests;
+# you need maxConnect=256 in your DSN for this test to pass
+
my $dsn = $ENV{DBICTEST_SYBASE_DSN} || '';
my $user = $ENV{DBICTEST_SYBASE_USER} || '';
my $password = $ENV{DBICTEST_SYBASE_PASS} || '';
my $tester = dbixcsl_common_tests->new(
vendor => 'Sybase',
- quote_char => [qw/[ ]/],
auto_inc_pk => 'INTEGER IDENTITY NOT NULL PRIMARY KEY',
dsn => $dsn,
user => $user,
--- /dev/null
+use strict;
+use warnings;
+
+# use this if you keep a copy of DBD::Sybase linked to FreeTDS somewhere else
+BEGIN {
+ if (my $lib_dirs = $ENV{DBICTEST_MSSQL_PERL5LIB}) {
+ unshift @INC, $_ for split /:/, $lib_dirs;
+ }
+}
+
+use lib qw(t/lib);
+use dbixcsl_common_tests;
+
+my $dsn = $ENV{DBICTEST_MSSQL_DSN} || '';
+my $user = $ENV{DBICTEST_MSSQL_USER} || '';
+my $password = $ENV{DBICTEST_MSSQL_PASS} || '';
+
+my $tester = dbixcsl_common_tests->new(
+ vendor => 'Microsoft',
+ auto_inc_pk => 'INTEGER IDENTITY NOT NULL PRIMARY KEY',
+ dsn => $dsn,
+ user => $user,
+ password => $password,
+);
+
+if( !$dsn || !$user ) {
+ $tester->skip_tests('You need to set the DBICTEST_MSSQL_DSN, _USER, and _PASS environment variables');
+}
+else {
+ $tester->run_tests();
+}
my $tester = dbixcsl_common_tests->new(
vendor => 'Microsoft',
- quote_char => [qw/[ ]/],
auto_inc_pk => 'INTEGER IDENTITY NOT NULL PRIMARY KEY',
dsn => $dsn,
user => $user,
--- /dev/null
+use strict;
+use lib qw(t/lib);
+use Test::More;
+use DBI;
+
+my $DUMP_DIR;
+BEGIN {
+ $DUMP_DIR = './t/_common_dump';
+}
+
+use lib $DUMP_DIR;
+use DBIx::Class::Schema::Loader 'make_schema_at', "dump_to_dir:$DUMP_DIR";
+use File::Path;
+
+my $dsn = $ENV{DBICTEST_MSSQL_ODBC_DSN} ||
+ $ENV{DBICTEST_MSSQL_DSN} || '';
+
+my $user = $ENV{DBICTEST_MSSQL_ODBC_USER} ||
+ $ENV{DBICTEST_MSSQL_USER} || '';
+
+my $password = $ENV{DBICTEST_MSSQL_ODBC_PASS} ||
+ $ENV{DBICTEST_MSSQL_PASS} || '';
+
+if( !$dsn || !$user ) {
+ plan skip_all =>
+'You need to set the DBICTEST_MSSQL_ODBC_DSN (or DBICTEST_MSSQL_DSN), _USER,' .
+' and _PASS environment variables';
+ exit;
+}
+
+plan tests => 3;
+
+my $dbh = DBI->connect($dsn, $user, $password, {
+ RaiseError => 1, PrintError => 0
+});
+
+eval { $dbh->do('DROP TABLE [loadertest.dot]') };
+$dbh->do(q{
+ CREATE TABLE [loadertest.dot] (
+ id INT IDENTITY NOT NULL PRIMARY KEY,
+ dat VARCHAR(8)
+ )
+});
+
+rmtree $DUMP_DIR;
+
+eval {
+ make_schema_at(
+ 'TestSL::Schema',
+ {
+ use_namespaces => 1,
+ constraint => qr/^loadertest\.dot\z/
+ },
+ [ $dsn, $user, $password, ]
+ );
+};
+
+ok !$@, 'table name with . parsed correctly';
+diag $@ if $@;
+
+#system qq{$^X -pi -e 's/"test\.dot"/\\\\"[loadertest.dot]"/' t/_common_dump/TestSL/Schema/Result/TestDot.pm};
+#diag do { local ($/, @ARGV) = (undef, "t/_common_dump/TestSL/Schema/Result/TestDot.pm"); <> };
+#do "t/_common_dump/TestSL/Schema/Result/TestDot.pm";
+
+eval 'use TestSL::Schema';
+ok !$@, 'loaded schema';
+diag $@ if $@;
+
+TODO: {
+ local $TODO = q{this is really a DBIC test to check if the table is usable,
+and it doesn't work in the released version yet};
+
+ eval {
+ my $rs = TestSL::Schema->resultset('LoadertestDot');
+ my $row = $rs->create({ dat => 'foo' });
+ $row->update({ dat => 'bar' });
+ $row = $rs->find($row->id);
+ $row->delete;
+ };
+ ok !$@, 'used table from DBIC succeessfully';
+ diag $@ if $@;
+}
+
+rmtree $DUMP_DIR;
+
+$dbh->do('DROP TABLE [loadertest.dot]');
# Only MySQL uses this
$self->{innodb} ||= '';
+
+ # DB2 doesn't support this
+ $self->{null} = 'NULL' unless defined $self->{null};
$self->{verbose} = $ENV{TEST_VERBOSE} || 0;
isa_ok( $rs_rel4->first, $class4);
# find on multi-col pk
- my $obj5 = $rsobj5->find({id1 => 1, id2 => 1});
+ my $obj5 =
+ eval { $rsobj5->find({id1 => 1, iD2 => 1}) } ||
+ eval { $rsobj5->find({id1 => 1, id2 => 1}) };
+ die $@ if $@;
+
is( $obj5->id2, 1, "Find on multi-col PK" );
# mulit-col fk def
ok($class6->column_info('loader_test2_id')->{is_foreign_key}, 'Foreign key detected');
ok($class6->column_info('id')->{is_foreign_key}, 'Foreign key detected');
- ok($class6->column_info('id2')->{is_foreign_key}, 'Foreign key detected');
+
+ my $id2_info = eval { $class6->column_info('id2') } ||
+ $class6->column_info('Id2');
+ ok($id2_info->{is_foreign_key}, 'Foreign key detected');
# fk that references a non-pk key (UNIQUE)
my $obj8 = $rsobj8->find(1);
id1 INTEGER NOT NULL,
iD2 INTEGER NOT NULL,
dat VARCHAR(8),
- PRIMARY KEY (id1,id2)
+ PRIMARY KEY (id1,iD2)
) $self->{innodb}
},
- q{ INSERT INTO loader_test5 (id1,id2,dat) VALUES (1,1,'aaa') },
+ q{ INSERT INTO loader_test5 (id1,iD2,dat) VALUES (1,1,'aaa') },
qq{
CREATE TABLE loader_test6 (
) $self->{innodb}
},
- (q{ INSERT INTO loader_test6 (id, id2,loader_test2_id,dat) } .
+ (q{ INSERT INTO loader_test6 (id, Id2,loader_test2_id,dat) } .
q{ VALUES (1, 1,1,'aaa') }),
qq{
CREATE TABLE loader_test32 (
id INTEGER NOT NULL PRIMARY KEY,
rel1 INTEGER NOT NULL,
- rel2 INTEGER,
+ rel2 INTEGER $self->{null},
FOREIGN KEY (rel1) REFERENCES loader_test31(id),
FOREIGN KEY (rel2) REFERENCES loader_test31(id)
) $self->{innodb}
CREATE TABLE loader_test34 (
id INTEGER NOT NULL PRIMARY KEY,
rel1 INTEGER NOT NULL,
- rel2 INTEGER,
+ rel2 INTEGER $self->{null},
FOREIGN KEY (id,rel1) REFERENCES loader_test33(id1,id2),
FOREIGN KEY (id,rel2) REFERENCES loader_test33(id1,id2)
) $self->{innodb}
CREATE TABLE loader_test10 (
id10 $self->{auto_inc_pk},
subject VARCHAR(8),
- loader_test11 INTEGER
+ loader_test11 INTEGER $self->{null}
) $self->{innodb}
},
$make_auto_inc->(qw/loader_test10 id10/),
CREATE TABLE loader_test11 (
id11 $self->{auto_inc_pk},
message VARCHAR(8) DEFAULT 'foo',
- loader_test10 INTEGER,
+ loader_test10 INTEGER $self->{null},
FOREIGN KEY (loader_test10) REFERENCES loader_test10 (id10)
) $self->{innodb}
},
sub DESTROY {
my $self = shift;
- $self->drop_tables if $self->{_created};
- rmtree $DUMP_DIR;
+ unless ($ENV{SCHEMA_LOADER_TESTS_NOCLEANUP}) {
+ $self->drop_tables if $self->{_created};
+ rmtree $DUMP_DIR
+ }
}
1;
projects / dbsrgits/DBIx-Class-Schema-Loader.git / commitdiff