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