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