Merge 'sybase_support' into 'sybase_bulkinsert_support'
[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI / Sybase.pm
CommitLineData
f68f4d44 1package DBIx::Class::Storage::DBI::Sybase;
2
3use strict;
4use warnings;
2ad62d97 5
eabab5d0 6use base qw/
d867eeda 7 DBIx::Class::Storage::DBI::Sybase::Common
8 DBIx::Class::Storage::DBI::AutoCast
eabab5d0 9/;
2ad62d97 10use mro 'c3';
d867eeda 11use Carp::Clan qw/^DBIx::Class/;
12use List::Util ();
13use Sub::Name ();
14
15__PACKAGE__->mk_group_accessors('simple' =>
0a9a9955 16 qw/_identity _blob_log_on_update _writer_storage _is_extra_storage
17 _bulk_storage _is_bulk_storage _began_bulk_work
18 _bulk_disabled_due_to_coderef_connect_info_warned
d867eeda 19 _identity_method/
20);
21
0a9a9955 22my @also_proxy_to_extra_storages = qw/
2baff5da 23 connect_call_set_auto_cast auto_cast connect_call_blob_setup
24 connect_call_datetime_setup
25
d867eeda 26 disconnect _connect_info _sql_maker _sql_maker_opts disable_sth_caching
27 auto_savepoint unsafe cursor_class debug debugobj schema
28/;
29
30=head1 NAME
31
32DBIx::Class::Storage::DBI::Sybase - Sybase support for DBIx::Class
33
34=head1 SYNOPSIS
35
36This subclass supports L<DBD::Sybase> for real Sybase databases. If you are
37using an MSSQL database via L<DBD::Sybase>, your storage will be reblessed to
38L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
39
40=head1 DESCRIPTION
41
42If your version of Sybase does not support placeholders, then your storage
43will be reblessed to L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>. You can
44also enable that driver explicitly, see the documentation for more details.
45
46With this driver there is unfortunately no way to get the C<last_insert_id>
47without doing a C<SELECT MAX(col)>. This is done safely in a transaction
48(locking the table.) See L</INSERTS WITH PLACEHOLDERS>.
49
50A recommended L<DBIx::Class::Storage::DBI/connect_info> setting:
51
52 on_connect_call => [['datetime_setup'], ['blob_setup', log_on_update => 0]]
53
54=head1 METHODS
55
56=cut
f68f4d44 57
47d9646a 58sub _rebless {
d867eeda 59 my $self = shift;
d29565e0 60
d867eeda 61 if (ref($self) eq 'DBIx::Class::Storage::DBI::Sybase') {
ef131d82 62 my $dbtype = eval {
d867eeda 63 @{$self->_get_dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
64 } || '';
65
66 my $exception = $@;
67 $dbtype =~ s/\W/_/gi;
68 my $subclass = "DBIx::Class::Storage::DBI::Sybase::${dbtype}";
69
70 if (!$exception && $dbtype && $self->load_optional_class($subclass)) {
71 bless $self, $subclass;
72 $self->_rebless;
73 } else { # real Sybase
74 my $no_bind_vars = 'DBIx::Class::Storage::DBI::Sybase::NoBindVars';
75
76 if ($self->using_freetds) {
77 carp <<'EOF' unless $ENV{DBIC_SYBASE_FREETDS_NOWARN};
78
79You are using FreeTDS with Sybase.
80
81We will do our best to support this configuration, but please consider this
82support experimental.
83
84TEXT/IMAGE columns will definitely not work.
85
86You are encouraged to recompile DBD::Sybase with the Sybase Open Client libraries
87instead.
88
89See perldoc DBIx::Class::Storage::DBI::Sybase for more details.
90
91To turn off this warning set the DBIC_SYBASE_FREETDS_NOWARN environment
92variable.
93EOF
94 if (not $self->_typeless_placeholders_supported) {
95 if ($self->_placeholders_supported) {
96 $self->auto_cast(1);
97 } else {
98 $self->ensure_class_loaded($no_bind_vars);
99 bless $self, $no_bind_vars;
d29565e0 100 $self->_rebless;
d867eeda 101 }
d29565e0 102 }
d867eeda 103 }
104 elsif (not $self->_get_dbh->{syb_dynamic_supported}) {
105 # not necessarily FreeTDS, but no placeholders nevertheless
106 $self->ensure_class_loaded($no_bind_vars);
107 bless $self, $no_bind_vars;
108 $self->_rebless;
109 } elsif (not $self->_typeless_placeholders_supported) {
0a9a9955 110 # this is highly unlikely, but we check just in case
d867eeda 111 $self->auto_cast(1);
112 }
113 }
114 }
115}
116
117sub _init {
118 my $self = shift;
119 $self->_set_max_connect(256);
120
121 # based on LongReadLen in connect_info
122 $self->set_textsize if $self->using_freetds;
123
124# create storage for insert/(update blob) transactions,
125# unless this is that storage
0a9a9955 126 return if $self->_is_extra_storage;
d867eeda 127
128 my $writer_storage = (ref $self)->new;
129
0a9a9955 130 $writer_storage->_is_extra_storage(1);
d867eeda 131 $writer_storage->connect_info($self->connect_info);
2baff5da 132 $writer_storage->auto_cast($self->auto_cast);
d867eeda 133
134 $self->_writer_storage($writer_storage);
0a9a9955 135
136# create a bulk storage unless connect_info is a coderef
137 return
138 if (Scalar::Util::reftype($self->_dbi_connect_info->[0])||'') eq 'CODE';
139
140 my $bulk_storage = (ref $self)->new;
141
142 $bulk_storage->_is_extra_storage(1);
143 $bulk_storage->_is_bulk_storage(1); # for special ->disconnect acrobatics
144 $bulk_storage->connect_info($self->connect_info);
145
146# this is why
147 $bulk_storage->_dbi_connect_info->[0] .= ';bulkLogin=1';
148
149 $self->_bulk_storage($bulk_storage);
d867eeda 150}
151
0a9a9955 152for my $method (@also_proxy_to_extra_storages) {
d867eeda 153 no strict 'refs';
2baff5da 154 no warnings 'redefine';
d867eeda 155
156 my $replaced = __PACKAGE__->can($method);
157
0a9a9955 158 *{$method} = Sub::Name::subname $method => sub {
d867eeda 159 my $self = shift;
160 $self->_writer_storage->$replaced(@_) if $self->_writer_storage;
0a9a9955 161 $self->_bulk_storage->$replaced(@_) if $self->_bulk_storage;
d867eeda 162 return $self->$replaced(@_);
163 };
164}
165
0a9a9955 166sub disconnect {
167 my $self = shift;
168
169# Even though we call $sth->finish for uses off the bulk API, there's still an
170# "active statement" warning on disconnect, which we throw away here.
171# This is due to the bug described in insert_bulk.
172# Currently a noop because 'prepare' is used instead of 'prepare_cached'.
173 local $SIG{__WARN__} = sub {
174 warn $_[0] unless $_[0] =~ /active statement/i;
175 } if $self->_is_bulk_storage;
176
177# so that next transaction gets a dbh
178 $self->_began_bulk_work(0) if $self->_is_bulk_storage;
179
180 $self->next::method;
181}
182
d867eeda 183# Make sure we have CHAINED mode turned on if AutoCommit is off in non-FreeTDS
184# DBD::Sybase (since we don't know how DBD::Sybase was compiled.) If however
185# we're using FreeTDS, CHAINED mode turns on an implicit transaction which we
186# only want when AutoCommit is off.
187sub _populate_dbh {
188 my $self = shift;
189
190 $self->next::method(@_);
0a9a9955 191
192 if ($self->_is_bulk_storage) {
193# this should be cleared on every reconnect
194 $self->_began_bulk_work(0);
195 return;
196 }
d867eeda 197
198 if (not $self->using_freetds) {
199 $self->_dbh->{syb_chained_txn} = 1;
200 } else {
201 if ($self->_dbh_autocommit) {
202 $self->_dbh->do('SET CHAINED OFF');
203 } else {
204 $self->_dbh->do('SET CHAINED ON');
205 }
206 }
207}
208
209=head2 connect_call_blob_setup
210
211Used as:
212
213 on_connect_call => [ [ 'blob_setup', log_on_update => 0 ] ]
214
215Does C<< $dbh->{syb_binary_images} = 1; >> to return C<IMAGE> data as raw binary
216instead of as a hex string.
217
218Recommended.
219
220Also sets the C<log_on_update> value for blob write operations. The default is
221C<1>, but C<0> is better if your database is configured for it.
222
223See
224L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.
225
226=cut
227
228sub connect_call_blob_setup {
229 my $self = shift;
230 my %args = @_;
231 my $dbh = $self->_dbh;
232 $dbh->{syb_binary_images} = 1;
233
234 $self->_blob_log_on_update($args{log_on_update})
235 if exists $args{log_on_update};
236}
237
238sub _is_lob_type {
239 my $self = shift;
240 my $type = shift;
241 $type && $type =~ /(?:text|image|lob|bytea|binary|memo)/i;
242}
243
2baff5da 244sub _is_lob_column {
245 my ($self, $source, $column) = @_;
246
247 return $self->_is_lob_type($source->column_info($column)->{data_type});
248}
249
d867eeda 250sub _prep_for_execute {
251 my $self = shift;
252 my ($op, $extra_bind, $ident, $args) = @_;
253
254 my ($sql, $bind) = $self->next::method (@_);
255
db66bc3f 256 my $table = Scalar::Util::blessed($ident) ? $ident->from : $ident;
d867eeda 257
db66bc3f 258 my $bind_info = $self->_resolve_column_info(
259 $ident, [map $_->[0], @{$bind}]
260 );
261 my $bound_identity_col = List::Util::first
262 { $bind_info->{$_}{is_auto_increment} }
263 (keys %$bind_info)
264 ;
265 my $identity_col = Scalar::Util::blessed($ident) &&
266 List::Util::first
267 { $ident->column_info($_)->{is_auto_increment} }
268 $ident->columns
269 ;
270
271 if (($op eq 'insert' && $bound_identity_col) ||
272 ($op eq 'update' && exists $args->[0]{$identity_col})) {
273 $sql = join ("\n",
274 $self->_set_table_identity_sql($op => $table, 'on'),
275 $sql,
276 $self->_set_table_identity_sql($op => $table, 'off'),
d867eeda 277 );
db66bc3f 278 }
d867eeda 279
82a1c958 280 if ($op eq 'insert' && (not $bound_identity_col) && $identity_col &&
281 (not $self->{insert_bulk})) {
db66bc3f 282 $sql =
283 "$sql\n" .
284 $self->_fetch_identity_sql($ident, $identity_col);
d867eeda 285 }
286
287 return ($sql, $bind);
288}
289
db66bc3f 290sub _set_table_identity_sql {
291 my ($self, $op, $table, $on_off) = @_;
292
293 return sprintf 'SET IDENTITY_%s %s %s',
294 uc($op), $self->sql_maker->_quote($table), uc($on_off);
295}
296
d867eeda 297# Stolen from SQLT, with some modifications. This is a makeshift
298# solution before a sane type-mapping library is available, thus
299# the 'our' for easy overrides.
300our %TYPE_MAPPING = (
301 number => 'numeric',
302 money => 'money',
303 varchar => 'varchar',
304 varchar2 => 'varchar',
305 timestamp => 'datetime',
306 text => 'varchar',
307 real => 'double precision',
308 comment => 'text',
309 bit => 'bit',
310 tinyint => 'smallint',
311 float => 'double precision',
312 serial => 'numeric',
313 bigserial => 'numeric',
314 boolean => 'varchar',
315 long => 'varchar',
316);
317
318sub _native_data_type {
319 my ($self, $type) = @_;
320
321 $type = lc $type;
322 $type =~ s/\s* identity//x;
323
324 return uc($TYPE_MAPPING{$type} || $type);
325}
326
327sub _fetch_identity_sql {
328 my ($self, $source, $col) = @_;
329
330 return sprintf ("SELECT MAX(%s) FROM %s",
331 map { $self->sql_maker->_quote ($_) } ($col, $source->from)
332 );
333}
334
335sub _execute {
336 my $self = shift;
337 my ($op) = @_;
338
339 my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
340
341 if ($op eq 'insert') {
342 $self->_identity($sth->fetchrow_array);
343 $sth->finish;
344 }
345
346 return wantarray ? ($rv, $sth, @bind) : $rv;
347}
348
349sub last_insert_id { shift->_identity }
350
351# handles TEXT/IMAGE and transaction for last_insert_id
352sub insert {
353 my $self = shift;
354 my ($source, $to_insert) = @_;
355
cd048330 356 my $identity_col = (List::Util::first
d867eeda 357 { $source->column_info($_)->{is_auto_increment} }
cd048330 358 $source->columns) || '';
359
360 # check for empty insert
361 # INSERT INTO foo DEFAULT VALUES -- does not work with Sybase
362 # try to insert explicit 'DEFAULT's instead (except for identity)
363 if (not %$to_insert) {
364 for my $col ($source->columns) {
365 next if $col eq $identity_col;
366 $to_insert->{$col} = \'DEFAULT';
367 }
368 }
369
370 my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
d867eeda 371
372 # do we need the horrific SELECT MAX(COL) hack?
373 my $dumb_last_insert_id =
374 $identity_col
375 && (not exists $to_insert->{$identity_col})
376 && ($self->_identity_method||'') ne '@@IDENTITY';
377
378 my $next = $self->next::can;
379
380 # we are already in a transaction, or there are no blobs
381 # and we don't need the PK - just (try to) do it
382 if ($self->{transaction_depth}
383 || (!$blob_cols && !$dumb_last_insert_id)
384 ) {
385 return $self->_insert (
386 $next, $source, $to_insert, $blob_cols, $identity_col
387 );
388 }
389
390 # otherwise use the _writer_storage to do the insert+transaction on another
391 # connection
392 my $guard = $self->_writer_storage->txn_scope_guard;
393
394 my $updated_cols = $self->_writer_storage->_insert (
395 $next, $source, $to_insert, $blob_cols, $identity_col
396 );
397
398 $self->_identity($self->_writer_storage->_identity);
399
400 $guard->commit;
401
402 return $updated_cols;
403}
404
405sub _insert {
406 my ($self, $next, $source, $to_insert, $blob_cols, $identity_col) = @_;
407
408 my $updated_cols = $self->$next ($source, $to_insert);
409
410 my $final_row = {
cd048330 411 ($identity_col ?
412 ($identity_col => $self->last_insert_id($source, $identity_col)) : ()),
d867eeda 413 %$to_insert,
414 %$updated_cols,
415 };
416
417 $self->_insert_blobs ($source, $blob_cols, $final_row) if $blob_cols;
418
419 return $updated_cols;
420}
421
422sub update {
423 my $self = shift;
2baff5da 424 my ($source, $fields, $where, @rest) = @_;
d867eeda 425
426 my $wantarray = wantarray;
2baff5da 427
d867eeda 428 my $blob_cols = $self->_remove_blob_cols($source, $fields);
429
2baff5da 430 my $table = $source->name;
431
432 my $identity_col = List::Util::first
433 { $source->column_info($_)->{is_auto_increment} }
434 $source->columns;
435
436 my $is_identity_update = $identity_col && defined $fields->{$identity_col};
437
db66bc3f 438 return $self->next::method(@_) unless $blob_cols;
2baff5da 439
d390bd3c 440# If there are any blobs in $where, Sybase will return a descriptive error
441# message.
db66bc3f 442# XXX blobs can still be used with a LIKE query, and this should be handled.
d867eeda 443
444# update+blob update(s) done atomically on separate connection
445 $self = $self->_writer_storage;
446
447 my $guard = $self->txn_scope_guard;
448
2baff5da 449# First update the blob columns to be updated to '' (taken from $fields, where
450# it is originally put by _remove_blob_cols .)
451 my %blobs_to_empty = map { ($_ => delete $fields->{$_}) } keys %$blob_cols;
d867eeda 452
574d7df6 453# We can't only update NULL blobs, because blobs cannot be in the WHERE clause.
454
2baff5da 455 $self->next::method($source, \%blobs_to_empty, $where, @rest);
e19677ad 456
2baff5da 457# Now update the blobs before the other columns in case the update of other
458# columns makes the search condition invalid.
d867eeda 459 $self->_update_blobs($source, $blob_cols, $where);
460
2baff5da 461 my @res;
462 if (%$fields) {
2baff5da 463 if ($wantarray) {
464 @res = $self->next::method(@_);
465 }
466 elsif (defined $wantarray) {
467 $res[0] = $self->next::method(@_);
468 }
469 else {
470 $self->next::method(@_);
471 }
2baff5da 472 }
473
d867eeda 474 $guard->commit;
475
476 return $wantarray ? @res : $res[0];
477}
478
d867eeda 479sub insert_bulk {
480 my $self = shift;
481 my ($source, $cols, $data) = @_;
482
0a9a9955 483 my $identity_col = List::Util::first
484 { $source->column_info($_)->{is_auto_increment} }
485 $source->columns;
486
d867eeda 487 my $is_identity_insert = (List::Util::first
587daa97 488 { $_ eq $identity_col }
0a9a9955 489 @{$cols}
490 ) ? 1 : 0;
491
492 my @source_columns = $source->columns;
493
494 my $use_bulk_api =
495 $self->_bulk_storage &&
496 $self->_get_dbh->{syb_has_blk};
497
498 if ((not $use_bulk_api) &&
499 (Scalar::Util::reftype($self->_dbi_connect_info->[0])||'') eq 'CODE' &&
500 (not $self->_bulk_disabled_due_to_coderef_connect_info_warned)) {
501 carp <<'EOF';
502Bulk API support disabled due to use of a CODEREF connect_info. Reverting to
587daa97 503regular array inserts.
0a9a9955 504EOF
505 $self->_bulk_disabled_due_to_coderef_connect_info_warned(1);
d867eeda 506 }
507
0a9a9955 508 if (not $use_bulk_api) {
509 my $blob_cols = $self->_remove_blob_cols_array($source, $cols, $data);
510
c68af2f3 511# _execute_array uses a txn anyway, but it ends too early in case we need to
512# select max(col) to get the identity for inserting blobs.
8195240c 513 ($self, my $guard) = $self->{transaction_depth} == 0 ?
514 ($self->_writer_storage, $self->_writer_storage->txn_scope_guard)
515 :
516 ($self, undef);
517
82a1c958 518 local $self->{insert_bulk} = 1;
0a9a9955 519
0a9a9955 520 $self->next::method(@_);
0a9a9955 521
522 if ($blob_cols) {
523 if ($is_identity_insert) {
524 $self->_insert_blobs_array ($source, $blob_cols, $cols, $data);
525 }
526 else {
527 my @cols_with_identities = (@$cols, $identity_col);
528
529 ## calculate identities
530 # XXX This assumes identities always increase by 1, which may or may not
531 # be true.
532 my ($last_identity) =
533 $self->_dbh->selectrow_array (
534 $self->_fetch_identity_sql($source, $identity_col)
535 );
536 my @identities = (($last_identity - @$data + 1) .. $last_identity);
537
538 my @data_with_identities = map [@$_, shift @identities], @$data;
539
540 $self->_insert_blobs_array (
541 $source, $blob_cols, \@cols_with_identities, \@data_with_identities
542 );
543 }
544 }
d867eeda 545
8195240c 546 $guard->commit if $guard;
547
0a9a9955 548 return;
d867eeda 549 }
d867eeda 550
0a9a9955 551# otherwise, use the bulk API
552
553# rearrange @$data so that columns are in database order
554 my %orig_idx;
555 @orig_idx{@$cols} = 0..$#$cols;
556
557 my %new_idx;
558 @new_idx{@source_columns} = 0..$#source_columns;
559
560 my @new_data;
561 for my $datum (@$data) {
562 my $new_datum = [];
563 for my $col (@source_columns) {
564# identity data will be 'undef' if not $is_identity_insert
565# columns with defaults will also be 'undef'
566 $new_datum->[ $new_idx{$col} ] =
567 exists $orig_idx{$col} ? $datum->[ $orig_idx{$col} ] : undef;
568 }
569 push @new_data, $new_datum;
570 }
571
572# bcp identity index is 1-based
573 my $identity_idx = exists $new_idx{$identity_col} ?
574 $new_idx{$identity_col} + 1 : 0;
575
576## Set a client-side conversion error handler, straight from DBD::Sybase docs.
577# This ignores any data conversion errors detected by the client side libs, as
578# they are usually harmless.
579 my $orig_cslib_cb = DBD::Sybase::set_cslib_cb(
580 Sub::Name::subname insert_bulk => sub {
581 my ($layer, $origin, $severity, $errno, $errmsg, $osmsg, $blkmsg) = @_;
582
583 return 1 if $errno == 36;
584
585 carp
586 "Layer: $layer, Origin: $origin, Severity: $severity, Error: $errno" .
587 ($errmsg ? "\n$errmsg" : '') .
588 ($osmsg ? "\n$osmsg" : '') .
589 ($blkmsg ? "\n$blkmsg" : '');
590
591 return 0;
592 });
593
594 eval {
595 my $bulk = $self->_bulk_storage;
596
597 my $guard = $bulk->txn_scope_guard;
598
599## XXX get this to work instead of our own $sth
600## will require SQLA or *Hacks changes for ordered columns
601# $bulk->next::method($source, \@source_columns, \@new_data, {
602# syb_bcp_attribs => {
603# identity_flag => $is_identity_insert,
604# identity_column => $identity_idx,
605# }
606# });
607 my $sql = 'INSERT INTO ' .
608 $bulk->sql_maker->_quote($source->name) . ' (' .
609# colname list is ignored for BCP, but does no harm
610 (join ', ', map $bulk->sql_maker->_quote($_), @source_columns) . ') '.
611 ' VALUES ('. (join ', ', ('?') x @source_columns) . ')';
612
613## XXX there's a bug in the DBD::Sybase bulk support that makes $sth->finish for
614## a prepare_cached statement ineffective. Replace with ->sth when fixed, or
615## better yet the version above. Should be fixed in DBD::Sybase .
616 my $sth = $bulk->_get_dbh->prepare($sql,
617# 'insert', # op
618 {
619 syb_bcp_attribs => {
620 identity_flag => $is_identity_insert,
621 identity_column => $identity_idx,
622 }
623 }
624 );
625
587daa97 626 my @bind = do {
627 my $idx = 0;
628 map [ $_, $idx++ ], @source_columns;
629 };
0a9a9955 630
587daa97 631 $self->_execute_array(
018f6efb 632 $source, $sth, \@bind, \@source_columns, \@new_data, sub {
633 $guard->commit
634 }
587daa97 635 );
0a9a9955 636
637 $bulk->_query_end($sql);
638 };
db66bc3f 639
0a9a9955 640 my $exception = $@;
db66bc3f 641 DBD::Sybase::set_cslib_cb($orig_cslib_cb);
642
0a9a9955 643 if ($exception =~ /-Y option/) {
644 carp <<"EOF";
645
646Sybase bulk API operation failed due to character set incompatibility, reverting
647to regular array inserts:
648
649*** Try unsetting the LANG environment variable.
650
db66bc3f 651$exception
0a9a9955 652EOF
653 $self->_bulk_storage(undef);
0a9a9955 654 unshift @_, $self;
655 goto \&insert_bulk;
656 }
657 elsif ($exception) {
0a9a9955 658# rollback makes the bulkLogin connection unusable
659 $self->_bulk_storage->disconnect;
660 $self->throw_exception($exception);
661 }
0a9a9955 662}
d867eeda 663
936f31c1 664sub _dbh_execute_array {
665 my ($self, $sth, $tuple_status, $cb) = @_;
666
667 my $rv = $self->next::method($sth, $tuple_status);
668 $cb->() if $cb;
669
670 return $rv;
671}
672
2baff5da 673# Make sure blobs are not bound as placeholders, and return any non-empty ones
674# as a hash.
d867eeda 675sub _remove_blob_cols {
676 my ($self, $source, $fields) = @_;
677
678 my %blob_cols;
679
680 for my $col (keys %$fields) {
587daa97 681 if ($self->_is_lob_column($source, $col)) {
2baff5da 682 my $blob_val = delete $fields->{$col};
683 if (not defined $blob_val) {
684 $fields->{$col} = \'NULL';
685 }
686 else {
687 $fields->{$col} = \"''";
688 $blob_cols{$col} = $blob_val unless $blob_val eq '';
689 }
d867eeda 690 }
691 }
692
6a9765c1 693 return %blob_cols ? \%blob_cols : undef;
d867eeda 694}
695
0a9a9955 696# same for insert_bulk
697sub _remove_blob_cols_array {
698 my ($self, $source, $cols, $data) = @_;
699
700 my @blob_cols;
701
702 for my $i (0..$#$cols) {
703 my $col = $cols->[$i];
704
587daa97 705 if ($self->_is_lob_column($source, $col)) {
0a9a9955 706 for my $j (0..$#$data) {
707 my $blob_val = delete $data->[$j][$i];
708 if (not defined $blob_val) {
709 $data->[$j][$i] = \'NULL';
710 }
711 else {
712 $data->[$j][$i] = \"''";
713 $blob_cols[$j][$i] = $blob_val
714 unless $blob_val eq '';
715 }
716 }
717 }
718 }
719
720 return @blob_cols ? \@blob_cols : undef;
721}
722
d867eeda 723sub _update_blobs {
724 my ($self, $source, $blob_cols, $where) = @_;
725
726 my (@primary_cols) = $source->primary_columns;
727
728 $self->throw_exception('Cannot update TEXT/IMAGE column(s) without a primary key')
729 unless @primary_cols;
730
731# check if we're updating a single row by PK
732 my $pk_cols_in_where = 0;
733 for my $col (@primary_cols) {
734 $pk_cols_in_where++ if defined $where->{$col};
735 }
736 my @rows;
737
738 if ($pk_cols_in_where == @primary_cols) {
739 my %row_to_update;
740 @row_to_update{@primary_cols} = @{$where}{@primary_cols};
741 @rows = \%row_to_update;
742 } else {
743 my $cursor = $self->select ($source, \@primary_cols, $where, {});
744 @rows = map {
745 my %row; @row{@primary_cols} = @$_; \%row
746 } $cursor->all;
747 }
748
749 for my $row (@rows) {
750 $self->_insert_blobs($source, $blob_cols, $row);
751 }
752}
753
754sub _insert_blobs {
755 my ($self, $source, $blob_cols, $row) = @_;
756 my $dbh = $self->_get_dbh;
757
2baff5da 758 my $table = $source->name;
d867eeda 759
760 my %row = %$row;
761 my (@primary_cols) = $source->primary_columns;
762
763 $self->throw_exception('Cannot update TEXT/IMAGE column(s) without a primary key')
764 unless @primary_cols;
765
766 $self->throw_exception('Cannot update TEXT/IMAGE column(s) without primary key values')
767 if ((grep { defined $row{$_} } @primary_cols) != @primary_cols);
768
769 for my $col (keys %$blob_cols) {
770 my $blob = $blob_cols->{$col};
771
772 my %where = map { ($_, $row{$_}) } @primary_cols;
773
774 my $cursor = $self->select ($source, [$col], \%where, {});
775 $cursor->next;
776 my $sth = $cursor->sth;
777
2baff5da 778 if (not $sth) {
b561bb6f 779
780 $self->throw_exception(
781 "Could not find row in table '$table' for blob update:\n"
782 . $self->_pretty_print (\%where)
783 );
2baff5da 784 }
785
d867eeda 786 eval {
787 do {
788 $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
789 } while $sth->fetch;
790
791 $sth->func('ct_prepare_send') or die $sth->errstr;
792
793 my $log_on_update = $self->_blob_log_on_update;
794 $log_on_update = 1 if not defined $log_on_update;
795
796 $sth->func('CS_SET', 1, {
797 total_txtlen => length($blob),
798 log_on_update => $log_on_update
799 }, 'ct_data_info') or die $sth->errstr;
800
801 $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
802
803 $sth->func('ct_finish_send') or die $sth->errstr;
804 };
805 my $exception = $@;
806 $sth->finish if $sth;
807 if ($exception) {
808 if ($self->using_freetds) {
809 $self->throw_exception (
810 'TEXT/IMAGE operation failed, probably because you are using FreeTDS: '
811 . $exception
812 );
813 } else {
814 $self->throw_exception($exception);
815 }
816 }
817 }
818}
819
0a9a9955 820sub _insert_blobs_array {
821 my ($self, $source, $blob_cols, $cols, $data) = @_;
822
823 for my $i (0..$#$data) {
824 my $datum = $data->[$i];
825
826 my %row;
827 @row{ @$cols } = @$datum;
828
829 my %blob_vals;
830 for my $j (0..$#$cols) {
831 if (exists $blob_cols->[$i][$j]) {
832 $blob_vals{ $cols->[$j] } = $blob_cols->[$i][$j];
833 }
834 }
835
836 $self->_insert_blobs ($source, \%blob_vals, \%row);
837 }
838}
839
d867eeda 840=head2 connect_call_datetime_setup
841
842Used as:
843
844 on_connect_call => 'datetime_setup'
845
846In L<DBIx::Class::Storage::DBI/connect_info> to set:
847
848 $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
849 $dbh->do('set dateformat mdy'); # input fmt: 08/13/1979 18:08:55.080
850
851On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
852L<DateTime::Format::Sybase>, which you will need to install.
853
854This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
855C<SMALLDATETIME> columns only have minute precision.
856
857=cut
858
859{
860 my $old_dbd_warned = 0;
861
862 sub connect_call_datetime_setup {
863 my $self = shift;
9a6a7fdb 864 my $dbh = $self->_get_dbh;
d867eeda 865
866 if ($dbh->can('syb_date_fmt')) {
867 # amazingly, this works with FreeTDS
868 $dbh->syb_date_fmt('ISO_strict');
869 } elsif (not $old_dbd_warned) {
870 carp "Your DBD::Sybase is too old to support ".
871 "DBIx::Class::InflateColumn::DateTime, please upgrade!";
872 $old_dbd_warned = 1;
47d9646a 873 }
d867eeda 874
875 $dbh->do('SET DATEFORMAT mdy');
876
877 1;
878 }
879}
880
881sub datetime_parser_type { "DateTime::Format::Sybase" }
882
883# ->begin_work and such have no effect with FreeTDS but we run them anyway to
884# let the DBD keep any state it needs to.
885#
886# If they ever do start working, the extra statements will do no harm (because
887# Sybase supports nested transactions.)
888
889sub _dbh_begin_work {
890 my $self = shift;
0a9a9955 891
892# bulkLogin=1 connections are always in a transaction, and can only call BEGIN
893# TRAN once. However, we need to make sure there's a $dbh.
894 return if $self->_is_bulk_storage && $self->_dbh && $self->_began_bulk_work;
895
d867eeda 896 $self->next::method(@_);
0a9a9955 897
d867eeda 898 if ($self->using_freetds) {
899 $self->_get_dbh->do('BEGIN TRAN');
900 }
0a9a9955 901
902 $self->_began_bulk_work(1) if $self->_is_bulk_storage;
47d9646a 903}
904
d867eeda 905sub _dbh_commit {
906 my $self = shift;
907 if ($self->using_freetds) {
908 $self->_dbh->do('COMMIT');
909 }
910 return $self->next::method(@_);
911}
912
913sub _dbh_rollback {
914 my $self = shift;
915 if ($self->using_freetds) {
916 $self->_dbh->do('ROLLBACK');
917 }
918 return $self->next::method(@_);
919}
920
921# savepoint support using ASE syntax
922
923sub _svp_begin {
924 my ($self, $name) = @_;
925
926 $self->_get_dbh->do("SAVE TRANSACTION $name");
927}
928
929# A new SAVE TRANSACTION with the same name releases the previous one.
930sub _svp_release { 1 }
931
932sub _svp_rollback {
933 my ($self, $name) = @_;
934
935 $self->_get_dbh->do("ROLLBACK TRANSACTION $name");
a964a928 936}
937
f68f4d44 9381;
939
d867eeda 940=head1 Schema::Loader Support
f68f4d44 941
d867eeda 942There is an experimental branch of L<DBIx::Class::Schema::Loader> that will
943allow you to dump a schema from most (if not all) versions of Sybase.
f68f4d44 944
d867eeda 945It is available via subversion from:
946
947 http://dev.catalyst.perl.org/repos/bast/branches/DBIx-Class-Schema-Loader/current/
948
949=head1 FreeTDS
950
951This driver supports L<DBD::Sybase> compiled against FreeTDS
952(L<http://www.freetds.org/>) to the best of our ability, however it is
953recommended that you recompile L<DBD::Sybase> against the Sybase Open Client
954libraries. They are a part of the Sybase ASE distribution:
955
956The Open Client FAQ is here:
957L<http://www.isug.com/Sybase_FAQ/ASE/section7.html>.
958
959Sybase ASE for Linux (which comes with the Open Client libraries) may be
960downloaded here: L<http://response.sybase.com/forms/ASE_Linux_Download>.
961
962To see if you're using FreeTDS check C<< $schema->storage->using_freetds >>, or run:
963
964 perl -MDBI -le 'my $dbh = DBI->connect($dsn, $user, $pass); print $dbh->{syb_oc_version}'
965
966Some versions of the libraries involved will not support placeholders, in which
967case the storage will be reblessed to
968L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>.
969
970In some configurations, placeholders will work but will throw implicit type
971conversion errors for anything that's not expecting a string. In such a case,
972the C<auto_cast> option from L<DBIx::Class::Storage::DBI::AutoCast> is
973automatically set, which you may enable on connection with
974L<DBIx::Class::Storage::DBI::AutoCast/connect_call_set_auto_cast>. The type info
975for the C<CAST>s is taken from the L<DBIx::Class::ResultSource/data_type>
976definitions in your Result classes, and are mapped to a Sybase type (if it isn't
977already) using a mapping based on L<SQL::Translator>.
978
979In other configurations, placeholers will work just as they do with the Sybase
980Open Client libraries.
981
982Inserts or updates of TEXT/IMAGE columns will B<NOT> work with FreeTDS.
983
984=head1 INSERTS WITH PLACEHOLDERS
985
986With placeholders enabled, inserts are done in a transaction so that there are
987no concurrency issues with getting the inserted identity value using
988C<SELECT MAX(col)>, which is the only way to get the C<IDENTITY> value in this
989mode.
990
991In addition, they are done on a separate connection so that it's possible to
992have active cursors when doing an insert.
993
994When using C<DBIx::Class::Storage::DBI::Sybase::NoBindVars> transactions are
995disabled, as there are no concurrency issues with C<SELECT @@IDENTITY> as it's a
996session variable.
997
998=head1 TRANSACTIONS
999
1000Due to limitations of the TDS protocol, L<DBD::Sybase>, or both; you cannot
d390bd3c 1001begin a transaction while there are active cursors; nor can you use multiple
1002active cursors within a transaction. An active cursor is, for example, a
1003L<ResultSet|DBIx::Class::ResultSet> that has been executed using C<next> or
1004C<first> but has not been exhausted or L<reset|DBIx::Class::ResultSet/reset>.
d867eeda 1005
1006For example, this will not work:
1007
1008 $schema->txn_do(sub {
1009 my $rs = $schema->resultset('Book');
1010 while (my $row = $rs->next) {
1011 $schema->resultset('MetaData')->create({
1012 book_id => $row->id,
1013 ...
1014 });
1015 }
1016 });
1017
d390bd3c 1018This won't either:
1019
1020 my $first_row = $large_rs->first;
1021 $schema->txn_do(sub { ... });
1022
d867eeda 1023Transactions done for inserts in C<AutoCommit> mode when placeholders are in use
1024are not affected, as they are done on an extra database handle.
1025
1026Some workarounds:
1027
1028=over 4
1029
1030=item * use L<DBIx::Class::Storage::DBI::Replicated>
1031
1032=item * L<connect|DBIx::Class::Schema/connect> another L<Schema|DBIx::Class::Schema>
1033
1034=item * load the data from your cursor with L<DBIx::Class::ResultSet/all>
1035
1036=back
1037
1038=head1 MAXIMUM CONNECTIONS
1039
1040The TDS protocol makes separate connections to the server for active statements
1041in the background. By default the number of such connections is limited to 25,
1042on both the client side and the server side.
1043
1044This is a bit too low for a complex L<DBIx::Class> application, so on connection
1045the client side setting is set to C<256> (see L<DBD::Sybase/maxConnect>.) You
1046can override it to whatever setting you like in the DSN.
1047
1048See
1049L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
1050for information on changing the setting on the server side.
1051
1052=head1 DATES
1053
1054See L</connect_call_datetime_setup> to setup date formats
1055for L<DBIx::Class::InflateColumn::DateTime>.
1056
1057=head1 TEXT/IMAGE COLUMNS
1058
1059L<DBD::Sybase> compiled with FreeTDS will B<NOT> allow you to insert or update
1060C<TEXT/IMAGE> columns.
1061
1062Setting C<< $dbh->{LongReadLen} >> will also not work with FreeTDS use either:
1063
1064 $schema->storage->dbh->do("SET TEXTSIZE $bytes");
f68f4d44 1065
d867eeda 1066or
f68f4d44 1067
d867eeda 1068 $schema->storage->set_textsize($bytes);
d4483998 1069
d867eeda 1070instead.
d4483998 1071
d867eeda 1072However, the C<LongReadLen> you pass in
1073L<DBIx::Class::Storage::DBI/connect_info> is used to execute the equivalent
1074C<SET TEXTSIZE> command on connection.
d4483998 1075
d867eeda 1076See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
1077setting you need to work with C<IMAGE> columns.
f68f4d44 1078
0a9a9955 1079=head1 BULK API
1080
1081The experimental L<DBD::Sybase> Bulk API support is used for
1082L<populate|DBIx::Class::ResultSet/populate> in B<void> context, in a transaction
1083on a separate connection.
1084
1085To use this feature effectively, use a large number of rows for each
1086L<populate|DBIx::Class::ResultSet/populate> call, eg.:
1087
1088 while (my $rows = $data_source->get_100_rows()) {
1089 $rs->populate($rows);
1090 }
1091
1092B<NOTE:> the L<add_columns|DBIx::Class::ResultSource/add_columns>
1093calls in your C<Result> classes B<must> list columns in database order for this
1094to work. Also, you may have to unset the C<LANG> environment variable before
1095loading your app, if it doesn't match the character set of your database.
1096
1097When inserting IMAGE columns using this method, you'll need to use
1098L</connect_call_blob_setup> as well.
1099
6a9765c1 1100=head1 TODO
1101
1102=over
1103
1104=item *
1105
1106Transitions to AutoCommit=0 (starting a transaction) mode by exhausting
1107any active cursors, using eager cursors.
1108
1109=item *
1110
1111Real limits and limited counts using stored procedures deployed on startup.
1112
1113=item *
1114
1115Adaptive Server Anywhere (ASA) support, with possible SQLA::Limit support.
1116
1117=item *
1118
1119Blob update with a LIKE query on a blob, without invalidating the WHERE condition.
1120
1121=item *
1122
1123bulk_insert using prepare_cached (see comments.)
1124
1125=back
1126
d867eeda 1127=head1 AUTHOR
f68f4d44 1128
d867eeda 1129See L<DBIx::Class/CONTRIBUTORS>.
47d9646a 1130
f68f4d44 1131=head1 LICENSE
1132
1133You may distribute this code under the same terms as Perl itself.
1134
1135=cut
d867eeda 1136# vim:sts=2 sw=2: