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