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( 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) = 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     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   try {
 180     local $dbh->{RaiseError} = 1;
 181     local $dbh->{PrintError} = 0;
 182     $dbh->do('select 1');
 183     1;
 184   }
 185   catch {
 186     # MSSQL is *really* annoying wrt multiple active resultsets,
 187     # and this may very well be the reason why the _ping failed
 188     #
 189     # Proactively disconnect, while hiding annoying warnings if the case
 190     #
 191     # The callchain is:
 192     #   < check basic retryability prerequisites (e.g. no txn) >
 193     #    ->retry_handler
 194     #     ->storage->connected()
 195     #      ->ping
 196     # So if we got here with the in_handler bit set - we won't  break
 197     # anything by a disconnect
 198     if( $self->{_in_do_block_retry_handler} ) {
 199       local $SIG{__WARN__} = sigwarn_silencer qr/disconnect invalidates .+? active statement/;
 200       $self->disconnect;
 201     }
 202
 203     # RV of _ping itself
 204     0;
 205   };
 206 }
 207
 208 package # hide from PAUSE
 209   DBIx::Class::Storage::DBI::MSSQL::DateTime::Format;
 210
 211 my $datetime_format      = '%Y-%m-%d %H:%M:%S.%3N'; # %F %T
 212 my $smalldatetime_format = '%Y-%m-%d %H:%M:%S';
 213
 214 my ($datetime_parser, $smalldatetime_parser);
 215
 216 sub parse_datetime {
 217   shift;
 218   require DateTime::Format::Strptime;
 219   $datetime_parser ||= DateTime::Format::Strptime->new(
 220     pattern  => $datetime_format,
 221     on_error => 'croak',
 222   );
 223   return $datetime_parser->parse_datetime(shift);
 224 }
 225
 226 sub format_datetime {
 227   shift;
 228   require DateTime::Format::Strptime;
 229   $datetime_parser ||= DateTime::Format::Strptime->new(
 230     pattern  => $datetime_format,
 231     on_error => 'croak',
 232   );
 233   return $datetime_parser->format_datetime(shift);
 234 }
 235
 236 sub parse_smalldatetime {
 237   shift;
 238   require DateTime::Format::Strptime;
 239   $smalldatetime_parser ||= DateTime::Format::Strptime->new(
 240     pattern  => $smalldatetime_format,
 241     on_error => 'croak',
 242   );
 243   return $smalldatetime_parser->parse_datetime(shift);
 244 }
 245
 246 sub format_smalldatetime {
 247   shift;
 248   require DateTime::Format::Strptime;
 249   $smalldatetime_parser ||= DateTime::Format::Strptime->new(
 250     pattern  => $smalldatetime_format,
 251     on_error => 'croak',
 252   );
 253   return $smalldatetime_parser->format_datetime(shift);
 254 }
 255
 256 1;
 257
 258 =head1 NAME
 259
 260 DBIx::Class::Storage::DBI::MSSQL - Base Class for Microsoft SQL Server support
 261 in DBIx::Class
 262
 263 =head1 SYNOPSIS
 264
 265 This is the base class for Microsoft SQL Server support, used by
 266 L<DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server> and
 267 L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
 268
 269 =head1 IMPLEMENTATION NOTES
 270
 271 =head2 IDENTITY information
 272
 273 Microsoft SQL Server supports three methods of retrieving the IDENTITY
 274 value for inserted row: IDENT_CURRENT, @@IDENTITY, and SCOPE_IDENTITY().
 275 SCOPE_IDENTITY is used here because it is the safest.  However, it must
 276 be called is the same execute statement, not just the same connection.
 277
 278 So, this implementation appends a SELECT SCOPE_IDENTITY() statement
 279 onto each INSERT to accommodate that requirement.
 280
 281 C<SELECT @@IDENTITY> can also be used by issuing:
 282
 283   $self->_identity_method('@@identity');
 284
 285 it will only be used if SCOPE_IDENTITY() fails.
 286
 287 This is more dangerous, as inserting into a table with an on insert trigger that
 288 inserts into another table with an identity will give erroneous results on
 289 recent versions of SQL Server.
 290
 291 =head2 identity insert
 292
 293 Be aware that we have tried to make things as simple as possible for our users.
 294 For MSSQL that means that when a user tries to create a row, while supplying an
 295 explicit value for an autoincrementing column, we will try to issue the
 296 appropriate database call to make this possible, namely C<SET IDENTITY_INSERT
 297 $table_name ON>. Unfortunately this operation in MSSQL requires the
 298 C<db_ddladmin> privilege, which is normally not included in the standard
 299 write-permissions.
 300
 301 =head2 Ordered Subselects
 302
 303 If you attempted the following query (among many others) in Microsoft SQL
 304 Server
 305
 306  $rs->search ({}, {
 307   prefetch => 'relation',
 308   rows => 2,
 309   offset => 3,
 310  });
 311
 312 You may be surprised to receive an exception. The reason for this is a quirk
 313 in the MSSQL engine itself, and sadly doesn't have a sensible workaround due
 314 to the way DBIC is built. DBIC can do truly wonderful things with the aid of
 315 subselects, and does so automatically when necessary. The list of situations
 316 when a subselect is necessary is long and still changes often, so it can not
 317 be exhaustively enumerated here. The general rule of thumb is a joined
 318 L<has_many|DBIx::Class::Relationship/has_many> relationship with limit/group
 319 applied to the left part of the join.
 320
 321 In its "pursuit of standards" Microsft SQL Server goes to great lengths to
 322 forbid the use of ordered subselects. This breaks a very useful group of
 323 searches like "Give me things number 4 to 6 (ordered by name), and prefetch
 324 all their relations, no matter how many". While there is a hack which fools
 325 the syntax checker, the optimizer may B<still elect to break the subselect>.
 326 Testing has determined that while such breakage does occur (the test suite
 327 contains an explicit test which demonstrates the problem), it is relative
 328 rare. The benefits of ordered subselects are on the other hand too great to be
 329 outright disabled for MSSQL.
 330
 331 Thus compromise between usability and perfection is the MSSQL-specific
 332 L<resultset attribute|DBIx::Class::ResultSet/ATTRIBUTES> C<unsafe_subselect_ok>.
 333 It is deliberately not possible to set this on the Storage level, as the user
 334 should inspect (and preferably regression-test) the return of every such
 335 ResultSet individually. The example above would work if written like:
 336
 337  $rs->search ({}, {
 338   unsafe_subselect_ok => 1,
 339   prefetch => 'relation',
 340   rows => 2,
 341   offset => 3,
 342  });
 343
 344 If it is possible to rewrite the search() in a way that will avoid the need
 345 for this flag - you are urged to do so. If DBIC internals insist that an
 346 ordered subselect is necessary for an operation, and you believe there is a
 347 different/better way to get the same result - please file a bugreport.
 348
 349 =head1 FURTHER QUESTIONS?
 350
 351 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
 352
 353 =head1 COPYRIGHT AND LICENSE
 354
 355 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
 356 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
 357 redistribute it and/or modify it under the same terms as the
 358 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.