Merge 'trunk' into 'sybase'
[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
eabab5d0 8/;
2ad62d97 9use mro 'c3';
6b1f5ef7 10use Carp::Clan qw/^DBIx::Class/;
289877b0 11use List::Util ();
6b1f5ef7 12
285baccb 13__PACKAGE__->mk_group_accessors('simple' =>
e97a6ee2 14 qw/_identity _blob_log_on_update auto_cast _insert_txn/
285baccb 15);
16
98259fe4 17=head1 NAME
18
928f0af8 19DBIx::Class::Storage::DBI::Sybase - Sybase support for DBIx::Class
98259fe4 20
21=head1 SYNOPSIS
22
23This subclass supports L<DBD::Sybase> for real Sybase databases. If you are
24using an MSSQL database via L<DBD::Sybase>, your storage will be reblessed to
25L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
26
27=head1 DESCRIPTION
28
29If your version of Sybase does not support placeholders, then your storage
30will be reblessed to L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>. You can
31also enable that driver explicitly, see the documentation for more details.
32
33With this driver there is unfortunately no way to get the C<last_insert_id>
f6de7111 34without doing a C<SELECT MAX(col)>.
98259fe4 35
36But your queries will be cached.
37
61cfaef7 38A recommended L<DBIx::Class::Storage::DBI/connect_info> setting:
98259fe4 39
61cfaef7 40 on_connect_call => [['datetime_setup'], ['blob_setup', log_on_update => 0]]
98259fe4 41
42=head1 METHODS
43
44=cut
45
47d9646a 46sub _rebless {
b50a5275 47 my $self = shift;
c5ce7cd6 48
49 if (ref($self) eq 'DBIx::Class::Storage::DBI::Sybase') {
50 my $dbtype = eval {
44e538d0 51 @{$self->last_dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
c5ce7cd6 52 } || '';
53
54 my $exception = $@;
55 $dbtype =~ s/\W/_/gi;
56 my $subclass = "DBIx::Class::Storage::DBI::Sybase::${dbtype}";
57
58 if (!$exception && $dbtype && $self->load_optional_class($subclass)) {
59 bless $self, $subclass;
60 $self->_rebless;
5703eb14 61 } else { # real Sybase
62 my $no_bind_vars = 'DBIx::Class::Storage::DBI::Sybase::NoBindVars';
63
a3a526cc 64# This is reset to 0 in ::NoBindVars, only necessary because we use max(col) to
65# get the identity.
66 $self->_insert_txn(1);
67
e97a6ee2 68 if ($self->using_freetds) {
a3a526cc 69 carp <<'EOF' unless $ENV{DBIC_SYBASE_FREETDS_NOWARN};
70
71You are using FreeTDS with Sybase.
5703eb14 72
a3a526cc 73We will do our best to support this configuration, but please consider this
74support experimental.
5703eb14 75
a3a526cc 76TEXT/IMAGE columns will definitely not work.
8c4b6c50 77
e97a6ee2 78You are encouraged to recompile DBD::Sybase with the Sybase Open Client libraries
a3a526cc 79instead.
5703eb14 80
81See perldoc DBIx::Class::Storage::DBI::Sybase for more details.
a3a526cc 82
83To turn off this warning set the DBIC_SYBASE_FREETDS_NOWARN environment
84variable.
5703eb14 85EOF
e97a6ee2 86 if (not $self->placeholders_with_type_conversion_supported) {
87 if ($self->placeholders_supported) {
88 $self->auto_cast(1);
a3a526cc 89 } else {
90 $self->ensure_class_loaded($no_bind_vars);
91 bless $self, $no_bind_vars;
92 $self->_rebless;
93 }
94 }
61cfaef7 95
e97a6ee2 96 $self->set_textsize; # based on LongReadLen in connect_info
97
98 } elsif (not $self->dbh->{syb_dynamic_supported}) {
99# not necessarily FreeTDS, but no placeholders nevertheless
61cfaef7 100 $self->ensure_class_loaded($no_bind_vars);
101 bless $self, $no_bind_vars;
102 $self->_rebless;
103 }
104
a3a526cc 105 $self->_set_max_connect(256);
47d9646a 106 }
c5ce7cd6 107 }
b50a5275 108}
109
a3a526cc 110# Make sure we have CHAINED mode turned on if AutoCommit is off in non-FreeTDS
111# DBD::Sybase (since we don't know how DBD::Sybase was compiled.) If however
112# we're using FreeTDS, CHAINED mode turns on an implicit transaction which we
113# only want when AutoCommit is off.
f6de7111 114sub _populate_dbh {
115 my $self = shift;
41c93b1b 116
a3a526cc 117 $self->next::method(@_);
41c93b1b 118
e97a6ee2 119 if (not $self->using_freetds) {
a3a526cc 120 $self->_dbh->{syb_chained_txn} = 1;
121 } else {
122 if ($self->_dbh_autocommit) {
123 $self->_dbh->do('SET CHAINED OFF');
124 } else {
125 $self->_dbh->do('SET CHAINED ON');
126 }
41c93b1b 127 }
128}
129
63d46bb3 130=head2 connect_call_blob_setup
131
132Used as:
133
61cfaef7 134 on_connect_call => [ [ 'blob_setup', log_on_update => 0 ] ]
63d46bb3 135
136Does C<< $dbh->{syb_binary_images} = 1; >> to return C<IMAGE> data as raw binary
137instead of as a hex string.
138
6636ad53 139Recommended.
140
fd5a07e4 141Also sets the C<log_on_update> value for blob write operations. The default is
142C<1>, but C<0> is better if your database is configured for it.
143
144See
145L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.
146
63d46bb3 147=cut
148
149sub connect_call_blob_setup {
150 my $self = shift;
fd5a07e4 151 my %args = @_;
63d46bb3 152 my $dbh = $self->_dbh;
153 $dbh->{syb_binary_images} = 1;
fd5a07e4 154
155 $self->_blob_log_on_update($args{log_on_update})
156 if exists $args{log_on_update};
157}
158
e97a6ee2 159=head2 connect_call_set_auto_cast
160
161In some configurations (usually with L</FreeTDS>) statements with values bound
162to columns or conditions that are not strings will throw implicit type
163conversion errors. For L</FreeTDS> this is automatically detected, and this
164option is set.
165
166It converts placeholders to:
167
168 CAST(? as $type)
169
170the type is taken from the L<DBIx::Class::ResultSource/data_type> setting from
171your Result class, and mapped to a Sybase type using a mapping based on
172L<SQL::Translator> if necessary.
173
174This setting can also be set outside of
175L<DBIx::Class::Storage::DBI/connect_info> at any time using:
176
177 $schema->storage->auto_cast(1);
178
179=cut
180
181sub connect_call_set_auto_cast {
182 my $self = shift;
183 $self->auto_cast(1);
184}
185
fd5a07e4 186sub _is_lob_type {
187 my $self = shift;
5703eb14 188 my $type = shift;
078a332f 189 $type && $type =~ /(?:text|image|lob|bytea|binary|memo)/i;
fd5a07e4 190}
191
a3a526cc 192# The select-piggybacking-on-insert trick stolen from odbc/mssql
285baccb 193sub _prep_for_execute {
194 my $self = shift;
195 my ($op, $extra_bind, $ident, $args) = @_;
196
197 my ($sql, $bind) = $self->next::method (@_);
198
a3a526cc 199# Some combinations of FreeTDS and Sybase throw implicit conversion errors for
200# all placeeholders, so we convert them into CASTs here.
201# Based on code in ::DBI::NoBindVars .
202#
203# If we're using ::NoBindVars, there are no binds by this point so this code
204# gets skippeed.
e97a6ee2 205 if ($self->auto_cast && @$bind) {
a3a526cc 206 my $new_sql;
207 my @sql_part = split /\?/, $sql;
208 my $col_info = $self->_resolve_column_info($ident,[ map $_->[0], @$bind ]);
209
210 foreach my $bound (@$bind) {
211 my $col = $bound->[0];
212 my $syb_type = $self->_syb_base_type($col_info->{$col}{data_type});
213
214 foreach my $data (@{$bound}[1..$#$bound]) {
215 $new_sql .= shift(@sql_part) .
216 ($syb_type ? "CAST(? AS $syb_type)" : '?');
217 }
218 }
219 $new_sql .= join '', @sql_part;
220 $sql = $new_sql;
221 }
222
285baccb 223 if ($op eq 'insert') {
285baccb 224 my $table = $ident->from;
225
a3a526cc 226 my $bind_info = $self->_resolve_column_info(
227 $ident, [map $_->[0], @{$bind}]
228 );
ec15b3fe 229 my $identity_col =
285baccb 230List::Util::first { $bind_info->{$_}{is_auto_increment} } (keys %$bind_info);
231
232 if ($identity_col) {
ec15b3fe 233 $sql =
234"SET IDENTITY_INSERT $table ON\n" .
235"$sql\n" .
236"SET IDENTITY_INSERT $table OFF"
285baccb 237 } else {
238 $identity_col = List::Util::first {
239 $ident->column_info($_)->{is_auto_increment}
240 } $ident->columns;
241 }
242
243 if ($identity_col) {
285baccb 244 $sql =
285baccb 245 "$sql\n" .
a3a526cc 246 $self->_fetch_identity_sql($ident, $identity_col);
285baccb 247 }
248 }
249
250 return ($sql, $bind);
251}
252
a3a526cc 253# Stolen from SQLT, with some modifications. This will likely change when the
254# SQLT Sybase stuff is redone/fixed-up.
255my %TYPE_MAPPING = (
256 number => 'numeric',
257 money => 'money',
258 varchar => 'varchar',
259 varchar2 => 'varchar',
260 timestamp => 'datetime',
261 text => 'varchar',
262 real => 'double precision',
263 comment => 'text',
264 bit => 'bit',
265 tinyint => 'smallint',
266 float => 'double precision',
267 serial => 'numeric',
268 bigserial => 'numeric',
269 boolean => 'varchar',
270 long => 'varchar',
271);
272
273sub _syb_base_type {
274 my ($self, $type) = @_;
275
276 $type = lc $type;
277 $type =~ s/ identity//;
278
279 return uc($TYPE_MAPPING{$type} || $type);
280}
281
285baccb 282sub _fetch_identity_sql {
283 my ($self, $source, $col) = @_;
284
285 return "SELECT MAX($col) FROM ".$source->from;
286}
287
288sub _execute {
289 my $self = shift;
290 my ($op) = @_;
291
292 my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
293
294 if ($op eq 'insert') {
295 $self->_identity($sth->fetchrow_array);
296 $sth->finish;
297 }
298
299 return wantarray ? ($rv, $sth, @bind) : $rv;
300}
301
302sub last_insert_id { shift->_identity }
303
a3a526cc 304# override to handle TEXT/IMAGE and to do a transaction if necessary
fd5a07e4 305sub insert {
7d17f469 306 my ($self, $source, $to_insert) = splice @_, 0, 3;
289877b0 307 my $dbh = $self->_dbh;
7d17f469 308
309 my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
310
a3a526cc 311# We have to do the insert in a transaction to avoid race conditions with the
312# SELECT MAX(COL) identity method used when placeholders are enabled.
f6de7111 313 my $updated_cols = do {
a3a526cc 314 if ($self->_insert_txn && (not $self->{transaction_depth})) {
315 my $args = \@_;
316 my $method = $self->next::can;
317 $self->txn_do(
318 sub { $self->$method($source, $to_insert, @$args) }
319 );
320 } else {
321 $self->next::method($source, $to_insert, @_);
322 }
f6de7111 323 };
7d17f469 324
078a332f 325 $self->_insert_blobs($source, $blob_cols, $to_insert) if %$blob_cols;
7d17f469 326
327 return $updated_cols;
328}
329
078a332f 330sub update {
331 my ($self, $source) = splice @_, 0, 2;
332 my ($fields, $where) = @_;
333 my $wantarray = wantarray;
334
335 my $blob_cols = $self->_remove_blob_cols($source, $fields);
336
337 my @res;
338 if ($wantarray) {
339 @res = $self->next::method($source, @_);
340 } else {
341 $res[0] = $self->next::method($source, @_);
342 }
343
344 $self->_update_blobs($source, $blob_cols, $where) if %$blob_cols;
345
346 return $wantarray ? @res : $res[0];
347}
7d17f469 348
349sub _remove_blob_cols {
350 my ($self, $source, $fields) = @_;
fd5a07e4 351
352 my %blob_cols;
353
7d17f469 354 for my $col (keys %$fields) {
9b3dabe0 355 if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
356 $blob_cols{$col} = delete $fields->{$col};
357 $fields->{$col} = \"''";
358 }
fd5a07e4 359 }
360
7d17f469 361 return \%blob_cols;
fd5a07e4 362}
363
364sub _update_blobs {
078a332f 365 my ($self, $source, $blob_cols, $where) = @_;
366
367 my (@primary_cols) = $source->primary_columns;
368
369 croak "Cannot update TEXT/IMAGE column(s) without a primary key"
370 unless @primary_cols;
371
372# check if we're updating a single row by PK
373 my $pk_cols_in_where = 0;
374 for my $col (@primary_cols) {
375 $pk_cols_in_where++ if defined $where->{$col};
376 }
377 my @rows;
378
379 if ($pk_cols_in_where == @primary_cols) {
380 my %row_to_update;
381 @row_to_update{@primary_cols} = @{$where}{@primary_cols};
382 @rows = \%row_to_update;
383 } else {
384 my $rs = $source->resultset->search(
385 $where,
386 {
387 result_class => 'DBIx::Class::ResultClass::HashRefInflator',
388 select => \@primary_cols
389 }
390 );
391 @rows = $rs->all; # statement must finish
392 }
393
394 for my $row (@rows) {
395 $self->_insert_blobs($source, $blob_cols, $row);
396 }
397}
398
399sub _insert_blobs {
400 my ($self, $source, $blob_cols, $row) = @_;
fd5a07e4 401 my $dbh = $self->dbh;
402
403 my $table = $source->from;
404
078a332f 405 my %row = %$row;
fd5a07e4 406 my (@primary_cols) = $source->primary_columns;
407
9b3dabe0 408 croak "Cannot update TEXT/IMAGE column(s) without a primary key"
fd5a07e4 409 unless @primary_cols;
410
078a332f 411 if ((grep { defined $row{$_} } @primary_cols) != @primary_cols) {
9b3dabe0 412 if (@primary_cols == 1) {
413 my $col = $primary_cols[0];
078a332f 414 $row{$col} = $self->last_insert_id($source, $col);
9b3dabe0 415 } else {
416 croak "Cannot update TEXT/IMAGE column(s) without primary key values";
417 }
418 }
fd5a07e4 419
420 for my $col (keys %$blob_cols) {
421 my $blob = $blob_cols->{$col};
422
a3a526cc 423 my %where = map { ($_, $row{$_}) } @primary_cols;
424 my $cursor = $source->resultset->search(\%where, {
425 select => [$col]
426 })->cursor;
427 $cursor->next;
5137d252 428 my $sth = $cursor->sth;
fd5a07e4 429
430 eval {
a3a526cc 431 do {
fd5a07e4 432 $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
a3a526cc 433 } while $sth->fetch;
434
fd5a07e4 435 $sth->func('ct_prepare_send') or die $sth->errstr;
436
437 my $log_on_update = $self->_blob_log_on_update;
438 $log_on_update = 1 if not defined $log_on_update;
439
440 $sth->func('CS_SET', 1, {
441 total_txtlen => length($blob),
442 log_on_update => $log_on_update
443 }, 'ct_data_info') or die $sth->errstr;
444
445 $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
446
447 $sth->func('ct_finish_send') or die $sth->errstr;
448 };
449 my $exception = $@;
a3a526cc 450 $sth->finish if $sth;
451 if ($exception) {
e97a6ee2 452 if ($self->using_freetds) {
a3a526cc 453 croak
454"TEXT/IMAGE operation failed, probably because you're using FreeTDS: " .
455$exception;
456 } else {
457 croak $exception;
458 }
459 }
fd5a07e4 460 }
63d46bb3 461}
462
9539eeb1 463=head2 connect_call_datetime_setup
464
465Used as:
466
467 on_connect_call => 'datetime_setup'
468
469In L<DBIx::Class::Storage::DBI/connect_info> to set:
470
3abafb11 471 $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
472 $dbh->do('set dateformat mdy'); # input fmt: 08/13/1979 18:08:55.080
9539eeb1 473
474On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
3abafb11 475L<DateTime::Format::Sybase>, which you will need to install.
476
477This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
478C<SMALLDATETIME> columns only have minute precision.
9539eeb1 479
480=cut
481
9041a97a 482{
483 my $old_dbd_warned = 0;
484
9539eeb1 485 sub connect_call_datetime_setup {
6b1f5ef7 486 my $self = shift;
6b1f5ef7 487 my $dbh = $self->_dbh;
488
489 if ($dbh->can('syb_date_fmt')) {
e97a6ee2 490# amazingly, this works with FreeTDS
6b1f5ef7 491 $dbh->syb_date_fmt('ISO_strict');
492 } elsif (not $old_dbd_warned) {
493 carp "Your DBD::Sybase is too old to support ".
494 "DBIx::Class::InflateColumn::DateTime, please upgrade!";
495 $old_dbd_warned = 1;
496 }
497
e97a6ee2 498 $dbh->do('SET DATEFORMAT mdy');
c5ce7cd6 499
6b1f5ef7 500 1;
c5ce7cd6 501 }
6b1f5ef7 502}
503
6636ad53 504sub datetime_parser_type { "DateTime::Format::Sybase" }
505
e97a6ee2 506# ->begin_work and such have no effect with FreeTDS but we run them anyway to
507# let the DBD keep any state it needs to.
508#
509# If they ever do start working, the extra statements will do no harm (because
510# Sybase supports nested transactions.)
a3a526cc 511
512sub _dbh_begin_work {
513 my $self = shift;
e97a6ee2 514 $self->next::method(@_);
515 if ($self->using_freetds) {
a3a526cc 516 $self->dbh->do('BEGIN TRAN');
517 }
518}
519
520sub _dbh_commit {
521 my $self = shift;
e97a6ee2 522 if ($self->using_freetds) {
a3a526cc 523 $self->_dbh->do('COMMIT');
524 }
e97a6ee2 525 return $self->next::method(@_);
a3a526cc 526}
527
528sub _dbh_rollback {
529 my $self = shift;
e97a6ee2 530 if ($self->using_freetds) {
a3a526cc 531 $self->_dbh->do('ROLLBACK');
532 }
e97a6ee2 533 return $self->next::method(@_);
a3a526cc 534}
535
1816be4f 536# savepoint support using ASE syntax
537
538sub _svp_begin {
539 my ($self, $name) = @_;
540
541 $self->dbh->do("SAVE TRANSACTION $name");
542}
543
544# A new SAVE TRANSACTION with the same name releases the previous one.
545sub _svp_release { 1 }
546
547sub _svp_rollback {
548 my ($self, $name) = @_;
549
550 $self->dbh->do("ROLLBACK TRANSACTION $name");
551}
552
3885cff6 5531;
554
efe75aaa 555=head1 Schema::Loader Support
556
557There is an experimental branch of L<DBIx::Class::Schema::Loader> that will
558allow you to dump a schema from most (if not all) versions of Sybase.
559
560It is available via subversion from:
561
562 http://dev.catalyst.perl.org/repos/bast/branches/DBIx-Class-Schema-Loader/mssql_tweaks
563
e97a6ee2 564=head1 FreeTDS
565
566This driver supports L<DBD::Sybase> compiled against FreeTDS
567(L<http://www.freetds.org/>) to the best of our ability, however it is
568recommended that you recompile L<DBD::Sybase> against the Sybase Open Client
569libraries. They are a part of the Sybase ASE distribution:
570
571The Open Client FAQ is here:
572L<http://www.isug.com/Sybase_FAQ/ASE/section7.html>.
573
574Sybase ASE for Linux (which comes with the Open Client libraries) may be
575downloaded here: L<http://response.sybase.com/forms/ASE_Linux_Download>.
576
577To see if you're using FreeTDS check C<< $schema->storage->using_freetds >>, or run:
578
579 perl -MDBI -le 'my $dbh = DBI->connect($dsn, $user, $pass); print $dbh->{syb_oc_version}'
580
581Some versions of the libraries involved will not support placeholders, in which
582case the storage will be reblessed to
583L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>.
584
585In some configurations, placeholders will work but will throw implicit
586conversion errors for anything that's not expecting a string. In such a case,
587the C<auto_cast> option is automatically set, which you may enable yourself with
588L</connect_call_set_auto_cast> (see the description of that method for more
589details.)
590
591In other configurations, placeholers will work just as they do with the Sybase
592Open Client libraries.
593
594Inserts or updates of TEXT/IMAGE columns will B<NOT> work with FreeTDS.
595
41c93b1b 596=head1 MAXIMUM CONNECTIONS
597
e97a6ee2 598The TDS protocol makes separate connections to the server for active statements
599in the background. By default the number of such connections is limited to 25,
600on both the client side and the server side.
41c93b1b 601
e97a6ee2 602This is a bit too low for a complex L<DBIx::Class> application, so on connection
603the client side setting is set to C<256> (see L<DBD::Sybase/maxConnect>.) You
604can override it to whatever setting you like in the DSN.
41c93b1b 605
606See
607L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
608for information on changing the setting on the server side.
609
c5ce7cd6 610=head1 DATES
611
3abafb11 612See L</connect_call_datetime_setup> to setup date formats
613for L<DBIx::Class::InflateColumn::DateTime>.
c5ce7cd6 614
e97a6ee2 615=head1 TEXT/IMAGE COLUMNS
63d46bb3 616
a3a526cc 617L<DBD::Sybase> compiled with FreeTDS will B<NOT> allow you to insert or update
618C<TEXT/IMAGE> columns.
619
e97a6ee2 620Setting C<< $dbh->{LongReadLen} >> will also not work with FreeTDS use either:
621
622 $schema->storage->dbh->do("SET TEXTSIZE $bytes");
a3a526cc 623
e97a6ee2 624or
625
626 $schema->storage->set_textsize($bytes);
a3a526cc 627
628instead.
5703eb14 629
e97a6ee2 630However, the C<LongReadLen> you pass in
631L<DBIx::Class::Storage::DBI/connect_info> is used to execute the equivalent
632C<SET TEXTSIZE> command on connection.
633
63d46bb3 634See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
635setting you need to work with C<IMAGE> columns.
636
3885cff6 637=head1 AUTHORS
638
7e8cecc1 639See L<DBIx::Class/CONTRIBUTORS>.
c5ce7cd6 640
3885cff6 641=head1 LICENSE
642
643You may distribute this code under the same terms as Perl itself.
644
645=cut
c5ce7cd6 646# vim:sts=2 sw=2: