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