Remove use of Try::Tiny entirely (the missing part of ddcc02d1)
[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/
7   DBIx::Class::Storage::DBI::UniqueIdentifier
8   DBIx::Class::Storage::DBI::IdentityInsert
9 /;
10 use mro 'c3';
11
12 use DBIx::Class::_Util qw( dbic_internal_try dbic_internal_catch sigwarn_silencer );
13 use namespace::clean;
14
15 __PACKAGE__->mk_group_accessors(simple => qw/
16   _identity _identity_method _no_scope_identity_query
17 /);
18
19 __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::MSSQL');
20
21 __PACKAGE__->sql_quote_char([qw/[ ]/]);
22
23 __PACKAGE__->datetime_parser_type (
24   'DBIx::Class::Storage::DBI::MSSQL::DateTime::Format'
25 );
26
27 __PACKAGE__->new_guid('NEWID()');
28
29 sub _prep_for_execute {
30   my $self = shift;
31   my ($op, $ident, $args) = @_;
32
33 # cast MONEY values properly
34   if ($op eq 'insert' || $op eq 'update') {
35     my $fields = $args->[0];
36
37     my $colinfo = $ident->columns_info([keys %$fields]);
38
39     for my $col (keys %$fields) {
40       # $ident is a result source object with INSERT/UPDATE ops
41       if (
42         $colinfo->{$col}{data_type}
43           &&
44         $colinfo->{$col}{data_type} =~ /^money\z/i
45       ) {
46         my $val = $fields->{$col};
47         $fields->{$col} = \['CAST(? AS MONEY)', [ $col => $val ]];
48       }
49     }
50   }
51
52   my ($sql, $bind) = $self->next::method (@_);
53
54   # SELECT SCOPE_IDENTITY only works within a statement scope. We
55   # must try to always use this particular idiom first, as it is the
56   # only one that guarantees retrieving the correct id under high
57   # concurrency. When this fails we will fall back to whatever secondary
58   # retrieval method is specified in _identity_method, but at this
59   # point we don't have many guarantees we will get what we expected.
60   # http://msdn.microsoft.com/en-us/library/ms190315.aspx
61   # http://davidhayden.com/blog/dave/archive/2006/01/17/2736.aspx
62   if ($self->_perform_autoinc_retrieval and not $self->_no_scope_identity_query) {
63     $sql .= "\nSELECT SCOPE_IDENTITY()";
64   }
65
66   return ($sql, $bind);
67 }
68
69 sub _execute {
70   my $self = shift;
71
72   # always list ctx - we need the $sth
73   my ($rv, $sth, @bind) = $self->next::method(@_);
74
75   if ($self->_perform_autoinc_retrieval) {
76
77     # attempt to bring back the result of SELECT SCOPE_IDENTITY() we tacked
78     # on in _prep_for_execute above
79     my $identity;
80
81     # we didn't even try on ftds
82     unless ($self->_no_scope_identity_query) {
83       ($identity) = dbic_internal_try { $sth->fetchrow_array };
84       $sth->finish;
85     }
86
87     # SCOPE_IDENTITY failed, but we can do something else
88     if ( (! $identity) && $self->_identity_method) {
89       ($identity) = $self->_dbh->selectrow_array(
90         'select ' . $self->_identity_method
91       );
92     }
93
94     $self->_identity($identity);
95   }
96
97   return wantarray ? ($rv, $sth, @bind) : $rv;
98 }
99
100 sub last_insert_id { shift->_identity }
101
102 #
103 # MSSQL is retarded wrt ordered subselects. One needs to add a TOP
104 # to *all* subqueries, but one also *can't* use TOP 100 PERCENT
105 # http://sqladvice.com/forums/permalink/18496/22931/ShowThread.aspx#22931
106 #
107 sub _select_args_to_query {
108   #my ($self, $ident, $select, $cond, $attrs) = @_;
109   my $self = shift;
110   my $attrs = $_[3];
111
112   my $sql_bind = $self->next::method (@_);
113
114   # see if this is an ordered subquery
115   if (
116     $$sql_bind->[0] !~ /^ \s* \( \s* SELECT \s+ TOP \s+ \d+ \s+ /xi
117       and
118     scalar $self->_extract_order_criteria ($attrs->{order_by})
119   ) {
120     $self->throw_exception(
121       'An ordered subselect encountered - this is not safe! Please see "Ordered Subselects" in DBIx::Class::Storage::DBI::MSSQL'
122     ) unless $attrs->{unsafe_subselect_ok};
123
124     $$sql_bind->[0] =~ s/^ \s* \( \s* SELECT (?=\s) / '(SELECT TOP ' . $self->sql_maker->__max_int /exi;
125   }
126
127   $sql_bind;
128 }
129
130
131 # savepoint syntax is the same as in Sybase ASE
132
133 sub _exec_svp_begin {
134   my ($self, $name) = @_;
135
136   $self->_dbh->do("SAVE TRANSACTION $name");
137 }
138
139 # A new SAVE TRANSACTION with the same name releases the previous one.
140 sub _exec_svp_release { 1 }
141
142 sub _exec_svp_rollback {
143   my ($self, $name) = @_;
144
145   $self->_dbh->do("ROLLBACK TRANSACTION $name");
146 }
147
148 sub sqlt_type { 'SQLServer' }
149
150 sub sql_limit_dialect {
151   my $self = shift;
152
153   my $supports_rno = 0;
154
155   if (exists $self->_server_info->{normalized_dbms_version}) {
156     $supports_rno = 1 if $self->_server_info->{normalized_dbms_version} >= 9;
157   }
158   else {
159     # User is connecting via DBD::Sybase and has no permission to run
160     # stored procedures like xp_msver, or version detection failed for some
161     # other reason.
162     # So, we use a query to check if RNO is implemented.
163     dbic_internal_try {
164       $self->_get_dbh->selectrow_array('SELECT row_number() OVER (ORDER BY rand())');
165       $supports_rno = 1;
166     };
167   }
168
169   return $supports_rno ? 'RowNumberOver' : 'Top';
170 }
171
172 sub _ping {
173   my $self = shift;
174
175   my $dbh = $self->_dbh or return 0;
176
177   dbic_internal_try {
178     local $dbh->{RaiseError} = 1;
179     local $dbh->{PrintError} = 0;
180
181     $dbh->do('select 1');
182     1;
183   }
184   dbic_internal_catch {
185     # MSSQL is *really* annoying wrt multiple active resultsets,
186     # and this may very well be the reason why the _ping failed
187     #
188     # Proactively disconnect, while hiding annoying warnings if the case
189     #
190     # The callchain is:
191     #   < check basic retryability prerequisites (e.g. no txn) >
192     #    ->retry_handler
193     #     ->storage->connected()
194     #      ->ping
195     # So if we got here with the in_handler bit set - we won't  break
196     # anything by a disconnect
197     if( $self->{_in_do_block_retry_handler} ) {
198       local $SIG{__WARN__} = sigwarn_silencer qr/disconnect invalidates .+? active statement/;
199       $self->disconnect;
200     }
201
202     # RV of _ping itself
203     0;
204   };
205 }
206
207 package # hide from PAUSE
208   DBIx::Class::Storage::DBI::MSSQL::DateTime::Format;
209
210 my $datetime_format      = '%Y-%m-%d %H:%M:%S.%3N'; # %F %T
211 my $smalldatetime_format = '%Y-%m-%d %H:%M:%S';
212
213 my ($datetime_parser, $smalldatetime_parser);
214
215 sub parse_datetime {
216   shift;
217   require DateTime::Format::Strptime;
218   $datetime_parser ||= DateTime::Format::Strptime->new(
219     pattern  => $datetime_format,
220     on_error => 'croak',
221   );
222   return $datetime_parser->parse_datetime(shift);
223 }
224
225 sub format_datetime {
226   shift;
227   require DateTime::Format::Strptime;
228   $datetime_parser ||= DateTime::Format::Strptime->new(
229     pattern  => $datetime_format,
230     on_error => 'croak',
231   );
232   return $datetime_parser->format_datetime(shift);
233 }
234
235 sub parse_smalldatetime {
236   shift;
237   require DateTime::Format::Strptime;
238   $smalldatetime_parser ||= DateTime::Format::Strptime->new(
239     pattern  => $smalldatetime_format,
240     on_error => 'croak',
241   );
242   return $smalldatetime_parser->parse_datetime(shift);
243 }
244
245 sub format_smalldatetime {
246   shift;
247   require DateTime::Format::Strptime;
248   $smalldatetime_parser ||= DateTime::Format::Strptime->new(
249     pattern  => $smalldatetime_format,
250     on_error => 'croak',
251   );
252   return $smalldatetime_parser->format_datetime(shift);
253 }
254
255 1;
256
257 =head1 NAME
258
259 DBIx::Class::Storage::DBI::MSSQL - Base Class for Microsoft SQL Server support
260 in DBIx::Class
261
262 =head1 SYNOPSIS
263
264 This is the base class for Microsoft SQL Server support, used by
265 L<DBIx::Class::Storage::DBI::ODBC::Microsoft_SQL_Server> and
266 L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
267
268 =head1 IMPLEMENTATION NOTES
269
270 =head2 IDENTITY information
271
272 Microsoft SQL Server supports three methods of retrieving the IDENTITY
273 value for inserted row: IDENT_CURRENT, @@IDENTITY, and SCOPE_IDENTITY().
274 SCOPE_IDENTITY is used here because it is the safest.  However, it must
275 be called is the same execute statement, not just the same connection.
276
277 So, this implementation appends a SELECT SCOPE_IDENTITY() statement
278 onto each INSERT to accommodate that requirement.
279
280 C<SELECT @@IDENTITY> can also be used by issuing:
281
282   $self->_identity_method('@@identity');
283
284 it will only be used if SCOPE_IDENTITY() fails.
285
286 This is more dangerous, as inserting into a table with an on insert trigger that
287 inserts into another table with an identity will give erroneous results on
288 recent versions of SQL Server.
289
290 =head2 identity insert
291
292 Be aware that we have tried to make things as simple as possible for our users.
293 For MSSQL that means that when a user tries to create a row, while supplying an
294 explicit value for an autoincrementing column, we will try to issue the
295 appropriate database call to make this possible, namely C<SET IDENTITY_INSERT
296 $table_name ON>. Unfortunately this operation in MSSQL requires the
297 C<db_ddladmin> privilege, which is normally not included in the standard
298 write-permissions.
299
300 =head2 Ordered Subselects
301
302 If you attempted the following query (among many others) in Microsoft SQL
303 Server
304
305  $rs->search ({}, {
306   prefetch => 'relation',
307   rows => 2,
308   offset => 3,
309  });
310
311 You may be surprised to receive an exception. The reason for this is a quirk
312 in the MSSQL engine itself, and sadly doesn't have a sensible workaround due
313 to the way DBIC is built. DBIC can do truly wonderful things with the aid of
314 subselects, and does so automatically when necessary. The list of situations
315 when a subselect is necessary is long and still changes often, so it can not
316 be exhaustively enumerated here. The general rule of thumb is a joined
317 L<has_many|DBIx::Class::Relationship/has_many> relationship with limit/group
318 applied to the left part of the join.
319
320 In its "pursuit of standards" Microsft SQL Server goes to great lengths to
321 forbid the use of ordered subselects. This breaks a very useful group of
322 searches like "Give me things number 4 to 6 (ordered by name), and prefetch
323 all their relations, no matter how many". While there is a hack which fools
324 the syntax checker, the optimizer may B<still elect to break the subselect>.
325 Testing has determined that while such breakage does occur (the test suite
326 contains an explicit test which demonstrates the problem), it is relative
327 rare. The benefits of ordered subselects are on the other hand too great to be
328 outright disabled for MSSQL.
329
330 Thus compromise between usability and perfection is the MSSQL-specific
331 L<resultset attribute|DBIx::Class::ResultSet/ATTRIBUTES> C<unsafe_subselect_ok>.
332 It is deliberately not possible to set this on the Storage level, as the user
333 should inspect (and preferably regression-test) the return of every such
334 ResultSet individually. The example above would work if written like:
335
336  $rs->search ({}, {
337   unsafe_subselect_ok => 1,
338   prefetch => 'relation',
339   rows => 2,
340   offset => 3,
341  });
342
343 If it is possible to rewrite the search() in a way that will avoid the need
344 for this flag - you are urged to do so. If DBIC internals insist that an
345 ordered subselect is necessary for an operation, and you believe there is a
346 different/better way to get the same result - please file a bugreport.
347
348 =head1 FURTHER QUESTIONS?
349
350 Check the list of L<additional DBIC resources|DBIx::Class/GETTING HELP/SUPPORT>.
351
352 =head1 COPYRIGHT AND LICENSE
353
354 This module is free software L<copyright|DBIx::Class/COPYRIGHT AND LICENSE>
355 by the L<DBIx::Class (DBIC) authors|DBIx::Class/AUTHORS>. You can
356 redistribute it and/or modify it under the same terms as the
357 L<DBIx::Class library|DBIx::Class/COPYRIGHT AND LICENSE>.