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::AmbiguousGlob DBIx::Class::Storage::DBI/;
   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 # support MSSQL GUID column types
  70
  71 sub insert {
  72   my $self = shift;
  73   my ($source, $to_insert) = @_;
  74
  75   my $supplied_col_info = $self->_resolve_column_info($source, [keys %$to_insert] );
  76
  77   my %guid_cols;
  78   my @pk_cols = $source->primary_columns;
  79   my %pk_cols;
  80   @pk_cols{@pk_cols} = ();
  81
  82   my @pk_guids = grep {
  83     $source->column_info($_)->{data_type}
  84     &&
  85     $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
  86   } @pk_cols;
  87
  88   my @auto_guids = grep {
  89     $source->column_info($_)->{data_type}
  90     &&
  91     $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
  92     &&
  93     $source->column_info($_)->{auto_nextval}
  94   } grep { not exists $pk_cols{$_} } $source->columns;
  95
  96   my @get_guids_for =
  97     grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids);
  98
  99   my $updated_cols = {};
 100
 101   for my $guid_col (@get_guids_for) {
 102     my ($new_guid) = $self->_get_dbh->selectrow_array('SELECT NEWID()');
 103     $updated_cols->{$guid_col} = $to_insert->{$guid_col} = $new_guid;
 104   }
 105
 106   my $is_identity_insert = (List::Util::first { $_->{is_auto_increment} } (values %$supplied_col_info) )
 107      ? 1
 108      : 0;
 109
 110   if ($is_identity_insert) {
 111      $self->_set_identity_insert ($source->name);
 112   }
 113
 114   $updated_cols = { %$updated_cols, %{ $self->next::method(@_) } };
 115
 116   if ($is_identity_insert) {
 117      $self->_unset_identity_insert ($source->name);
 118   }
 119
 120
 121   return $updated_cols;
 122 }
 123
 124 sub _prep_for_execute {
 125   my $self = shift;
 126   my ($op, $extra_bind, $ident, $args) = @_;
 127
 128 # cast MONEY values properly
 129   if ($op eq 'insert' || $op eq 'update') {
 130     my $fields = $args->[0];
 131
 132     for my $col (keys %$fields) {
 133       # $ident is a result source object with INSERT/UPDATE ops
 134       if ($ident->column_info ($col)->{data_type}
 135          &&
 136          $ident->column_info ($col)->{data_type} =~ /^money\z/i) {
 137         my $val = $fields->{$col};
 138         $fields->{$col} = \['CAST(? AS MONEY)', [ $col => $val ]];
 139       }
 140     }
 141   }
 142
 143   my ($sql, $bind) = $self->next::method (@_);
 144
 145   if ($op eq 'insert') {
 146     $sql .= ';SELECT SCOPE_IDENTITY()';
 147
 148   }
 149
 150   return ($sql, $bind);
 151 }
 152
 153 sub _execute {
 154   my $self = shift;
 155   my ($op) = @_;
 156
 157   my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
 158
 159   if ($op eq 'insert') {
 160
 161     # this should bring back the result of SELECT SCOPE_IDENTITY() we tacked
 162     # on in _prep_for_execute above
 163     my ($identity) = eval { $sth->fetchrow_array };
 164
 165     # SCOPE_IDENTITY failed, but we can do something else
 166     if ( (! $identity) && $self->_identity_method) {
 167       ($identity) = $self->_dbh->selectrow_array(
 168         'select ' . $self->_identity_method
 169       );
 170     }
 171
 172     $self->_identity($identity);
 173     $sth->finish;
 174   }
 175
 176   return wantarray ? ($rv, $sth, @bind) : $rv;
 177 }
 178
 179 sub last_insert_id { shift->_identity }
 180
 181 #
 182 # MSSQL is retarded wrt ordered subselects. One needs to add a TOP
 183 # to *all* subqueries, but one also can't use TOP 100 PERCENT
 184 # http://sqladvice.com/forums/permalink/18496/22931/ShowThread.aspx#22931
 185 #
 186 sub _select_args_to_query {
 187   my $self = shift;
 188
 189   my ($sql, $prep_bind, @rest) = $self->next::method (@_);
 190
 191   # see if this is an ordered subquery
 192   my $attrs = $_[3];
 193   if ( scalar $self->sql_maker->_order_by_chunks ($attrs->{order_by}) ) {
 194     my $max = 2 ** 32;
 195     $sql =~ s/^ \s* SELECT \s/SELECT TOP $max /xi;
 196   }
 197
 198   return wantarray
 199     ? ($sql, $prep_bind, @rest)
 200     : \[ "($sql)", @$prep_bind ]
 201   ;
 202 }
 203
 204
 205 # savepoint syntax is the same as in Sybase ASE
 206
 207 sub _svp_begin {
 208   my ($self, $name) = @_;
 209
 210   $self->_get_dbh->do("SAVE TRANSACTION $name");
 211 }
 212
 213 # A new SAVE TRANSACTION with the same name releases the previous one.
 214 sub _svp_release { 1 }
 215
 216 sub _svp_rollback {
 217   my ($self, $name) = @_;
 218
 219   $self->_get_dbh->do("ROLLBACK TRANSACTION $name");
 220 }
 221
 222 sub build_datetime_parser {
 223   my $self = shift;
 224   my $type = "DateTime::Format::Strptime";
 225   eval "use ${type}";
 226   $self->throw_exception("Couldn't load ${type}: $@") if $@;
 227   return $type->new( pattern => '%Y-%m-%d %H:%M:%S' );  # %F %T
 228 }
 229
 230 sub sqlt_type { 'SQLServer' }
 231
 232 sub _get_mssql_version {
 233   my $self = shift;
 234
 235   my $data = $self->_get_dbh->selectrow_hashref('xp_msver ProductVersion');
 236
 237   if ($data->{Character_Value} =~ /^(\d+)\./) {
 238     return $1;
 239   } else {
 240     $self->throw_exception(q{Your ProductVersion's Character_Value is missing or malformed!});
 241   }
 242 }
 243
 244 sub sql_maker {
 245   my $self = shift;
 246
 247   unless ($self->_sql_maker) {
 248     unless ($self->{_sql_maker_opts}{limit_dialect}) {
 249       my $version = eval { $self->_get_mssql_version; } || 0;
 250
 251       $self->{_sql_maker_opts} = {
 252         limit_dialect => ($version >= 9 ? 'RowNumberOver' : 'Top'),
 253         %{$self->{_sql_maker_opts}||{}}
 254       };
 255     }
 256
 257     my $maker = $self->next::method (@_);
 258   }
 259
 260   return $self->_sql_maker;
 261 }
 262
 263 1;
 264
 265 =head1 NAME
 266
 267 DBIx::Class::Storage::DBI::MSSQL - Base Class for Microsoft SQL Server support
 268 in DBIx::Class
 269
 270 =head1 SYNOPSIS
 271
 272 This is the base class for Microsoft SQL Server support, used by
 273 L<DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server> and
 274 L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
 275
 276 =head1 IMPLEMENTATION NOTES
 277
 278 =head2 IDENTITY information
 279
 280 Microsoft SQL Server supports three methods of retrieving the IDENTITY
 281 value for inserted row: IDENT_CURRENT, @@IDENTITY, and SCOPE_IDENTITY().
 282 SCOPE_IDENTITY is used here because it is the safest.  However, it must
 283 be called is the same execute statement, not just the same connection.
 284
 285 So, this implementation appends a SELECT SCOPE_IDENTITY() statement
 286 onto each INSERT to accommodate that requirement.
 287
 288 C<SELECT @@IDENTITY> can also be used by issuing:
 289
 290   $self->_identity_method('@@identity');
 291
 292 it will only be used if SCOPE_IDENTITY() fails.
 293
 294 This is more dangerous, as inserting into a table with an on insert trigger that
 295 inserts into another table with an identity will give erroneous results on
 296 recent versions of SQL Server.
 297
 298 =head2 identity insert
 299
 300 Be aware that we have tried to make things as simple as possible for our users.
 301 For MSSQL that means that when a user tries to create a row, while supplying an
 302 explicit value for an autoincrementing column, we will try to issue the
 303 appropriate database call to make this possible, namely C<SET IDENTITY_INSERT
 304 $table_name ON>. Unfortunately this operation in MSSQL requires the
 305 C<db_ddladmin> privilege, which is normally not included in the standard
 306 write-permissions.
 307
 308 =head1 AUTHOR
 309
 310 See L<DBIx::Class/CONTRIBUTORS>.
 311
 312 =head1 LICENSE
 313
 314 You may distribute this code under the same terms as Perl itself.
 315
 316 =cut