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
   9 use List::Util();
  10
  11 __PACKAGE__->mk_group_accessors(simple => qw/
  12   _identity _identity_method
  13 /);
  14
  15 __PACKAGE__->sql_maker_class('DBIx::Class::SQLAHacks::MSSQL');
  16
  17 sub _set_identity_insert {
  18   my ($self, $table) = @_;
  19
  20   my $sql = sprintf (
  21     'SET IDENTITY_INSERT %s ON',
  22     $self->sql_maker->_quote ($table),
  23   );
  24
  25   my $dbh = $self->_get_dbh;
  26   eval { $dbh->do ($sql) };
  27   if ($@) {
  28     $self->throw_exception (sprintf "Error executing '%s': %s",
  29       $sql,
  30       $dbh->errstr,
  31     );
  32   }
  33 }
  34
  35 sub _unset_identity_insert {
  36   my ($self, $table) = @_;
  37
  38   my $sql = sprintf (
  39     'SET IDENTITY_INSERT %s OFF',
  40     $self->sql_maker->_quote ($table),
  41   );
  42
  43   my $dbh = $self->_get_dbh;
  44   $dbh->do ($sql);
  45 }
  46
  47 sub insert_bulk {
  48   my $self = shift;
  49   my ($source, $cols, $data) = @_;
  50
  51   my $is_identity_insert = (List::Util::first
  52       { $source->column_info ($_)->{is_auto_increment} }
  53       (@{$cols})
  54   )
  55      ? 1
  56      : 0;
  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 = (List::Util::first { $_->{is_auto_increment} } (values %$supplied_col_info) )
  76      ? 1
  77      : 0;
  78
  79   if ($is_identity_insert) {
  80      $self->_set_identity_insert ($source->name);
  81   }
  82
  83   my $updated_cols = $self->next::method(@_);
  84
  85   if ($is_identity_insert) {
  86      $self->_unset_identity_insert ($source->name);
  87   }
  88
  89   return $updated_cols;
  90 }
  91
  92 sub _prep_for_execute {
  93   my $self = shift;
  94   my ($op, $extra_bind, $ident, $args) = @_;
  95
  96 # cast MONEY values properly
  97   if ($op eq 'insert' || $op eq 'update') {
  98     my $fields = $args->[0];
  99
 100     for my $col (keys %$fields) {
 101       # $ident is a result source object with INSERT/UPDATE ops
 102       if ($ident->column_info ($col)->{data_type}
 103          &&
 104          $ident->column_info ($col)->{data_type} =~ /^money\z/i) {
 105         my $val = $fields->{$col};
 106         $fields->{$col} = \['CAST(? AS MONEY)', [ $col => $val ]];
 107       }
 108     }
 109   }
 110
 111   my ($sql, $bind) = $self->next::method (@_);
 112
 113   if ($op eq 'insert') {
 114     $sql .= ';SELECT SCOPE_IDENTITY()';
 115
 116   }
 117
 118   return ($sql, $bind);
 119 }
 120
 121 sub _execute {
 122   my $self = shift;
 123   my ($op) = @_;
 124
 125   my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
 126
 127   if ($op eq 'insert') {
 128
 129     # this should bring back the result of SELECT SCOPE_IDENTITY() we tacked
 130     # on in _prep_for_execute above
 131     my ($identity) = eval { $sth->fetchrow_array };
 132
 133     # SCOPE_IDENTITY failed, but we can do something else
 134     if ( (! $identity) && $self->_identity_method) {
 135       ($identity) = $self->_dbh->selectrow_array(
 136         'select ' . $self->_identity_method
 137       );
 138     }
 139
 140     $self->_identity($identity);
 141     $sth->finish;
 142   }
 143
 144   return wantarray ? ($rv, $sth, @bind) : $rv;
 145 }
 146
 147 sub last_insert_id { shift->_identity }
 148
 149 #
 150 # MSSQL is retarded wrt ordered subselects. One needs to add a TOP
 151 # to *all* subqueries, but one also can't use TOP 100 PERCENT
 152 # http://sqladvice.com/forums/permalink/18496/22931/ShowThread.aspx#22931
 153 #
 154 sub _select_args_to_query {
 155   my $self = shift;
 156
 157   my ($sql, $prep_bind, @rest) = $self->next::method (@_);
 158
 159   # see if this is an ordered subquery
 160   my $attrs = $_[3];
 161   if ( scalar $self->_parse_order_by ($attrs->{order_by}) ) {
 162     $self->throw_exception(
 163       'An ordered subselect encountered - this is not safe! Please see "Ordered Subselects" in DBIx::Class::Storage::DBI::MSSQL
 164     ') unless $attrs->{unsafe_subselect_ok};
 165     my $max = 2 ** 32;
 166     $sql =~ s/^ \s* SELECT \s/SELECT TOP $max /xi;
 167   }
 168
 169   return wantarray
 170     ? ($sql, $prep_bind, @rest)
 171     : \[ "($sql)", @$prep_bind ]
 172   ;
 173 }
 174
 175
 176 # savepoint syntax is the same as in Sybase ASE
 177
 178 sub _svp_begin {
 179   my ($self, $name) = @_;
 180
 181   $self->_get_dbh->do("SAVE TRANSACTION $name");
 182 }
 183
 184 # A new SAVE TRANSACTION with the same name releases the previous one.
 185 sub _svp_release { 1 }
 186
 187 sub _svp_rollback {
 188   my ($self, $name) = @_;
 189
 190   $self->_get_dbh->do("ROLLBACK TRANSACTION $name");
 191 }
 192
 193 sub build_datetime_parser {
 194   my $self = shift;
 195   my $type = "DateTime::Format::Strptime";
 196   eval "use ${type}";
 197   $self->throw_exception("Couldn't load ${type}: $@") if $@;
 198   return $type->new( pattern => '%Y-%m-%d %H:%M:%S' );  # %F %T
 199 }
 200
 201 sub sqlt_type { 'SQLServer' }
 202
 203 sub sql_maker {
 204   my $self = shift;
 205
 206   unless ($self->_sql_maker) {
 207     unless ($self->{_sql_maker_opts}{limit_dialect}) {
 208
 209       my ($version) = $self->_server_info->{dbms_ver} =~ /^(\d+)/;
 210       $version ||= 0;
 211
 212       $self->{_sql_maker_opts} = {
 213         limit_dialect => ($version >= 9 ? 'RowNumberOver' : 'Top'),
 214         %{$self->{_sql_maker_opts}||{}}
 215       };
 216     }
 217
 218     my $maker = $self->next::method (@_);
 219   }
 220
 221   return $self->_sql_maker;
 222 }
 223
 224 sub _ping {
 225   my $self = shift;
 226
 227   my $dbh = $self->_dbh or return 0;
 228
 229   local $dbh->{RaiseError} = 1;
 230   local $dbh->{PrintError} = 0;
 231
 232   eval {
 233     $dbh->do('select 1');
 234   };
 235
 236   return $@ ? 0 : 1;
 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