From: Rafael Kitover Date: Sun, 23 Jan 2011 12:03:13 +0000 (-0500) Subject: Comprehensive MSAccess support over both DBD::ODBC and DBD::ADO X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=726c8f65;p=dbsrgits%2FDBIx-Class-Historic.git Comprehensive MSAccess support over both DBD::ODBC and DBD::ADO --- diff --git a/Changes b/Changes index 1f24e0b..49a1b35 100644 --- a/Changes +++ b/Changes @@ -3,6 +3,8 @@ Revision history for DBIx::Class * New Features / Changes - Add quote_names connection option. When set to true automatically sets quote_char and name_sep appropriate for your RDBMS + - Support for MS Access databases via DBD::ODBC and DBD::ADO (only + Win32 support currently tested) - IC::DateTime support for MSSQL over DBD::ADO - Both the ::ODBC and ::ADO dispatchers now warn if a rdbms-specific driver is not found for this connection before falling back to diff --git a/lib/DBIx/Class.pm b/lib/DBIx/Class.pm index 4551941..e5d9d85 100644 --- a/lib/DBIx/Class.pm +++ b/lib/DBIx/Class.pm @@ -415,6 +415,8 @@ rjbs: Ricardo Signes robkinyon: Rob Kinyon +Robert Olson + Roman: Roman Filippov Sadrak: Felix Antonius Wilhelm Ostmann diff --git a/lib/DBIx/Class/Optional/Dependencies.pm b/lib/DBIx/Class/Optional/Dependencies.pm index 81b3ee6..571d187 100644 --- a/lib/DBIx/Class/Optional/Dependencies.pm +++ b/lib/DBIx/Class/Optional/Dependencies.pm @@ -57,6 +57,12 @@ my $rdbms_mssql_sybase = { my $rdbms_mssql_ado = { 'DBD::ADO' => '0', }; +my $rdbms_msaccess_odbc = { + 'DBD::ODBC' => '0', +}; +my $rdbms_msaccess_ado = { + 'DBD::ADO' => '0', +}; my $rdbms_mysql = { 'DBD::mysql' => '0', }; @@ -268,6 +274,26 @@ my $reqs = { }, }, + rdbms_msaccess_odbc => { + req => { + %$rdbms_msaccess_odbc, + }, + pod => { + title => 'MS Access support via DBD::ODBC', + desc => 'Modules required to connect to MS Access via DBD::ODBC', + }, + }, + + rdbms_msaccess_ado => { + req => { + %$rdbms_msaccess_ado, + }, + pod => { + title => 'MS Access support via DBD::ADO (Windows only)', + desc => 'Modules required to connect to MS Access via DBD::ADO. This particular DBD is available on Windows only', + }, + }, + rdbms_mysql => { req => { %$rdbms_mysql, @@ -348,6 +374,28 @@ my $reqs = { }, }, + test_rdbms_msaccess_odbc => { + req => { + $ENV{DBICTEST_MSACCESS_ODBC_DSN} + ? ( + %$rdbms_msaccess_odbc, + %$datetime_basic, + 'Data::GUID' => '0', + ) : () + }, + }, + + test_rdbms_msaccess_ado => { + req => { + $ENV{DBICTEST_MSACCESS_ADO_DSN} + ? ( + %$rdbms_msaccess_ado, + %$datetime_basic, + 'Data::GUID' => 0, + ) : () + }, + }, + test_rdbms_mysql => { req => { $ENV{DBICTEST_MYSQL_DSN} diff --git a/lib/DBIx/Class/SQLMaker.pm b/lib/DBIx/Class/SQLMaker.pm index 871862f..89053e3 100644 --- a/lib/DBIx/Class/SQLMaker.pm +++ b/lib/DBIx/Class/SQLMaker.pm @@ -369,17 +369,26 @@ sub _table { sub _generate_join_clause { my ($self, $join_type) = @_; + $join_type = $self->{_default_jointype} + if ! defined $join_type; + return sprintf ('%s JOIN ', - $join_type ? ' ' . $self->_sqlcase($join_type) : '' + $join_type ? $self->_sqlcase($join_type) : '' ); } sub _recurse_from { - my ($self, $from, @join) = @_; - my @sqlf; - push @sqlf, $self->_from_chunk_to_sql($from); + my $self = shift; + + return join (' ', $self->_gen_from_blocks(@_) ); +} + +sub _gen_from_blocks { + my ($self, $from, @joins) = @_; + + my @fchunks = $self->_from_chunk_to_sql($from); - for (@join) { + for (@joins) { my ($to, $on) = @$_; # check whether a join type exists @@ -390,18 +399,21 @@ sub _recurse_from { $join_type =~ s/^\s+ | \s+$//xg; } - $join_type = $self->{_default_jointype} if not defined $join_type; - - push @sqlf, $self->_generate_join_clause( $join_type ); + my @j = $self->_generate_join_clause( $join_type ); if (ref $to eq 'ARRAY') { - push(@sqlf, '(', $self->_recurse_from(@$to), ')'); - } else { - push(@sqlf, $self->_from_chunk_to_sql($to)); + push(@j, '(', $self->_recurse_from(@$to), ')'); + } + else { + push(@j, $self->_from_chunk_to_sql($to)); } - push(@sqlf, ' ON ', $self->_join_condition($on)); + + push(@j, ' ON ', $self->_join_condition($on)); + + push @fchunks, join '', @j; } - return join('', @sqlf); + + return @fchunks; } sub _from_chunk_to_sql { diff --git a/lib/DBIx/Class/SQLMaker/ACCESS.pm b/lib/DBIx/Class/SQLMaker/ACCESS.pm new file mode 100644 index 0000000..aec276d --- /dev/null +++ b/lib/DBIx/Class/SQLMaker/ACCESS.pm @@ -0,0 +1,24 @@ +package # Hide from PAUSE + DBIx::Class::SQLMaker::ACCESS; + +use strict; +use warnings; +use base 'DBIx::Class::SQLMaker'; + +# MSAccess is retarded wrt multiple joins in FROM - it requires a certain +# way of parenthesizing each left part before each next right part +sub _recurse_from { + my @j = shift->_gen_from_blocks(@_); + + # first 2 steps need no parenthesis + my $fin_join = join (' ', splice @j, 0, 2); + + while (@j) { + $fin_join = sprintf '( %s ) %s', $fin_join, (shift @j); + } + + # the entire FROM is *ALSO* expected aprenthesized + "( $fin_join )"; +} + +1; diff --git a/lib/DBIx/Class/Storage/DBI/ACCESS.pm b/lib/DBIx/Class/Storage/DBI/ACCESS.pm new file mode 100644 index 0000000..723b856 --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/ACCESS.pm @@ -0,0 +1,145 @@ +package DBIx::Class::Storage::DBI::ACCESS; + +use strict; +use warnings; +use base 'DBIx::Class::Storage::DBI::UniqueIdentifier'; +use mro 'c3'; + +use List::Util 'first'; +use namespace::clean; + +__PACKAGE__->sql_limit_dialect ('Top'); +__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::ACCESS'); +__PACKAGE__->sql_quote_char ([qw/[ ]/]); + +sub sqlt_type { 'ACCESS' } + +__PACKAGE__->new_guid(undef); + +=head1 NAME + +DBIx::Class::Storage::DBI::ACCESS - Support specific to MS Access + +=head1 DESCRIPTION + +This is the base class for Microsoft Access support. + +This driver supports L, +empty inserts for tables with C columns, nested transactions via +L, C columns via +L. + +=head1 SUPPORTED VERSIONS + +This module has currently only been tested on MS Access 2010. + +Information about how well it works on different version of MS Access is welcome +(write the mailing list, or submit a ticket to RT if you find bugs.) + +=head1 USING GUID COLUMNS + +If you have C PKs or other C columns with +L you will need to set a +L callback, like +so: + + $schema->storage->new_guid(sub { Data::GUID->new->as_string }); + +Under L you can use code similar to this in your +L C: + + after BUILD => sub { + my $self = shift; + $self->storage->new_guid(sub { Data::GUID->new->as_string }); + }; + +=cut + +sub _dbh_last_insert_id { $_[1]->selectrow_array('select @@identity') } + +# support empty insert +sub insert { + my $self = shift; + my ($source, $to_insert) = @_; + + my $columns_info = $source->columns_info; + + if (keys %$to_insert == 0) { + my $autoinc_col = first { + $columns_info->{$_}{is_auto_increment} + } keys %$columns_info; + + if (not $autoinc_col) { + $self->throw_exception( +'empty insert only supported for tables with an autoincrement column' + ); + } + + my $table = $source->from; + $table = $$table if ref $table; + + $to_insert->{$autoinc_col} = \"dmax('${autoinc_col}', '${table}')+1"; + } + + return $self->next::method(@_); +} + +sub bind_attribute_by_data_type { + my $self = shift; + my ($data_type) = @_; + + my $attributes = $self->next::method(@_) || {}; + + if ($self->_is_text_lob_type($data_type)) { + $attributes->{TYPE} = DBI::SQL_LONGVARCHAR; + } + elsif ($self->_is_binary_lob_type($data_type)) { + $attributes->{TYPE} = DBI::SQL_LONGVARBINARY; + } + + return $attributes; +} + +# savepoints are not supported, but nested transactions are. +# Unfortunately DBI does not support nested transactions. +# WARNING: this code uses the undocumented 'BegunWork' DBI attribute. + +sub _svp_begin { + my ($self, $name) = @_; + + $self->throw_exception( + 'cannot BEGIN a nested transaction on a disconnected handle' + ) unless $self->_dbh; + + local $self->_dbh->{AutoCommit} = 1; + local $self->_dbh->{BegunWork} = 0; + $self->_dbh_begin_work; +} + +# A new nested transaction on the same level releases the previous one. +sub _svp_release { 1 } + +sub _svp_rollback { + my ($self, $name) = @_; + + $self->throw_exception( + 'cannot ROLLBACK a nested transaction on a disconnected handle' + ) unless $self->_dbh; + + local $self->_dbh->{AutoCommit} = 0; + local $self->_dbh->{BegunWork} = 1; + $self->_dbh_rollback; +} + +1; + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut +# vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/ADO.pm b/lib/DBIx/Class/Storage/DBI/ADO.pm index 98c1941..8c64735 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO.pm @@ -32,7 +32,9 @@ sub _rebless { my $subclass = "DBIx::Class::Storage::DBI::ADO::${dbtype}"; - if ($self->load_optional_class($subclass) && !$self->isa($subclass)) { + return if $self->isa($subclass); + + if ($self->load_optional_class($subclass)) { bless $self, $subclass; $self->_rebless; } diff --git a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm new file mode 100644 index 0000000..8475313 --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm @@ -0,0 +1,167 @@ +package DBIx::Class::Storage::DBI::ADO::MS_Jet; + +use strict; +use warnings; +use base qw/ + DBIx::Class::Storage::DBI::ADO + DBIx::Class::Storage::DBI::ACCESS +/; +use mro 'c3'; +use DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor (); + +__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor'); + +=head1 NAME + +DBIx::Class::Storage::DBI::ADO::MS_Jet - Support for MS Access over ADO + +=head1 DESCRIPTION + +This driver is a subclass of L and +L for connecting to MS Access via +L. + +See the documentation for L for +information on the MS Access driver for L. + +This driver implements workarounds for C columns, sets the +L to +L to normalize returned +C values and provides L support +for C columns. + +=head1 EXAMPLE DSNs + + # older Access versions: + dbi:ADO:Microsoft.Jet.OLEDB.4.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb + + # newer Access versions: + dbi:ADO:Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb;Persist Security Info=False' + +=head1 TEXT/IMAGE/MEMO COLUMNS + +The ADO driver does not suffer from the +L +the L driver has with these types +of columns. You can use them safely. + +When you execute a C statement over this driver with a C +column, it will be converted to C, while in the +L driver it is converted to +C. + +However, the caveat about L having to be twice the +max size of your largest C column C<+1> still applies. L +sets L to a large value by default, so it should be +safe to just leave it unset. If you do pass a L in +your L, it will be +multiplied by two and C<1> added, just as for the +L driver. + +=cut + +# set LongReadLen = LongReadLen * 2 + 1 (see docs on MEMO) +sub _run_connection_actions { + my $self = shift; + + my $long_read_len = $self->_dbh->{LongReadLen}; + +# This is the DBD::ADO default. + if ($long_read_len != 2147483647) { + $self->_dbh->{LongReadLen} = $long_read_len * 2 + 1; + } + + return $self->next::method(@_); +} + +# AutoCommit does not get reset properly after transactions for some reason +# (probably because of my nested transaction hacks in ACCESS.pm) fix it up +# here. + +sub _dbh_commit { + my $self = shift; + $self->next::method(@_); + $self->_dbh->{AutoCommit} = $self->_dbh_autocommit + if $self->{transaction_depth} == 1; +} + +sub _dbh_rollback { + my $self = shift; + $self->next::method(@_); + $self->_dbh->{AutoCommit} = $self->_dbh_autocommit + if $self->{transaction_depth} == 1; +} + +# Fix up GUIDs for ->find, for cursors see the cursor_class above. + +sub select_single { + my $self = shift; + my ($ident, $select) = @_; + + my @row = $self->next::method(@_); + + return @row unless + $self->cursor_class->isa('DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor'); + + my $col_info = $self->_resolve_column_info($ident); + + for my $select_idx (0..$#$select) { + my $selected = $select->[$select_idx]; + + next if ref $selected; + + my $data_type = $col_info->{$selected}{data_type}; + + if ($self->_is_guid_type($data_type)) { + my $returned = $row[$select_idx]; + + $row[$select_idx] = substr($returned, 1, 36) + if substr($returned, 0, 1) eq '{'; + } + } + + return @row; +} + +sub datetime_parser_type { + 'DBIx::Class::Storage::DBI::ADO::MS_Jet::DateTime::Format' +} + +package # hide from PAUSE + DBIx::Class::Storage::DBI::ADO::MS_Jet::DateTime::Format; + +my $datetime_format = '%m/%d/%Y %I:%M:%S %p'; +my $datetime_parser; + +sub parse_datetime { + shift; + require DateTime::Format::Strptime; + $datetime_parser ||= DateTime::Format::Strptime->new( + pattern => $datetime_format, + on_error => 'croak', + ); + return $datetime_parser->parse_datetime(shift); +} + +sub format_datetime { + shift; + require DateTime::Format::Strptime; + $datetime_parser ||= DateTime::Format::Strptime->new( + pattern => $datetime_format, + on_error => 'croak', + ); + return $datetime_parser->format_datetime(shift); +} + +1; + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut +# vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm new file mode 100644 index 0000000..4fc6d02 --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm @@ -0,0 +1,107 @@ +package DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor; + +use strict; +use warnings; +use base 'DBIx::Class::Storage::DBI::Cursor'; +use mro 'c3'; + +=head1 NAME + +DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor - GUID Support for MS Access over +ADO + +=head1 DESCRIPTION + +This class is for normalizing GUIDs retrieved from Microsoft Access over ADO. + +You probably don't want to be here, see +L for information on the Microsoft +Access driver. + +Unfortunately when using L, GUIDs come back wrapped in braces, the +purpose of this class is to remove them. +L sets +L to this class by default. +It is overridable via your +L. + +You can use L safely with this class and not lose +the GUID normalizing functionality, +L<::Cursor::Cached|DBIx::Class::Cursor::Cached> uses the underlying class data +for the inner cursor class. + +=cut + +sub _dbh_next { + my ($storage, $dbh, $self) = @_; + + my $next = $self->next::can; + + my @row = $next->(@_); + + my $col_info = $storage->_resolve_column_info($self->args->[0]); + + my $select = $self->args->[1]; + + for my $select_idx (0..$#$select) { + my $selected = $select->[$select_idx]; + + next if ref $selected; + + my $data_type = $col_info->{$selected}{data_type}; + + if ($storage->_is_guid_type($data_type)) { + my $returned = $row[$select_idx]; + + $row[$select_idx] = substr($returned, 1, 36) + if substr($returned, 0, 1) eq '{'; + } + } + + return @row; +} + +sub _dbh_all { + my ($storage, $dbh, $self) = @_; + + my $next = $self->next::can; + + my @rows = $next->(@_); + + my $col_info = $storage->_resolve_column_info($self->args->[0]); + + my $select = $self->args->[1]; + + for my $row (@rows) { + for my $select_idx (0..$#$select) { + my $selected = $select->[$select_idx]; + + next if ref $selected; + + my $data_type = $col_info->{$selected}{data_type}; + + if ($storage->_is_guid_type($data_type)) { + my $returned = $row->[$select_idx]; + + $row->[$select_idx] = substr($returned, 1, 36) + if substr($returned, 0, 1) eq '{'; + } + } + } + + return @rows; +} + +1; + +=head1 AUTHOR + +See L and L. + +=head1 LICENSE + +You may distribute this code under the same terms as Perl itself. + +=cut + +# vim:sts=2 sw=2: diff --git a/lib/DBIx/Class/Storage/DBI/ODBC.pm b/lib/DBIx/Class/Storage/DBI/ODBC.pm index 8f0b418..0f3259e 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC.pm @@ -12,7 +12,9 @@ sub _rebless { $dbtype =~ s/\W/_/gi; my $subclass = "DBIx::Class::Storage::DBI::ODBC::${dbtype}"; - if ($self->load_optional_class($subclass) && !$self->isa($subclass)) { + return if $self->isa($subclass); + + if ($self->load_optional_class($subclass)) { bless $self, $subclass; $self->_rebless; } diff --git a/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm b/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm index b41b1f3..2a0624f 100644 --- a/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm +++ b/lib/DBIx/Class/Storage/DBI/ODBC/ACCESS.pm @@ -1,131 +1,154 @@ package DBIx::Class::Storage::DBI::ODBC::ACCESS; + use strict; use warnings; - -use base qw/DBIx::Class::Storage::DBI/; +use base qw/ + DBIx::Class::Storage::DBI::ODBC + DBIx::Class::Storage::DBI::ACCESS +/; use mro 'c3'; -use DBI; - -my $ERR_MSG_START = __PACKAGE__ . ' failed: '; +__PACKAGE__->mk_group_accessors(inherited => + 'disable_sth_caching_for_image_insert_or_update' +); -__PACKAGE__->sql_limit_dialect ('Top'); -__PACKAGE__->sql_quote_char ([qw/[ ]/]); - -sub insert { - my $self = shift; - my ( $source, $to_insert ) = @_; +__PACKAGE__->disable_sth_caching_for_image_insert_or_update(1); - my ( undef, $sth ) = $self->_execute( 'insert', $source, $to_insert ); - - #store the identity here since @@IDENTITY is connection global and this prevents - #possibility that another insert to a different table overwrites it for this resultsource - my $identity = 'SELECT @@IDENTITY'; - my $max_sth = $self->{ _dbh }->prepare( $identity ) - or $self->throw_exception( $ERR_MSG_START . $self->{ _dbh }->errstr() ); - $max_sth->execute() or $self->throw_exception( $ERR_MSG_START . $max_sth->errstr ); - - my $row = $max_sth->fetchrow_arrayref() - or $self->throw_exception( $ERR_MSG_START . "$identity did not return any result." ); - - $self->{ last_pk }->{ $source->name() } = $row; +=head1 NAME - return $to_insert; -} +DBIx::Class::Storage::DBI::ODBC::ACCESS - Support specific to MS Access over ODBC -sub last_insert_id { - my $self = shift; - my ( $result_source ) = @_; +=head1 DESCRIPTION - return @{ $self->{ last_pk }->{ $result_source->name() } }; -} +This class implements support specific to Microsoft Access over ODBC. -sub bind_attribute_by_data_type { - my $self = shift; +It is a subclass of L and +L, see those classes for more +information. - my ( $data_type ) = @_; +It is loaded automatically by by L when it +detects a MS Access back-end. - return { TYPE => $data_type } if $data_type == DBI::SQL_LONGVARCHAR; +This driver implements workarounds for C and C columns, and +L support for C columns. - return; -} +=head1 EXAMPLE DSN -sub sqlt_type { 'ACCESS' } + dbi:ODBC:driver={Microsoft Access Driver (*.mdb, *.accdb)};dbq=C:\Users\rkitover\Documents\access_sample.accdb -1; +=head1 TEXT/IMAGE/MEMO COLUMNS -=head1 NAME +Avoid using C columns as they will be truncated to 255 bytes. Some other +drivers (like L) will automatically +convert C columns to C, but the ODBC driver does not. -DBIx::Class::Storage::DBI::ODBC::ACCESS - Support specific to MS Access over ODBC +C columns work correctly, but the statements for inserting or updating an +C column will not be L, due to a bug in the +Access ODBC driver. -=head1 WARNING +C columns work correctly as well, but you must take care to set +L to C<$max_memo_size * 2 + 1>. This is done for +you automatically if you pass L in your +L; but if you set this +attribute directly on the C<$dbh>, keep this limitation in mind. -I am not a DBI, DBIx::Class or MS Access guru. Use this module with that in -mind. +=cut -This module is currently considered alpha software and can change without notice. +# set LongReadLen = LongReadLen * 2 + 1 (see docs on MEMO) +sub _run_connection_actions { + my $self = shift; -=head1 DESCRIPTION + my $long_read_len = $self->_dbh->{LongReadLen}; -This class implements support specific to Microsoft Access over ODBC. + # 80 is another default (just like 0) on some drivers + if ($long_read_len != 0 && $long_read_len != 80) { + $self->_dbh->{LongReadLen} = $long_read_len * 2 + 1; + } -It is loaded automatically by by DBIx::Class::Storage::DBI::ODBC when it -detects a MS Access back-end. + return $self->next::method(@_); +} -=head1 SUPPORTED VERSIONS +sub insert { + my $self = shift; + my ($source, $to_insert) = @_; -This module have currently only been tested on MS Access 2003 using the Jet 4.0 engine. + my $columns_info = $source->columns_info; -As far as my knowledge it should work on MS Access 2000 or later, but that have not been tested. -Information about support for different version of MS Access is welcome. + my $is_image_insert = 0; -=head1 IMPLEMENTATION NOTES + for my $col (keys %$to_insert) { + if ($self->_is_binary_lob_type($columns_info->{$col}{data_type})) { + $is_image_insert = 1; + last; + } + } -MS Access supports the @@IDENTITY function for retrieving the id of the latest inserted row. -@@IDENTITY is global to the connection, so to support the possibility of getting the last inserted -id for different tables, the insert() function stores the inserted id on a per table basis. -last_insert_id() then just returns the stored value. + local $self->{disable_sth_caching} = 1 if $is_image_insert + && $self->disable_sth_caching_for_image_insert_or_update; -=head1 KNOWN ACCESS PROBLEMS + return $self->next::method(@_); +} -=over +sub update { + my $self = shift; + my ($source, $fields) = @_; -=item Invalid precision value + my $columns_info = $source->columns_info; -This error message is received when trying to store more than 255 characters in a MEMO field. -The problem is (to my knowledge) an error in the MS Access ODBC driver. The problem is fixed -by setting the C of the column to C in C. -C is a constant in the C module. + my $is_image_insert = 0; -=back + for my $col (keys %$fields) { + if ($self->_is_binary_lob_type($columns_info->{$col}{data_type})) { + $is_image_insert = 1; + last; + } + } -=head1 IMPLEMENTED FUNCTIONS + local $self->{disable_sth_caching} = 1 if $is_image_insert + && $self->disable_sth_caching_for_image_insert_or_update; -=head2 bind_attribute_by_data_type + return $self->next::method(@_); +} -This function currently supports the SQL_LONGVARCHAR column type. +sub datetime_parser_type { + 'DBIx::Class::Storage::DBI::ODBC::ACCESS::DateTime::Format' +} -=head2 insert +package # hide from PAUSE + DBIx::Class::Storage::DBI::ODBC::ACCESS::DateTime::Format; -=head2 last_insert_id +my $datetime_format = '%Y-%m-%d %H:%M:%S'; # %F %T, no fractional part +my $datetime_parser; -=head2 sqlt_type +sub parse_datetime { + shift; + require DateTime::Format::Strptime; + $datetime_parser ||= DateTime::Format::Strptime->new( + pattern => $datetime_format, + on_error => 'croak', + ); + return $datetime_parser->parse_datetime(shift); +} -=head1 BUGS +sub format_datetime { + shift; + require DateTime::Format::Strptime; + $datetime_parser ||= DateTime::Format::Strptime->new( + pattern => $datetime_format, + on_error => 'croak', + ); + return $datetime_parser->format_datetime(shift); +} -Most likely. Bug reports are welcome. +1; -=head1 AUTHORS +=head1 AUTHOR -Øystein Torget C<< >> +See L and L. -=head1 COPYRIGHT +=head1 LICENSE You may distribute this code under the same terms as Perl itself. -Det Norske Veritas AS (DNV) - -http://www.dnv.com - =cut - +# vim:sts=2 sw=2: diff --git a/t/751msaccess.t b/t/751msaccess.t new file mode 100644 index 0000000..26ab187 --- /dev/null +++ b/t/751msaccess.t @@ -0,0 +1,402 @@ +use strict; +use warnings; + +use Test::More; +use Test::Exception; +use Scope::Guard (); +use Try::Tiny; +use lib qw(t/lib); +use DBICTest; + +DBICTest::Schema->load_classes('ArtistGUID'); + +# Example DSNs (32bit only): +# dbi:ODBC:driver={Microsoft Access Driver (*.mdb, *.accdb)};dbq=C:\Users\rkitover\Documents\access_sample.accdb +# dbi:ADO:Microsoft.Jet.OLEDB.4.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb +# dbi:ADO:Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\Users\rkitover\Documents\access_sample.accdb;Persist Security Info=False' + +my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSACCESS_ODBC_${_}" } qw/DSN USER PASS/}; +my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSACCESS_ADO_${_}" } qw/DSN USER PASS/}; + +plan skip_all => <<'EOF' unless $dsn || $dsn2; +Set $ENV{DBICTEST_MSACCESS_ODBC_DSN} and/or $ENV{DBICTEST_MSACCESS_ADO_DSN} (and optionally _USER and _PASS) to run these tests.\nWarning: this test drops and creates the tables 'artist', 'cd', 'bindtype_test' and 'artist_guid'. +EOF + +plan skip_all => 'Test needs ' . +DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_odbc') +. ' or ' . +DBIx::Class::Optional::Dependencies->req_missing_for('test_rdbms_msaccess_ado') + unless + DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_odbc') + or + DBIx::Class::Optional::Dependencies->req_ok_for('test_rdbms_msaccess_ado'); + +my @info = ( + [ $dsn, $user || '', $pass || '' ], + [ $dsn2, $user2 || '', $pass2 || '' ], +); + +my $schema; + +foreach my $info (@info) { + my ($dsn, $user, $pass) = @$info; + + next unless $dsn; + +# Check that we can connect without any options. + $schema = DBICTest::Schema->connect($dsn, $user, $pass); + lives_ok { + $schema->storage->ensure_connected; + } 'connection without any options'; + + my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) ); + $binstr{'large'} = $binstr{'small'} x 1024; + + my $maxloblen = length $binstr{'large'}; + + $schema = DBICTest::Schema->connect($dsn, $user, $pass, { + quote_names => 1, + auto_savepoint => 1, + LongReadLen => $maxloblen, + }); + + my $guard = Scope::Guard->new(\&cleanup); + + my $dbh = $schema->storage->dbh; + + # turn off warnings for OLE exception from ADO about nonexistant table + eval { local $^W = 0; $dbh->do("DROP TABLE artist") }; + + $dbh->do(<resultset('Artist'); + is ( $ars->count, 0, 'No rows at first' ); + +# test primary key handling + my $new = $ars->create({ name => 'foo' }); + ok($new->artistid, "Auto-PK worked"); + + my $first_artistid = $new->artistid; + +# test explicit key spec + $new = $ars->create ({ name => 'bar', artistid => 66 }); + is($new->artistid, 66, 'Explicit PK worked'); + $new->discard_changes; + is($new->artistid, 66, 'Explicit PK assigned'); + +# test joins + eval { local $^W = 0; $dbh->do("DROP TABLE cd") }; + + $dbh->do(<do(<resultset('CD')->create({ + artist => $first_artistid, + title => 'Some Album', + }); + +# one-step join + my $joined_artist = $schema->resultset('Artist')->search({ + artistid => $first_artistid, + }, { + join => [ 'cds' ], + '+select' => [ 'cds.title' ], + '+as' => [ 'cd_title' ], + })->next; + + is $joined_artist->get_column('cd_title'), 'Some Album', + 'one-step join works'; + +# two-step join + my $track = $schema->resultset('Track')->create({ + cd => $cd->cdid, + position => 1, + title => 'my track', + }); + + my $joined_track = try { + $schema->resultset('Artist')->search({ + artistid => $first_artistid, + }, { + join => [{ cds => 'tracks' }], + '+select' => [ 'tracks.title' ], + '+as' => [ 'track_title' ], + })->next; + } + catch { + diag "Could not execute two-step join: $_"; + }; + + is try { $joined_track->get_column('track_title') }, 'my track', + 'two-step join works'; + +# test basic transactions + $schema->txn_do(sub { + $ars->create({ name => 'transaction_commit' }); + }); + ok($ars->search({ name => 'transaction_commit' })->first, + 'transaction committed'); + $ars->search({ name => 'transaction_commit' })->delete, + throws_ok { + $schema->txn_do(sub { + $ars->create({ name => 'transaction_rollback' }); + die 'rolling back'; + }); + } qr/rolling back/, 'rollback executed'; + is $ars->search({ name => 'transaction_rollback' })->first, undef, + 'transaction rolled back'; + +# test two-phase commit and inner transaction rollback from nested transactions + $schema->txn_do(sub { + $ars->create({ name => 'in_outer_transaction' }); + $schema->txn_do(sub { + $ars->create({ name => 'in_inner_transaction' }); + }); + ok($ars->search({ name => 'in_inner_transaction' })->first, + 'commit from inner transaction visible in outer transaction'); + throws_ok { + $schema->txn_do(sub { + $ars->create({ name => 'in_inner_transaction_rolling_back' }); + die 'rolling back inner transaction'; + }); + } qr/rolling back inner transaction/, 'inner transaction rollback executed'; + }); + ok($ars->search({ name => 'in_outer_transaction' })->first, + 'commit from outer transaction'); + ok($ars->search({ name => 'in_inner_transaction' })->first, + 'commit from inner transaction'); + is $ars->search({ name => 'in_inner_transaction_rolling_back' })->first, + undef, + 'rollback from inner transaction'; + $ars->search({ name => 'in_outer_transaction' })->delete; + $ars->search({ name => 'in_inner_transaction' })->delete; + +# test populate + lives_ok (sub { + my @pop; + for (1..2) { + push @pop, { name => "Artist_$_" }; + } + $ars->populate (\@pop); + }); + +# test populate with explicit key + lives_ok (sub { + my @pop; + for (1..2) { + push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ }; + } + $ars->populate (\@pop); + }); + +# count what we did so far + is ($ars->count, 6, 'Simple count works'); + +# test LIMIT support +# not testing offset because access only supports TOP + my $lim = $ars->search( {}, + { + rows => 2, + offset => 0, + order_by => 'artistid' + } + ); + is( $lim->count, 2, 'ROWS+OFFSET count ok' ); + is( $lim->all, 2, 'Number of ->all objects matches count' ); + +# test iterator + $lim->reset; + is( $lim->next->artistid, 1, "iterator->next ok" ); + is( $lim->next->artistid, 66, "iterator->next ok" ); + is( $lim->next, undef, "next past end of resultset ok" ); + +# test empty insert + my $current_artistid = $ars->search({}, { + select => [ { max => 'artistid' } ], as => ['artistid'] + })->first->artistid; + + my $row; + lives_ok { $row = $ars->create({}) } + 'empty insert works'; + + $row->discard_changes; + + is $row->artistid, $current_artistid+1, + 'empty insert generated correct PK'; + +# test that autoinc column still works after empty insert + $row = $ars->create({ name => 'after_empty_insert' }); + + is $row->artistid, $current_artistid+2, + 'autoincrement column functional aftear empty insert'; + +# test blobs (stolen from 73oracle.t) + +# turn off horrendous binary DBIC_TRACE output + { + local $schema->storage->{debug} = 0; + + eval { local $^W = 0; $dbh->do('DROP TABLE bindtype_test') }; + $dbh->do(qq[ + CREATE TABLE bindtype_test + ( + id INT NOT NULL PRIMARY KEY, + bytea INT NULL, + blob IMAGE NULL, + clob TEXT NULL, + a_memo MEMO NULL + ) + ],{ RaiseError => 1, PrintError => 1 }); + + my $rs = $schema->resultset('BindType'); + my $id = 0; + + foreach my $type (qw( blob clob a_memo )) { + foreach my $size (qw( small large )) { + SKIP: { + skip 'TEXT columns not cast to MEMO over ODBC', 2 + if $type eq 'clob' && $size eq 'large' && $dsn =~ /:ODBC:/; + + $id++; + + lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) } + "inserted $size $type without dying" or next; + + my $from_db = eval { $rs->find($id)->$type } || ''; + diag $@ if $@; + + ok($from_db eq $binstr{$size}, "verified inserted $size $type" ) + or do { + my $hexdump = sub { + join '', map sprintf('%02X', ord), split //, shift + }; + diag 'Got: ', "\n", substr($hexdump->($from_db),0,255), '...', + substr($hexdump->($from_db),-255); + diag 'Size: ', length($from_db); + diag 'Expected Size: ', length($binstr{$size}); + diag 'Expected: ', "\n", + substr($hexdump->($binstr{$size}), 0, 255), + "...", substr($hexdump->($binstr{$size}),-255); + }; + } + } + } +# test IMAGE update + lives_ok { + $rs->search({ id => 0 })->update({ blob => $binstr{small} }); + } 'updated IMAGE to small binstr without dying'; + + lives_ok { + $rs->search({ id => 0 })->update({ blob => $binstr{large} }); + } 'updated IMAGE to large binstr without dying'; + } + +# test GUIDs (and the cursor GUID fixup stuff for ADO) + + require Data::GUID; + $schema->storage->new_guid(sub { Data::GUID->new->as_string }); + + local $schema->source('ArtistGUID')->column_info('artistid')->{data_type} + = 'guid'; + + local $schema->source('ArtistGUID')->column_info('a_guid')->{data_type} + = 'guid'; + + $schema->storage->dbh_do (sub { + my ($storage, $dbh) = @_; + eval { local $^W = 0; $dbh->do("DROP TABLE artist_guid") }; + $dbh->do(<<"SQL"); +CREATE TABLE artist_guid ( + artistid GUID NOT NULL, + name VARCHAR(100), + rank INT NULL, + charfield CHAR(10) NULL, + a_guid GUID, + primary key(artistid) +) +SQL + }); + + lives_ok { + $row = $schema->resultset('ArtistGUID')->create({ name => 'mtfnpy' }) + } 'created a row with a GUID'; + + ok( + eval { $row->artistid }, + 'row has GUID PK col populated', + ); + diag $@ if $@; + + ok( + eval { $row->a_guid }, + 'row has a GUID col with auto_nextval populated', + ); + diag $@ if $@; + + my $row_from_db = $schema->resultset('ArtistGUID') + ->search({ name => 'mtfnpy' })->first; + + is $row_from_db->artistid, $row->artistid, + 'PK GUID round trip (via ->search->next)'; + + is $row_from_db->a_guid, $row->a_guid, + 'NON-PK GUID round trip (via ->search->next)'; + + $row_from_db = $schema->resultset('ArtistGUID') + ->find($row->artistid); + + is $row_from_db->artistid, $row->artistid, + 'PK GUID round trip (via ->find)'; + + is $row_from_db->a_guid, $row->a_guid, + 'NON-PK GUID round trip (via ->find)'; + + ($row_from_db) = $schema->resultset('ArtistGUID') + ->search({ name => 'mtfnpy' })->all; + + is $row_from_db->artistid, $row->artistid, + 'PK GUID round trip (via ->search->all)'; + + is $row_from_db->a_guid, $row->a_guid, + 'NON-PK GUID round trip (via ->search->all)'; +} + +done_testing; + +sub cleanup { + if (my $storage = eval { $schema->storage }) { + # cannot drop a table if it has been used, have to reconnect first + $schema->storage->disconnect; + local $^W = 0; # for ADO OLE exceptions + $schema->storage->dbh->do("DROP TABLE $_") + for qw/artist track cd bindtype_test artist_guid/; + } +} + +# vim:sts=2 sw=2: diff --git a/t/inflate/datetime_msaccess.t b/t/inflate/datetime_msaccess.t new file mode 100644 index 0000000..7f62e4e --- /dev/null +++ b/t/inflate/datetime_msaccess.t @@ -0,0 +1,80 @@ +use strict; +use warnings; + +use Test::More; +use Test::Exception; +use Scope::Guard (); +use Try::Tiny; +use lib qw(t/lib); +use DBICTest; + +my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSACCESS_ODBC_${_}" } qw/DSN USER PASS/}; +my ($dsn2, $user2, $pass2) = @ENV{map { "DBICTEST_MSACCESS_ADO_${_}" } qw/DSN USER PASS/}; + +plan skip_all => <<'EOF' unless $dsn || $dsn2; +Set $ENV{DBICTEST_MSACCESS_ODBC_DSN} and/or $ENV{DBICTEST_MSACCESS_ADO_DSN} (and optionally _USER and _PASS) to run these tests.\nWarning: this test drops and creates the table 'track'. +EOF + +plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt') + unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt'); + +my @connect_info = ( + [ $dsn, $user || '', $pass || '' ], + [ $dsn2, $user2 || '', $pass2 || '' ], +); + +my $schema; + +for my $connect_info (@connect_info) { + my ($dsn, $user, $pass) = @$connect_info; + + next unless $dsn; + + $schema = DBICTest::Schema->connect($dsn, $user, $pass, { + on_connect_call => 'datetime_setup', + quote_names => 1, + }); + + my $guard = Scope::Guard->new(\&cleanup); + + try { local $^W = 0; $schema->storage->dbh->do('DROP TABLE track') }; + $schema->storage->dbh->do(<<"SQL"); +CREATE TABLE track ( + trackid AUTOINCREMENT PRIMARY KEY, + cd INT, + [position] INT, + last_updated_at DATETIME +) +SQL + + ok(my $dt = DateTime->new({ + year => 2004, + month => 8, + day => 21, + hour => 14, + minute => 36, + second => 48, + })); + + ok(my $row = $schema->resultset('Track')->create({ + last_updated_at => $dt, + cd => 1 + })); + ok($row = $schema->resultset('Track') + ->search({ trackid => $row->trackid }, { select => ['last_updated_at'] }) + ->first + ); + is($row->last_updated_at, $dt, "DATETIME roundtrip" ); +} + +done_testing; + +# clean up our mess +sub cleanup { + # have to reconnect to drop a table that's in use + if (my $storage = eval { $schema->storage }) { + local $^W = 0; + $storage->disconnect; + $storage->dbh->do('DROP TABLE track'); + } +} diff --git a/t/sqlmaker/msaccess.t b/t/sqlmaker/msaccess.t new file mode 100644 index 0000000..77e6cd4 --- /dev/null +++ b/t/sqlmaker/msaccess.t @@ -0,0 +1,53 @@ +use strict; +use warnings; +use Test::More; +use lib qw(t/lib); +use DBICTest; +use DBIC::SqlMakerTest; + +use DBIx::Class::SQLMaker::ACCESS; + +my $sa = DBIx::Class::SQLMaker::ACCESS->new; + +# my ($self, $table, $fields, $where, $order, @rest) = @_; +my ($sql, @bind) = $sa->select( + [ + { me => "cd" }, + [ + { "-join_type" => "LEFT", artist => "artist" }, + { "artist.artistid" => "me.artist" }, + ], + ], + [ 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ], + undef, + undef +); +is_same_sql_bind( + $sql, \@bind, + 'SELECT cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM (cd me LEFT JOIN artist artist ON artist.artistid = me.artist)', [], + 'one-step join parenthesized' +); + +($sql, @bind) = $sa->select( + [ + { me => "cd" }, + [ + { "-join_type" => "LEFT", track => "track" }, + { "track.cd" => "me.cdid" }, + ], + [ + { "-join_type" => "LEFT", artist => "artist" }, + { "artist.artistid" => "me.artist" }, + ], + ], + [ 'track.title', 'cd.cdid', 'cd.artist', 'cd.title', 'cd.year', 'artist.artistid', 'artist.name' ], + undef, + undef +); +is_same_sql_bind( + $sql, \@bind, + 'SELECT track.title, cd.cdid, cd.artist, cd.title, cd.year, artist.artistid, artist.name FROM ((cd me LEFT JOIN track track ON track.cd = me.cdid) LEFT JOIN artist artist ON artist.artistid = me.artist)', [], + 'two-step join parenthesized' +); + +done_testing;