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