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