add money type support
[dbsrgits/DBIx-Class-Historic.git] / lib / DBIx / Class / Storage / DBI / Sybase.pm
CommitLineData
3885cff6 1package DBIx::Class::Storage::DBI::Sybase;
2
3use strict;
4use warnings;
2ad62d97 5
eabab5d0 6use base qw/
64f4e691 7 DBIx::Class::Storage::DBI::Sybase::Base
b0b44f97 8 DBIx::Class::Storage::DBI
eabab5d0 9/;
2ad62d97 10use mro 'c3';
6b1f5ef7 11use Carp::Clan qw/^DBIx::Class/;
289877b0 12use List::Util ();
6b1f5ef7 13
285baccb 14__PACKAGE__->mk_group_accessors('simple' =>
15 qw/_identity _blob_log_on_update/
16);
17
98259fe4 18=head1 NAME
19
928f0af8 20DBIx::Class::Storage::DBI::Sybase - Sybase support for DBIx::Class
98259fe4 21
22=head1 SYNOPSIS
23
24This subclass supports L<DBD::Sybase> for real Sybase databases. If you are
25using an MSSQL database via L<DBD::Sybase>, your storage will be reblessed to
26L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
27
28=head1 DESCRIPTION
29
30If your version of Sybase does not support placeholders, then your storage
31will be reblessed to L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>. You can
32also enable that driver explicitly, see the documentation for more details.
33
34With this driver there is unfortunately no way to get the C<last_insert_id>
f6de7111 35without doing a C<SELECT MAX(col)>.
98259fe4 36
37But your queries will be cached.
38
8c4b6c50 39You need a version of L<DBD::Sybase> compiled with the Sybase OpenClient
40libraries, B<NOT> FreeTDS, for placeholder support. Otherwise your storage will
41be automatically reblessed into C<::NoBindVars>.
5703eb14 42
61cfaef7 43A recommended L<DBIx::Class::Storage::DBI/connect_info> setting:
98259fe4 44
61cfaef7 45 on_connect_call => [['datetime_setup'], ['blob_setup', log_on_update => 0]]
98259fe4 46
47=head1 METHODS
48
49=cut
50
47d9646a 51sub _rebless {
b50a5275 52 my $self = shift;
c5ce7cd6 53
54 if (ref($self) eq 'DBIx::Class::Storage::DBI::Sybase') {
55 my $dbtype = eval {
56 @{$self->dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
57 } || '';
58
59 my $exception = $@;
60 $dbtype =~ s/\W/_/gi;
61 my $subclass = "DBIx::Class::Storage::DBI::Sybase::${dbtype}";
62
63 if (!$exception && $dbtype && $self->load_optional_class($subclass)) {
64 bless $self, $subclass;
65 $self->_rebless;
5703eb14 66 } else { # real Sybase
67 my $no_bind_vars = 'DBIx::Class::Storage::DBI::Sybase::NoBindVars';
68
8c4b6c50 69 if ($self->_using_freetds) {
5703eb14 70 carp <<'EOF';
71
72Your version of Sybase potentially supports placeholders and query caching,
8c4b6c50 73however you seem to be using FreeTDS which does not (yet?) support this.
5703eb14 74
8c4b6c50 75Please recompile DBD::Sybase with the Sybase OpenClient libraries if you want
76these features.
77
78TEXT/IMAGE column support will also not work under FreeTDS.
5703eb14 79
80See perldoc DBIx::Class::Storage::DBI::Sybase for more details.
81EOF
82 $self->ensure_class_loaded($no_bind_vars);
83 bless $self, $no_bind_vars;
683f73ec 84 $self->_rebless;
85 }
61cfaef7 86
87 if (not $self->dbh->{syb_dynamic_supported}) {
88 $self->ensure_class_loaded($no_bind_vars);
89 bless $self, $no_bind_vars;
90 $self->_rebless;
91 }
92
41c93b1b 93 $self->_set_maxConnect;
47d9646a 94 }
c5ce7cd6 95 }
b50a5275 96}
97
f6de7111 98# Make sure we have CHAINED mode turned on, we don't know how DBD::Sybase was
99# compiled.
100sub _populate_dbh {
101 my $self = shift;
102 $self->next::method(@_);
103 $self->_dbh->{syb_chained_txn} = 1;
104}
105
61cfaef7 106sub _using_freetds {
107 my $self = shift;
8c4b6c50 108
61cfaef7 109 return $self->_dbh->{syb_oc_version} =~ /freetds/i;
8c4b6c50 110}
111
41c93b1b 112sub _set_maxConnect {
113 my $self = shift;
114
115 my $dsn = $self->_dbi_connect_info->[0];
116
117 return if ref($dsn) eq 'CODE';
118
119 if ($dsn !~ /maxConnect=/) {
120 $self->_dbi_connect_info->[0] = "$dsn;maxConnect=256";
41c93b1b 121 my $connected = defined $self->_dbh;
122 $self->disconnect;
123 $self->ensure_connected if $connected;
124 }
125}
126
63d46bb3 127=head2 connect_call_blob_setup
128
129Used as:
130
61cfaef7 131 on_connect_call => [ [ 'blob_setup', log_on_update => 0 ] ]
63d46bb3 132
133Does C<< $dbh->{syb_binary_images} = 1; >> to return C<IMAGE> data as raw binary
134instead of as a hex string.
135
6636ad53 136Recommended.
137
fd5a07e4 138Also sets the C<log_on_update> value for blob write operations. The default is
139C<1>, but C<0> is better if your database is configured for it.
140
141See
142L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.
143
63d46bb3 144=cut
145
146sub connect_call_blob_setup {
147 my $self = shift;
fd5a07e4 148 my %args = @_;
63d46bb3 149 my $dbh = $self->_dbh;
150 $dbh->{syb_binary_images} = 1;
fd5a07e4 151
152 $self->_blob_log_on_update($args{log_on_update})
153 if exists $args{log_on_update};
154}
155
156sub _is_lob_type {
157 my $self = shift;
5703eb14 158 my $type = shift;
078a332f 159 $type && $type =~ /(?:text|image|lob|bytea|binary|memo)/i;
fd5a07e4 160}
161
b5453fbb 162## This will be useful if we ever implement BLOB filehandle inflation and will
163## need to use the API, but for now it isn't.
5703eb14 164#
b5453fbb 165#sub order_columns_for_select {
61cfaef7 166# my ($self, $source, $columns) = @_;
5703eb14 167#
168# my (@non_blobs, @blobs);
169#
61cfaef7 170# for my $col (@$columns) {
b5453fbb 171# if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
5703eb14 172# push @blobs, $col;
173# } else {
174# push @non_blobs, $col;
175# }
176# }
177#
b5453fbb 178# croak "cannot select more than a one TEXT/IMAGE column at a time"
5703eb14 179# if @blobs > 1;
180#
b5453fbb 181# return (@non_blobs, @blobs);
5703eb14 182#}
183
285baccb 184# the select-piggybacking-on-insert trick stolen from odbc/mssql
185sub _prep_for_execute {
186 my $self = shift;
187 my ($op, $extra_bind, $ident, $args) = @_;
188
189 my ($sql, $bind) = $self->next::method (@_);
190
191 if ($op eq 'insert') {
285baccb 192 my $table = $ident->from;
193
194 my $bind_info = $self->_resolve_column_info($ident, [map $_->[0], @{$bind}]);
ec15b3fe 195 my $identity_col =
285baccb 196List::Util::first { $bind_info->{$_}{is_auto_increment} } (keys %$bind_info);
197
198 if ($identity_col) {
ec15b3fe 199 $sql =
200"SET IDENTITY_INSERT $table ON\n" .
201"$sql\n" .
202"SET IDENTITY_INSERT $table OFF"
285baccb 203 } else {
204 $identity_col = List::Util::first {
205 $ident->column_info($_)->{is_auto_increment}
206 } $ident->columns;
207 }
208
209 if ($identity_col) {
285baccb 210 $sql =
285baccb 211 "$sql\n" .
f6de7111 212 $self->_fetch_identity_sql($ident, $identity_col) . "\n";
285baccb 213 }
214 }
215
216 return ($sql, $bind);
217}
218
219sub _fetch_identity_sql {
220 my ($self, $source, $col) = @_;
221
222 return "SELECT MAX($col) FROM ".$source->from;
223}
224
225sub _execute {
226 my $self = shift;
227 my ($op) = @_;
228
229 my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
230
231 if ($op eq 'insert') {
232 $self->_identity($sth->fetchrow_array);
233 $sth->finish;
234 }
235
236 return wantarray ? ($rv, $sth, @bind) : $rv;
237}
238
239sub last_insert_id { shift->_identity }
240
f6de7111 241# override to handle TEXT/IMAGE and nested txn
fd5a07e4 242sub insert {
7d17f469 243 my ($self, $source, $to_insert) = splice @_, 0, 3;
289877b0 244 my $dbh = $self->_dbh;
7d17f469 245
246 my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
247
e06ad5d5 248# Sybase has savepoints fortunately, because we have to do the insert in a
249# transaction to avoid race conditions with the SELECT MAX(COL) identity method
250# used when placeholders are enabled.
f6de7111 251 my $updated_cols = do {
252 local $self->{auto_savepoint} = 1;
253 my $args = \@_;
254 my $method = $self->next::can;
255 $self->txn_do(
256 sub { $self->$method($source, $to_insert, @$args) }
257 );
258 };
7d17f469 259
078a332f 260 $self->_insert_blobs($source, $blob_cols, $to_insert) if %$blob_cols;
7d17f469 261
262 return $updated_cols;
263}
264
078a332f 265sub update {
266 my ($self, $source) = splice @_, 0, 2;
267 my ($fields, $where) = @_;
268 my $wantarray = wantarray;
269
270 my $blob_cols = $self->_remove_blob_cols($source, $fields);
271
272 my @res;
273 if ($wantarray) {
274 @res = $self->next::method($source, @_);
275 } else {
276 $res[0] = $self->next::method($source, @_);
277 }
278
279 $self->_update_blobs($source, $blob_cols, $where) if %$blob_cols;
280
281 return $wantarray ? @res : $res[0];
282}
7d17f469 283
284sub _remove_blob_cols {
285 my ($self, $source, $fields) = @_;
fd5a07e4 286
287 my %blob_cols;
288
7d17f469 289 for my $col (keys %$fields) {
9b3dabe0 290 if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
291 $blob_cols{$col} = delete $fields->{$col};
292 $fields->{$col} = \"''";
293 }
fd5a07e4 294 }
295
7d17f469 296 return \%blob_cols;
fd5a07e4 297}
298
299sub _update_blobs {
078a332f 300 my ($self, $source, $blob_cols, $where) = @_;
301
302 my (@primary_cols) = $source->primary_columns;
303
304 croak "Cannot update TEXT/IMAGE column(s) without a primary key"
305 unless @primary_cols;
306
307# check if we're updating a single row by PK
308 my $pk_cols_in_where = 0;
309 for my $col (@primary_cols) {
310 $pk_cols_in_where++ if defined $where->{$col};
311 }
312 my @rows;
313
314 if ($pk_cols_in_where == @primary_cols) {
315 my %row_to_update;
316 @row_to_update{@primary_cols} = @{$where}{@primary_cols};
317 @rows = \%row_to_update;
318 } else {
319 my $rs = $source->resultset->search(
320 $where,
321 {
322 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
323 select => \@primary_cols
324 }
325 );
326 @rows = $rs->all; # statement must finish
327 }
328
329 for my $row (@rows) {
330 $self->_insert_blobs($source, $blob_cols, $row);
331 }
332}
333
334sub _insert_blobs {
335 my ($self, $source, $blob_cols, $row) = @_;
fd5a07e4 336 my $dbh = $self->dbh;
337
338 my $table = $source->from;
339
078a332f 340 my %row = %$row;
fd5a07e4 341 my (@primary_cols) = $source->primary_columns;
342
9b3dabe0 343 croak "Cannot update TEXT/IMAGE column(s) without a primary key"
fd5a07e4 344 unless @primary_cols;
345
078a332f 346 if ((grep { defined $row{$_} } @primary_cols) != @primary_cols) {
9b3dabe0 347 if (@primary_cols == 1) {
348 my $col = $primary_cols[0];
078a332f 349 $row{$col} = $self->last_insert_id($source, $col);
9b3dabe0 350 } else {
351 croak "Cannot update TEXT/IMAGE column(s) without primary key values";
352 }
353 }
fd5a07e4 354
355 for my $col (keys %$blob_cols) {
356 my $blob = $blob_cols->{$col};
9b3dabe0 357 my $sth;
fd5a07e4 358
9b3dabe0 359 if (not $self->isa('DBIx::Class::Storage::DBI::NoBindVars')) {
360 my $search_cond = join ',' => map "$_ = ?", @primary_cols;
361
362 $sth = $self->sth(
363 "select $col from $table where $search_cond"
364 );
078a332f 365 $sth->execute(map $row{$_}, @primary_cols);
9b3dabe0 366 } else {
078a332f 367 my $search_cond = join ',' => map "$_ = $row{$_}", @primary_cols;
9b3dabe0 368
369 $sth = $dbh->prepare(
370 "select $col from $table where $search_cond"
371 );
372 $sth->execute;
373 }
fd5a07e4 374
375 eval {
376 while ($sth->fetch) {
377 $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
378 }
379 $sth->func('ct_prepare_send') or die $sth->errstr;
380
381 my $log_on_update = $self->_blob_log_on_update;
382 $log_on_update = 1 if not defined $log_on_update;
383
384 $sth->func('CS_SET', 1, {
385 total_txtlen => length($blob),
386 log_on_update => $log_on_update
387 }, 'ct_data_info') or die $sth->errstr;
388
389 $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
390
391 $sth->func('ct_finish_send') or die $sth->errstr;
392 };
393 my $exception = $@;
394 $sth->finish;
395 croak $exception if $exception;
396 }
63d46bb3 397}
398
9539eeb1 399=head2 connect_call_datetime_setup
400
401Used as:
402
403 on_connect_call => 'datetime_setup'
404
405In L<DBIx::Class::Storage::DBI/connect_info> to set:
406
3abafb11 407 $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
408 $dbh->do('set dateformat mdy'); # input fmt: 08/13/1979 18:08:55.080
9539eeb1 409
410On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
3abafb11 411L<DateTime::Format::Sybase>, which you will need to install.
412
413This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
414C<SMALLDATETIME> columns only have minute precision.
9539eeb1 415
416=cut
417
9041a97a 418{
419 my $old_dbd_warned = 0;
420
9539eeb1 421 sub connect_call_datetime_setup {
6b1f5ef7 422 my $self = shift;
6b1f5ef7 423 my $dbh = $self->_dbh;
424
425 if ($dbh->can('syb_date_fmt')) {
426 $dbh->syb_date_fmt('ISO_strict');
427 } elsif (not $old_dbd_warned) {
428 carp "Your DBD::Sybase is too old to support ".
429 "DBIx::Class::InflateColumn::DateTime, please upgrade!";
430 $old_dbd_warned = 1;
431 }
432
433 $dbh->do('set dateformat mdy');
c5ce7cd6 434
6b1f5ef7 435 1;
c5ce7cd6 436 }
6b1f5ef7 437}
438
6636ad53 439sub datetime_parser_type { "DateTime::Format::Sybase" }
440
1816be4f 441# savepoint support using ASE syntax
442
443sub _svp_begin {
444 my ($self, $name) = @_;
445
446 $self->dbh->do("SAVE TRANSACTION $name");
447}
448
449# A new SAVE TRANSACTION with the same name releases the previous one.
450sub _svp_release { 1 }
451
452sub _svp_rollback {
453 my ($self, $name) = @_;
454
455 $self->dbh->do("ROLLBACK TRANSACTION $name");
456}
457
3885cff6 4581;
459
41c93b1b 460=head1 MAXIMUM CONNECTIONS
461
462L<DBD::Sybase> makes separate connections to the server for active statements in
463the background. By default the number of such connections is limited to 25, on
464both the client side and the server side.
465
466This is a bit too low, so on connection the clientside setting is set to C<256>
467(see L<DBD::Sybase/maxConnect>.) You can override it to whatever setting you
468like in the DSN.
469
470See
471L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
472for information on changing the setting on the server side.
473
c5ce7cd6 474=head1 DATES
475
3abafb11 476See L</connect_call_datetime_setup> to setup date formats
477for L<DBIx::Class::InflateColumn::DateTime>.
c5ce7cd6 478
6636ad53 479=head1 IMAGE AND TEXT COLUMNS
63d46bb3 480
8c4b6c50 481L<DBD::Sybase> compiled with FreeTDS will B<NOT> work with C<TEXT/IMAGE>
482columns.
5703eb14 483
63d46bb3 484See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
485setting you need to work with C<IMAGE> columns.
486
3885cff6 487=head1 AUTHORS
488
7e8cecc1 489See L<DBIx::Class/CONTRIBUTORS>.
c5ce7cd6 490
3885cff6 491=head1 LICENSE
492
493You may distribute this code under the same terms as Perl itself.
494
495=cut
c5ce7cd6 496# vim:sts=2 sw=2: