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->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->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} =~ /^uniqueidentifier/i
  59   } @pk_cols;
  60
  61   my @auto_guids = grep {
  62     $source->column_info($_)->{data_type} =~ /^uniqueidentifier/i
  63     &&
  64     $source->column_info($_)->{auto_nextval}
  65   } grep { not exists $pk_cols{$_} } $source->columns;
  66
  67   my @get_guids_for =
  68     grep { not exists $to_insert->{$_} } (@pk_guids, @auto_guids);
  69
  70   for my $guid_col (@get_guids_for) {
  71     my ($new_guid) = $self->dbh->selectrow_array('SELECT NEWID()');
  72     $updated_cols->{$guid_col} = $to_insert->{$guid_col} = $new_guid;
  73   }
  74
  75   $updated_cols = { %$updated_cols, %{ $self->next::method(@_) } };
  76
  77   return $updated_cols;
  78 }
  79
  80 sub _prep_for_execute {
  81   my $self = shift;
  82   my ($op, $extra_bind, $ident, $args) = @_;
  83
  84 # cast MONEY values properly
  85   if ($op eq 'insert' || $op eq 'update') {
  86     my $fields = $args->[0];
  87
  88     for my $col (keys %$fields) {
  89       # $ident is a result source object with INSERT/UPDATE ops
  90       if ($ident->column_info ($col)->{data_type} =~ /^money\z/i) {
  91         my $val = $fields->{$col};
  92         $fields->{$col} = \['CAST(? AS MONEY)', [ $col => $val ]];
  93       }
  94     }
  95   }
  96
  97   my ($sql, $bind) = $self->next::method (@_);
  98
  99   if ($op eq 'insert') {
 100     $sql .= ';SELECT SCOPE_IDENTITY()';
 101
 102     my $col_info = $self->_resolve_column_info($ident, [map $_->[0], @{$bind}]);
 103     if (List::Util::first { $_->{is_auto_increment} } (values %$col_info) ) {
 104
 105       my $table = $ident->from;
 106       my $identity_insert_on = "SET IDENTITY_INSERT $table ON";
 107       my $identity_insert_off = "SET IDENTITY_INSERT $table OFF";
 108       $sql = "$identity_insert_on; $sql; $identity_insert_off";
 109     }
 110   }
 111
 112   return ($sql, $bind);
 113 }
 114
 115 sub _execute {
 116   my $self = shift;
 117   my ($op) = @_;
 118
 119   my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
 120
 121   if ($op eq 'insert') {
 122
 123     # this should bring back the result of SELECT SCOPE_IDENTITY() we tacked
 124     # on in _prep_for_execute above
 125     my ($identity) = $sth->fetchrow_array;
 126
 127     # SCOPE_IDENTITY failed, but we can do something else
 128     if ( (! $identity) && $self->_identity_method) {
 129       ($identity) = $self->_dbh->selectrow_array(
 130         'select ' . $self->_identity_method
 131       );
 132     }
 133
 134     $self->_identity($identity);
 135     $sth->finish;
 136   }
 137
 138   return wantarray ? ($rv, $sth, @bind) : $rv;
 139 }
 140
 141 sub last_insert_id { shift->_identity }
 142
 143 # savepoint syntax is the same as in Sybase ASE
 144
 145 sub _svp_begin {
 146   my ($self, $name) = @_;
 147
 148   $self->dbh->do("SAVE TRANSACTION $name");
 149 }
 150
 151 # A new SAVE TRANSACTION with the same name releases the previous one.
 152 sub _svp_release { 1 }
 153
 154 sub _svp_rollback {
 155   my ($self, $name) = @_;
 156
 157   $self->dbh->do("ROLLBACK TRANSACTION $name");
 158 }
 159
 160 sub build_datetime_parser {
 161   my $self = shift;
 162   my $type = "DateTime::Format::Strptime";
 163   eval "use ${type}";
 164   $self->throw_exception("Couldn't load ${type}: $@") if $@;
 165   return $type->new( pattern => '%Y-%m-%d %H:%M:%S' );  # %F %T
 166 }
 167
 168 sub sqlt_type { 'SQLServer' }
 169
 170 sub _sql_maker_opts {
 171   my ( $self, $opts ) = @_;
 172
 173   if ( $opts ) {
 174     $self->{_sql_maker_opts} = { %$opts };
 175   }
 176
 177   return { limit_dialect => 'Top', %{$self->{_sql_maker_opts}||{}} };
 178 }
 179
 180 1;
 181
 182 =head1 NAME
 183
 184 DBIx::Class::Storage::DBI::MSSQL - Base Class for Microsoft SQL Server support
 185 in DBIx::Class
 186
 187 =head1 SYNOPSIS
 188
 189 This is the base class for Microsoft SQL Server support, used by
 190 L<DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server> and
 191 L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
 192
 193 =head1 IMPLEMENTATION NOTES
 194
 195 Microsoft SQL Server supports three methods of retrieving the IDENTITY
 196 value for inserted row: IDENT_CURRENT, @@IDENTITY, and SCOPE_IDENTITY().
 197 SCOPE_IDENTITY is used here because it is the safest.  However, it must
 198 be called is the same execute statement, not just the same connection.
 199
 200 So, this implementation appends a SELECT SCOPE_IDENTITY() statement
 201 onto each INSERT to accommodate that requirement.
 202
 203 C<SELECT @@IDENTITY> can also be used by issuing:
 204
 205   $self->_identity_method('@@identity');
 206
 207 it will only be used if SCOPE_IDENTITY() fails.
 208
 209 This is more dangerous, as inserting into a table with an on insert trigger that
 210 inserts into another table with an identity will give erroneous results on
 211 recent versions of SQL Server.
 212
 213 =head1 AUTHOR
 214
 215 See L<DBIx::Class/CONTRIBUTORS>.
 216
 217 =head1 LICENSE
 218
 219 You may distribute this code under the same terms as Perl itself.
 220
 221 =cut