clean up set_identity stuff
[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
256 if ($op eq 'insert') {
257 my $table = $ident->from;
258
259 my $bind_info = $self->_resolve_column_info(
260 $ident, [map $_->[0], @{$bind}]
261 );
262 my $identity_col = List::Util::first
263 { $bind_info->{$_}{is_auto_increment} }
264 (keys %$bind_info)
265 ;
266
267 if ($identity_col) {
268 $sql = join ("\n",
269 "SET IDENTITY_INSERT $table ON",
270 $sql,
271 "SET IDENTITY_INSERT $table OFF",
272 );
273 }
274 else {
275 $identity_col = List::Util::first
276 { $ident->column_info($_)->{is_auto_increment} }
277 $ident->columns
278 ;
279 }
280
281 if ($identity_col) {
282 $sql =
283 "$sql\n" .
284 $self->_fetch_identity_sql($ident, $identity_col);
285 }
286 }
287
288 return ($sql, $bind);
289}
290
291# Stolen from SQLT, with some modifications. This is a makeshift
292# solution before a sane type-mapping library is available, thus
293# the 'our' for easy overrides.
294our %TYPE_MAPPING = (
295 number => 'numeric',
296 money => 'money',
297 varchar => 'varchar',
298 varchar2 => 'varchar',
299 timestamp => 'datetime',
300 text => 'varchar',
301 real => 'double precision',
302 comment => 'text',
303 bit => 'bit',
304 tinyint => 'smallint',
305 float => 'double precision',
306 serial => 'numeric',
307 bigserial => 'numeric',
308 boolean => 'varchar',
309 long => 'varchar',
310);
311
312sub _native_data_type {
313 my ($self, $type) = @_;
314
315 $type = lc $type;
316 $type =~ s/\s* identity//x;
317
318 return uc($TYPE_MAPPING{$type} || $type);
319}
320
321sub _fetch_identity_sql {
322 my ($self, $source, $col) = @_;
323
324 return sprintf ("SELECT MAX(%s) FROM %s",
325 map { $self->sql_maker->_quote ($_) } ($col, $source->from)
326 );
327}
328
329sub _execute {
330 my $self = shift;
331 my ($op) = @_;
332
333 my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
334
335 if ($op eq 'insert') {
336 $self->_identity($sth->fetchrow_array);
337 $sth->finish;
338 }
339
340 return wantarray ? ($rv, $sth, @bind) : $rv;
341}
342
343sub last_insert_id { shift->_identity }
344
345# handles TEXT/IMAGE and transaction for last_insert_id
346sub insert {
347 my $self = shift;
348 my ($source, $to_insert) = @_;
349
350 my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
351
352 my $identity_col = List::Util::first
353 { $source->column_info($_)->{is_auto_increment} }
354 $source->columns;
355
356 # do we need the horrific SELECT MAX(COL) hack?
357 my $dumb_last_insert_id =
358 $identity_col
359 && (not exists $to_insert->{$identity_col})
360 && ($self->_identity_method||'') ne '@@IDENTITY';
361
362 my $next = $self->next::can;
363
364 # we are already in a transaction, or there are no blobs
365 # and we don't need the PK - just (try to) do it
366 if ($self->{transaction_depth}
367 || (!$blob_cols && !$dumb_last_insert_id)
368 ) {
369 return $self->_insert (
370 $next, $source, $to_insert, $blob_cols, $identity_col
371 );
372 }
373
374 # otherwise use the _writer_storage to do the insert+transaction on another
375 # connection
376 my $guard = $self->_writer_storage->txn_scope_guard;
377
378 my $updated_cols = $self->_writer_storage->_insert (
379 $next, $source, $to_insert, $blob_cols, $identity_col
380 );
381
382 $self->_identity($self->_writer_storage->_identity);
383
384 $guard->commit;
385
386 return $updated_cols;
387}
388
389sub _insert {
390 my ($self, $next, $source, $to_insert, $blob_cols, $identity_col) = @_;
391
392 my $updated_cols = $self->$next ($source, $to_insert);
393
394 my $final_row = {
395 $identity_col => $self->last_insert_id($source, $identity_col),
396 %$to_insert,
397 %$updated_cols,
398 };
399
400 $self->_insert_blobs ($source, $blob_cols, $final_row) if $blob_cols;
401
402 return $updated_cols;
403}
404
405sub update {
406 my $self = shift;
2baff5da 407 my ($source, $fields, $where, @rest) = @_;
d867eeda 408
409 my $wantarray = wantarray;
2baff5da 410
d867eeda 411 my $blob_cols = $self->_remove_blob_cols($source, $fields);
412
2baff5da 413 my $table = $source->name;
414
415 my $identity_col = List::Util::first
416 { $source->column_info($_)->{is_auto_increment} }
417 $source->columns;
418
419 my $is_identity_update = $identity_col && defined $fields->{$identity_col};
420
d867eeda 421 if (not $blob_cols) {
a4b33e7f 422 $self->_set_session_identity(UPDATE => $table, 'ON')
423 if $is_identity_update;
424
d867eeda 425 return $self->next::method(@_);
a4b33e7f 426
427 $self->_set_session_identity(UPDATE => $table, 'OFF')
428 if $is_identity_update;
2baff5da 429 }
430
431# check that we're not updating a blob column that's also in $where
432 for my $blob (grep $self->_is_lob_column($source, $_), $source->columns) {
433 if (exists $where->{$blob} && exists $fields->{$blob}) {
434 croak
435'Update of TEXT/IMAGE column that is also in search condition impossible';
436 }
d867eeda 437 }
438
439# update+blob update(s) done atomically on separate connection
440 $self = $self->_writer_storage;
441
442 my $guard = $self->txn_scope_guard;
443
2baff5da 444# First update the blob columns to be updated to '' (taken from $fields, where
445# it is originally put by _remove_blob_cols .)
446 my %blobs_to_empty = map { ($_ => delete $fields->{$_}) } keys %$blob_cols;
d867eeda 447
2baff5da 448 $self->next::method($source, \%blobs_to_empty, $where, @rest);
e19677ad 449
2baff5da 450# Now update the blobs before the other columns in case the update of other
451# columns makes the search condition invalid.
d867eeda 452 $self->_update_blobs($source, $blob_cols, $where);
453
2baff5da 454 my @res;
455 if (%$fields) {
a4b33e7f 456 $self->_set_session_identity(UPDATE => $table, 'ON')
457 if $is_identity_update;
2baff5da 458
459 if ($wantarray) {
460 @res = $self->next::method(@_);
461 }
462 elsif (defined $wantarray) {
463 $res[0] = $self->next::method(@_);
464 }
465 else {
466 $self->next::method(@_);
467 }
468
a4b33e7f 469 $self->_set_session_identity(UPDATE => $table, 'OFF')
470 if $is_identity_update;
2baff5da 471 }
472
d867eeda 473 $guard->commit;
474
475 return $wantarray ? @res : $res[0];
476}
477
a4b33e7f 478sub _set_session_identity {
479 my ($self, $op, $table, $off_on) = @_;
d867eeda 480
481 my $sql = sprintf (
a4b33e7f 482 'SET IDENTITY_%s %s %s',
483 uc $op,
484 $self->sql_maker->_quote($table),
485 uc $off_on,
d867eeda 486 );
487
2baff5da 488 $self->_query_start($sql);
489
d867eeda 490 my $dbh = $self->_get_dbh;
a4b33e7f 491 eval {
492 local $dbh->{RaiseError} = 1;
493 local $dbh->{PrintError} = 0;
494 $dbh->do ($sql)
495 };
2baff5da 496 my $exception = $@;
497
498 $self->_query_end($sql);
499
500 if ($exception) {
d867eeda 501 $self->throw_exception (sprintf "Error executing '%s': %s",
502 $sql,
a4b33e7f 503 $exception,
d867eeda 504 );
505 }
506}
507
2baff5da 508# for tests
509sub _can_insert_bulk { 1 }
510
d867eeda 511sub insert_bulk {
512 my $self = shift;
513 my ($source, $cols, $data) = @_;
514
0a9a9955 515 my $identity_col = List::Util::first
516 { $source->column_info($_)->{is_auto_increment} }
517 $source->columns;
518
d867eeda 519 my $is_identity_insert = (List::Util::first
0a9a9955 520 { $source->column_info ($_)->{is_auto_increment} }
521 @{$cols}
522 ) ? 1 : 0;
523
524 my @source_columns = $source->columns;
525
526 my $use_bulk_api =
527 $self->_bulk_storage &&
528 $self->_get_dbh->{syb_has_blk};
529
530 if ((not $use_bulk_api) &&
531 (Scalar::Util::reftype($self->_dbi_connect_info->[0])||'') eq 'CODE' &&
532 (not $self->_bulk_disabled_due_to_coderef_connect_info_warned)) {
533 carp <<'EOF';
534Bulk API support disabled due to use of a CODEREF connect_info. Reverting to
535array inserts.
536EOF
537 $self->_bulk_disabled_due_to_coderef_connect_info_warned(1);
d867eeda 538 }
539
0a9a9955 540 if (not $use_bulk_api) {
541 my $blob_cols = $self->_remove_blob_cols_array($source, $cols, $data);
542
543 my $dumb_last_insert_id =
544 $identity_col
545 && (not $is_identity_insert)
546 && ($self->_identity_method||'') ne '@@IDENTITY';
547
548 ($self, my ($guard)) = do {
549 if ($self->{transaction_depth} == 0 &&
550 ($blob_cols || $dumb_last_insert_id)) {
551 ($self->_writer_storage, $self->_writer_storage->txn_scope_guard);
552 }
553 else {
554 ($self, undef);
555 }
556 };
557
0a9a9955 558 $self->next::method(@_);
0a9a9955 559
560 if ($blob_cols) {
561 if ($is_identity_insert) {
562 $self->_insert_blobs_array ($source, $blob_cols, $cols, $data);
563 }
564 else {
565 my @cols_with_identities = (@$cols, $identity_col);
566
567 ## calculate identities
568 # XXX This assumes identities always increase by 1, which may or may not
569 # be true.
570 my ($last_identity) =
571 $self->_dbh->selectrow_array (
572 $self->_fetch_identity_sql($source, $identity_col)
573 );
574 my @identities = (($last_identity - @$data + 1) .. $last_identity);
575
576 my @data_with_identities = map [@$_, shift @identities], @$data;
577
578 $self->_insert_blobs_array (
579 $source, $blob_cols, \@cols_with_identities, \@data_with_identities
580 );
581 }
582 }
d867eeda 583
0a9a9955 584 $guard->commit if $guard;
585 return;
d867eeda 586 }
d867eeda 587
0a9a9955 588# otherwise, use the bulk API
589
590# rearrange @$data so that columns are in database order
591 my %orig_idx;
592 @orig_idx{@$cols} = 0..$#$cols;
593
594 my %new_idx;
595 @new_idx{@source_columns} = 0..$#source_columns;
596
597 my @new_data;
598 for my $datum (@$data) {
599 my $new_datum = [];
600 for my $col (@source_columns) {
601# identity data will be 'undef' if not $is_identity_insert
602# columns with defaults will also be 'undef'
603 $new_datum->[ $new_idx{$col} ] =
604 exists $orig_idx{$col} ? $datum->[ $orig_idx{$col} ] : undef;
605 }
606 push @new_data, $new_datum;
607 }
608
609# bcp identity index is 1-based
610 my $identity_idx = exists $new_idx{$identity_col} ?
611 $new_idx{$identity_col} + 1 : 0;
612
613## Set a client-side conversion error handler, straight from DBD::Sybase docs.
614# This ignores any data conversion errors detected by the client side libs, as
615# they are usually harmless.
616 my $orig_cslib_cb = DBD::Sybase::set_cslib_cb(
617 Sub::Name::subname insert_bulk => sub {
618 my ($layer, $origin, $severity, $errno, $errmsg, $osmsg, $blkmsg) = @_;
619
620 return 1 if $errno == 36;
621
622 carp
623 "Layer: $layer, Origin: $origin, Severity: $severity, Error: $errno" .
624 ($errmsg ? "\n$errmsg" : '') .
625 ($osmsg ? "\n$osmsg" : '') .
626 ($blkmsg ? "\n$blkmsg" : '');
627
628 return 0;
629 });
630
631 eval {
632 my $bulk = $self->_bulk_storage;
633
634 my $guard = $bulk->txn_scope_guard;
635
636## XXX get this to work instead of our own $sth
637## will require SQLA or *Hacks changes for ordered columns
638# $bulk->next::method($source, \@source_columns, \@new_data, {
639# syb_bcp_attribs => {
640# identity_flag => $is_identity_insert,
641# identity_column => $identity_idx,
642# }
643# });
644 my $sql = 'INSERT INTO ' .
645 $bulk->sql_maker->_quote($source->name) . ' (' .
646# colname list is ignored for BCP, but does no harm
647 (join ', ', map $bulk->sql_maker->_quote($_), @source_columns) . ') '.
648 ' VALUES ('. (join ', ', ('?') x @source_columns) . ')';
649
650## XXX there's a bug in the DBD::Sybase bulk support that makes $sth->finish for
651## a prepare_cached statement ineffective. Replace with ->sth when fixed, or
652## better yet the version above. Should be fixed in DBD::Sybase .
653 my $sth = $bulk->_get_dbh->prepare($sql,
654# 'insert', # op
655 {
656 syb_bcp_attribs => {
657 identity_flag => $is_identity_insert,
658 identity_column => $identity_idx,
659 }
660 }
661 );
662
663 my $bind_attributes = $self->source_bind_attributes($source);
664
665 foreach my $slice_idx (0..$#source_columns) {
666 my $col = $source_columns[$slice_idx];
667
668 my $attributes = $bind_attributes->{$col}
669 if $bind_attributes && defined $bind_attributes->{$col};
670
671 my @slice = map $_->[$slice_idx], @new_data;
672
673 $sth->bind_param_array(($slice_idx + 1), \@slice, $attributes);
674 }
675
676 $bulk->_query_start($sql);
677
678# this is stolen from DBI::insert_bulk
679 my $tuple_status = [];
680 my $rv = eval { $sth->execute_array({ArrayTupleStatus => $tuple_status}) };
681
682 if (my $err = $@ || $sth->errstr) {
683 my $i = 0;
684 ++$i while $i <= $#$tuple_status && !ref $tuple_status->[$i];
685
686 $self->throw_exception("Unexpected populate error: $err")
687 if ($i > $#$tuple_status);
688
689 $self->throw_exception(sprintf "%s for populate slice:\n%s",
690 ($tuple_status->[$i][1] || $err),
691 $self->_pretty_print ({
692 map { $source_columns[$_] => $new_data[$i][$_] } (0 .. $#$cols)
693 }),
694 );
695 }
696
697 $guard->commit;
698 $sth->finish;
699
700 $bulk->_query_end($sql);
701 };
702 my $exception = $@;
703 if ($exception =~ /-Y option/) {
704 carp <<"EOF";
705
706Sybase bulk API operation failed due to character set incompatibility, reverting
707to regular array inserts:
708
709*** Try unsetting the LANG environment variable.
710
711$@
712EOF
713 $self->_bulk_storage(undef);
714 DBD::Sybase::set_cslib_cb($orig_cslib_cb);
715 unshift @_, $self;
716 goto \&insert_bulk;
717 }
718 elsif ($exception) {
719 DBD::Sybase::set_cslib_cb($orig_cslib_cb);
720# rollback makes the bulkLogin connection unusable
721 $self->_bulk_storage->disconnect;
722 $self->throw_exception($exception);
723 }
724
725 DBD::Sybase::set_cslib_cb($orig_cslib_cb);
726}
d867eeda 727
2baff5da 728# Make sure blobs are not bound as placeholders, and return any non-empty ones
729# as a hash.
d867eeda 730sub _remove_blob_cols {
731 my ($self, $source, $fields) = @_;
732
733 my %blob_cols;
734
735 for my $col (keys %$fields) {
736 if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
2baff5da 737 my $blob_val = delete $fields->{$col};
738 if (not defined $blob_val) {
739 $fields->{$col} = \'NULL';
740 }
741 else {
742 $fields->{$col} = \"''";
743 $blob_cols{$col} = $blob_val unless $blob_val eq '';
744 }
d867eeda 745 }
746 }
747
748 return keys %blob_cols ? \%blob_cols : undef;
749}
750
0a9a9955 751# same for insert_bulk
752sub _remove_blob_cols_array {
753 my ($self, $source, $cols, $data) = @_;
754
755 my @blob_cols;
756
757 for my $i (0..$#$cols) {
758 my $col = $cols->[$i];
759
760 if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
761 for my $j (0..$#$data) {
762 my $blob_val = delete $data->[$j][$i];
763 if (not defined $blob_val) {
764 $data->[$j][$i] = \'NULL';
765 }
766 else {
767 $data->[$j][$i] = \"''";
768 $blob_cols[$j][$i] = $blob_val
769 unless $blob_val eq '';
770 }
771 }
772 }
773 }
774
775 return @blob_cols ? \@blob_cols : undef;
776}
777
d867eeda 778sub _update_blobs {
779 my ($self, $source, $blob_cols, $where) = @_;
780
781 my (@primary_cols) = $source->primary_columns;
782
783 $self->throw_exception('Cannot update TEXT/IMAGE column(s) without a primary key')
784 unless @primary_cols;
785
786# check if we're updating a single row by PK
787 my $pk_cols_in_where = 0;
788 for my $col (@primary_cols) {
789 $pk_cols_in_where++ if defined $where->{$col};
790 }
791 my @rows;
792
793 if ($pk_cols_in_where == @primary_cols) {
794 my %row_to_update;
795 @row_to_update{@primary_cols} = @{$where}{@primary_cols};
796 @rows = \%row_to_update;
797 } else {
798 my $cursor = $self->select ($source, \@primary_cols, $where, {});
799 @rows = map {
800 my %row; @row{@primary_cols} = @$_; \%row
801 } $cursor->all;
802 }
803
804 for my $row (@rows) {
805 $self->_insert_blobs($source, $blob_cols, $row);
806 }
807}
808
809sub _insert_blobs {
810 my ($self, $source, $blob_cols, $row) = @_;
811 my $dbh = $self->_get_dbh;
812
2baff5da 813 my $table = $source->name;
d867eeda 814
815 my %row = %$row;
816 my (@primary_cols) = $source->primary_columns;
817
818 $self->throw_exception('Cannot update TEXT/IMAGE column(s) without a primary key')
819 unless @primary_cols;
820
821 $self->throw_exception('Cannot update TEXT/IMAGE column(s) without primary key values')
822 if ((grep { defined $row{$_} } @primary_cols) != @primary_cols);
823
824 for my $col (keys %$blob_cols) {
825 my $blob = $blob_cols->{$col};
826
827 my %where = map { ($_, $row{$_}) } @primary_cols;
828
829 my $cursor = $self->select ($source, [$col], \%where, {});
830 $cursor->next;
831 my $sth = $cursor->sth;
832
2baff5da 833 if (not $sth) {
b561bb6f 834
835 $self->throw_exception(
836 "Could not find row in table '$table' for blob update:\n"
837 . $self->_pretty_print (\%where)
838 );
2baff5da 839 }
840
d867eeda 841 eval {
842 do {
843 $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
844 } while $sth->fetch;
845
846 $sth->func('ct_prepare_send') or die $sth->errstr;
847
848 my $log_on_update = $self->_blob_log_on_update;
849 $log_on_update = 1 if not defined $log_on_update;
850
851 $sth->func('CS_SET', 1, {
852 total_txtlen => length($blob),
853 log_on_update => $log_on_update
854 }, 'ct_data_info') or die $sth->errstr;
855
856 $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
857
858 $sth->func('ct_finish_send') or die $sth->errstr;
859 };
860 my $exception = $@;
861 $sth->finish if $sth;
862 if ($exception) {
863 if ($self->using_freetds) {
864 $self->throw_exception (
865 'TEXT/IMAGE operation failed, probably because you are using FreeTDS: '
866 . $exception
867 );
868 } else {
869 $self->throw_exception($exception);
870 }
871 }
872 }
873}
874
0a9a9955 875sub _insert_blobs_array {
876 my ($self, $source, $blob_cols, $cols, $data) = @_;
877
878 for my $i (0..$#$data) {
879 my $datum = $data->[$i];
880
881 my %row;
882 @row{ @$cols } = @$datum;
883
884 my %blob_vals;
885 for my $j (0..$#$cols) {
886 if (exists $blob_cols->[$i][$j]) {
887 $blob_vals{ $cols->[$j] } = $blob_cols->[$i][$j];
888 }
889 }
890
891 $self->_insert_blobs ($source, \%blob_vals, \%row);
892 }
893}
894
d867eeda 895=head2 connect_call_datetime_setup
896
897Used as:
898
899 on_connect_call => 'datetime_setup'
900
901In L<DBIx::Class::Storage::DBI/connect_info> to set:
902
903 $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
904 $dbh->do('set dateformat mdy'); # input fmt: 08/13/1979 18:08:55.080
905
906On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
907L<DateTime::Format::Sybase>, which you will need to install.
908
909This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
910C<SMALLDATETIME> columns only have minute precision.
911
912=cut
913
914{
915 my $old_dbd_warned = 0;
916
917 sub connect_call_datetime_setup {
918 my $self = shift;
919 my $dbh = $self->_dbh;
920
921 if ($dbh->can('syb_date_fmt')) {
922 # amazingly, this works with FreeTDS
923 $dbh->syb_date_fmt('ISO_strict');
924 } elsif (not $old_dbd_warned) {
925 carp "Your DBD::Sybase is too old to support ".
926 "DBIx::Class::InflateColumn::DateTime, please upgrade!";
927 $old_dbd_warned = 1;
47d9646a 928 }
d867eeda 929
930 $dbh->do('SET DATEFORMAT mdy');
931
932 1;
933 }
934}
935
936sub datetime_parser_type { "DateTime::Format::Sybase" }
937
938# ->begin_work and such have no effect with FreeTDS but we run them anyway to
939# let the DBD keep any state it needs to.
940#
941# If they ever do start working, the extra statements will do no harm (because
942# Sybase supports nested transactions.)
943
944sub _dbh_begin_work {
945 my $self = shift;
0a9a9955 946
947# bulkLogin=1 connections are always in a transaction, and can only call BEGIN
948# TRAN once. However, we need to make sure there's a $dbh.
949 return if $self->_is_bulk_storage && $self->_dbh && $self->_began_bulk_work;
950
d867eeda 951 $self->next::method(@_);
0a9a9955 952
d867eeda 953 if ($self->using_freetds) {
954 $self->_get_dbh->do('BEGIN TRAN');
955 }
0a9a9955 956
957 $self->_began_bulk_work(1) if $self->_is_bulk_storage;
47d9646a 958}
959
d867eeda 960sub _dbh_commit {
961 my $self = shift;
962 if ($self->using_freetds) {
963 $self->_dbh->do('COMMIT');
964 }
965 return $self->next::method(@_);
966}
967
968sub _dbh_rollback {
969 my $self = shift;
970 if ($self->using_freetds) {
971 $self->_dbh->do('ROLLBACK');
972 }
973 return $self->next::method(@_);
974}
975
976# savepoint support using ASE syntax
977
978sub _svp_begin {
979 my ($self, $name) = @_;
980
981 $self->_get_dbh->do("SAVE TRANSACTION $name");
982}
983
984# A new SAVE TRANSACTION with the same name releases the previous one.
985sub _svp_release { 1 }
986
987sub _svp_rollback {
988 my ($self, $name) = @_;
989
990 $self->_get_dbh->do("ROLLBACK TRANSACTION $name");
a964a928 991}
992
f68f4d44 9931;
994
d867eeda 995=head1 Schema::Loader Support
f68f4d44 996
d867eeda 997There is an experimental branch of L<DBIx::Class::Schema::Loader> that will
998allow you to dump a schema from most (if not all) versions of Sybase.
f68f4d44 999
d867eeda 1000It is available via subversion from:
1001
1002 http://dev.catalyst.perl.org/repos/bast/branches/DBIx-Class-Schema-Loader/current/
1003
1004=head1 FreeTDS
1005
1006This driver supports L<DBD::Sybase> compiled against FreeTDS
1007(L<http://www.freetds.org/>) to the best of our ability, however it is
1008recommended that you recompile L<DBD::Sybase> against the Sybase Open Client
1009libraries. They are a part of the Sybase ASE distribution:
1010
1011The Open Client FAQ is here:
1012L<http://www.isug.com/Sybase_FAQ/ASE/section7.html>.
1013
1014Sybase ASE for Linux (which comes with the Open Client libraries) may be
1015downloaded here: L<http://response.sybase.com/forms/ASE_Linux_Download>.
1016
1017To see if you're using FreeTDS check C<< $schema->storage->using_freetds >>, or run:
1018
1019 perl -MDBI -le 'my $dbh = DBI->connect($dsn, $user, $pass); print $dbh->{syb_oc_version}'
1020
1021Some versions of the libraries involved will not support placeholders, in which
1022case the storage will be reblessed to
1023L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>.
1024
1025In some configurations, placeholders will work but will throw implicit type
1026conversion errors for anything that's not expecting a string. In such a case,
1027the C<auto_cast> option from L<DBIx::Class::Storage::DBI::AutoCast> is
1028automatically set, which you may enable on connection with
1029L<DBIx::Class::Storage::DBI::AutoCast/connect_call_set_auto_cast>. The type info
1030for the C<CAST>s is taken from the L<DBIx::Class::ResultSource/data_type>
1031definitions in your Result classes, and are mapped to a Sybase type (if it isn't
1032already) using a mapping based on L<SQL::Translator>.
1033
1034In other configurations, placeholers will work just as they do with the Sybase
1035Open Client libraries.
1036
1037Inserts or updates of TEXT/IMAGE columns will B<NOT> work with FreeTDS.
1038
1039=head1 INSERTS WITH PLACEHOLDERS
1040
1041With placeholders enabled, inserts are done in a transaction so that there are
1042no concurrency issues with getting the inserted identity value using
1043C<SELECT MAX(col)>, which is the only way to get the C<IDENTITY> value in this
1044mode.
1045
1046In addition, they are done on a separate connection so that it's possible to
1047have active cursors when doing an insert.
1048
1049When using C<DBIx::Class::Storage::DBI::Sybase::NoBindVars> transactions are
1050disabled, as there are no concurrency issues with C<SELECT @@IDENTITY> as it's a
1051session variable.
1052
1053=head1 TRANSACTIONS
1054
1055Due to limitations of the TDS protocol, L<DBD::Sybase>, or both; you cannot
1056begin a transaction while there are active cursors. An active cursor is, for
1057example, a L<ResultSet|DBIx::Class::ResultSet> that has been executed using
1058C<next> or C<first> but has not been exhausted or
1059L<reset|DBIx::Class::ResultSet/reset>.
1060
1061For example, this will not work:
1062
1063 $schema->txn_do(sub {
1064 my $rs = $schema->resultset('Book');
1065 while (my $row = $rs->next) {
1066 $schema->resultset('MetaData')->create({
1067 book_id => $row->id,
1068 ...
1069 });
1070 }
1071 });
1072
1073Transactions done for inserts in C<AutoCommit> mode when placeholders are in use
1074are not affected, as they are done on an extra database handle.
1075
1076Some workarounds:
1077
1078=over 4
1079
1080=item * use L<DBIx::Class::Storage::DBI::Replicated>
1081
1082=item * L<connect|DBIx::Class::Schema/connect> another L<Schema|DBIx::Class::Schema>
1083
1084=item * load the data from your cursor with L<DBIx::Class::ResultSet/all>
1085
1086=back
1087
1088=head1 MAXIMUM CONNECTIONS
1089
1090The TDS protocol makes separate connections to the server for active statements
1091in the background. By default the number of such connections is limited to 25,
1092on both the client side and the server side.
1093
1094This is a bit too low for a complex L<DBIx::Class> application, so on connection
1095the client side setting is set to C<256> (see L<DBD::Sybase/maxConnect>.) You
1096can override it to whatever setting you like in the DSN.
1097
1098See
1099L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
1100for information on changing the setting on the server side.
1101
1102=head1 DATES
1103
1104See L</connect_call_datetime_setup> to setup date formats
1105for L<DBIx::Class::InflateColumn::DateTime>.
1106
1107=head1 TEXT/IMAGE COLUMNS
1108
1109L<DBD::Sybase> compiled with FreeTDS will B<NOT> allow you to insert or update
1110C<TEXT/IMAGE> columns.
1111
1112Setting C<< $dbh->{LongReadLen} >> will also not work with FreeTDS use either:
1113
1114 $schema->storage->dbh->do("SET TEXTSIZE $bytes");
f68f4d44 1115
d867eeda 1116or
f68f4d44 1117
d867eeda 1118 $schema->storage->set_textsize($bytes);
d4483998 1119
d867eeda 1120instead.
d4483998 1121
d867eeda 1122However, the C<LongReadLen> you pass in
1123L<DBIx::Class::Storage::DBI/connect_info> is used to execute the equivalent
1124C<SET TEXTSIZE> command on connection.
d4483998 1125
d867eeda 1126See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
1127setting you need to work with C<IMAGE> columns.
f68f4d44 1128
0a9a9955 1129=head1 BULK API
1130
1131The experimental L<DBD::Sybase> Bulk API support is used for
1132L<populate|DBIx::Class::ResultSet/populate> in B<void> context, in a transaction
1133on a separate connection.
1134
1135To use this feature effectively, use a large number of rows for each
1136L<populate|DBIx::Class::ResultSet/populate> call, eg.:
1137
1138 while (my $rows = $data_source->get_100_rows()) {
1139 $rs->populate($rows);
1140 }
1141
1142B<NOTE:> the L<add_columns|DBIx::Class::ResultSource/add_columns>
1143calls in your C<Result> classes B<must> list columns in database order for this
1144to work. Also, you may have to unset the C<LANG> environment variable before
1145loading your app, if it doesn't match the character set of your database.
1146
1147When inserting IMAGE columns using this method, you'll need to use
1148L</connect_call_blob_setup> as well.
1149
d867eeda 1150=head1 AUTHOR
f68f4d44 1151
d867eeda 1152See L<DBIx::Class/CONTRIBUTORS>.
47d9646a 1153
f68f4d44 1154=head1 LICENSE
1155
1156You may distribute this code under the same terms as Perl itself.
1157
1158=cut
d867eeda 1159# vim:sts=2 sw=2: