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