* 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
robkinyon: Rob Kinyon <rkinyon@cpan.org>
+Robert Olson <bob@rdolson.org>
+
Roman: Roman Filippov <romanf@cpan.org>
Sadrak: Felix Antonius Wilhelm Ostmann <sadrak@cpan.org>
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',
};
},
},
+ 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,
},
},
+ 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}
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
$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 {
--- /dev/null
+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;
--- /dev/null
+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<last_insert_id|DBIx::Class::Storage::DBI/last_insert_id>,
+empty inserts for tables with C<AUTOINCREMENT> columns, nested transactions via
+L<auto_savepoint|DBIx::Class::Storage::DBI/auto_savepoint>, C<GUID> columns via
+L<DBIx::Class::Storage::DBI::UniqueIdentifier>.
+
+=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<GUID> PKs or other C<GUID> columns with
+L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> you will need to set a
+L<new_guid|DBIx::Class::Storage::DBI::UniqueIdentifier/new_guid> callback, like
+so:
+
+ $schema->storage->new_guid(sub { Data::GUID->new->as_string });
+
+Under L<Catalyst> you can use code similar to this in your
+L<Catalyst::Model::DBIC::Schema> C<Model.pm>:
+
+ 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<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
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;
}
--- /dev/null
+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<DBIx::Class::Storage::DBI::ADO> and
+L<DBIx::Class::Storage::DBI::ACCESS> for connecting to MS Access via
+L<DBD::ADO>.
+
+See the documentation for L<DBIx::Class::Storage::DBI::ACCESS> for
+information on the MS Access driver for L<DBIx::Class>.
+
+This driver implements workarounds for C<TEXT/IMAGE/MEMO> columns, sets the
+L<cursor_class|DBIx::Class::Storage::DBI/cursor_class> to
+L<DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor> to normalize returned
+C<GUID> values and provides L<DBIx::Class::InflateColumn::DateTime> support
+for C<DATETIME> 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<problems|DBIx::Class::Storage::DBI::ODBC::ACCESS/"TEXT/IMAGE/MEMO COLUMNS">
+the L<ODBC|DBIx::Class::Storage::DBI::ODBC::ACCESS> driver has with these types
+of columns. You can use them safely.
+
+When you execute a C<CREATE TABLE> statement over this driver with a C<TEXT>
+column, it will be converted to C<MEMO>, while in the
+L<ODBC|DBIx::Class::Storage::DBI::ODBC::ACCESS> driver it is converted to
+C<VARCHAR(255)>.
+
+However, the caveat about L<LongReadLen|DBI/LongReadLen> having to be twice the
+max size of your largest C<MEMO/TEXT> column C<+1> still applies. L<DBD::ADO>
+sets L<LongReadLen|DBI/LongReadLen> to a large value by default, so it should be
+safe to just leave it unset. If you do pass a L<LongReadLen|DBI/LongReadLen> in
+your L<connect_info|DBIx::Class::Storage::DBI/connect_info>, it will be
+multiplied by two and C<1> added, just as for the
+L<ODBC|DBIx::Class::Storage::DBI::ODBC::ACCESS> 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<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+# vim:sts=2 sw=2:
--- /dev/null
+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<DBIx::Class::Storage::DBI::ACCESS> for information on the Microsoft
+Access driver.
+
+Unfortunately when using L<DBD::ADO>, GUIDs come back wrapped in braces, the
+purpose of this class is to remove them.
+L<DBIx::Class::Storage::DBI::ADO::MS_Jet> sets
+L<cursor_class|DBIx::Class::Storage::DBI/cursor_class> to this class by default.
+It is overridable via your
+L<connect_info|DBIx::Class::Storage::DBI/connect_info>.
+
+You can use L<DBIx::Class::Cursor::Cached> 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<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
+
+# vim:sts=2 sw=2:
$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;
}
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<DBIx::Class::Storage::DBI::ODBC> and
+L<DBIx::Class::Storage::DBI::ACCESS>, see those classes for more
+information.
- my ( $data_type ) = @_;
+It is loaded automatically by by L<DBIx::Class::Storage::DBI::ODBC> when it
+detects a MS Access back-end.
- return { TYPE => $data_type } if $data_type == DBI::SQL_LONGVARCHAR;
+This driver implements workarounds for C<IMAGE> and C<MEMO> columns, and
+L<DBIx::Class::InflateColumn::DateTime> support for C<DATETIME> 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<TEXT> columns as they will be truncated to 255 bytes. Some other
+drivers (like L<ADO|DBIx::Class::Storage::DBI::ADO::MS_Jet>) will automatically
+convert C<TEXT> columns to C<MEMO>, but the ODBC driver does not.
-DBIx::Class::Storage::DBI::ODBC::ACCESS - Support specific to MS Access over ODBC
+C<IMAGE> columns work correctly, but the statements for inserting or updating an
+C<IMAGE> column will not be L<cached|DBI/prepare_cached>, due to a bug in the
+Access ODBC driver.
-=head1 WARNING
+C<MEMO> columns work correctly as well, but you must take care to set
+L<LongReadLen|DBI/LongReadLen> to C<$max_memo_size * 2 + 1>. This is done for
+you automatically if you pass L<LongReadLen|DBI/LongReadLen> in your
+L<connect_info|DBIx::Class::Storage::DBI/connect_info>; 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<data_type> of the column to C<SQL_LONGVARCHAR> in C<add_columns>.
-C<SQL_LONGVARCHAR> is a constant in the C<DBI> 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<< <oystein.torget@dnv.com> >>
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
-=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:
--- /dev/null
+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(<<EOF);
+ CREATE TABLE artist (
+ artistid AUTOINCREMENT PRIMARY KEY,
+ name VARCHAR(255) NULL,
+ charfield CHAR(10) NULL,
+ rank INT NULL
+ )
+EOF
+
+ my $ars = $schema->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(<<EOF);
+ CREATE TABLE cd (
+ cdid AUTOINCREMENT PRIMARY KEY,
+ artist INTEGER NULL,
+ title VARCHAR(255) NULL,
+ [year] CHAR(4) NULL,
+ genreid INTEGER NULL,
+ single_track INTEGER NULL
+ )
+EOF
+
+ $dbh->do(<<EOF);
+ CREATE TABLE track (
+ trackid AUTOINCREMENT PRIMARY KEY,
+ cd INTEGER REFERENCES cd(cdid),
+ [position] INTEGER,
+ title VARCHAR(255),
+ last_updated_on DATETIME,
+ last_updated_at DATETIME
+ )
+EOF
+
+ my $cd = $schema->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:
--- /dev/null
+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');
+ }
+}
--- /dev/null
+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;
projects / dbsrgits/DBIx-Class.git / commitdiff