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__->sql_maker_class('DBIx::Class::SQLAHacks::MSSQL');
  12
  13 sub insert_bulk {
  14   my $self = shift;
  15   my ($source, $cols, $data) = @_;
  16
  17   my $identity_insert = 0;
  18
  19   COLUMNS:
  20   foreach my $col (@{$cols}) {
  21     if ($source->column_info($col)->{is_auto_increment}) {
  22       $identity_insert = 1;
  23       last COLUMNS;
  24     }
  25   }
  26
  27   if ($identity_insert) {
  28     my $table = $source->from;
  29     $self->dbh->do("SET IDENTITY_INSERT $table ON");
  30   }
  31
  32   $self->next::method(@_);
  33
  34   if ($identity_insert) {
  35     my $table = $source->from;
  36     $self->dbh->do("SET IDENTITY_INSERT $table OFF");
  37   }
  38 }
  39
  40 sub _prep_for_execute {
  41   my $self = shift;
  42   my ($op, $extra_bind, $ident, $args) = @_;
  43
  44 # cast MONEY values properly
  45   if ($op eq 'insert' || $op eq 'update') {
  46     my $fields = $args->[0];
  47     my $col_info = $self->_resolve_column_info($ident, [keys %$fields]);
  48
  49     for my $col (keys %$fields) {
  50       if ($col_info->{$col}{data_type} =~ /^money\z/i) {
  51         my $val = $fields->{$col};
  52         $fields->{$col} = \['CAST(? AS MONEY)', [ $col => $val ]];
  53       }
  54     }
  55   }
  56
  57   my ($sql, $bind) = $self->next::method (@_);
  58
  59   if ($op eq 'insert') {
  60     $sql .= ';SELECT SCOPE_IDENTITY()';
  61
  62     my $col_info = $self->_resolve_column_info($ident, [map $_->[0], @{$bind}]);
  63     if (List::Util::first { $_->{is_auto_increment} } (values %$col_info) ) {
  64
  65       my $table = $ident->from;
  66       my $identity_insert_on = "SET IDENTITY_INSERT $table ON";
  67       my $identity_insert_off = "SET IDENTITY_INSERT $table OFF";
  68       $sql = "$identity_insert_on; $sql; $identity_insert_off";
  69     }
  70   }
  71
  72   return ($sql, $bind);
  73 }
  74
  75 sub _execute {
  76   my $self = shift;
  77   my ($op) = @_;
  78
  79   my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
  80   if ($op eq 'insert') {
  81     $self->{_scope_identity} = $sth->fetchrow_array;
  82     $sth->finish;
  83   }
  84
  85   return wantarray ? ($rv, $sth, @bind) : $rv;
  86 }
  87
  88
  89 sub last_insert_id { shift->{_scope_identity} }
  90
  91 sub build_datetime_parser {
  92   my $self = shift;
  93   my $type = "DateTime::Format::Strptime";
  94   eval "use ${type}";
  95   $self->throw_exception("Couldn't load ${type}: $@") if $@;
  96   return $type->new( pattern => '%Y-%m-%d %H:%M:%S' );  # %F %T
  97 }
  98
  99 sub sqlt_type { 'SQLServer' }
 100
 101 sub _sql_maker_opts {
 102   my ( $self, $opts ) = @_;
 103
 104   if ( $opts ) {
 105     $self->{_sql_maker_opts} = { %$opts };
 106   }
 107
 108   return { limit_dialect => 'Top', %{$self->{_sql_maker_opts}||{}} };
 109 }
 110
 111 1;
 112
 113 =head1 NAME
 114
 115 DBIx::Class::Storage::DBI::MSSQL - Base Class for Microsoft SQL Server support
 116 in DBIx::Class
 117
 118 =head1 SYNOPSIS
 119
 120 This is the base class for Microsoft SQL Server support, used by
 121 L<DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server> and
 122 L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
 123
 124 =head1 IMPLEMENTATION NOTES
 125
 126 Microsoft SQL Server supports three methods of retrieving the IDENTITY
 127 value for inserted row: IDENT_CURRENT, @@IDENTITY, and SCOPE_IDENTITY().
 128 SCOPE_IDENTITY is used here because it is the safest.  However, it must
 129 be called is the same execute statement, not just the same connection.
 130
 131 So, this implementation appends a SELECT SCOPE_IDENTITY() statement
 132 onto each INSERT to accommodate that requirement.
 133
 134 =head1 AUTHOR
 135
 136 See L<DBIx::Class/CONTRIBUTORS>.
 137
 138 =head1 LICENSE
 139
 140 You may distribute this code under the same terms as Perl itself.
 141
 142 =cut