lib/DBIx/Class/Storage/DBI/Sybase.pm

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