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