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