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