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 =head2 IDENTITY information
 202
 203 Microsoft SQL Server supports three methods of retrieving the IDENTITY
 204 value for inserted row: IDENT_CURRENT, @@IDENTITY, and SCOPE_IDENTITY().
 205 SCOPE_IDENTITY is used here because it is the safest.  However, it must
 206 be called is the same execute statement, not just the same connection.
 207
 208 So, this implementation appends a SELECT SCOPE_IDENTITY() statement
 209 onto each INSERT to accommodate that requirement.
 210
 211 C<SELECT @@IDENTITY> can also be used by issuing:
 212
 213   $self->_identity_method('@@identity');
 214
 215 it will only be used if SCOPE_IDENTITY() fails.
 216
 217 This is more dangerous, as inserting into a table with an on insert trigger that
 218 inserts into another table with an identity will give erroneous results on
 219 recent versions of SQL Server.
 220
 221 =head2 bulk_insert
 222
 223 Be aware that we have tried to make things as simple as possible for our users.
 224 For MSSQL that means that when a user tries to do a populate/bulk_insert which
 225 includes an autoincrementing column, we will try to tell the database to allow
 226 the insertion of the autoinc column.  But the user must have the db_ddladmin
 227 role membership, otherwise you will get a fairly opaque error message.
 228
 229 =head1 AUTHOR
 230
 231 See L<DBIx::Class/CONTRIBUTORS>.
 232
 233 =head1 LICENSE
 234
 235 You may distribute this code under the same terms as Perl itself.
 236
 237 =cut