lib/DBIx/Class/Storage/DBI/MSSQL.pm

   1 package DBIx::Class::Storage::DBI::MSSQL;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/
   7   DBIx::Class::Storage::DBI::UniqueIdentifier
   8   DBIx::Class::Storage::DBI::IdentityInsert
   9 /;
  10 use mro 'c3';
  11
  12 use Try::Tiny;
  13 use DBIx::Class::_Util qw( dbic_internal_try sigwarn_silencer );
  14 use List::Util 'first';
  15 use namespace::clean;
  16
  17 __PACKAGE__->mk_group_accessors(simple => qw/
  18   _identity _identity_method _no_scope_identity_query
  19 /);
  20
  21 __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::MSSQL');
  22
  23 __PACKAGE__->sql_quote_char([qw/[ ]/]);
  24
  25 __PACKAGE__->datetime_parser_type (
  26   'DBIx::Class::Storage::DBI::MSSQL::DateTime::Format'
  27 );
  28
  29 __PACKAGE__->new_guid('NEWID()');
  30
  31 sub _prep_for_execute {
  32   my $self = shift;
  33   my ($op, $ident, $args) = @_;
  34
  35 # cast MONEY values properly
  36   if ($op eq 'insert' || $op eq 'update') {
  37     my $fields = $args->[0];
  38
  39     my $colinfo = $ident->columns_info([keys %$fields]);
  40
  41     for my $col (keys %$fields) {
  42       # $ident is a result source object with INSERT/UPDATE ops
  43       if (
  44         $colinfo->{$col}{data_type}
  45           &&
  46         $colinfo->{$col}{data_type} =~ /^money\z/i
  47       ) {
  48         my $val = $fields->{$col};
  49         $fields->{$col} = \['CAST(? AS MONEY)', [ $col => $val ]];
  50       }
  51     }
  52   }
  53
  54   my ($sql, $bind) = $self->next::method (@_);
  55
  56   # SELECT SCOPE_IDENTITY only works within a statement scope. We
  57   # must try to always use this particular idiom first, as it is the
  58   # only one that guarantees retrieving the correct id under high
  59   # concurrency. When this fails we will fall back to whatever secondary
  60   # retrieval method is specified in _identity_method, but at this
  61   # point we don't have many guarantees we will get what we expected.
  62   # http://msdn.microsoft.com/en-us/library/ms190315.aspx
  63   # http://davidhayden.com/blog/dave/archive/2006/01/17/2736.aspx
  64   if ($self->_perform_autoinc_retrieval and not $self->_no_scope_identity_query) {
  65     $sql .= "\nSELECT SCOPE_IDENTITY()";
  66   }
  67
  68   return ($sql, $bind);
  69 }
  70
  71 sub _execute {
  72   my $self = shift;
  73
  74   # always list ctx - we need the $sth
  75   my ($rv, $sth, @bind) = $self->next::method(@_);
  76
  77   if ($self->_perform_autoinc_retrieval) {
  78
  79     # attempt to bring back the result of SELECT SCOPE_IDENTITY() we tacked
  80     # on in _prep_for_execute above
  81     my $identity;
  82
  83     # we didn't even try on ftds
  84     unless ($self->_no_scope_identity_query) {
  85       ($identity) = dbic_internal_try { $sth->fetchrow_array };
  86       $sth->finish;
  87     }
  88
  89     # SCOPE_IDENTITY failed, but we can do something else
  90     if ( (! $identity) && $self->_identity_method) {
  91       ($identity) = $self->_dbh->selectrow_array(
  92         'select ' . $self->_identity_method
  93       );
  94     }
  95
  96     $self->_identity($identity);
  97   }
  98
  99   return wantarray ? ($rv, $sth, @bind) : $rv;
 100 }
 101
 102 sub last_insert_id { shift->_identity }
 103
 104 #
 105 # MSSQL is retarded wrt ordered subselects. One needs to add a TOP
 106 # to *all* subqueries, but one also *can't* use TOP 100 PERCENT
 107 # http://sqladvice.com/forums/permalink/18496/22931/ShowThread.aspx#22931
 108 #
 109 sub _select_args_to_query {
 110   #my ($self, $ident, $select, $cond, $attrs) = @_;
 111   my $self = shift;
 112   my $attrs = $_[3];
 113
 114   my $sql_bind = $self->next::method (@_);
 115
 116   # see if this is an ordered subquery
 117   if (
 118     $$sql_bind->[0] !~ /^ \s* \( \s* SELECT \s+ TOP \s+ \d+ \s+ /xi
 119       and
 120     scalar $self->_extract_order_criteria ($attrs->{order_by})
 121   ) {
 122     $self->throw_exception(
 123       'An ordered subselect encountered - this is not safe! Please see "Ordered Subselects" in DBIx::Class::Storage::DBI::MSSQL'
 124     ) unless $attrs->{unsafe_subselect_ok};
 125
 126     $$sql_bind->[0] =~ s/^ \s* \( \s* SELECT (?=\s) / '(SELECT TOP ' . $self->sql_maker->__max_int /exi;
 127   }
 128
 129   $sql_bind;
 130 }
 131
 132
 133 # savepoint syntax is the same as in Sybase ASE
 134
 135 sub _exec_svp_begin {
 136   my ($self, $name) = @_;
 137
 138   $self->_dbh->do("SAVE TRANSACTION $name");
 139 }
 140
 141 # A new SAVE TRANSACTION with the same name releases the previous one.
 142 sub _exec_svp_release { 1 }
 143
 144 sub _exec_svp_rollback {
 145   my ($self, $name) = @_;
 146
 147   $self->_dbh->do("ROLLBACK TRANSACTION $name");
 148 }
 149
 150 sub sqlt_type { 'SQLServer' }
 151
 152 sub sql_limit_dialect {
 153   my $self = shift;
 154
 155   my $supports_rno = 0;
 156
 157   if (exists $self->_server_info->{normalized_dbms_version}) {
 158     $supports_rno = 1 if $self->_server_info->{normalized_dbms_version} >= 9;
 159   }
 160   else {
 161     # User is connecting via DBD::Sybase and has no permission to run
 162     # stored procedures like xp_msver, or version detection failed for some
 163     # other reason.
 164     # So, we use a query to check if RNO is implemented.
 165     dbic_internal_try {
 166       $self->_get_dbh->selectrow_array('SELECT row_number() OVER (ORDER BY rand())');
 167       $supports_rno = 1;
 168     };
 169   }
 170
 171   return $supports_rno ? 'RowNumberOver' : 'Top';
 172 }
 173
 174 sub _ping {
 175   my $self = shift;
 176
 177   my $dbh = $self->_dbh or return 0;
 178
 179   dbic_internal_try {
 180     local $dbh->{RaiseError} = 1;
 181     local $dbh->{PrintError} = 0;
 182
 183     $dbh->do('select 1');
 184     1;
 185   }
 186   catch {
 187     # MSSQL is *really* annoying wrt multiple active resultsets,
 188     # and this may very well be the reason why the _ping failed
 189     #
 190     # Proactively disconnect, while hiding annoying warnings if the case
 191     #
 192     # The callchain is:
 193     #   < check basic retryability prerequisites (e.g. no txn) >
 194     #    ->retry_handler
 195     #     ->storage->connected()
 196     #      ->ping
 197     # So if we got here with the in_handler bit set - we won't  break
 198     # anything by a disconnect
 199     if( $self->{_in_do_block_retry_handler} ) {
 200       local $SIG{__WARN__} = sigwarn_silencer qr/disconnect invalidates .+? active statement/;
 201       $self->disconnect;
 202     }
 203
 204     # RV of _ping itself
 205     0;
 206   };
 207 }
 208
 209 package # hide from PAUSE
 210   DBIx::Class::Storage::DBI::MSSQL::DateTime::Format;
 211
 212 my $datetime_format      = '%Y-%m-%d %H:%M:%S.%3N'; # %F %T
 213 my $smalldatetime_format = '%Y-%m-%d %H:%M:%S';
 214
 215 my ($datetime_parser, $smalldatetime_parser);
 216
 217 sub parse_datetime {
 218   shift;
 219   require DateTime::Format::Strptime;
 220   $datetime_parser ||= DateTime::Format::Strptime->new(
 221     pattern  => $datetime_format,
 222     on_error => 'croak',
 223   );
 224   return $datetime_parser->parse_datetime(shift);
 225 }
 226
 227 sub format_datetime {
 228   shift;
 229   require DateTime::Format::Strptime;
 230   $datetime_parser ||= DateTime::Format::Strptime->new(
 231     pattern  => $datetime_format,
 232     on_error => 'croak',
 233   );
 234   return $datetime_parser->format_datetime(shift);
 235 }
 236
 237 sub parse_smalldatetime {
 238   shift;
 239   require DateTime::Format::Strptime;
 240   $smalldatetime_parser ||= DateTime::Format::Strptime->new(
 241     pattern  => $smalldatetime_format,
 242     on_error => 'croak',
 243   );
 244   return $smalldatetime_parser->parse_datetime(shift);
 245 }
 246
 247 sub format_smalldatetime {
 248   shift;
 249   require DateTime::Format::Strptime;
 250   $smalldatetime_parser ||= DateTime::Format::Strptime->new(
 251     pattern  => $smalldatetime_format,
 252     on_error => 'croak',
 253   );
 254   return $smalldatetime_parser->format_datetime(shift);
 255 }
 256
 257 1;
 258
 259 =head1 NAME
 260
 261 DBIx::Class::Storage::DBI::MSSQL - Base Class for Microsoft SQL Server support
 262 in DBIx::Class
 263
 264 =head1 SYNOPSIS
 265
 266 This is the base class for Microsoft SQL Server support, used by
 267 L<DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server> and
 268 L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
 269
 270 =head1 IMPLEMENTATION NOTES
 271
 272 =head2 IDENTITY information
 273
 274 Microsoft SQL Server supports three methods of retrieving the IDENTITY
 275 value for inserted row: IDENT_CURRENT, @@IDENTITY, and SCOPE_IDENTITY().
 276 SCOPE_IDENTITY is used here because it is the safest.  However, it must
 277 be called is the same execute statement, not just the same connection.
 278
 279 So, this implementation appends a SELECT SCOPE_IDENTITY() statement
 280 onto each INSERT to accommodate that requirement.
 281
 282 C<SELECT @@IDENTITY> can also be used by issuing:
 283
 284   $self->_identity_method('@@identity');
 285
 286 it will only be used if SCOPE_IDENTITY() fails.
 287
 288 This is more dangerous, as inserting into a table with an on insert trigger that
 289 inserts into another table with an identity will give erroneous results on
 290 recent versions of SQL Server.
 291
 292 =head2 identity insert
 293
 294 Be aware that we have tried to make things as simple as possible for our users.
 295 For MSSQL that means that when a user tries to create a row, while supplying an
 296 explicit value for an autoincrementing column, we will try to issue the
 297 appropriate database call to make this possible, namely C<SET IDENTITY_INSERT
 298 $table_name ON>. Unfortunately this operation in MSSQL requires the
 299 C<db_ddladmin> privilege, which is normally not included in the standard
 300 write-permissions.
 301
 302 =head2 Ordered Subselects
 303
 304 If you attempted the following query (among many others) in Microsoft SQL
 305 Server
 306
 307  $rs->search ({}, {
 308   prefetch => 'relation',
 309   rows => 2,
 310   offset => 3,
 311  });
 312
 313 You may be surprised to receive an exception. The reason for this is a quirk
 314 in the MSSQL engine itself, and sadly doesn't have a sensible workaround due
 315 to the way DBIC is built. DBIC can do truly wonderful things with the aid of
 316 subselects, and does so automatically when necessary. The list of situations
 317 when a subselect is necessary is long and still changes often, so it can not
 318 be exhaustively enumerated here. The general rule of thumb is a joined
 319 L<has_many|DBIx::Class::Relationship/has_many> relationship with limit/group
 320 applied to the left part of the join.
 321
 322 In its "pursuit of standards" Microsft SQL Server goes to great lengths to
 323 forbid the use of ordered subselects. This breaks a very useful group of
 324 searches like "Give me things number 4 to 6 (ordered by name), and prefetch
 325 all their relations, no matter how many". While there is a hack which fools
 326 the syntax checker, the optimizer may B<still elect to break the subselect>.
 327 Testing has determined that while such breakage does occur (the test suite
 328 contains an explicit test which demonstrates the problem), it is relative
 329 rare. The benefits of ordered subselects are on the other hand too great to be
 330 outright disabled for MSSQL.
 331
 332 Thus compromise between usability and perfection is the MSSQL-specific
 333 L<resultset attribute|DBIx::Class::ResultSet/ATTRIBUTES> C<unsafe_subselect_ok>.
 334 It is deliberately not possible to set this on the Storage level, as the user
 335 should inspect (and preferably regression-test) the return of every such
 336 ResultSet individually. The example above would work if written like:
 337
 338  $rs->search ({}, {
 339   unsafe_subselect_ok => 1,
 340   prefetch => 'relation',
 341   rows => 2,
 342   offset => 3,
 343  });
 344
 345 If it is possible to rewrite the search() in a way that will avoid the need
 346 for this flag - you are urged to do so. If DBIC internals insist that an
 347 ordered subselect is necessary for an operation, and you believe there is a
 348 different/better way to get the same result - please file a bugreport.
 349
 350 =head1 FURTHER QUESTIONS?
 351
 352 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 353
 354 =head1 COPYRIGHT AND LICENSE
 355
 356 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
 357 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
 358 redistribute it and/or modify it under the same terms as the
 359 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.