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

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