From: Rafael Kitover Date: Thu, 17 Feb 2011 14:44:15 +0000 (-0500) Subject: MS Access support over DBD::ODBC and DBD::ADO X-Git-Tag: 0.07008~3 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=3b17d9885e593f0705e1e16360b816778d71ec95;p=dbsrgits%2FDBIx-Class-Schema-Loader.git MS Access support over DBD::ODBC and DBD::ADO --- diff --git a/Changes b/Changes index c8419fe..edf9c38 100644 --- a/Changes +++ b/Changes @@ -2,6 +2,8 @@ Revision history for Perl extension DBIx::Class::Schema::Loader - 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 diff --git a/lib/DBIx/Class/Schema/Loader/DBI.pm b/lib/DBIx/Class/Schema/Loader/DBI.pm index 7275497..76e741b 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI.pm @@ -10,6 +10,13 @@ use namespace::clean; 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. @@ -196,9 +203,22 @@ sub _table_columns { 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; @@ -208,9 +228,13 @@ sub _table_pk_info { 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 []; } @@ -225,17 +249,14 @@ sub _table_uniq_info { || !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; @@ -245,9 +266,19 @@ sub _table_uniq_info { 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; @@ -377,6 +408,23 @@ sub _dbh_column_info { 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 diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ADO.pm b/lib/DBIx/Class/Schema/Loader/DBI/ADO.pm new file mode 100644 index 0000000..caf63ca --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBI/ADO.pm @@ -0,0 +1,74 @@ +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 proxy + +=head1 DESCRIPTION + +Reblesses into an C<::ADO::> class when connecting via L. + +See L 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, +L, +L, L, +L + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + +1; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ADO/MS_Jet.pm b/lib/DBIx/Class/Schema/Loader/DBI/ADO/MS_Jet.pm new file mode 100644 index 0000000..bf28fd0 --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBI/ADO/MS_Jet.pm @@ -0,0 +1,231 @@ +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 + +=head1 DESCRIPTION + +Proxy for L when using +L. + +See L 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 = ); + $conn->Open($dsn, $user, $pass); + $self->_passwords->{$dsn}{$user} = $pass; + }; + } + else { + print "Enter database password for $user ($dsn): "; + chomp($pass = ); + $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, +L, +L, L, +L + +=head1 AUTHOR + +See L and L. + +=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: diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ADO/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Schema/Loader/DBI/ADO/Microsoft_SQL_Server.pm new file mode 100644 index 0000000..f332a9e --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBI/ADO/Microsoft_SQL_Server.pm @@ -0,0 +1,43 @@ +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 + +=head1 DESCRIPTION + +Proxy for L when using L. + +See L for usage information. + +=head1 SEE ALSO + +L, +L, L, +L + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +This library is free software; you can redistribute it and/or modify it under +the same terms as Perl itself. + +=cut + +1; diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm b/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm index bba28cd..cb33593 100644 --- a/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm +++ b/lib/DBIx/Class/Schema/Loader/DBI/ODBC.pm @@ -3,8 +3,9 @@ package DBIx::Class::Schema::Loader::DBI::ODBC; 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'; @@ -41,7 +42,7 @@ sub _rebless { } } -sub _tables_list { +sub _tables_list { my ($self, $opts) = @_; return $self->next::method($opts, undef, undef); diff --git a/lib/DBIx/Class/Schema/Loader/DBI/ODBC/ACCESS.pm b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/ACCESS.pm new file mode 100644 index 0000000..766024e --- /dev/null +++ b/lib/DBIx/Class/Schema/Loader/DBI/ODBC/ACCESS.pm @@ -0,0 +1,321 @@ +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 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 = ); + + ($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 = ); + + ($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, L, +L + +=head1 AUTHOR + +See L and L. + +=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: diff --git a/t/10_11msaccess_common.t b/t/10_11msaccess_common.t new file mode 100644 index 0000000..49e3483 --- /dev/null +++ b/t/10_11msaccess_common.t @@ -0,0 +1,119 @@ +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: diff --git a/t/lib/dbixcsl_common_tests.pm b/t/lib/dbixcsl_common_tests.pm index bcd5944..0fa1710 100644 --- a/t/lib/dbixcsl_common_tests.pm +++ b/t/lib/dbixcsl_common_tests.pm @@ -23,7 +23,7 @@ use dbixcsl_test_dir qw/$tdir/; 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; @@ -169,6 +169,8 @@ sub drop_extra_tables_only { 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} || [] }; @@ -440,9 +442,10 @@ sub test_schema { 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 { @@ -459,38 +462,42 @@ sub test_schema { 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}; @@ -617,22 +624,23 @@ sub test_schema { 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' ); @@ -645,49 +653,49 @@ sub test_schema { "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 @@ -701,9 +709,9 @@ sub test_schema { } # 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'); @@ -713,30 +721,30 @@ sub test_schema { 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'); @@ -747,42 +755,42 @@ sub test_schema { 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, @@ -791,10 +799,15 @@ sub test_schema { 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); @@ -802,16 +815,16 @@ sub test_schema { 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}; @@ -833,7 +846,7 @@ sub test_schema { $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' ); @@ -875,13 +888,13 @@ sub test_schema { 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 @@ -890,10 +903,12 @@ sub test_schema { { 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)'); @@ -901,7 +916,7 @@ sub test_schema { $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'; } @@ -921,7 +936,7 @@ sub test_schema { 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 ); } } @@ -1004,7 +1019,7 @@ sub test_schema { 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}, @@ -1099,11 +1114,11 @@ qq| INSERT INTO ${oqt}LoaderTest41${cqt} VALUES (1, 1) |, $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'; } } @@ -1160,7 +1175,7 @@ sub dbconnect { }, ]); - my $dbh = eval { $storage->dbh }; + my $dbh = $storage->dbh; die "Failed to connect to database: $@" if !$dbh; $self->{storage} = $storage; # storage DESTROY disconnects @@ -1244,7 +1259,8 @@ sub create { ) $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', @@ -1254,6 +1270,16 @@ sub create { 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{ @@ -1534,7 +1560,7 @@ sub create { 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 = ( @@ -1547,10 +1573,11 @@ sub create { }, $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} @@ -1653,7 +1680,15 @@ sub create { # 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); } @@ -1749,6 +1784,8 @@ sub drop_tables { # 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} || [] };