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