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