From: Rafael Kitover Date: Sun, 18 Mar 2012 06:33:54 +0000 (-0400) Subject: improvements for MSSQL driver via DBD::ADO X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=2edf33525bc7be0824693925c528791d84db98aa;p=dbsrgits%2FDBIx-Class-Historic.git improvements for MSSQL driver via DBD::ADO Various improvements and bug fixes: - Fix transaction support by changing CursorLocation on connection to adUseClient. - Support for VARCHAR(MAX)/VARBINARY(MAX)/NVARCHAR(MAX), add a catch for size => 'max' in _dbi_attrs_for_bind to set the ado_size workaround to LongReadLen, add a mapping to the data_type for literal 'varchar(max)' entries as well. Tests for these types have been added as well. - Set $dbh->{LongReadLen} * 2 + 1 on connection, necessary for some LOB types. - Remove trailing null padding from BINARY/VARBINARY/IMAGE data via a custom Cursor class. - uniqueidentifier brace removal from data returned from ADO via Cursor class and re-addition via _dbi_attrs_for_bind and insert_bulk override for data sent to ADO. - Add type mappings for some missing MSSQL types and the types from other databases for cross-deployment. - Full set of tests, stolen from the MS Access tests, for savepoints, LOB support and GUIDs. The trailing null padding and GUID brace removal is in utilities in ::DBI::ADO::CursorUtils which both ::DBI::ADO::MS_Jet (Access) and this driver use, in their respective Cursor classes and in the drivers themselves in select_single. --- diff --git a/Changes b/Changes index 08675d9..8994856 100644 --- a/Changes +++ b/Changes @@ -13,6 +13,10 @@ Revision history for DBIx::Class - 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) diff --git a/lib/DBIx/Class/Storage/DBI/ADO/CursorUtils.pm b/lib/DBIx/Class/Storage/DBI/ADO/CursorUtils.pm new file mode 100644 index 0000000..93053ce --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/ADO/CursorUtils.pm @@ -0,0 +1,42 @@ +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: diff --git a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm index 438db4e..8eb1719 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet.pm @@ -7,7 +7,8 @@ use base qw/ 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'); @@ -103,22 +104,9 @@ sub select_single { 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; } diff --git a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm index 4fc6d02..71916c2 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/MS_Jet/Cursor.pm @@ -4,6 +4,8 @@ use strict; 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 @@ -39,24 +41,11 @@ sub _dbh_next { 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; } @@ -68,26 +57,11 @@ sub _dbh_all { 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; } diff --git a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm index 7e08098..0d38311 100644 --- a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm +++ b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server.pm @@ -8,6 +8,24 @@ use base qw/ 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 @@ -46,9 +64,31 @@ The C workaround is used (see L) with the 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 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 is set to C 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 column data comes back padded with trailing C chars. +The Cursor class for this driver +(L) removes them, +of course if your binary data is actually C 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) 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 @@ -57,56 +97,166 @@ currently supported, datetimes are truncated at the second. =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, @@ -114,15 +264,20 @@ sub _mssql_max_data_type_representation_size_in_bytes { 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, @@ -132,16 +287,126 @@ sub _mssql_max_data_type_representation_size_in_bytes { 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, } } diff --git a/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm new file mode 100644 index 0000000..d421145 --- /dev/null +++ b/lib/DBIx/Class/Storage/DBI/ADO/Microsoft_SQL_Server/Cursor.pm @@ -0,0 +1,88 @@ +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 Cs 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 for information on the +Microsoft SQL Server driver for ADO and L for +the Microsoft SQL Server driver base class. + +Unfortunately when using L, binary data comes back padded with +trailing Cs and GUIDs come back wrapped in braces, the purpose of this +class is to remove the Cs and braces. +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 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 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/UniqueIdentifier.pm b/lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm index 955529d..8621da0 100644 --- a/lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm +++ b/lib/DBIx/Class/Storage/DBI/UniqueIdentifier.pm @@ -38,7 +38,8 @@ In which case it is used as the name of database function to create a new GUID, =item coderef In which case the coderef should return a string GUID, using L, or -whatever GUID generation method you prefer. +whatever GUID generation method you prefer. It is passed the C<$self> +L reference as a parameter. =back @@ -97,7 +98,7 @@ sub _prefetch_autovalues { } 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"); diff --git a/t/747mssql_ado.t b/t/747mssql_ado.t index 5c83ab8..77a88dc 100644 --- a/t/747mssql_ado.t +++ b/t/747mssql_ado.t @@ -2,6 +2,8 @@ use strict; use warnings; use Test::More; +use Test::Exception; +use Try::Tiny; use DBIx::Class::Optional::Dependencies (); use lib qw(t/lib); use DBICTest; @@ -17,21 +19,33 @@ my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_MSSQL_ADO_${_}" } qw/DSN USER PAS 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, @@ -43,7 +57,45 @@ CREATE TABLE artist ( 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 @@ -68,7 +120,7 @@ my $rs1 = $schema->resultset('Artist')->search({}, { order_by => 'artistid' }); 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 @@ -80,17 +132,256 @@ is $schema->resultset('Artist')->search({ artistid => 13 })->first->name, '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; diff --git a/t/lib/DBICTest/Schema/VaryingMAX.pm b/t/lib/DBICTest/Schema/VaryingMAX.pm new file mode 100644 index 0000000..beca65f --- /dev/null +++ b/t/lib/DBICTest/Schema/VaryingMAX.pm @@ -0,0 +1,34 @@ +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;