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