X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI%2FMSSQL.pm;h=679fe7c9575cb0668de8ba91b522a90da46c051e;hb=e705f5290cf384194c31a807c9bb722c7a167dfd;hp=03311809716199c340e4b50580aca2428445caf7;hpb=010f82a001cea2c6067fd8a080e29eb3310c2ecb;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI/MSSQL.pm b/lib/DBIx/Class/Storage/DBI/MSSQL.pm index 0331180..679fe7c 100644 --- a/lib/DBIx/Class/Storage/DBI/MSSQL.pm +++ b/lib/DBIx/Class/Storage/DBI/MSSQL.pm @@ -3,137 +3,47 @@ package DBIx::Class::Storage::DBI::MSSQL; use strict; use warnings; -use base qw/DBIx::Class::Storage::DBI::AmbiguousGlob DBIx::Class::Storage::DBI/; +use base qw/ + DBIx::Class::Storage::DBI::UniqueIdentifier + DBIx::Class::Storage::DBI::IdentityInsert +/; use mro 'c3'; -use List::Util(); +use Try::Tiny; +use List::Util 'first'; +use namespace::clean; __PACKAGE__->mk_group_accessors(simple => qw/ - _identity _identity_method + _identity _identity_method _no_scope_identity_query /); -__PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::MSSQL'); +__PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::MSSQL'); -sub _set_identity_insert { - my ($self, $table) = @_; +__PACKAGE__->sql_quote_char([qw/[ ]/]); - my $sql = sprintf ( - 'SET IDENTITY_INSERT %s ON', - $self->sql_maker->_quote ($table), - ); - - my $dbh = $self->_get_dbh; - eval { $dbh->do ($sql) }; - if ($@) { - $self->throw_exception (sprintf "Error executing '%s': %s", - $sql, - $dbh->errstr, - ); - } -} - -sub _unset_identity_insert { - my ($self, $table) = @_; - - my $sql = sprintf ( - 'SET IDENTITY_INSERT %s OFF', - $self->sql_maker->_quote ($table), - ); - - my $dbh = $self->_get_dbh; - $dbh->do ($sql); -} - -sub insert_bulk { - my $self = shift; - my ($source, $cols, $data) = @_; - - my $is_identity_insert = (List::Util::first - { $source->column_info ($_)->{is_auto_increment} } - (@{$cols}) - ) - ? 1 - : 0; - - if ($is_identity_insert) { - $self->_set_identity_insert ($source->name); - } - - $self->next::method(@_); - - if ($is_identity_insert) { - $self->_unset_identity_insert ($source->name); - } -} +__PACKAGE__->datetime_parser_type ( + 'DBIx::Class::Storage::DBI::MSSQL::DateTime::Format' +); -# support MSSQL GUID column types - -sub insert { - my $self = shift; - my ($source, $to_insert) = @_; - - my $supplied_col_info = $self->_resolve_column_info($source, [keys %$to_insert] ); - - my %guid_cols; - my @pk_cols = $source->primary_columns; - my %pk_cols; - @pk_cols{@pk_cols} = (); - - my @pk_guids = grep { - $source->column_info($_)->{data_type} - && - $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i - } @pk_cols; - - my @auto_guids = grep { - $source->column_info($_)->{data_type} - && - $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i - && - $source->column_info($_)->{auto_nextval} - } grep { not exists $pk_cols{$_} } $source->columns; - - my @get_guids_for = - grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids); - - my $updated_cols = {}; - - for my $guid_col (@get_guids_for) { - my ($new_guid) = $self->_get_dbh->selectrow_array('SELECT NEWID()'); - $updated_cols->{$guid_col} = $to_insert->{$guid_col} = $new_guid; - } - - my $is_identity_insert = (List::Util::first { $_->{is_auto_increment} } (values %$supplied_col_info) ) - ? 1 - : 0; - - if ($is_identity_insert) { - $self->_set_identity_insert ($source->name); - } - - $updated_cols = { %$updated_cols, %{ $self->next::method(@_) } }; - - if ($is_identity_insert) { - $self->_unset_identity_insert ($source->name); - } - - - return $updated_cols; -} +__PACKAGE__->new_guid('NEWID()'); sub _prep_for_execute { my $self = shift; - my ($op, $extra_bind, $ident, $args) = @_; + my ($op, $ident, $args) = @_; # cast MONEY values properly if ($op eq 'insert' || $op eq 'update') { my $fields = $args->[0]; + my $colinfo = $ident->columns_info([keys %$fields]); + for my $col (keys %$fields) { # $ident is a result source object with INSERT/UPDATE ops - if ($ident->column_info ($col)->{data_type} - && - $ident->column_info ($col)->{data_type} =~ /^money\z/i) { + if ( + $colinfo->{$col}{data_type} + && + $colinfo->{$col}{data_type} =~ /^money\z/i + ) { my $val = $fields->{$col}; $fields->{$col} = \['CAST(? AS MONEY)', [ $col => $val ]]; } @@ -142,9 +52,16 @@ sub _prep_for_execute { my ($sql, $bind) = $self->next::method (@_); - if ($op eq 'insert') { - $sql .= ';SELECT SCOPE_IDENTITY()'; - + # SELECT SCOPE_IDENTITY only works within a statement scope. We + # must try to always use this particular idiom frist, as it is the + # only one that guarantees retrieving the correct id under high + # concurrency. When this fails we will fall back to whatever secondary + # retrieval method is specified in _identity_method, but at this + # point we don't have many guarantees we will get what we expected. + # http://msdn.microsoft.com/en-us/library/ms190315.aspx + # http://davidhayden.com/blog/dave/archive/2006/01/17/2736.aspx + if ($self->_perform_autoinc_retrieval and not $self->_no_scope_identity_query) { + $sql .= "\nSELECT SCOPE_IDENTITY()"; } return ($sql, $bind); @@ -152,15 +69,21 @@ sub _prep_for_execute { sub _execute { my $self = shift; - my ($op) = @_; - my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_); + # always list ctx - we need the $sth + my ($rv, $sth, @bind) = $self->next::method(@_); - if ($op eq 'insert') { + if ($self->_perform_autoinc_retrieval) { - # this should bring back the result of SELECT SCOPE_IDENTITY() we tacked + # attempt to bring back the result of SELECT SCOPE_IDENTITY() we tacked # on in _prep_for_execute above - my ($identity) = eval { $sth->fetchrow_array }; + my $identity; + + # we didn't even try on ftds + unless ($self->_no_scope_identity_query) { + ($identity) = try { $sth->fetchrow_array }; + $sth->finish; + } # SCOPE_IDENTITY failed, but we can do something else if ( (! $identity) && $self->_identity_method) { @@ -170,7 +93,6 @@ sub _execute { } $self->_identity($identity); - $sth->finish; } return wantarray ? ($rv, $sth, @bind) : $rv; @@ -180,7 +102,7 @@ sub last_insert_id { shift->_identity } # # MSSQL is retarded wrt ordered subselects. One needs to add a TOP -# to *all* subqueries, but one also can't use TOP 100 PERCENT +# to *all* subqueries, but one also *can't* use TOP 100 PERCENT # http://sqladvice.com/forums/permalink/18496/22931/ShowThread.aspx#22931 # sub _select_args_to_query { @@ -190,11 +112,15 @@ sub _select_args_to_query { # see if this is an ordered subquery my $attrs = $_[3]; - if ( scalar $self->sql_maker->_order_by_chunks ($attrs->{order_by}) ) { + if ( + $sql !~ /^ \s* SELECT \s+ TOP \s+ \d+ \s+ /xi + && + scalar $self->_extract_order_criteria ($attrs->{order_by}) + ) { $self->throw_exception( - 'An ordered subquery encountered. Please see "Ordered Subqueries" in DBIx::Class::Storage::DBI::MSSQL - ') unless $attrs->{unsafe_subquery}; - my $max = 2 ** 32; + 'An ordered subselect encountered - this is not safe! Please see "Ordered Subselects" in DBIx::Class::Storage::DBI::MSSQL' + ) unless $attrs->{unsafe_subselect_ok}; + my $max = $self->sql_maker->__max_int; $sql =~ s/^ \s* SELECT \s/SELECT TOP $max /xi; } @@ -207,60 +133,107 @@ sub _select_args_to_query { # savepoint syntax is the same as in Sybase ASE -sub _svp_begin { +sub _exec_svp_begin { my ($self, $name) = @_; - $self->_get_dbh->do("SAVE TRANSACTION $name"); + $self->_dbh->do("SAVE TRANSACTION $name"); } # A new SAVE TRANSACTION with the same name releases the previous one. -sub _svp_release { 1 } +sub _exec_svp_release { 1 } -sub _svp_rollback { +sub _exec_svp_rollback { my ($self, $name) = @_; - $self->_get_dbh->do("ROLLBACK TRANSACTION $name"); -} - -sub build_datetime_parser { - my $self = shift; - my $type = "DateTime::Format::Strptime"; - eval "use ${type}"; - $self->throw_exception("Couldn't load ${type}: $@") if $@; - return $type->new( pattern => '%Y-%m-%d %H:%M:%S' ); # %F %T + $self->_dbh->do("ROLLBACK TRANSACTION $name"); } sub sqlt_type { 'SQLServer' } -sub _get_mssql_version { +sub sql_limit_dialect { my $self = shift; - my $data = $self->_get_dbh->selectrow_hashref('xp_msver ProductVersion'); + my $supports_rno = 0; - if ($data->{Character_Value} =~ /^(\d+)\./) { - return $1; - } else { - $self->throw_exception(q{Your ProductVersion's Character_Value is missing or malformed!}); + if (exists $self->_server_info->{normalized_dbms_version}) { + $supports_rno = 1 if $self->_server_info->{normalized_dbms_version} >= 9; + } + else { + # User is connecting via DBD::Sybase and has no permission to run + # stored procedures like xp_msver, or version detection failed for some + # other reason. + # So, we use a query to check if RNO is implemented. + try { + $self->_get_dbh->selectrow_array('SELECT row_number() OVER (ORDER BY rand())'); + $supports_rno = 1; + }; } + + return $supports_rno ? 'RowNumberOver' : 'Top'; } -sub sql_maker { +sub _ping { my $self = shift; - unless ($self->_sql_maker) { - unless ($self->{_sql_maker_opts}{limit_dialect}) { - my $version = eval { $self->_get_mssql_version; } || 0; + my $dbh = $self->_dbh or return 0; - $self->{_sql_maker_opts} = { - limit_dialect => ($version >= 9 ? 'RowNumberOver' : 'Top'), - %{$self->{_sql_maker_opts}||{}} - }; - } + local $dbh->{RaiseError} = 1; + local $dbh->{PrintError} = 0; - my $maker = $self->next::method (@_); - } + return try { + $dbh->do('select 1'); + 1; + } catch { + 0; + }; +} + +package # hide from PAUSE + DBIx::Class::Storage::DBI::MSSQL::DateTime::Format; - return $self->_sql_maker; +my $datetime_format = '%Y-%m-%d %H:%M:%S.%3N'; # %F %T +my $smalldatetime_format = '%Y-%m-%d %H:%M:%S'; + +my ($datetime_parser, $smalldatetime_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); +} + +sub parse_smalldatetime { + shift; + require DateTime::Format::Strptime; + $smalldatetime_parser ||= DateTime::Format::Strptime->new( + pattern => $smalldatetime_format, + on_error => 'croak', + ); + return $smalldatetime_parser->parse_datetime(shift); +} + +sub format_smalldatetime { + shift; + require DateTime::Format::Strptime; + $smalldatetime_parser ||= DateTime::Format::Strptime->new( + pattern => $smalldatetime_format, + on_error => 'croak', + ); + return $smalldatetime_parser->format_datetime(shift); } 1; @@ -308,48 +281,57 @@ $table_name ON>. Unfortunately this operation in MSSQL requires the C privilege, which is normally not included in the standard write-permissions. -=head2 Ordered Subqueries +=head2 Ordered Subselects + +If you attempted the following query (among many others) in Microsoft SQL +Server - # this is deemed unsafe and throws under MSSQL $rs->search ({}, { prefetch => 'relation', rows => 2, offset => 3, }); - # however this should work (but please check what comes back from the db) +You may be surprised to receive an exception. The reason for this is a quirk +in the MSSQL engine itself, and sadly doesn't have a sensible workaround due +to the way DBIC is built. DBIC can do truly wonderful things with the aid of +subselects, and does so automatically when necessary. The list of situations +when a subselect is necessary is long and still changes often, so it can not +be exhaustively enumerated here. The general rule of thumb is a joined +L relationship with limit/group +applied to the left part of the join. + +In its "pursuit of standards" Microsft SQL Server goes to great lengths to +forbid the use of ordered subselects. This breaks a very useful group of +searches like "Give me things number 4 to 6 (ordered by name), and prefetch +all their relations, no matter how many". While there is a hack which fools +the syntax checker, the optimizer may B. +Testing has determined that while such breakage does occur (the test suite +contains an explicit test which demonstrates the problem), it is relative +rare. The benefits of ordered subselects are on the other hand too great to be +outright disabled for MSSQL. + +Thus compromise between usability and perfection is the MSSQL-specific +L C. +It is deliberately not possible to set this on the Storage level, as the user +should inspect (and preferably regression-test) the return of every such +ResultSet individually. The example above would work if written like: + $rs->search ({}, { - unsafe_subquery => 1, + unsafe_subselect_ok => 1, prefetch => 'relation', rows => 2, offset => 3, }); -DBIC can do truly wonderful things with the aid of subqueries, and does so -automatically when necessary. Especially useful are ordered subqueries, -which allow searches like "Give me things number 4 to 6 (ordered by name), and -prefetch all their relations, no matter how many". In its pursuit of standards -Microsft SQL Server goes to great lengths to forbid the use of ordered -subqueries. While there is a hack which fools the syntax checker, the optimizer -may B. Testing has determined that while -such breakage does occur (the test suite contains an explicit test which -demonstrates the problem), it is relative rare. The benefits of ordered -subqueries are on the other hand too great to be outright disabled for MSSQL. - -Thus compromise between usability and perfection is the MSSQL-specific -L C. -It is deliberately not possible to set this on the Storage level, as the user -should inspect (and preferrably regression-test) the return of every such -ResultSet individually. - If it is possible to rewrite the search() in a way that will avoid the need for this flag - you are urged to do so. If DBIC internals insist that an -ordered subquery is necessary for an operation, and you believe there is a -differnt/better way to get the same result - please file a bugreport. +ordered subselect is necessary for an operation, and you believe there is a +different/better way to get the same result - please file a bugreport. =head1 AUTHOR -See L. +See L and L. =head1 LICENSE