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