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