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