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