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 insert_bulk {
  18   my $self = shift;
  19   my ($source, $cols, $data) = @_;
  20
  21   my $identity_insert = 0;
  22
  23   COLUMNS:
  24   foreach my $col (@{$cols}) {
  25     if ($source->column_info($col)->{is_auto_increment}) {
  26       $identity_insert = 1;
  27       last COLUMNS;
  28     }
  29   }
  30
  31   if ($identity_insert) {
  32     my $table = $source->from;
  33     $self->_get_dbh->do("SET IDENTITY_INSERT $table ON");
  34   }
  35
  36   $self->next::method(@_);
  37
  38   if ($identity_insert) {
  39     my $table = $source->from;
  40     $self->_get_dbh->do("SET IDENTITY_INSERT $table OFF");
  41   }
  42 }
  43
  44 # support MSSQL GUID column types
  45
  46 sub insert {
  47   my $self = shift;
  48   my ($source, $to_insert) = @_;
  49
  50   my $updated_cols = {};
  51
  52   my %guid_cols;
  53   my @pk_cols = $source->primary_columns;
  54   my %pk_cols;
  55   @pk_cols{@pk_cols} = ();
  56
  57   my @pk_guids = grep {
  58     $source->column_info($_)->{data_type}
  59     &&
  60     $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
  61   } @pk_cols;
  62
  63   my @auto_guids = grep {
  64     $source->column_info($_)->{data_type}
  65     &&
  66     $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
  67     &&
  68     $source->column_info($_)->{auto_nextval}
  69   } grep { not exists $pk_cols{$_} } $source->columns;
  70
  71   my @get_guids_for =
  72     grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids);
  73
  74   for my $guid_col (@get_guids_for) {
  75     my ($new_guid) = $self->_get_dbh->selectrow_array('SELECT NEWID()');
  76     $updated_cols->{$guid_col} = $to_insert->{$guid_col} = $new_guid;
  77   }
  78
  79   $updated_cols = { %$updated_cols, %{ $self->next::method(@_) } };
  80
  81   return $updated_cols;
  82 }
  83
  84 sub _prep_for_execute {
  85   my $self = shift;
  86   my ($op, $extra_bind, $ident, $args) = @_;
  87
  88 # cast MONEY values properly
  89   if ($op eq 'insert' || $op eq 'update') {
  90     my $fields = $args->[0];
  91
  92     for my $col (keys %$fields) {
  93       # $ident is a result source object with INSERT/UPDATE ops
  94       if ($ident->column_info ($col)->{data_type}
  95          &&
  96          $ident->column_info ($col)->{data_type} =~ /^money\z/i) {
  97         my $val = $fields->{$col};
  98         $fields->{$col} = \['CAST(? AS MONEY)', [ $col => $val ]];
  99       }
 100     }
 101   }
 102
 103   my ($sql, $bind) = $self->next::method (@_);
 104
 105   if ($op eq 'insert') {
 106     $sql .= ';SELECT SCOPE_IDENTITY()';
 107
 108     my $col_info = $self->_resolve_column_info($ident, [map $_->[0], @{$bind}]);
 109     if (List::Util::first { $_->{is_auto_increment} } (values %$col_info) ) {
 110
 111       my $table = $ident->from;
 112       my $identity_insert_on = "SET IDENTITY_INSERT $table ON";
 113       my $identity_insert_off = "SET IDENTITY_INSERT $table OFF";
 114       $sql = "$identity_insert_on; $sql; $identity_insert_off";
 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) = $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 # savepoint syntax is the same as in Sybase ASE
 150
 151 sub _svp_begin {
 152   my ($self, $name) = @_;
 153
 154   $self->_get_dbh->do("SAVE TRANSACTION $name");
 155 }
 156
 157 # A new SAVE TRANSACTION with the same name releases the previous one.
 158 sub _svp_release { 1 }
 159
 160 sub _svp_rollback {
 161   my ($self, $name) = @_;
 162
 163   $self->_get_dbh->do("ROLLBACK TRANSACTION $name");
 164 }
 165
 166 sub build_datetime_parser {
 167   my $self = shift;
 168   my $type = "DateTime::Format::Strptime";
 169   eval "use ${type}";
 170   $self->throw_exception("Couldn't load ${type}: $@") if $@;
 171   return $type->new( pattern => '%Y-%m-%d %H:%M:%S' );  # %F %T
 172 }
 173
 174 sub sqlt_type { 'SQLServer' }
 175
 176 sub _sql_maker_opts {
 177   my ( $self, $opts ) = @_;
 178
 179   if ( $opts ) {
 180     $self->{_sql_maker_opts} = { %$opts };
 181   }
 182
 183   return { limit_dialect => 'Top', %{$self->{_sql_maker_opts}||{}} };
 184 }
 185
 186 1;
 187
 188 =head1 NAME
 189
 190 DBIx::Class::Storage::DBI::MSSQL - Base Class for Microsoft SQL Server support
 191 in DBIx::Class
 192
 193 =head1 SYNOPSIS
 194
 195 This is the base class for Microsoft SQL Server support, used by
 196 L<DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server> and
 197 L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
 198
 199 =head1 IMPLEMENTATION NOTES
 200
 201 Microsoft SQL Server supports three methods of retrieving the IDENTITY
 202 value for inserted row: IDENT_CURRENT, @@IDENTITY, and SCOPE_IDENTITY().
 203 SCOPE_IDENTITY is used here because it is the safest.  However, it must
 204 be called is the same execute statement, not just the same connection.
 205
 206 So, this implementation appends a SELECT SCOPE_IDENTITY() statement
 207 onto each INSERT to accommodate that requirement.
 208
 209 C<SELECT @@IDENTITY> can also be used by issuing:
 210
 211   $self->_identity_method('@@identity');
 212
 213 it will only be used if SCOPE_IDENTITY() fails.
 214
 215 This is more dangerous, as inserting into a table with an on insert trigger that
 216 inserts into another table with an identity will give erroneous results on
 217 recent versions of SQL Server.
 218
 219 =head1 AUTHOR
 220
 221 See L<DBIx::Class/CONTRIBUTORS>.
 222
 223 =head1 LICENSE
 224
 225 You may distribute this code under the same terms as Perl itself.
 226
 227 =cut