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