- rename column_accessor_map to col_accessor_map, the old alias still
works
+ - support MSSQL over DBD::ADO
+ - support for MS Access over DBD::ODBC and DBD::ADO
0.07007 2011-02-15 10:00:07
- bump DBIx::Class dep to 0.08127
our $VERSION = '0.07007';
+__PACKAGE__->mk_group_accessors('simple', qw/
+ _disable_pk_detection
+ _disable_uniq_detection
+ _disable_fk_detection
+ _passwords
+/);
+
=head1 NAME
DBIx::Class::Schema::Loader::DBI - DBIx::Class::Schema::Loader DBI Implementation.
sub _table_pk_info {
my ($self, $table) = @_;
+ return [] if $self->_disable_pk_detection;
+
my $dbh = $self->schema->storage->dbh;
- my @primary = map { $self->_lc($_) } $dbh->primary_key('', $self->db_schema, $table);
+ my @primary = try {
+ $dbh->primary_key('', $self->db_schema, $table);
+ }
+ catch {
+ warn "Cannot find primary keys for this driver: $_";
+ $self->_disable_pk_detection(1);
+ return ();
+ };
+
+ return [] if not @primary;
+
+ @primary = map { $self->_lc($_) } @primary;
s/\Q$self->{_quoter}\E//g for @primary;
return \@primary;
sub _table_uniq_info {
my ($self, $table) = @_;
+ return [] if $self->_disable_uniq_detection;
+
my $dbh = $self->schema->storage->dbh;
- if(!$dbh->can('statistics_info')) {
- warn "No UNIQUE constraint information can be gathered for this vendor";
+
+ if (not $dbh->can('statistics_info')) {
+ warn "No UNIQUE constraint information can be gathered for this driver";
+ $self->_disable_uniq_detection(1);
return [];
}
|| !defined $row->{ORDINAL_POSITION}
|| !$row->{COLUMN_NAME};
- $indices{$row->{INDEX_NAME}}->{$row->{ORDINAL_POSITION}} = $row->{COLUMN_NAME};
+ $indices{$row->{INDEX_NAME}}[$row->{ORDINAL_POSITION}] = $self->_lc($row->{COLUMN_NAME});
}
$sth->finish;
my @retval;
foreach my $index_name (keys %indices) {
my $index = $indices{$index_name};
- push(@retval, [ $index_name => [
- map { $index->{$_} }
- sort keys %$index
- ]]);
+ push(@retval, [ $index_name => [ @$index[1..$#$index] ] ]);
}
return \@retval;
sub _table_fk_info {
my ($self, $table) = @_;
+ return [] if $self->_disable_fk_detection;
+
my $dbh = $self->schema->storage->dbh;
- my $sth = $dbh->foreign_key_info( '', $self->db_schema, '',
- '', $self->db_schema, $table );
+ my $sth = try {
+ $dbh->foreign_key_info( '', $self->db_schema, '',
+ '', $self->db_schema, $table );
+ }
+ catch {
+ warn "Cannot introspect relationships for this driver: $_";
+ $self->_disable_fk_detection(1);
+ return undef;
+ };
+
return [] if !$sth;
my %rels;
return $dbh->column_info(@_);
}
+# If a coderef uses DBI->connect, this should get its connect info.
+sub _try_infer_connect_info_from_coderef {
+ my ($self, $code) = @_;
+
+ my ($dsn, $user, $pass, $params);
+
+ no warnings 'redefine';
+
+ local *DBI::connect = sub {
+ (undef, $dsn, $user, $pass, $params) = @_;
+ };
+
+ $code->();
+
+ return ($dsn, $user, $pass, $params);
+}
+
=head1 SEE ALSO
L<DBIx::Class::Schema::Loader>
--- /dev/null
+package DBIx::Class::Schema::Loader::DBI::ADO;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Schema::Loader::DBI';
+use mro 'c3';
+use Carp::Clan qw/^DBIx::Class/;
+use namespace::clean;
+
+our $VERSION = '0.07007';
+
+=head1 NAME
+
+DBIx::Class::Schema::Loader::DBI::ADO - L<DBD::ADO> proxy
+
+=head1 DESCRIPTION
+
+Reblesses into an C<::ADO::> class when connecting via L<DBD::ADO>.
+
+See L<DBIx::Class::Schema::Loader::Base> for usage information.
+
+=cut
+
+sub _rebless {
+ my $self = shift;
+
+ return if ref $self ne __PACKAGE__;
+
+ my $dbh = $self->schema->storage->dbh;
+ my $dbtype = eval { $dbh->get_info(17) };
+ unless ( $@ ) {
+ # Translate the backend name into a perl identifier
+ $dbtype =~ s/\W/_/gi;
+ my $class = "DBIx::Class::Schema::Loader::DBI::ADO::${dbtype}";
+ if ($self->load_optional_class($class) && !$self->isa($class)) {
+ bless $self, $class;
+ $self->_rebless;
+ }
+ }
+}
+
+sub _tables_list {
+ my ($self, $opts) = @_;
+
+ return $self->next::method($opts, undef, undef);
+}
+
+sub _filter_tables {
+ my $self = shift;
+
+ local $^W = 0; # turn off exception printing from Win32::OLE
+
+ $self->next::method(@_);
+}
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader::DBI::ADO::Microsoft_SQL_Server>,
+L<DBIx::Class::Schema::Loader::DBI::ADO::MS_Jet>,
+L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
+L<DBIx::Class::Schema::Loader::DBI>
+
+=head1 AUTHOR
+
+See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
--- /dev/null
+package DBIx::Class::Schema::Loader::DBI::ADO::MS_Jet;
+
+use strict;
+use warnings;
+use base qw/
+ DBIx::Class::Schema::Loader::DBI::ADO
+ DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS
+/;
+use mro 'c3';
+use Carp::Clan qw/^DBIx::Class/;
+use Try::Tiny;
+use namespace::clean;
+
+our $VERSION = '0.07007';
+
+=head1 NAME
+
+DBIx::Class::Schema::Loader::DBI::ADO::MS_Jet - ADO wrapper for
+L<DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS>
+
+=head1 DESCRIPTION
+
+Proxy for L<DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS> when using
+L<DBD::ADO>.
+
+See L<DBIx::Class::Schema::Loader::Base> for usage information.
+
+=cut
+
+sub _db_path {
+ my $self = shift;
+
+ $self->schema->storage->dbh->get_info(2);
+}
+
+sub _ado_connection {
+ my $self = shift;
+
+ return $self->__ado_connection if $self->__ado_connection;
+
+ my ($dsn, $user, $pass) = @{ $self->schema->storage->_dbi_connect_info };
+
+ my $have_pass = 1;
+
+ if (ref $dsn eq 'CODE') {
+ ($dsn, $user, $pass) = $self->_try_infer_connect_info_from_coderef($dsn);
+
+ if (not $dsn) {
+ my $dbh = $self->schema->storage->dbh;
+ $dsn = $dbh->{Name};
+ $user = $dbh->{Username};
+ $have_pass = 0;
+ }
+ }
+
+ require Win32::OLE;
+ my $conn = Win32::OLE->new('ADODB.Connection');
+
+ $dsn =~ s/^dbi:[^:]+://i;
+
+ local $Win32::OLE::Warn = 0;
+
+ my @dsn;
+ for my $s (split /;/, $dsn) {
+ my ($k, $v) = split /=/, $s, 2;
+ if (defined $conn->{$k}) {
+ $conn->{$k} = $v;
+ next;
+ }
+ push @dsn, $s;
+ }
+
+ $dsn = join ';', @dsn;
+
+ $user = '' unless defined $user;
+
+ if ((not $have_pass) && exists $self->_passwords->{$dsn}{$user}) {
+ $pass = $self->_passwords->{$dsn}{$user};
+ $have_pass = 1;
+ }
+ $pass = '' unless defined $pass;
+
+ try {
+ $conn->Open($dsn, $user, $pass);
+ }
+ catch {
+ if (not $have_pass) {
+ if (exists $ENV{DBI_PASS}) {
+ $pass = $ENV{DBI_PASS};
+ try {
+ $conn->Open($dsn, $user, $pass);
+ $self->_passwords->{$dsn}{$user} = $pass;
+ }
+ catch {
+ print "Enter database password for $user ($dsn): ";
+ chomp($pass = <STDIN>);
+ $conn->Open($dsn, $user, $pass);
+ $self->_passwords->{$dsn}{$user} = $pass;
+ };
+ }
+ else {
+ print "Enter database password for $user ($dsn): ";
+ chomp($pass = <STDIN>);
+ $conn->Open($dsn, $user, $pass);
+ $self->_passwords->{$dsn}{$user} = $pass;
+ }
+ }
+ else {
+ die $_;
+ }
+ };
+
+ $self->__ado_connection($conn);
+
+ return $conn;
+}
+
+sub _columns_info_for {
+ my $self = shift;
+ my ($table) = @_;
+
+ my $result = $self->next::method(@_);
+
+ while (my ($col, $info) = each %$result) {
+ my $data_type = $info->{data_type};
+
+ my $col_obj;
+
+ $self->_adox_catalog->Tables->Item($table)->Columns;
+
+ for my $col_idx (0..$cols->Count-1) {
+ $col_obj = $cols->Item($col_idx);
+ if ($self->preserve_case) {
+ last if $col_obj->Name eq $col;
+ }
+ else {
+ last if lc($col_obj->Name) eq lc($col);
+ }
+ }
+
+ if ($col_obj->Attributes | 2 == 2) {
+ $info->{is_nullable} = 1;
+ }
+
+ if ($data_type eq 'long') {
+ $info->{data_type} = 'integer';
+ delete $info->{size};
+
+ my $props = $col_obj->Properties;
+ for my $prop_idx (0..$props->Count-1) {
+ my $prop = $props->Item($prop_idx);
+ if ($prop->Name eq 'Autoincrement' && $prop->Value == 1) {
+ $info->{is_auto_increment} = 1;
+ last;
+ }
+ }
+ }
+ elsif ($data_type eq 'short') {
+ $info->{data_type} = 'smallint';
+ delete $info->{size};
+ }
+ elsif ($data_type eq 'single') {
+ $info->{data_type} = 'real';
+ delete $info->{size};
+ }
+ elsif ($data_type eq 'money') {
+ if (ref $info->{size} eq 'ARRAY') {
+ if ($info->{size}[0] == 19 && $info->{size}[1] == 255) {
+ delete $info->{size};
+ }
+ else {
+ # it's really a decimal
+ $info->{data_type} = 'decimal';
+
+ if ($info->{size}[0] == 18 && $info->{size}[1] == 0) {
+ # default size
+ delete $info->{size};
+ }
+ delete $info->{original};
+ }
+ }
+ }
+ elsif ($data_type eq 'varchar') {
+ $info->{data_type} = 'char' if $col_obj->Type == 130;
+ $info->{size} = $col_obj->DefinedSize;
+ }
+ elsif ($data_type eq 'bigbinary') {
+ $info->{data_type} = 'varbinary';
+
+ my $props = $col_obj->Properties;
+ for my $prop_idx (0..$props->Count-1) {
+ my $prop = $props->Item($prop_idx);
+ if ($prop->Name eq 'Fixed Length' && $prop->Value == 1) {
+ $info->{data_type} = 'binary';
+ last;
+ }
+
+ }
+
+ $info->{size} = $col_obj->DefinedSize;
+ }
+ elsif ($data_type eq 'longtext') {
+ $info->{data_type} = 'text';
+ $info->{original}{data_type} = 'longchar';
+ delete $info->{size};
+ }
+ }
+
+ return $result;
+}
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS>,
+L<DBIx::Class::Schema::Loader::DBI::ADO>,
+L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
+L<DBIx::Class::Schema::Loader::DBI>
+
+=head1 AUTHOR
+
+See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
+# vim:et sts=4 sw=4 tw=0:
--- /dev/null
+package DBIx::Class::Schema::Loader::DBI::ADO::Microsoft_SQL_Server;
+
+use strict;
+use warnings;
+use base qw/
+ DBIx::Class::Schema::Loader::DBI::ADO
+ DBIx::Class::Schema::Loader::DBI::MSSQL
+/;
+use mro 'c3';
+use Carp::Clan qw/^DBIx::Class/;
+use namespace::clean;
+
+our $VERSION = '0.07007';
+
+=head1 NAME
+
+DBIx::Class::Schema::Loader::DBI::ADO::Microsoft_SQL_Server - ADO wrapper for
+L<DBIx::Class::Schema::Loader::DBI::MSSQL>
+
+=head1 DESCRIPTION
+
+Proxy for L<DBIx::Class::Schema::Loader::DBI::MSSQL> when using L<DBD::ADO>.
+
+See L<DBIx::Class::Schema::Loader::Base> for usage information.
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader::DBI::MSSQL>,
+L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
+L<DBIx::Class::Schema::Loader::DBI>
+
+=head1 AUTHOR
+
+See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
use strict;
use warnings;
use base 'DBIx::Class::Schema::Loader::DBI';
-use Carp::Clan qw/^DBIx::Class/;
use mro 'c3';
+use Carp::Clan qw/^DBIx::Class/;
+use namespace::clean;
our $VERSION = '0.07007';
}
}
-sub _tables_list {
+sub _tables_list {
my ($self, $opts) = @_;
return $self->next::method($opts, undef, undef);
--- /dev/null
+package DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS;
+
+use strict;
+use warnings;
+use base qw/
+ DBIx::Class::Schema::Loader::DBI::ODBC
+/;
+use mro 'c3';
+use Carp::Clan qw/^DBIx::Class/;
+use Try::Tiny;
+use namespace::clean;
+
+our $VERSION = '0.07007';
+
+__PACKAGE__->mk_group_accessors('simple', qw/
+ __ado_connection
+ __adox_catalog
+/);
+
+=head1 NAME
+
+DBIx::Class::Schema::Loader::DBI::ODBC::ACCESS - Microsoft Access driver for
+DBIx::Class::Schema::Loader
+
+=head1 DESCRIPTION
+
+See L<DBIx::Class::Schema::Loader::Base> for usage information.
+
+=cut
+
+sub _db_path {
+ my $self = shift;
+
+ $self->schema->storage->dbh->get_info(16);
+}
+
+sub _open_ado_connection {
+ my ($self, $conn, $user, $pass) = @_;
+
+ my @info = ({
+ provider => 'Microsoft.ACE.OLEDB.12.0',
+ dsn_extra => 'Persist Security Info=False',
+ }, {
+ provider => 'Microsoft.Jet.OLEDB.4.0',
+ });
+
+ my $opened = 0;
+ my $exception;
+
+ for my $info (@info) {
+ $conn->{Provider} = $info->{provider};
+
+ my $dsn = 'Data Source='.($self->_db_path);
+ $dsn .= ";$info->{dsn_extra}" if exists $info->{dsn_extra};
+
+ try {
+ $conn->Open($dsn, $user, $pass);
+ undef $exception;
+ }
+ catch {
+ $exception = $_;
+ };
+
+ next if $exception;
+
+ $opened = 1;
+ last;
+ }
+
+ return ($opened, $exception);
+}
+
+
+sub _ado_connection {
+ my $self = shift;
+
+ return $self->__ado_connection if $self->__ado_connection;
+
+ my ($dsn, $user, $pass) = @{ $self->schema->storage->_dbi_connect_info };
+
+ my $have_pass = 1;
+
+ if (ref $dsn eq 'CODE') {
+ ($dsn, $user, $pass) = $self->_try_infer_connect_info_from_coderef($dsn);
+
+ if (not $dsn) {
+ my $dbh = $self->schema->storage->dbh;
+ $dsn = $dbh->{Name};
+ $user = $dbh->{Username};
+ $have_pass = 0;
+ }
+ }
+
+ require Win32::OLE;
+ my $conn = Win32::OLE->new('ADODB.Connection');
+
+ $user = '' unless defined $user;
+ if ((not $have_pass) && exists $self->_passwords->{$dsn}{$user}) {
+ $pass = $self->_passwords->{$dsn}{$user};
+ $have_pass = 1;
+ }
+ $pass = '' unless defined $pass;
+
+ my ($opened, $exception) = $self->_open_ado_connection($conn, $user, $pass);
+
+ if ((not $opened) && (not $have_pass)) {
+ if (exists $ENV{DBI_PASS}) {
+ $pass = $ENV{DBI_PASS};
+
+ ($opened, $exception) = $self->_open_ado_connection($conn, $user, $pass);
+
+ if ($opened) {
+ $self->_passwords->{$dsn}{$user} = $pass;
+ }
+ else {
+ print "Enter database password for $user ($dsn): ";
+ chomp($pass = <STDIN>);
+
+ ($opened, $exception) = $self->_open_ado_connection($conn, $user, $pass);
+
+ if ($opened) {
+ $self->_passwords->{$dsn}{$user} = $pass;
+ }
+ }
+ }
+ else {
+ print "Enter database password for $user ($dsn): ";
+ chomp($pass = <STDIN>);
+
+ ($opened, $exception) = $self->_open_ado_connection($conn, $user, $pass);
+
+ if ($opened) {
+ $self->_passwords->{$dsn}{$user} = $pass;
+ }
+ }
+ }
+
+ if (not $opened) {
+ die "Failed to open ADO connection: $exception";
+ }
+
+ $self->__ado_connection($conn);
+
+ return $conn;
+}
+
+sub _adox_catalog {
+ my $self = shift;
+
+ return $self->__adox_catalog if $self->__adox_catalog;
+
+ require Win32::OLE;
+ my $cat = Win32::OLE->new('ADOX.Catalog');
+ $cat->{ActiveConnection} = $self->_ado_connection;
+
+ $self->__adox_catalog($cat);
+
+ return $cat;
+}
+
+sub rescan {
+ my $self = shift;
+
+ if ($self->__adox_catalog) {
+ $self->__ado_connection(undef);
+ $self->__adox_catalog(undef);
+ }
+
+ return $self->next::method(@_);
+}
+
+sub _table_pk_info {
+ my ($self, $table) = @_;
+
+ return [] if $self->_disable_pk_detection;
+
+ my @keydata;
+
+ my $indexes = try {
+ $self->_adox_catalog->Tables->Item($table)->Indexes
+ }
+ catch {
+ warn "Could not retrieve indexes in table '$table', disabling primary key detection: $_\n";
+ return undef;
+ };
+
+ if (not $indexes) {
+ $self->_disable_pk_detection(1);
+ return [];
+ }
+
+ for my $idx_num (0..($indexes->Count-1)) {
+ my $idx = $indexes->Item($idx_num);
+ if ($idx->PrimaryKey) {
+ my $cols = $idx->Columns;
+ for my $col_idx (0..$cols->Count-1) {
+ push @keydata, $self->_lc($cols->Item($col_idx)->Name);
+ }
+ }
+ }
+
+ return \@keydata;
+}
+
+sub _table_fk_info {
+ my ($self, $table) = @_;
+
+ return [] if $self->_disable_fk_detection;
+
+ my $keys = try {
+ $self->_adox_catalog->Tables->Item($table)->Keys;
+ }
+ catch {
+ warn "Could not retrieve keys in table '$table', disabling relationship detection: $_\n";
+ return undef;
+ };
+
+ if (not $keys) {
+ $self->_disable_fk_detection(1);
+ return [];
+ }
+
+ my @rels;
+
+ for my $key_idx (0..($keys->Count-1)) {
+ my $key = $keys->Item($key_idx);
+ if ($key->Type == 2) {
+ my $local_cols = $key->Columns;
+ my $remote_table = $key->RelatedTable;
+ my (@local_cols, @remote_cols);
+
+ for my $col_idx (0..$local_cols->Count-1) {
+ my $col = $local_cols->Item($col_idx);
+ push @local_cols, $self->_lc($col->Name);
+ push @remote_cols, $self->_lc($col->RelatedColumn);
+ }
+
+ push @rels, {
+ local_columns => \@local_cols,
+ remote_columns => \@remote_cols,
+ remote_table => $remote_table,
+ };
+
+ }
+ }
+
+ return \@rels;
+}
+
+sub _columns_info_for {
+ my $self = shift;
+ my ($table) = @_;
+
+ my $result = $self->next::method(@_);
+
+ while (my ($col, $info) = each %$result) {
+ my $data_type = $info->{data_type};
+
+ if ($data_type eq 'counter') {
+ $info->{data_type} = 'integer';
+ $info->{is_auto_increment} = 1;
+ delete $info->{size};
+ }
+ elsif ($data_type eq 'longbinary') {
+ $info->{data_type} = 'image';
+ $info->{original}{data_type} = 'longbinary';
+ }
+ elsif ($data_type eq 'longchar') {
+ $info->{data_type} = 'text';
+ $info->{original}{data_type} = 'longchar';
+ }
+ elsif ($data_type eq 'double') {
+ $info->{data_type} = 'double precision';
+ $info->{original}{data_type} = 'double';
+ }
+ elsif ($data_type eq 'guid') {
+ $info->{data_type} = 'uniqueidentifier';
+ $info->{original}{data_type} = 'guid';
+ }
+ elsif ($data_type eq 'byte') {
+ $info->{data_type} = 'tinyint';
+ $info->{original}{data_type} = 'byte';
+ }
+ elsif ($data_type eq 'currency') {
+ $info->{data_type} = 'money';
+ $info->{original}{data_type} = 'currency';
+
+ if (ref $info->{size} eq 'ARRAY' && $info->{size}[0] == 19 && $info->{size}[1] == 4) {
+ # Actual money column via ODBC, otherwise we pass the sizes on to the ADO driver for decimal
+ # columns (which masquerade as money columns...)
+ delete $info->{size};
+ }
+ }
+
+# Pass through currency (which can be decimal for ADO.)
+ if ($data_type !~ /^(?:(?:var)?(?:char|binary))\z/ && $data_type ne 'currency') {
+ delete $info->{size};
+ }
+ }
+
+ return $result;
+}
+
+=head1 SEE ALSO
+
+L<DBIx::Class::Schema::Loader>, L<DBIx::Class::Schema::Loader::Base>,
+L<DBIx::Class::Schema::Loader::DBI>
+
+=head1 AUTHOR
+
+See L<DBIx::Class::Schema::Loader/AUTHOR> and L<DBIx::Class::Schema::Loader/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify it under
+the same terms as Perl itself.
+
+=cut
+
+1;
+# vim:et sts=4 sw=4 tw=0:
--- /dev/null
+use strict;
+use warnings;
+use Test::More;
+use lib qw(t/lib);
+use dbixcsl_common_tests;
+
+my $odbc_dsn = $ENV{DBICTEST_MSACCESS_ODBC_DSN} || '';
+my $odbc_user = $ENV{DBICTEST_MSACCESS_ODBC_USER} || '';
+my $odbc_password = $ENV{DBICTEST_MSACCESS_ODBC_PASS} || '';
+
+my $ado_dsn = $ENV{DBICTEST_MSACCESS_ADO_DSN} || '';
+my $ado_user = $ENV{DBICTEST_MSACCESS_ADO_USER} || '';
+my $ado_password = $ENV{DBICTEST_MSACCESS_ADO_PASS} || '';
+
+my %ado_extra_types = (
+ 'tinyint' => { data_type => 'tinyint', original => { data_type => 'byte' } },
+ 'smallmoney' => { data_type => 'money', original => { data_type => 'currency' } },
+ 'decimal' => { data_type => 'decimal' },
+ 'decimal(3)' => { data_type => 'decimal', size => [3, 0] },
+ 'decimal(3,3)'=> { data_type => 'decimal', size => [3, 3] },
+ 'dec(5,5)' => { data_type => 'decimal', size => [5, 5] },
+ 'numeric(2,2)'=> { data_type => 'decimal', size => [2, 2] },
+ 'character' => { data_type => 'char', size => 255 },
+ 'character varying(5)' => { data_type => 'varchar', size => 5 },
+ 'nchar(5)' => { data_type => 'char', size => 5 },
+ 'national character(5)' => { data_type => 'char', size => 5 },
+ 'nvarchar(5)' => { data_type => 'varchar', size => 5 },
+ 'national character varying(5)' => { data_type => 'varchar', size => 5 },
+ 'national char varying(5)' => { data_type => 'varchar', size => 5 },
+ 'smalldatetime' => { data_type => 'datetime' },
+ 'uniqueidentifier' => { data_type => 'uniqueidentifier', original => { data_type => 'guid' } },
+ 'text' => { data_type => 'text', original => { data_type => 'longchar' } },
+ 'ntext' => { data_type => 'text', original => { data_type => 'longchar' } },
+);
+
+my $tester = dbixcsl_common_tests->new(
+ vendor => 'Access',
+ auto_inc_pk => 'AUTOINCREMENT PRIMARY KEY',
+ quote_char => [qw/[ ]/],
+ connect_info => [ ($odbc_dsn ? {
+ dsn => $odbc_dsn,
+ user => $odbc_user,
+ password => $odbc_password,
+ } : ()),
+ ($ado_dsn ? {
+ dsn => $ado_dsn,
+ user => $ado_user,
+ password => $ado_password,
+ } : ()),
+ ],
+ data_types => {
+ # http://msdn.microsoft.com/en-us/library/bb208866(v=office.12).aspx
+ #
+ # Numeric types
+ 'autoincrement'=>{ data_type => 'integer', is_auto_increment => 1 },
+ 'int' => { data_type => 'integer' },
+ 'integer' => { data_type => 'integer' },
+ 'long' => { data_type => 'integer' },
+ 'integer4' => { data_type => 'integer' },
+ 'smallint' => { data_type => 'smallint' },
+ 'short' => { data_type => 'smallint' },
+ 'integer2' => { data_type => 'smallint' },
+ 'integer1' => { data_type => 'tinyint', original => { data_type => 'byte' } },
+ 'byte' => { data_type => 'tinyint', original => { data_type => 'byte' } },
+ 'bit' => { data_type => 'bit' },
+ 'logical' => { data_type => 'bit' },
+ 'logical1' => { data_type => 'bit' },
+ 'yesno' => { data_type => 'bit' },
+ 'money' => { data_type => 'money', original => { data_type => 'currency' } },
+ 'currency' => { data_type => 'money', original => { data_type => 'currency' } },
+ 'real' => { data_type => 'real' },
+ 'single' => { data_type => 'real' },
+ 'ieeesingle' => { data_type => 'real' },
+ 'float4' => { data_type => 'real' },
+ 'float' => { data_type => 'double precision', original => { data_type => 'double' } },
+ 'float' => { data_type => 'double precision', original => { data_type => 'double' } },
+ 'float8' => { data_type => 'double precision', original => { data_type => 'double' } },
+ 'double' => { data_type => 'double precision', original => { data_type => 'double' } },
+ 'ieeedouble' => { data_type => 'double precision', original => { data_type => 'double' } },
+ 'number' => { data_type => 'double precision', original => { data_type => 'double' } },
+
+# # character types
+ 'text(25)' => { data_type => 'varchar', size => 25 },
+ 'char' => { data_type => 'char', size => 255 },
+ 'char(5)' => { data_type => 'char', size => 5 },
+ 'string(5)' => { data_type => 'varchar', size => 5 },
+ 'varchar(5)' => { data_type => 'varchar', size => 5 },
+
+ # binary types
+ 'binary(10)' => { data_type => 'binary', size => 10 },
+ 'varbinary(11)' => { data_type => 'varbinary', size => 11 },
+
+ # datetime types
+ 'datetime' => { data_type => 'datetime' },
+ 'time' => { data_type => 'datetime' },
+ 'timestamp' => { data_type => 'datetime' },
+
+ # misc types
+ 'guid' => { data_type => 'uniqueidentifier', original => { data_type => 'guid' } },
+
+ # blob types
+ 'longchar' => { data_type => 'text', original => { data_type => 'longchar' } },
+ 'longtext' => { data_type => 'text', original => { data_type => 'longchar' } },
+ 'memo' => { data_type => 'text', original => { data_type => 'longchar' } },
+ 'image' => { data_type => 'image', original => { data_type => 'longbinary' } },
+ 'longbinary' => { data_type => 'image', original => { data_type => 'longbinary' } },
+
+ ($ado_dsn && (not $odbc_dsn) ? %ado_extra_types : ())
+ },
+);
+
+if (not ($odbc_dsn || $ado_dsn)) {
+ $tester->skip_tests('You need to set the DBICTEST_MSACCESS_ODBC_DSN, and optionally _USER and _PASS and/or the DBICTEST_MSACCESS_ADO_DSN, and optionally _USER and _PASS environment variables');
+}
+else {
+ $tester->run_tests();
+}
+
+# vim:et sts=4 sw=4 tw=0:
my $DUMP_DIR = "$tdir/common_dump";
rmtree $DUMP_DIR;
-use constant RESCAN_WARNINGS => qr/(?i:loader_test)\d+ has no primary key|^Dumping manual schema|^Schema dump completed|collides with an inherited method|invalidates \d+ active statement|^Bad table or view/;
+use constant RESCAN_WARNINGS => qr/(?i:loader_test|LoaderTest)\d+s? has no primary key|^Dumping manual schema|^Schema dump completed|collides with an inherited method|invalidates \d+ active statement|^Bad table or view/;
sub new {
my $class = shift;
my $dbh = $self->dbconnect(0);
+ local $^W = 0; # for ADO
+
$dbh->do($_) for @{ $self->{extra}{pre_drop_ddl} || [] };
$dbh->do("DROP TABLE $_") for @{ $self->{extra}{drop} || [] };
ok( $class1->column_info('id')->{is_auto_increment}, 'is_auto_increment detection' );
- my $obj = $rsobj1->find(1);
- is( $obj->id, 1, "Find got the right row" );
- is( $obj->dat, "foo", "Column value" );
+ my $obj = try { $rsobj1->find(1) };
+
+ is( try { $obj->id }, 1, "Find got the right row" );
+ is( try { $obj->dat }, "foo", "Column value" );
is( $rsobj2->count, 4, "Count" );
my $saved_id;
eval {
my ($obj2) = $rsobj2->search({ dat => 'bbb' })->first;
is( $obj2->id, 2 );
- is(
- $class35->column_info('a_varchar')->{default_value}, 'foo',
- 'constant character default',
- );
+ SKIP: {
+ skip 'no DEFAULT on Access', 7 if $self->{vendor} eq 'Access';
- is(
- $class35->column_info('an_int')->{default_value}, 42,
- 'constant integer default',
- );
+ is(
+ $class35->column_info('a_varchar')->{default_value}, 'foo',
+ 'constant character default',
+ );
- is(
- $class35->column_info('a_negative_int')->{default_value}, -42,
- 'constant negative integer default',
- );
+ is(
+ $class35->column_info('an_int')->{default_value}, 42,
+ 'constant integer default',
+ );
- cmp_ok(
- $class35->column_info('a_double')->{default_value}, '==', 10.555,
- 'constant numeric default',
- );
+ is(
+ $class35->column_info('a_negative_int')->{default_value}, -42,
+ 'constant negative integer default',
+ );
- cmp_ok(
- $class35->column_info('a_negative_double')->{default_value}, '==', -10.555,
- 'constant negative numeric default',
- );
+ cmp_ok(
+ $class35->column_info('a_double')->{default_value}, '==', 10.555,
+ 'constant numeric default',
+ );
- my $function_default = $class35->column_info('a_function')->{default_value};
+ cmp_ok(
+ $class35->column_info('a_negative_double')->{default_value}, '==', -10.555,
+ 'constant negative numeric default',
+ );
- isa_ok( $function_default, 'SCALAR', 'default_value for function default' );
- is_deeply(
- $function_default, \$self->{default_function},
- 'default_value for function default is correct'
- );
+ my $function_default = $class35->column_info('a_function')->{default_value};
+
+ isa_ok( $function_default, 'SCALAR', 'default_value for function default' );
+ is_deeply(
+ $function_default, \$self->{default_function},
+ 'default_value for function default is correct'
+ );
+ }
SKIP: {
skip $self->{skip_rels}, 120 if $self->{skip_rels};
isa_ok( $rsobj36, "DBIx::Class::ResultSet" );
# basic rel test
- my $obj4 = $rsobj4->find(123);
- isa_ok( $obj4->fkid_singular, $class3);
+ my $obj4 = try { $rsobj4->find(123) } || $rsobj4->search({ id => 123 })->first;
+ isa_ok( try { $obj4->fkid_singular }, $class3);
# test renaming rel that conflicts with a class method
ok ($obj4->has_relationship('belongs_to_rel'), 'relationship name that conflicts with a method renamed');
- isa_ok( $obj4->belongs_to_rel, $class3);
+
+ isa_ok( try { $obj4->belongs_to_rel }, $class3);
ok ($obj4->has_relationship('caught_rel_collision_set_primary_key'),
'relationship name that conflicts with a method renamed based on rel_collision_map');
- isa_ok( $obj4->caught_rel_collision_set_primary_key, $class3);
+ isa_ok( try { $obj4->caught_rel_collision_set_primary_key }, $class3);
ok($class4->column_info('fkid')->{is_foreign_key}, 'Foreign key detected');
- my $obj3 = $rsobj3->find(1);
- my $rs_rel4 = $obj3->search_related('loader_test4zes');
- isa_ok( $rs_rel4->first, $class4);
+ my $obj3 = try { $rsobj3->find(1) } || $rsobj3->search({ id => 1 })->first;
+ my $rs_rel4 = try { $obj3->search_related('loader_test4zes') };
+ isa_ok( try { $rs_rel4->first }, $class4);
is( $class4->column_info('crumb_crisp_coating')->{accessor}, 'trivet',
'col_accessor_map is being run' );
"rel with preposition 'from' pluralized correctly");
# check default relationship attributes
- is $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{cascade_delete}, 0,
+ is try { $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{cascade_delete} }, 0,
'cascade_delete => 0 on has_many by default';
- is $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{cascade_copy}, 0,
+ is try { $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{cascade_copy} }, 0,
'cascade_copy => 0 on has_many by default';
- ok ((not exists $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{on_delete}),
+ ok ((not try { exists $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{on_delete} }),
'has_many does not have on_delete');
- ok ((not exists $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{on_update}),
+ ok ((not try { exists $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{on_update} }),
'has_many does not have on_update');
- ok ((not exists $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{is_deferrable}),
+ ok ((not try { exists $rsobj3->result_source->relationship_info('loader_test4zes')->{attrs}{is_deferrable} }),
'has_many does not have is_deferrable');
- is $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{on_delete}, 'CASCADE',
+ is try { $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{on_delete} }, 'CASCADE',
"on_delete => 'CASCADE' on belongs_to by default";
- is $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{on_update}, 'CASCADE',
+ is try { $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{on_update} }, 'CASCADE',
"on_update => 'CASCADE' on belongs_to by default";
- is $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{is_deferrable}, 1,
+ is try { $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{is_deferrable} }, 1,
"is_deferrable => 1 on belongs_to by default";
- ok ((not exists $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{cascade_delete}),
+ ok ((not try { exists $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{cascade_delete} }),
'belongs_to does not have cascade_delete');
- ok ((not exists $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{cascade_copy}),
+ ok ((not try { exists $rsobj4->result_source->relationship_info('fkid_singular')->{attrs}{cascade_copy} }),
'belongs_to does not have cascade_copy');
- is $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{cascade_delete}, 0,
+ is try { $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{cascade_delete} }, 0,
'cascade_delete => 0 on might_have by default';
- is $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{cascade_copy}, 0,
+ is try { $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{cascade_copy} }, 0,
'cascade_copy => 0 on might_have by default';
- ok ((not exists $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{on_delete}),
+ ok ((not try { exists $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{on_delete} }),
'might_have does not have on_delete');
- ok ((not exists $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{on_update}),
+ ok ((not try { exists $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{on_update} }),
'might_have does not have on_update');
- ok ((not exists $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{is_deferrable}),
+ ok ((not try { exists $rsobj27->result_source->relationship_info('loader_test28')->{attrs}{is_deferrable} }),
'might_have does not have is_deferrable');
# find on multi-col pk
}
# mulit-col fk def
- my $obj6 = $rsobj6->find(1);
- isa_ok( $obj6->loader_test2, $class2);
- isa_ok( $obj6->loader_test5, $class5);
+ my $obj6 = try { $rsobj6->find(1) } || $rsobj6->search({ id => 1 })->first;
+ isa_ok( try { $obj6->loader_test2 }, $class2);
+ isa_ok( try { $obj6->loader_test5 }, $class5);
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($id2_info->{is_foreign_key}, 'Foreign key detected');
# fk that references a non-pk key (UNIQUE)
- my $obj8 = $rsobj8->find(1);
- isa_ok( $obj8->loader_test7, $class7);
+ my $obj8 = try { $rsobj8->find(1) } || $rsobj8->search({ id => 1 })->first;
+ isa_ok( try { $obj8->loader_test7 }, $class7);
ok($class8->column_info('loader_test7')->{is_foreign_key}, 'Foreign key detected');
# test double-fk 17 ->-> 16
- my $obj17 = $rsobj17->find(33);
+ my $obj17 = try { $rsobj17->find(33) } || $rsobj17->search({ id => 33 })->first;
- my $rs_rel16_one = $obj17->loader16_one;
+ my $rs_rel16_one = try { $obj17->loader16_one };
isa_ok($rs_rel16_one, $class16);
- is($rs_rel16_one->dat, 'y16', "Multiple FKs to same table");
+ is(try { $rs_rel16_one->dat }, 'y16', "Multiple FKs to same table");
ok($class17->column_info('loader16_one')->{is_foreign_key}, 'Foreign key detected');
- my $rs_rel16_two = $obj17->loader16_two;
+ my $rs_rel16_two = try { $obj17->loader16_two };
isa_ok($rs_rel16_two, $class16);
- is($rs_rel16_two->dat, 'z16', "Multiple FKs to same table");
+ is(try { $rs_rel16_two->dat }, 'z16', "Multiple FKs to same table");
ok($class17->column_info('loader16_two')->{is_foreign_key}, 'Foreign key detected');
- my $obj16 = $rsobj16->find(2);
- my $rs_rel17 = $obj16->search_related('loader_test17_loader16_ones');
- isa_ok($rs_rel17->first, $class17);
- is($rs_rel17->first->id, 3, "search_related with multiple FKs from same table");
+ my $obj16 = try { $rsobj16->find(2) } || $rsobj16->search({ id => 2 })->first;
+ my $rs_rel17 = try { $obj16->search_related('loader_test17_loader16_ones') };
+ isa_ok(try { $rs_rel17->first }, $class17);
+ is(try { $rs_rel17->first->id }, 3, "search_related with multiple FKs from same table");
# XXX test m:m 18 <- 20 -> 19
ok($class20->column_info('parent')->{is_foreign_key}, 'Foreign key detected');
ok($class22->column_info('child')->{is_foreign_key}, 'Foreign key detected');
# test double multi-col fk 26 -> 25
- my $obj26 = $rsobj26->find(33);
+ my $obj26 = try { $rsobj26->find(33) } || $rsobj26->search({ id => 33 })->first;
- my $rs_rel25_one = $obj26->loader_test25_id_rel1;
+ my $rs_rel25_one = try { $obj26->loader_test25_id_rel1 };
isa_ok($rs_rel25_one, $class25);
- is($rs_rel25_one->dat, 'x25', "Multiple multi-col FKs to same table");
+ is(try { $rs_rel25_one->dat }, 'x25', "Multiple multi-col FKs to same table");
ok($class26->column_info('id')->{is_foreign_key}, 'Foreign key detected');
ok($class26->column_info('rel1')->{is_foreign_key}, 'Foreign key detected');
ok($class26->column_info('rel2')->{is_foreign_key}, 'Foreign key detected');
- my $rs_rel25_two = $obj26->loader_test25_id_rel2;
+ my $rs_rel25_two = try { $obj26->loader_test25_id_rel2 };
isa_ok($rs_rel25_two, $class25);
- is($rs_rel25_two->dat, 'y25', "Multiple multi-col FKs to same table");
+ is(try { $rs_rel25_two->dat }, 'y25', "Multiple multi-col FKs to same table");
- my $obj25 = $rsobj25->find(3,42);
- my $rs_rel26 = $obj25->search_related('loader_test26_id_rel1s');
- isa_ok($rs_rel26->first, $class26);
- is($rs_rel26->first->id, 3, "search_related with multiple multi-col FKs from same table");
+ my $obj25 = try { $rsobj25->find(3,42) } || $rsobj25->search({ id1 => 3, id2 => 42 })->first;
+ my $rs_rel26 = try { $obj25->search_related('loader_test26_id_rel1s') };
+ isa_ok(try { $rs_rel26->first }, $class26);
+ is(try { $rs_rel26->first->id }, 3, "search_related with multiple multi-col FKs from same table");
# test one-to-one rels
- my $obj27 = $rsobj27->find(1);
- my $obj28 = $obj27->loader_test28;
+ my $obj27 = try { $rsobj27->find(1) } || $rsobj27->search({ id => 1 })->first;
+ my $obj28 = try { $obj27->loader_test28 };
isa_ok($obj28, $class28);
- is($obj28->get_column('id'), 1, "One-to-one relationship with PRIMARY FK");
+ is(try { $obj28->get_column('id') }, 1, "One-to-one relationship with PRIMARY FK");
ok($class28->column_info('id')->{is_foreign_key}, 'Foreign key detected');
- my $obj29 = $obj27->loader_test29;
+ my $obj29 = try { $obj27->loader_test29 };
isa_ok($obj29, $class29);
- is($obj29->id, 1, "One-to-one relationship with UNIQUE FK");
+ is(try { $obj29->id }, 1, "One-to-one relationship with UNIQUE FK");
ok($class29->column_info('fk')->{is_foreign_key}, 'Foreign key detected');
- $obj27 = $rsobj27->find(2);
- is($obj27->loader_test28, undef, "Undef for missing one-to-one row");
- is($obj27->loader_test29, undef, "Undef for missing one-to-one row");
+ $obj27 = try { $rsobj27->find(2) } || $rsobj27->search({ id => 2 })->first;
+ is(try { $obj27->loader_test28 }, undef, "Undef for missing one-to-one row");
+ is(try { $obj27->loader_test29 }, undef, "Undef for missing one-to-one row");
# test outer join for nullable referring columns:
is $class32->column_info('rel2')->{is_nullable}, 1,
ok($class32->column_info('rel1')->{is_foreign_key}, 'Foreign key detected');
ok($class32->column_info('rel2')->{is_foreign_key}, 'Foreign key detected');
- my $obj32 = $rsobj32->find(1,{prefetch=>[qw/rel1 rel2/]});
- my $obj34 = $rsobj34->find(
- 1,{prefetch=>[qw/loader_test33_id_rel1 loader_test33_id_rel2/]}
- );
+ my $obj32 = try { $rsobj32->find(1, { prefetch => [qw/rel1 rel2/] }) }
+ || try { $rsobj32->search({ id => 1 }, { prefetch => [qw/rel1 rel2/] })->first }
+ || $rsobj32->search({ id => 1 })->first;
+
+ my $obj34 = eval { $rsobj34->find(1, { prefetch => [qw/loader_test33_id_rel1 loader_test33_id_rel2/] }) }
+ || eval { $rsobj34->search({ id => 1 }, { prefetch => [qw/loader_test33_id_rel1 loader_test33_id_rel2/] })->first }
+ || $rsobj34->search({ id => 1 })->first;
+ diag $@ if $@;
+
isa_ok($obj32,$class32);
isa_ok($obj34,$class34);
ok($class34->column_info('rel1')->{is_foreign_key}, 'Foreign key detected');
ok($class34->column_info('rel2')->{is_foreign_key}, 'Foreign key detected');
- my $rs_rel31_one = $obj32->rel1;
- my $rs_rel31_two = $obj32->rel2;
+ my $rs_rel31_one = try { $obj32->rel1 };
+ my $rs_rel31_two = try { $obj32->rel2 };
isa_ok($rs_rel31_one, $class31);
is($rs_rel31_two, undef);
- my $rs_rel33_one = $obj34->loader_test33_id_rel1;
- my $rs_rel33_two = $obj34->loader_test33_id_rel2;
+ my $rs_rel33_one = try { $obj34->loader_test33_id_rel1 };
+ my $rs_rel33_two = try { $obj34->loader_test33_id_rel2 };
- isa_ok($rs_rel33_one,$class33);
- is($rs_rel33_two, undef);
+ isa_ok($rs_rel33_one, $class33);
+ isa_ok($rs_rel33_two, $class33);
# from Chisel's tests...
my $moniker10 = $monikers->{loader_test10};
$obj10->update();
ok( defined $obj10, 'Create row' );
- my $obj11 = $rsobj11->create({ loader_test10 => $obj10->id() });
+ my $obj11 = $rsobj11->create({ loader_test10 => (try { $obj10->id() } || $obj10->id10) });
$obj11->update();
ok( defined $obj11, 'Create related row' );
ok($class13->column_info('loader_test12')->{is_foreign_key}, 'Foreign key detected');
ok($class13->column_info('dat')->{is_foreign_key}, 'Foreign key detected');
- my $obj13 = $rsobj13->find(1);
+ my $obj13 = try { $rsobj13->find(1) } || $rsobj13->search({ id => 1 })->first;
isa_ok( $obj13->id, $class12 );
isa_ok( $obj13->loader_test12, $class12);
isa_ok( $obj13->dat, $class12);
- my $obj12 = $rsobj12->find(1);
- isa_ok( $obj12->loader_test13, $class13 );
+ my $obj12 = try { $rsobj12->find(1) } || $rsobj12->search({ id => 1 })->first;
+ isa_ok( try { $obj12->loader_test13 }, $class13 );
# relname is preserved when another fk is added
{
local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /invalidates \d+ active statement/ };
- $conn->storage->disconnect; # for mssql
+ $conn->storage->disconnect; # for mssql and access
}
- isa_ok $rsobj3->find(1)->loader_test4zes, 'DBIx::Class::ResultSet';
+ isa_ok try { $rsobj3->find(1)->loader_test4zes }, 'DBIx::Class::ResultSet';
+
+ $conn->storage->disconnect; # for access
$conn->storage->dbh->do('ALTER TABLE loader_test4 ADD fkid2 INTEGER REFERENCES loader_test3 (id)');
$self->rescan_without_warnings($conn);
- isa_ok eval { $rsobj3->find(1)->loader_test4zes }, 'DBIx::Class::ResultSet',
+ isa_ok try { $rsobj3->find(1)->loader_test4zes }, 'DBIx::Class::ResultSet',
'relationship name preserved when another foreign key is added in remote table';
}
ok($class15->column_info('loader_test14')->{is_foreign_key}, 'Foreign key detected');
- my $obj15 = $rsobj15->find(1);
+ my $obj15 = try { $rsobj15->find(1) } || $rsobj15->search({ id => 1 })->first;
isa_ok( $obj15->loader_test14, $class14 );
}
}
SKIP: {
skip 'no rels', 2 if $self->{skip_rels};
- my $obj30 = $rsobj30->find(123);
+ my $obj30 = try { $rsobj30->find(123) } || $rsobj30->search({ id => 123 })->first;
isa_ok( $obj30->loader_test2, $class2);
ok($rsobj30->result_source->column_info('loader_test2')->{is_foreign_key},
$self->rescan_without_warnings($conn);
if (not $self->{skip_rels}) {
- is $conn->resultset('LoaderTest41')->find(1)->loader_test40->foo3_bar, 'foo',
+ is try { $conn->resultset('LoaderTest41')->find(1)->loader_test40->foo3_bar }, 'foo',
'rel and accessor for mixed-case column name in mixed case table';
}
else {
- is $conn->resultset('LoaderTest40')->find(1)->foo3_bar, 'foo',
+ is try { $conn->resultset('LoaderTest40')->find(1)->foo3_bar }, 'foo',
'accessor for mixed-case column name in mixed case table';
}
}
},
]);
- my $dbh = eval { $storage->dbh };
+ my $dbh = $storage->dbh;
die "Failed to connect to database: $@" if !$dbh;
$self->{storage} = $storage; # storage DESTROY disconnects
) $self->{innodb}
},
- qq{
+# Access does not support DEFAULT
+ $self->{vendor} ne 'Access' ? qq{
CREATE TABLE loader_test35 (
id INTEGER NOT NULL PRIMARY KEY,
a_varchar VARCHAR(100) DEFAULT 'foo',
a_negative_double DOUBLE PRECISION DEFAULT -10.555,
a_function $self->{default_function_def}
) $self->{innodb}
+ } : qq{
+ CREATE TABLE loader_test35 (
+ id INTEGER NOT NULL PRIMARY KEY,
+ a_varchar VARCHAR(100),
+ an_int INTEGER,
+ a_negative_int INTEGER,
+ a_double DOUBLE,
+ a_negative_double DOUBLE,
+ a_function DATETIME
+ )
},
qq{
FOREIGN KEY (id,rel2) REFERENCES loader_test33(id1,id2)
) $self->{innodb}
},
- q{ INSERT INTO loader_test34 (id,rel1) VALUES (1,2) },
+ q{ INSERT INTO loader_test34 (id,rel1,rel2) VALUES (1,2,2) },
);
@statements_advanced = (
},
$make_auto_inc->(qw/loader_test10 id10/),
+# Access does not support DEFAULT.
qq{
CREATE TABLE loader_test11 (
id11 $self->{auto_inc_pk},
- a_message VARCHAR(8) DEFAULT 'foo',
+ a_message VARCHAR(8) @{[ $self->{vendor} ne 'Access' ? "DEFAULT 'foo'" : '' ]},
loader_test10 INTEGER $self->{null},
FOREIGN KEY (loader_test10) REFERENCES loader_test10 (id10)
) $self->{innodb}
# hack for now, since DB2 doesn't like inline comments, and we need
# to test one for mysql, which works on everyone else...
# this all needs to be refactored anyways.
- $dbh->do($_) for (@statements_reltests);
+
+ for my $stmt (@statements_reltests) {
+ try {
+ $dbh->do($stmt);
+ }
+ catch {
+ die "Error executing '$stmt': $_\n";
+ };
+ }
if($self->{vendor} =~ /sqlite/i) {
$dbh->do($_) for (@statements_advanced_sqlite);
}
# For some reason some tests do this twice (I guess dependency issues?)
# do it twice for all drops
for (1,2) {
+ local $^W = 0; # for ADO
+
my $dbh = $self->dbconnect(0);
$dbh->do($_) for @{ $self->{extra}{pre_drop_ddl} || [] };
projects / dbsrgits/DBIx-Class-Schema-Loader.git / commitdiff