- dbicadmin now better supports catalyst-style config files, by
unrolling 'config_info' hashkeys
- MSSQL MARS over DBD::ODBC now works with freetds >= 0.91
+ - Multiple Improvements MSSQL over DBD::ADO
+ - Transaction support
+ - Support for VARCHAR(MAX)/VARBINARY(MAX)/NVARCHAR(MAX) datatypes
+ - Nomalization of retrieved GUID values
* Fixes
- Fix SkipFirst and FirstSkip limit dialects (Informix and Firebird)
--- /dev/null
+package # hide from PAUSE
+ DBIx::Class::Storage::DBI::ADO::CursorUtils;
+
+use strict;
+use warnings;
+use base 'Exporter';
+
+our @EXPORT_OK = qw/_normalize_guids _strip_trailing_binary_nulls/;
+
+sub _strip_trailing_binary_nulls {
+ my ($select, $col_infos, $data) = @_;
+
+ foreach my $select_idx (0..$#$select) {
+
+ next unless defined $data->[$select_idx];
+
+ my $data_type = $col_infos->{$select->[$select_idx]}{data_type}
+ or next;
+
+ $data->[$select_idx] =~ s/\0+\z//
+ if $data_type =~ /binary|image/i;
+ }
+}
+
+sub _normalize_guids {
+ my ($select, $col_infos, $data, $storage) = @_;
+
+ foreach my $select_idx (0..$#$select) {
+
+ next unless defined $data->[$select_idx];
+
+ my $data_type = $col_infos->{$select->[$select_idx]}{data_type}
+ or next;
+
+ $data->[$select_idx] =~ s/\A \{ (.+) \} \z/$1/xs
+ if $storage->_is_guid_type($data_type);
+ }
+}
+
+1;
+
+# vim:sts=2 sw=2:
DBIx::Class::Storage::DBI::ACCESS
/;
use mro 'c3';
-use DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor ();
+use DBIx::Class::Storage::DBI::ADO::CursorUtils '_normalize_guids';
+use namespace::clean;
__PACKAGE__->cursor_class('DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor');
return @row unless
$self->cursor_class->isa('DBIx::Class::Storage::DBI::ADO::MS_Jet::Cursor');
- my $col_info = $self->_resolve_column_info($ident);
+ my $col_infos = $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 '{';
- }
- }
+ _normalize_guids($select, $col_infos, \@row, $self);
return @row;
}
use warnings;
use base 'DBIx::Class::Storage::DBI::Cursor';
use mro 'c3';
+use DBIx::Class::Storage::DBI::ADO::CursorUtils '_normalize_guids';
+use namespace::clean;
=head1 NAME
my @row = $next->(@_);
- my $col_info = $storage->_resolve_column_info($self->args->[0]);
+ my $col_infos = $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 '{';
- }
- }
+ _normalize_guids($select, $col_infos, \@row, $storage);
return @row;
}
my @rows = $next->(@_);
- my $col_info = $storage->_resolve_column_info($self->args->[0]);
+ my $col_infos = $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 '{';
- }
- }
- }
+ _normalize_guids($select, $col_infos, $_, $storage) for @rows;
return @rows;
}
DBIx::Class::Storage::DBI::MSSQL
/;
use mro 'c3';
+use DBIx::Class::Carp;
+use DBIx::Class::Storage::DBI::ADO::CursorUtils qw/_normalize_guids _strip_trailing_binary_nulls/;
+use namespace::clean;
+
+__PACKAGE__->cursor_class(
+ 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor'
+);
+
+__PACKAGE__->datetime_parser_type (
+ 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::DateTime::Format'
+);
+
+__PACKAGE__->new_guid(sub {
+ my $self = shift;
+ my $guid = $self->_get_dbh->selectrow_array('SELECT NEWID()');
+ $guid =~ s/\A \{ (.+) \} \z/$1/xs;
+ return $guid;
+});
=head1 NAME
approximate maximum size of the data_type of the bound column, or 8000 (maximum
VARCHAR size) if the data_type is not available.
-This code is incomplete and may be buggy. Particularly, C<VARCHAR(MAX)> is not
-supported yet. The data_type list for other DBs is also incomplete. Please
-report problems (and send patches.)
+Please report problems with this driver and send patches.
+
+=head2 LongReadLen
+
+C<LongReadLen> is set to C<LongReadLen * 2 + 1> on connection as it is necessary
+for some LOB types. Be aware of this if you localize this value on the C<$dbh>
+directly.
+
+=head2 binary data
+
+Due perhaps to the ado_size workaround we use, and/or other reasons, binary data
+such as C<varbinary> column data comes back padded with trailing C<NULL> chars.
+The Cursor class for this driver
+(L<DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor>) removes them,
+of course if your binary data is actually C<NULL> padded that may be an issue to
+keep in mind when using this driver.
+
+=head2 uniqueidentifier columns
+
+uniqueidentifier columns come back from ADO wrapped in braces and must be
+submitted to the MSSQL ADO driver wrapped in braces. We take care of this
+transparently in this driver and the associated Cursor class
+(L<DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor>) so that you
+don't have to use braces in most cases (except in literal SQL, in those cases
+you will have to add the braces yourself.)
=head2 fractional seconds
=cut
-__PACKAGE__->datetime_parser_type (
- 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::DateTime::Format'
-);
-
-sub _rebless {
+sub _init {
my $self = shift;
+
+# SCOPE_IDENTITY() doesn't work
$self->_identity_method('@@identity');
+ $self->_no_scope_identity_query(1);
+
+ return $self->next::method(@_);
}
-# work around a bug in the ADO driver - use the max VARCHAR size for all
-# binds that do not specify one via bind_attributes_by_data_type()
+sub _run_connection_actions {
+ my $self = shift;
+
+# make transactions work
+ require DBD::ADO::Const;
+ $self->_dbh->{ado_conn}{CursorLocation} =
+ DBD::ADO::Const->Enums->{CursorLocationEnum}{adUseClient};
+
+# set LongReadLen = LongReadLen * 2 + 1
+# this may need to be in ADO.pm, being conservative for now...
+ 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(@_);
+}
+
+
+# Fix up binary data and 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::Microsoft_SQL_Server::Cursor'
+ );
+
+ my $col_infos = $self->_resolve_column_info($ident);
+
+ _normalize_guids($select, $col_infos, \@row, $self);
+
+ _strip_trailing_binary_nulls($select, $col_infos, \@row);
+
+ return @row;
+}
+
+# We need to catch VARCHAR(max) before bind_attribute_by_data_type because it
+# could be specified by size, also if bind_attribute_by_data_type fails we want
+# to specify the default ado_size of 8000.
+# Also make sure GUID binds have braces on them or else ADO throws an "Invalid
+# character value for cast specification"
+
sub _dbi_attrs_for_bind {
- my $attrs = shift->next::method(@_);
+ my $self = shift;
+ my ($ident, $bind) = @_;
+
+ my $lob_max = $self->_get_dbh->{LongReadLen} || 32768;
+
+ foreach my $bind (@$bind) {
+ my $attrs = $bind->[0];
+ my $data_type = $attrs->{sqlt_datatype};
+ my $size = $attrs->{sqlt_size};
+
+ if ($size && lc($size) eq 'max') {
+ if ($data_type =~ /^(?:varchar|character varying|nvarchar|national char varying|national character varying|varbinary)\z/i) {
+ $attrs->{dbd_attrs} = { ado_size => $lob_max };
+ }
+ else {
+ carp_unique "bizarre data_type '$data_type' with size => 'max'";
+ }
+ }
+
+ if ($self->_is_guid_type($data_type) && substr($bind->[1], 0, 1) ne '{') {
+ $bind->[1] = '{' . $bind->[1] . '}';
+ }
+ }
+
+ my $attrs = $self->next::method(@_);
+
+ foreach my $attr (@$attrs) {
+ $attr->{ado_size} ||= 8000 if $attr;
+ }
+
+ return $attrs;
+}
- for (@$attrs) {
- $_->{ado_size} ||= 8000 if $_;
+# Can't edit all the binds in _dbi_attrs_for_bind for insert_bulk, so we take
+# care of those GUIDs here.
+sub insert_bulk {
+ my $self = shift;
+ my ($source, $cols, $data) = @_;
+
+ my $columns_info = $source->columns_info($cols);
+
+ my $col_idx = 0;
+ foreach my $col (@$cols) {
+ if ($self->_is_guid_type($columns_info->{$col}{data_type})) {
+ foreach my $data_row (@$data) {
+ if (substr($data_row->[$col_idx], 0, 1) ne '{') {
+ $data_row->[$col_idx] = '{' . $data_row->[$col_idx] . '}';
+ }
+ }
+ }
+ $col_idx++;
}
- $attrs;
+ return $self->next::method(@_);
}
sub bind_attribute_by_data_type {
my ($self, $data_type) = @_;
- ($data_type = lc($data_type)) =~ s/\s+.*//;
+ $data_type = lc $data_type;
my $max_size =
$self->_mssql_max_data_type_representation_size_in_bytes->{$data_type};
my $res = {};
- $res->{ado_size} = $max_size if $max_size;
+
+ if ($max_size) {
+ $res->{ado_size} = $max_size;
+ }
+ else {
+ carp_unique "could not map data_type '$data_type' to a max size for ado_size: defaulting to 8000";
+ }
return $res;
}
-# approximate
-# XXX needs to support varchar(max) and varbinary(max)
+# FIXME This list is an abomination. We need a way to do this outside
+# of the scope of DBIC, as as it is right now nobody will ever think to
+# even look here to diagnose some sort of misbehavior.
sub _mssql_max_data_type_representation_size_in_bytes {
my $self = shift;
- my $blob_max = $self->_get_dbh->{LongReadLen} || 32768;
+ my $lob_max = $self->_get_dbh->{LongReadLen} || 32768;
return +{
# MSSQL types
char => 8000,
+ character => 8000,
varchar => 8000,
+ 'varchar(max)' => $lob_max,
+ 'character varying' => 8000,
binary => 8000,
varbinary => 8000,
- nchar => 8000,
- nvarchar => 8000,
+ 'varbinary(max)' => $lob_max,
+ nchar => 16000,
+ 'national character' => 16000,
+ 'national char' => 16000,
+ nvarchar => 16000,
+ 'nvarchar(max)' => ($lob_max*2),
+ 'national character varying' => 16000,
+ 'national char varying' => 16000,
numeric => 100,
smallint => 100,
tinyint => 100,
bigint => 100,
bit => 100,
decimal => 100,
+ dec => 100,
integer => 100,
int => 100,
+ 'int identity' => 100,
+ 'integer identity' => 100,
money => 100,
float => 100,
+ double => 100,
+ 'double precision' => 100,
real => 100,
uniqueidentifier => 100,
- ntext => $blob_max,
- text => $blob_max,
- image => $blob_max,
+ ntext => $lob_max,
+ text => $lob_max,
+ image => $lob_max,
date => 100,
datetime => 100,
datetime2 => 100,
timestamp => 100,
cursor => 100,
hierarchyid => 100,
+ rowversion => 100,
sql_variant => 100,
- table => 100,
- xml => $blob_max, # ???
-
-# some non-MSSQL types
+ table => $lob_max,
+ xml => $lob_max,
+
+# mysql types
+ bool => 100,
+ boolean => 100,
+ 'tinyint unsigned' => 100,
+ 'smallint unsigned' => 100,
+ 'mediumint unsigned' => 100,
+ 'int unsigned' => 100,
+ 'integer unsigned' => 100,
+ 'bigint unsigned' => 100,
+ 'float unsigned' => 100,
+ 'double unsigned' => 100,
+ 'double precision unsigned' => 100,
+ 'decimal unsigned' => 100,
+ 'fixed' => 100,
+ 'year' => 100,
+ tinyblob => $lob_max,
+ tinytext => $lob_max,
+ blob => $lob_max,
+ text => $lob_max,
+ mediumblob => $lob_max,
+ mediumtext => $lob_max,
+ longblob => $lob_max,
+ longtext => $lob_max,
+ enum => 100,
+ set => 8000,
+
+# Pg types
serial => 100,
bigserial => 100,
+ int8 => 100,
+ integer8 => 100,
+ serial8 => 100,
+ int4 => 100,
+ integer4 => 100,
+ serial4 => 100,
+ int2 => 100,
+ integer2 => 100,
+ float8 => 100,
+ float4 => 100,
+ 'bit varying' => 8000,
+ 'varbit' => 8000,
+ inet => 100,
+ cidr => 100,
+ macaddr => 100,
+ 'time without time zone' => 100,
+ 'time with time zone' => 100,
+ 'timestamp without time zone' => 100,
+ 'timestamp with time zone' => 100,
+ bytea => $lob_max,
+
+# DB2 types
+ graphic => 8000,
+ vargraphic => 8000,
+ 'long vargraphic' => $lob_max,
+ dbclob => $lob_max,
+ clob => $lob_max,
+ 'char for bit data' => 8000,
+ 'varchar for bit data' => 8000,
+ 'long varchar for bit data' => $lob_max,
+
+# oracle types
varchar2 => 8000,
- blob => $blob_max,
- clob => $blob_max,
+ binary_float => 100,
+ binary_double => 100,
+ raw => 8000,
+ nclob => $lob_max,
+ long => $lob_max,
+ 'long raw' => $lob_max,
+ 'timestamp with local time zone' => 100,
+
+# Sybase ASE types
+ unitext => $lob_max,
+ unichar => 16000,
+ univarchar => 16000,
+
+# SQL Anywhere types
+ 'long varbit' => $lob_max,
+ 'long bit varying' => $lob_max,
+ uniqueidentifierstr => 100,
+ 'long binary' => $lob_max,
+ 'long varchar' => $lob_max,
+ 'long nvarchar' => $lob_max,
+
+# Firebird types
+ 'char(x) character set unicode_fss' => 16000,
+ 'varchar(x) character set unicode_fss' => 16000,
+ 'blob sub_type text' => $lob_max,
+ 'blob sub_type text character set unicode_fss' => $lob_max,
+
+# Informix types
+ smallfloat => 100,
+ byte => $lob_max,
+ lvarchar => 8000,
+ 'datetime year to fraction(5)' => 100,
+ # FIXME add other datetime types
+
+# MS Access types
+ autoincrement => 100,
+ long => 100,
+ integer4 => 100,
+ integer2 => 100,
+ integer1 => 100,
+ logical => 100,
+ logical1 => 100,
+ yesno => 100,
+ currency => 100,
+ single => 100,
+ ieeesingle => 100,
+ ieeedouble => 100,
+ number => 100,
+ string => 8000,
+ guid => 100,
+ longchar => $lob_max,
+ memo => $lob_max,
+ longbinary => $lob_max,
}
}
--- /dev/null
+package DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor;
+
+use strict;
+use warnings;
+use base 'DBIx::Class::Storage::DBI::Cursor';
+use mro 'c3';
+use DBIx::Class::Storage::DBI::ADO::CursorUtils qw/_normalize_guids _strip_trailing_binary_nulls/;
+use namespace::clean;
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server::Cursor - Remove trailing
+NULLs in binary data and normalize GUIDs for MSSQL over ADO
+
+=head1 DESCRIPTION
+
+This class is for removing trailing C<NULL>s from binary data and removing braces
+from GUIDs retrieved from Microsoft SQL Server over ADO.
+
+You probably don't want to be here, see
+L<DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server> for information on the
+Microsoft SQL Server driver for ADO and L<DBIx::Class::Storage::DBI::MSSQL> for
+the Microsoft SQL Server driver base class.
+
+Unfortunately when using L<DBD::ADO>, binary data comes back padded with
+trailing C<NULL>s and GUIDs come back wrapped in braces, the purpose of this
+class is to remove the C<NULL>s and braces.
+L<DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server> 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 binary data 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_infos = $storage->_resolve_column_info($self->args->[0]);
+
+ my $select = $self->args->[1];
+
+ _normalize_guids($select, $col_infos, \@row, $storage);
+ _strip_trailing_binary_nulls($select, $col_infos, \@row);
+
+ return @row;
+}
+
+sub _dbh_all {
+ my ($storage, $dbh, $self) = @_;
+
+ my $next = $self->next::can;
+
+ my @rows = $next->(@_);
+
+ my $col_infos = $storage->_resolve_column_info($self->args->[0]);
+
+ my $select = $self->args->[1];
+
+ for (@rows) {
+ _normalize_guids($select, $col_infos, $_, $storage);
+ _strip_trailing_binary_nulls($select, $col_infos, $_);
+ }
+
+ 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:
=item coderef
In which case the coderef should return a string GUID, using L<Data::GUID>, or
-whatever GUID generation method you prefer.
+whatever GUID generation method you prefer. It is passed the C<$self>
+L<DBIx::Class::Storage> reference as a parameter.
=back
}
if (ref $guid_method eq 'CODE') {
- $to_insert->{$guid_col} = $guid_method->();
+ $to_insert->{$guid_col} = $guid_method->($self);
}
else {
($to_insert->{$guid_col}) = $self->_get_dbh->selectrow_array("SELECT $guid_method");
use warnings;
use Test::More;
+use Test::Exception;
+use Try::Tiny;
use DBIx::Class::Optional::Dependencies ();
use lib qw(t/lib);
use DBICTest;
plan skip_all => 'Set $ENV{DBICTEST_MSSQL_ADO_DSN}, _USER and _PASS to run this test'
unless ($dsn && $user);
-my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+DBICTest::Schema->load_classes(qw/VaryingMAX ArtistGUID/);
+
+my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+$binstr{'large'} = $binstr{'small'} x 1024;
+
+my $maxloblen = length $binstr{'large'};
+
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass, {
+ auto_savepoint => 1,
+ LongReadLen => $maxloblen,
+});
+
$schema->storage->ensure_connected;
-isa_ok( $schema->storage, 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server' );
+isa_ok($schema->storage, 'DBIx::Class::Storage::DBI::ADO::Microsoft_SQL_Server');
my $ver = $schema->storage->_server_info->{normalized_dbms_version};
ok $ver, 'can introspect DBMS version';
+# 2005 and greater
is $schema->storage->sql_limit_dialect, ($ver >= 9 ? 'RowNumberOver' : 'Top'),
'correct limit dialect detected';
$schema->storage->dbh_do (sub {
my ($storage, $dbh) = @_;
- eval { local $^W = 0; $dbh->do("DROP TABLE artist") };
+ try { local $^W = 0; $dbh->do("DROP TABLE artist") };
$dbh->do(<<'SQL');
CREATE TABLE artist (
artistid INT IDENTITY NOT NULL,
SQL
});
-my $new = $schema->resultset('Artist')->create({ name => 'foo' });
+$schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ try { local $^W = 0; $dbh->do("DROP TABLE artist_guid") };
+ $dbh->do(<<"SQL");
+CREATE TABLE artist_guid (
+ artistid UNIQUEIDENTIFIER NOT NULL,
+ name VARCHAR(100),
+ rank INT NULL,
+ charfield CHAR(10) NULL,
+ a_guid UNIQUEIDENTIFIER,
+ primary key(artistid)
+)
+SQL
+});
+
+my $have_max = $ver >= 9; # 2005 and greater
+
+$schema->storage->dbh_do (sub {
+ my ($storage, $dbh) = @_;
+ try { local $^W = 0; $dbh->do("DROP TABLE varying_max_test") };
+ $dbh->do("
+CREATE TABLE varying_max_test (
+ id INT IDENTITY NOT NULL,
+" . ($have_max ? "
+ varchar_max VARCHAR(MAX),
+ nvarchar_max NVARCHAR(MAX),
+ varbinary_max VARBINARY(MAX),
+" : "
+ varchar_max TEXT,
+ nvarchar_max NTEXT,
+ varbinary_max IMAGE,
+") . "
+ primary key(id)
+)");
+});
+
+my $ars = $schema->resultset('Artist');
+
+my $new = $ars->create({ name => 'foo' });
ok($new->artistid > 0, 'Auto-PK worked');
# make sure select works
my $rs2 = $schema->resultset('Artist')->search({}, { order_by => 'name' });
while ($rs1->next) {
- ok eval { $rs2->next }, 'multiple active cursors';
+ ok try { $rs2->next }, 'multiple active cursors';
}
# test bug where ADO blows up if the first bindparam is shorter than the second
'Artist 12',
'longer bindparam';
+# 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 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, 18, 'Simple count works');
+
+# 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';
+
+my $rs = $schema->resultset('VaryingMAX');
+
+foreach my $size (qw/small large/) {
+ my $orig_debug = $schema->storage->debug;
+
+ $schema->storage->debug(0) if $size eq 'large';
+
+ my $str = $binstr{$size};
+ my $row;
+ lives_ok {
+ $row = $rs->create({
+ varchar_max => $str, nvarchar_max => $str, varbinary_max => $str
+ });
+ } "created $size VARXXX(MAX) LOBs";
+
+ lives_ok {
+ $row->discard_changes;
+ } 're-selected just-inserted LOBs';
+
+ cmp_ok try { $row->varchar_max }, 'eq', $str, 'VARCHAR(MAX) matches';
+ cmp_ok try { $row->nvarchar_max }, 'eq', $str, 'NVARCHAR(MAX) matches';
+ cmp_ok try { $row->varbinary_max }, 'eq', $str, 'VARBINARY(MAX) matches';
+
+ $schema->storage->debug($orig_debug);
+}
+
+# test regular blobs
+
+try { local $^W = 0; $schema->storage->dbh->do('DROP TABLE bindtype_test') };
+$schema->storage->dbh->do(qq[
+CREATE TABLE bindtype_test
+(
+ id INT IDENTITY NOT NULL PRIMARY KEY,
+ bytea INT NULL,
+ blob IMAGE NULL,
+ clob TEXT NULL,
+ a_memo NTEXT NULL
+)
+],{ RaiseError => 1, PrintError => 1 });
+
+$rs = $schema->resultset('BindType');
+my $id = 0;
+
+foreach my $type (qw( blob clob a_memo )) {
+ foreach my $size (qw( small large )) {
+ $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
+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 $@;
+
+my $guid = try { $row->artistid }||'';
+
+ok(($guid !~ /^{.*?}\z/), 'GUID not enclosed in braces')
+ or diag "GUID is: $guid";
+
+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 try { $row_from_db->artistid }, try { $row->artistid },
+ 'PK GUID round trip (via ->search->next)';
+
+is try { $row_from_db->a_guid }, try { $row->a_guid },
+ 'NON-PK GUID round trip (via ->search->next)';
+
+$row_from_db = try { $schema->resultset('ArtistGUID')
+ ->find($row->artistid) };
+
+is try { $row_from_db->artistid }, try { $row->artistid },
+ 'PK GUID round trip (via ->find)';
+
+is try { $row_from_db->a_guid }, try { $row->a_guid },
+ 'NON-PK GUID round trip (via ->find)';
+
+($row_from_db) = $schema->resultset('ArtistGUID')
+ ->search({ name => 'mtfnpy' })->all;
+
+is try { $row_from_db->artistid }, try { $row->artistid },
+ 'PK GUID round trip (via ->search->all)';
+
+is try { $row_from_db->a_guid }, try { $row->a_guid },
+ 'NON-PK GUID round trip (via ->search->all)';
+
+lives_ok {
+ $row = $schema->resultset('ArtistGUID')->create({
+ artistid => '70171270-4822-4450-81DF-921F99BA3C06',
+ name => 'explicit_guid',
+ });
+} 'created a row with explicit PK GUID';
+
+is try { $row->artistid }, '70171270-4822-4450-81DF-921F99BA3C06',
+ 'row has correct PK GUID';
+
+lives_ok {
+ $row->update({ artistid => '70171270-4822-4450-81DF-921F99BA3C07' });
+} "updated row's PK GUID";
+
+is try { $row->artistid }, '70171270-4822-4450-81DF-921F99BA3C07',
+ 'row has correct PK GUID';
+
+lives_ok {
+ $row->delete;
+} 'deleted the row';
+
+lives_ok {
+ $schema->resultset('ArtistGUID')->populate([{
+ artistid => '70171270-4822-4450-81DF-921F99BA3C06',
+ name => 'explicit_guid',
+ }]);
+} 'created a row with explicit PK GUID via ->populate in void context';
+
done_testing;
# clean up our mess
END {
- my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
- local $SIG{__WARN__} = sub {
- $warn_handler->(@_) unless $_[0] =~ /Not a Win32::OLE object/
- };
- if (my $dbh = eval { $schema->storage->_dbh }) {
- eval { $dbh->do("DROP TABLE $_") }
- for qw/artist/;
+ local $SIG{__WARN__} = sub {};
+ if (my $dbh = try { $schema->storage->_dbh }) {
+ (try { $dbh->do("DROP TABLE $_") })
+ for qw/artist artist_guid varying_max_test bindtype_test/;
}
undef $schema;
--- /dev/null
+package # hide from PAUSE
+ DBICTest::Schema::VaryingMAX;
+
+use base qw/DBICTest::BaseResult/;
+
+# Test VARCHAR(MAX) type for MSSQL (used in ADO tests)
+
+__PACKAGE__->table('varying_max_test');
+
+__PACKAGE__->add_columns(
+ 'id' => {
+ data_type => 'integer',
+ is_auto_increment => 1,
+ },
+ 'varchar_max' => {
+ data_type => 'varchar',
+ size => 'max',
+ is_nullable => 1,
+ },
+ 'nvarchar_max' => {
+ data_type => 'nvarchar',
+ size => 'max',
+ is_nullable => 1,
+ },
+ 'varbinary_max' => {
+ data_type => 'varbinary(max)', # alternately
+ size => undef,
+ is_nullable => 1,
+ },
+);
+
+__PACKAGE__->set_primary_key('id');
+
+1;
projects / dbsrgits/DBIx-Class.git / commitdiff