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   DBIx::Class::Storage::DBI::IdentityInsert
  10 /;
  11 use mro 'c3';
  12 use DBIx::Class::Carp;
  13 use Scalar::Util qw/blessed weaken/;
  14 use List::Util 'first';
  15 use Sub::Name();
  16 use Data::Dumper::Concise 'Dumper';
  17 use Try::Tiny;
  18 use Context::Preserve 'preserve_context';
  19 use namespace::clean;
  20
  21 __PACKAGE__->sql_limit_dialect ('RowCountOrGenericSubQ');
  22 __PACKAGE__->sql_quote_char ([qw/[ ]/]);
  23 __PACKAGE__->datetime_parser_type(
  24   'DBIx::Class::Storage::DBI::Sybase::ASE::DateTime::Format'
  25 );
  26
  27 __PACKAGE__->mk_group_accessors('simple' =>
  28     qw/_identity _identity_method _blob_log_on_update _parent_storage
  29        _writer_storage _is_writer_storage
  30        _bulk_storage _is_bulk_storage _began_bulk_work
  31     /
  32 );
  33
  34
  35 my @also_proxy_to_extra_storages = qw/
  36   connect_call_set_auto_cast auto_cast connect_call_blob_setup
  37   connect_call_datetime_setup
  38
  39   disconnect _connect_info _sql_maker _sql_maker_opts disable_sth_caching
  40   auto_savepoint unsafe cursor_class debug debugobj schema
  41 /;
  42
  43 =head1 NAME
  44
  45 DBIx::Class::Storage::DBI::Sybase::ASE - Sybase ASE SQL Server support for
  46 DBIx::Class
  47
  48 =head1 SYNOPSIS
  49
  50 This subclass supports L<DBD::Sybase> for real (non-Microsoft) Sybase databases.
  51
  52 =head1 DESCRIPTION
  53
  54 If your version of Sybase does not support placeholders, then your storage will
  55 be reblessed to L<DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars>.
  56 You can also enable that driver explicitly, see the documentation for more
  57 details.
  58
  59 With this driver there is unfortunately no way to get the C<last_insert_id>
  60 without doing a C<SELECT MAX(col)>. This is done safely in a transaction
  61 (locking the table.) See L</INSERTS WITH PLACEHOLDERS>.
  62
  63 A recommended L<connect_info|DBIx::Class::Storage::DBI/connect_info> setting:
  64
  65   on_connect_call => [['datetime_setup'], ['blob_setup', log_on_update => 0]]
  66
  67 =head1 METHODS
  68
  69 =cut
  70
  71 sub _rebless {
  72   my $self = shift;
  73
  74   my $no_bind_vars = __PACKAGE__ . '::NoBindVars';
  75
  76   if ($self->using_freetds) {
  77     carp_once <<'EOF' unless $ENV{DBIC_SYBASE_FREETDS_NOWARN};
  78
  79 You are using FreeTDS with Sybase.
  80
  81 We will do our best to support this configuration, but please consider this
  82 support experimental.
  83
  84 TEXT/IMAGE columns will definitely not work.
  85
  86 You are encouraged to recompile DBD::Sybase with the Sybase Open Client libraries
  87 instead.
  88
  89 See perldoc DBIx::Class::Storage::DBI::Sybase::ASE for more details.
  90
  91 To turn off this warning set the DBIC_SYBASE_FREETDS_NOWARN environment
  92 variable.
  93 EOF
  94
  95     if (not $self->_use_typeless_placeholders) {
  96       if ($self->_use_placeholders) {
  97         $self->auto_cast(1);
  98       }
  99       else {
 100         $self->ensure_class_loaded($no_bind_vars);
 101         bless $self, $no_bind_vars;
 102         $self->_rebless;
 103       }
 104     }
 105   }
 106
 107   elsif (not $self->_get_dbh->{syb_dynamic_supported}) {
 108     # not necessarily FreeTDS, but no placeholders nevertheless
 109     $self->ensure_class_loaded($no_bind_vars);
 110     bless $self, $no_bind_vars;
 111     $self->_rebless;
 112   }
 113   # this is highly unlikely, but we check just in case
 114   elsif (not $self->_use_typeless_placeholders) {
 115     $self->auto_cast(1);
 116   }
 117 }
 118
 119 sub _init {
 120   my $self = shift;
 121   $self->_set_max_connect(256);
 122
 123 # create storage for insert/(update blob) transactions,
 124 # unless this is that storage
 125   return if $self->_parent_storage;
 126
 127   my $writer_storage = (ref $self)->new;
 128
 129   $writer_storage->_is_writer_storage(1); # just info
 130   $writer_storage->connect_info($self->connect_info);
 131   $writer_storage->auto_cast($self->auto_cast);
 132
 133   weaken ($writer_storage->{_parent_storage} = $self);
 134   $self->_writer_storage($writer_storage);
 135
 136 # create a bulk storage unless connect_info is a coderef
 137   return if ref($self->_dbi_connect_info->[0]) eq 'CODE';
 138
 139   my $bulk_storage = (ref $self)->new;
 140
 141   $bulk_storage->_is_bulk_storage(1); # for special ->disconnect acrobatics
 142   $bulk_storage->connect_info($self->connect_info);
 143
 144 # this is why
 145   $bulk_storage->_dbi_connect_info->[0] .= ';bulkLogin=1';
 146
 147   weaken ($bulk_storage->{_parent_storage} = $self);
 148   $self->_bulk_storage($bulk_storage);
 149 }
 150
 151 for my $method (@also_proxy_to_extra_storages) {
 152   no strict 'refs';
 153   no warnings 'redefine';
 154
 155   my $replaced = __PACKAGE__->can($method);
 156
 157   *{$method} = Sub::Name::subname $method => sub {
 158     my $self = shift;
 159     $self->_writer_storage->$replaced(@_) if $self->_writer_storage;
 160     $self->_bulk_storage->$replaced(@_)   if $self->_bulk_storage;
 161     return $self->$replaced(@_);
 162   };
 163 }
 164
 165 sub disconnect {
 166   my $self = shift;
 167
 168 # Even though we call $sth->finish for uses off the bulk API, there's still an
 169 # "active statement" warning on disconnect, which we throw away here.
 170 # This is due to the bug described in insert_bulk.
 171 # Currently a noop because 'prepare' is used instead of 'prepare_cached'.
 172   local $SIG{__WARN__} = sub {
 173     warn $_[0] unless $_[0] =~ /active statement/i;
 174   } if $self->_is_bulk_storage;
 175
 176 # so that next transaction gets a dbh
 177   $self->_began_bulk_work(0) if $self->_is_bulk_storage;
 178
 179   $self->next::method;
 180 }
 181
 182 # This is only invoked for FreeTDS drivers by ::Storage::DBI::Sybase::FreeTDS
 183 sub _set_autocommit_stmt {
 184   my ($self, $on) = @_;
 185
 186   return 'SET CHAINED ' . ($on ? 'OFF' : 'ON');
 187 }
 188
 189 # Set up session settings for Sybase databases for the connection.
 190 #
 191 # Make sure we have CHAINED mode turned on if AutoCommit is off in non-FreeTDS
 192 # DBD::Sybase (since we don't know how DBD::Sybase was compiled.) If however
 193 # we're using FreeTDS, CHAINED mode turns on an implicit transaction which we
 194 # only want when AutoCommit is off.
 195 sub _run_connection_actions {
 196   my $self = shift;
 197
 198   if ($self->_is_bulk_storage) {
 199     # this should be cleared on every reconnect
 200     $self->_began_bulk_work(0);
 201     return;
 202   }
 203
 204   $self->_dbh->{syb_chained_txn} = 1
 205     unless $self->using_freetds;
 206
 207   $self->next::method(@_);
 208 }
 209
 210 =head2 connect_call_blob_setup
 211
 212 Used as:
 213
 214   on_connect_call => [ [ 'blob_setup', log_on_update => 0 ] ]
 215
 216 Does C<< $dbh->{syb_binary_images} = 1; >> to return C<IMAGE> data as raw binary
 217 instead of as a hex string.
 218
 219 Recommended.
 220
 221 Also sets the C<log_on_update> value for blob write operations. The default is
 222 C<1>, but C<0> is better if your database is configured for it.
 223
 224 See
 225 L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.
 226
 227 =cut
 228
 229 sub connect_call_blob_setup {
 230   my $self = shift;
 231   my %args = @_;
 232   my $dbh = $self->_dbh;
 233   $dbh->{syb_binary_images} = 1;
 234
 235   $self->_blob_log_on_update($args{log_on_update})
 236     if exists $args{log_on_update};
 237 }
 238
 239 sub _is_lob_column {
 240   my ($self, $source, $column) = @_;
 241
 242   return $self->_is_lob_type($source->column_info($column)->{data_type});
 243 }
 244
 245 sub _prep_for_execute {
 246   my $self = shift;
 247   my ($op, $ident) = @_;
 248
 249   #
 250 ### This is commented out because all tests pass. However I am leaving it
 251 ### here as it may prove necessary (can't think through all combinations)
 252 ### BTW it doesn't currently work exactly - need better sensitivity to
 253   # currently set value
 254   #
 255   # inherit these from the parent for the duration of _prep_for_execute
 256   # Don't know how to make a localizing loop with if's, otherwise I would
 257   #local $self->{_autoinc_supplied_for_op}
 258   #  = $self->_parent_storage->_autoinc_supplied_for_op
 259   #if ($op eq 'insert' or $op eq 'update') and $self->_parent_storage;
 260   #local $self->{_perform_autoinc_retrieval}
 261   #  = $self->_parent_storage->_perform_autoinc_retrieval
 262   #if ($op eq 'insert' or $op eq 'update') and $self->_parent_storage;
 263
 264   my ($sql, $bind) = $self->next::method (@_);
 265
 266   if (my $identity_col = $self->_perform_autoinc_retrieval) {
 267     $sql .= "\n" . $self->_fetch_identity_sql($ident, $identity_col)
 268   }
 269
 270   return ($sql, $bind);
 271 }
 272
 273 sub _fetch_identity_sql {
 274   my ($self, $source, $col) = @_;
 275
 276   return sprintf ("SELECT MAX(%s) FROM %s",
 277     map { $self->sql_maker->_quote ($_) } ($col, $source->from)
 278   );
 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
 312 sub _execute {
 313   my $self = shift;
 314   my ($op) = @_;
 315
 316   my ($rv, $sth, @bind) = $self->next::method(@_);
 317
 318   $self->_identity( ($sth->fetchall_arrayref)[0][0] )
 319     if $self->_perform_autoinc_retrieval;
 320
 321   return wantarray ? ($rv, $sth, @bind) : $rv;
 322 }
 323
 324 sub last_insert_id { shift->_identity }
 325
 326 # handles TEXT/IMAGE and transaction for last_insert_id
 327 sub insert {
 328   my $self = shift;
 329   my ($source, $to_insert) = @_;
 330
 331   my $columns_info = $source->columns_info;
 332
 333   my $identity_col =
 334     (first { $columns_info->{$_}{is_auto_increment} }
 335       keys %$columns_info )
 336     || '';
 337
 338   # FIXME - this is duplication from DBI.pm. When refactored towards
 339   # the LobWriter this can be folded back where it belongs.
 340   local $self->{_autoinc_supplied_for_op} = exists $to_insert->{$identity_col}
 341     ? 1
 342     : 0
 343   ;
 344   local $self->{_perform_autoinc_retrieval} =
 345     ($identity_col and ! exists $to_insert->{$identity_col})
 346       ? $identity_col
 347       : undef
 348   ;
 349
 350   # check for empty insert
 351   # INSERT INTO foo DEFAULT VALUES -- does not work with Sybase
 352   # try to insert explicit 'DEFAULT's instead (except for identity, timestamp
 353   # and computed columns)
 354   if (not %$to_insert) {
 355     for my $col ($source->columns) {
 356       next if $col eq $identity_col;
 357
 358       my $info = $source->column_info($col);
 359
 360       next if ref $info->{default_value} eq 'SCALAR'
 361         || (exists $info->{data_type} && (not defined $info->{data_type}));
 362
 363       next if $info->{data_type} && $info->{data_type} =~ /^timestamp\z/i;
 364
 365       $to_insert->{$col} = \'DEFAULT';
 366     }
 367   }
 368
 369   my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
 370
 371   # do we need the horrific SELECT MAX(COL) hack?
 372   my $need_dumb_last_insert_id = (
 373     $self->_perform_autoinc_retrieval
 374       &&
 375     ($self->_identity_method||'') ne '@@IDENTITY'
 376   );
 377
 378   my $next = $self->next::can;
 379
 380   # we are already in a transaction, or there are no blobs
 381   # and we don't need the PK - just (try to) do it
 382   if ($self->{transaction_depth}
 383         || (!$blob_cols && !$need_dumb_last_insert_id)
 384   ) {
 385     return $self->_insert (
 386       $next, $source, $to_insert, $blob_cols, $identity_col
 387     );
 388   }
 389
 390   # otherwise use the _writer_storage to do the insert+transaction on another
 391   # connection
 392   my $guard = $self->_writer_storage->txn_scope_guard;
 393
 394   my $updated_cols = $self->_writer_storage->_insert (
 395     $next, $source, $to_insert, $blob_cols, $identity_col
 396   );
 397
 398   $self->_identity($self->_writer_storage->_identity);
 399
 400   $guard->commit;
 401
 402   return $updated_cols;
 403 }
 404
 405 sub _insert {
 406   my ($self, $next, $source, $to_insert, $blob_cols, $identity_col) = @_;
 407
 408   my $updated_cols = $self->$next ($source, $to_insert);
 409
 410   my $final_row = {
 411     ($identity_col ?
 412       ($identity_col => $self->last_insert_id($source, $identity_col)) : ()),
 413     %$to_insert,
 414     %$updated_cols,
 415   };
 416
 417   $self->_insert_blobs ($source, $blob_cols, $final_row) if $blob_cols;
 418
 419   return $updated_cols;
 420 }
 421
 422 sub update {
 423   my $self = shift;
 424   my ($source, $fields, $where, @rest) = @_;
 425
 426   #
 427   # When *updating* identities, ASE requires SET IDENTITY_UPDATE called
 428   #
 429   if (my $blob_cols = $self->_remove_blob_cols($source, $fields)) {
 430
 431     # If there are any blobs in $where, Sybase will return a descriptive error
 432     # message.
 433     # XXX blobs can still be used with a LIKE query, and this should be handled.
 434
 435     # update+blob update(s) done atomically on separate connection
 436     $self = $self->_writer_storage;
 437
 438     my $guard = $self->txn_scope_guard;
 439
 440     # First update the blob columns to be updated to '' (taken from $fields, where
 441     # it is originally put by _remove_blob_cols .)
 442     my %blobs_to_empty = map { ($_ => delete $fields->{$_}) } keys %$blob_cols;
 443
 444     # We can't only update NULL blobs, because blobs cannot be in the WHERE clause.
 445     $self->next::method($source, \%blobs_to_empty, $where, @rest);
 446
 447     # Now update the blobs before the other columns in case the update of other
 448     # columns makes the search condition invalid.
 449     my $rv = $self->_update_blobs($source, $blob_cols, $where);
 450
 451     if (keys %$fields) {
 452
 453       # Now set the identity update flags for the actual update
 454       local $self->{_autoinc_supplied_for_op} = (first
 455         { $_->{is_auto_increment} }
 456         values %{ $source->columns_info([ keys %$fields ]) }
 457       ) ? 1 : 0;
 458
 459       my $next = $self->next::can;
 460       my $args = \@_;
 461       return preserve_context {
 462         $self->$next(@$args);
 463       } after => sub { $guard->commit };
 464     }
 465     else {
 466       $guard->commit;
 467       return $rv;
 468     }
 469   }
 470   else {
 471     # Set the identity update flags for the actual update
 472     local $self->{_autoinc_supplied_for_op} = (first
 473       { $_->{is_auto_increment} }
 474       values %{ $source->columns_info([ keys %$fields ]) }
 475     ) ? 1 : 0;
 476
 477     return $self->next::method(@_);
 478   }
 479 }
 480
 481 sub insert_bulk {
 482   my $self = shift;
 483   my ($source, $cols, $data) = @_;
 484
 485   my $columns_info = $source->columns_info;
 486
 487   my $identity_col =
 488     first { $columns_info->{$_}{is_auto_increment} }
 489       keys %$columns_info;
 490
 491   # FIXME - this is duplication from DBI.pm. When refactored towards
 492   # the LobWriter this can be folded back where it belongs.
 493   local $self->{_autoinc_supplied_for_op} =
 494     (first { $_ eq $identity_col } @$cols)
 495       ? 1
 496       : 0
 497   ;
 498
 499   my $use_bulk_api =
 500     $self->_bulk_storage &&
 501     $self->_get_dbh->{syb_has_blk};
 502
 503   if (! $use_bulk_api and ref($self->_dbi_connect_info->[0]) eq 'CODE') {
 504     carp_unique( join ' ',
 505       'Bulk API support disabled due to use of a CODEREF connect_info.',
 506       'Reverting to regular array inserts.',
 507     );
 508   }
 509
 510   if (not $use_bulk_api) {
 511     my $blob_cols = $self->_remove_blob_cols_array($source, $cols, $data);
 512
 513 # next::method uses a txn anyway, but it ends too early in case we need to
 514 # select max(col) to get the identity for inserting blobs.
 515     ($self, my $guard) = $self->{transaction_depth} == 0 ?
 516       ($self->_writer_storage, $self->_writer_storage->txn_scope_guard)
 517       :
 518       ($self, undef);
 519
 520     $self->next::method(@_);
 521
 522     if ($blob_cols) {
 523       if ($self->_autoinc_supplied_for_op) {
 524         $self->_insert_blobs_array ($source, $blob_cols, $cols, $data);
 525       }
 526       else {
 527         my @cols_with_identities = (@$cols, $identity_col);
 528
 529         ## calculate identities
 530         # XXX This assumes identities always increase by 1, which may or may not
 531         # be true.
 532         my ($last_identity) =
 533           $self->_dbh->selectrow_array (
 534             $self->_fetch_identity_sql($source, $identity_col)
 535           );
 536         my @identities = (($last_identity - @$data + 1) .. $last_identity);
 537
 538         my @data_with_identities = map [@$_, shift @identities], @$data;
 539
 540         $self->_insert_blobs_array (
 541           $source, $blob_cols, \@cols_with_identities, \@data_with_identities
 542         );
 543       }
 544     }
 545
 546     $guard->commit if $guard;
 547
 548     return;
 549   }
 550
 551 # otherwise, use the bulk API
 552
 553 # rearrange @$data so that columns are in database order
 554 # and so we submit a full column list
 555   my %orig_order = map { $cols->[$_] => $_ } 0..$#$cols;
 556
 557   my @source_columns = $source->columns;
 558
 559   # bcp identity index is 1-based
 560   my $identity_idx = first { $source_columns[$_] eq $identity_col } (0..$#source_columns);
 561   $identity_idx = defined $identity_idx ? $identity_idx + 1 : 0;
 562
 563   my @new_data;
 564   for my $slice_idx (0..$#$data) {
 565     push @new_data, [map {
 566       # identity data will be 'undef' if not _autoinc_supplied_for_op()
 567       # columns with defaults will also be 'undef'
 568       exists $orig_order{$_}
 569         ? $data->[$slice_idx][$orig_order{$_}]
 570         : undef
 571     } @source_columns];
 572   }
 573
 574   my $proto_bind = $self->_resolve_bindattrs(
 575     $source,
 576     [map {
 577       [ { dbic_colname => $source_columns[$_], _bind_data_slice_idx => $_ }
 578         => $new_data[0][$_] ]
 579     } (0 ..$#source_columns) ],
 580     $columns_info
 581   );
 582
 583 ## Set a client-side conversion error handler, straight from DBD::Sybase docs.
 584 # This ignores any data conversion errors detected by the client side libs, as
 585 # they are usually harmless.
 586   my $orig_cslib_cb = DBD::Sybase::set_cslib_cb(
 587     Sub::Name::subname insert_bulk => sub {
 588       my ($layer, $origin, $severity, $errno, $errmsg, $osmsg, $blkmsg) = @_;
 589
 590       return 1 if $errno == 36;
 591
 592       carp
 593         "Layer: $layer, Origin: $origin, Severity: $severity, Error: $errno" .
 594         ($errmsg ? "\n$errmsg" : '') .
 595         ($osmsg  ? "\n$osmsg"  : '')  .
 596         ($blkmsg ? "\n$blkmsg" : '');
 597
 598       return 0;
 599   });
 600
 601   my $exception = '';
 602   try {
 603     my $bulk = $self->_bulk_storage;
 604
 605     my $guard = $bulk->txn_scope_guard;
 606
 607 ## FIXME - once this is done - address the FIXME on finish() below
 608 ## XXX get this to work instead of our own $sth
 609 ## will require SQLA or *Hacks changes for ordered columns
 610 #    $bulk->next::method($source, \@source_columns, \@new_data, {
 611 #      syb_bcp_attribs => {
 612 #        identity_flag   => $self->_autoinc_supplied_for_op ? 1 : 0,
 613 #        identity_column => $identity_idx,
 614 #      }
 615 #    });
 616     my $sql = 'INSERT INTO ' .
 617       $bulk->sql_maker->_quote($source->name) . ' (' .
 618 # colname list is ignored for BCP, but does no harm
 619       (join ', ', map $bulk->sql_maker->_quote($_), @source_columns) . ') '.
 620       ' VALUES ('.  (join ', ', ('?') x @source_columns) . ')';
 621
 622 ## XXX there's a bug in the DBD::Sybase bulk support that makes $sth->finish for
 623 ## a prepare_cached statement ineffective. Replace with ->sth when fixed, or
 624 ## better yet the version above. Should be fixed in DBD::Sybase .
 625     my $sth = $bulk->_get_dbh->prepare($sql,
 626 #      'insert', # op
 627       {
 628         syb_bcp_attribs => {
 629           identity_flag   => $self->_autoinc_supplied_for_op ? 1 : 0,
 630           identity_column => $identity_idx,
 631         }
 632       }
 633     );
 634
 635     {
 636       # FIXME the $sth->finish in _execute_array does a rollback for some
 637       # reason. Disable it temporarily until we fix the SQLMaker thing above
 638       no warnings 'redefine';
 639       no strict 'refs';
 640       local *{ref($sth).'::finish'} = sub {};
 641
 642       $self->_dbh_execute_for_fetch(
 643         $source, $sth, $proto_bind, \@source_columns, \@new_data
 644       );
 645     }
 646
 647     $guard->commit;
 648
 649     $bulk->_query_end($sql);
 650   } catch {
 651     $exception = shift;
 652   };
 653
 654   DBD::Sybase::set_cslib_cb($orig_cslib_cb);
 655
 656   if ($exception =~ /-Y option/) {
 657     my $w = 'Sybase bulk API operation failed due to character set incompatibility, '
 658           . 'reverting to regular array inserts. Try unsetting the LANG environment variable'
 659     ;
 660     $w .= "\n$exception" if $self->debug;
 661     carp $w;
 662
 663     $self->_bulk_storage(undef);
 664     unshift @_, $self;
 665     goto \&insert_bulk;
 666   }
 667   elsif ($exception) {
 668 # rollback makes the bulkLogin connection unusable
 669     $self->_bulk_storage->disconnect;
 670     $self->throw_exception($exception);
 671   }
 672 }
 673
 674 # Make sure blobs are not bound as placeholders, and return any non-empty ones
 675 # as a hash.
 676 sub _remove_blob_cols {
 677   my ($self, $source, $fields) = @_;
 678
 679   my %blob_cols;
 680
 681   for my $col (keys %$fields) {
 682     if ($self->_is_lob_column($source, $col)) {
 683       my $blob_val = delete $fields->{$col};
 684       if (not defined $blob_val) {
 685         $fields->{$col} = \'NULL';
 686       }
 687       else {
 688         $fields->{$col} = \"''";
 689         $blob_cols{$col} = $blob_val unless $blob_val eq '';
 690       }
 691     }
 692   }
 693
 694   return %blob_cols ? \%blob_cols : undef;
 695 }
 696
 697 # same for insert_bulk
 698 sub _remove_blob_cols_array {
 699   my ($self, $source, $cols, $data) = @_;
 700
 701   my @blob_cols;
 702
 703   for my $i (0..$#$cols) {
 704     my $col = $cols->[$i];
 705
 706     if ($self->_is_lob_column($source, $col)) {
 707       for my $j (0..$#$data) {
 708         my $blob_val = delete $data->[$j][$i];
 709         if (not defined $blob_val) {
 710           $data->[$j][$i] = \'NULL';
 711         }
 712         else {
 713           $data->[$j][$i] = \"''";
 714           $blob_cols[$j][$i] = $blob_val
 715             unless $blob_val eq '';
 716         }
 717       }
 718     }
 719   }
 720
 721   return @blob_cols ? \@blob_cols : undef;
 722 }
 723
 724 sub _update_blobs {
 725   my ($self, $source, $blob_cols, $where) = @_;
 726
 727   my @primary_cols = try
 728     { $source->_pri_cols }
 729     catch {
 730       $self->throw_exception("Cannot update TEXT/IMAGE column(s): $_")
 731     };
 732
 733   my @pks_to_update;
 734   if (
 735     ref $where eq 'HASH'
 736       and
 737     @primary_cols == grep { defined $where->{$_} } @primary_cols
 738   ) {
 739     my %row_to_update;
 740     @row_to_update{@primary_cols} = @{$where}{@primary_cols};
 741     @pks_to_update = \%row_to_update;
 742   }
 743   else {
 744     my $cursor = $self->select ($source, \@primary_cols, $where, {});
 745     @pks_to_update = map {
 746       my %row; @row{@primary_cols} = @$_; \%row
 747     } $cursor->all;
 748   }
 749
 750   for my $ident (@pks_to_update) {
 751     $self->_insert_blobs($source, $blob_cols, $ident);
 752   }
 753 }
 754
 755 sub _insert_blobs {
 756   my ($self, $source, $blob_cols, $row) = @_;
 757   my $dbh = $self->_get_dbh;
 758
 759   my $table = $source->name;
 760
 761   my %row = %$row;
 762   my @primary_cols = try
 763     { $source->_pri_cols }
 764     catch {
 765       $self->throw_exception("Cannot update TEXT/IMAGE column(s): $_")
 766     };
 767
 768   $self->throw_exception('Cannot update TEXT/IMAGE column(s) without primary key values')
 769     if ((grep { defined $row{$_} } @primary_cols) != @primary_cols);
 770
 771   for my $col (keys %$blob_cols) {
 772     my $blob = $blob_cols->{$col};
 773
 774     my %where = map { ($_, $row{$_}) } @primary_cols;
 775
 776     my $cursor = $self->select ($source, [$col], \%where, {});
 777     $cursor->next;
 778     my $sth = $cursor->sth;
 779
 780     if (not $sth) {
 781       $self->throw_exception(
 782           "Could not find row in table '$table' for blob update:\n"
 783         . (Dumper \%where)
 784       );
 785     }
 786
 787     try {
 788       do {
 789         $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
 790       } while $sth->fetch;
 791
 792       $sth->func('ct_prepare_send') or die $sth->errstr;
 793
 794       my $log_on_update = $self->_blob_log_on_update;
 795       $log_on_update    = 1 if not defined $log_on_update;
 796
 797       $sth->func('CS_SET', 1, {
 798         total_txtlen => length($blob),
 799         log_on_update => $log_on_update
 800       }, 'ct_data_info') or die $sth->errstr;
 801
 802       $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
 803
 804       $sth->func('ct_finish_send') or die $sth->errstr;
 805     }
 806     catch {
 807       if ($self->using_freetds) {
 808         $self->throw_exception (
 809           "TEXT/IMAGE operation failed, probably because you are using FreeTDS: $_"
 810         );
 811       }
 812       else {
 813         $self->throw_exception($_);
 814       }
 815     }
 816     finally {
 817       $sth->finish if $sth;
 818     };
 819   }
 820 }
 821
 822 sub _insert_blobs_array {
 823   my ($self, $source, $blob_cols, $cols, $data) = @_;
 824
 825   for my $i (0..$#$data) {
 826     my $datum = $data->[$i];
 827
 828     my %row;
 829     @row{ @$cols } = @$datum;
 830
 831     my %blob_vals;
 832     for my $j (0..$#$cols) {
 833       if (exists $blob_cols->[$i][$j]) {
 834         $blob_vals{ $cols->[$j] } = $blob_cols->[$i][$j];
 835       }
 836     }
 837
 838     $self->_insert_blobs ($source, \%blob_vals, \%row);
 839   }
 840 }
 841
 842 =head2 connect_call_datetime_setup
 843
 844 Used as:
 845
 846   on_connect_call => 'datetime_setup'
 847
 848 In L<connect_info|DBIx::Class::Storage::DBI/connect_info> to set:
 849
 850   $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
 851   $dbh->do('set dateformat mdy');   # input fmt:  08/13/1979 18:08:55.080
 852
 853 This works for both C<DATETIME> and C<SMALLDATETIME> columns, note that
 854 C<SMALLDATETIME> columns only have minute precision.
 855
 856 =cut
 857
 858 sub connect_call_datetime_setup {
 859   my $self = shift;
 860   my $dbh = $self->_get_dbh;
 861
 862   if ($dbh->can('syb_date_fmt')) {
 863     # amazingly, this works with FreeTDS
 864     $dbh->syb_date_fmt('ISO_strict');
 865   }
 866   else {
 867     carp_once
 868       'Your DBD::Sybase is too old to support '
 869      .'DBIx::Class::InflateColumn::DateTime, please upgrade!';
 870
 871     # FIXME - in retrospect this is a rather bad US-centric choice
 872     # of format. Not changing as a bugwards compat, though in reality
 873     # the only piece that sees the results of $dt object formatting
 874     # (as opposed to parsing) is the database itself, so theoretically
 875     # changing both this SET command and the formatter definition of
 876     # ::S::D::Sybase::ASE::DateTime::Format below should be safe and
 877     # transparent
 878
 879     $dbh->do('SET DATEFORMAT mdy');
 880   }
 881 }
 882
 883
 884 sub _exec_txn_begin {
 885   my $self = shift;
 886
 887 # bulkLogin=1 connections are always in a transaction, and can only call BEGIN
 888 # TRAN once. However, we need to make sure there's a $dbh.
 889   return if $self->_is_bulk_storage && $self->_dbh && $self->_began_bulk_work;
 890
 891   $self->next::method(@_);
 892
 893   $self->_began_bulk_work(1) if $self->_is_bulk_storage;
 894 }
 895
 896 # savepoint support using ASE syntax
 897
 898 sub _exec_svp_begin {
 899   my ($self, $name) = @_;
 900
 901   $self->_dbh->do("SAVE TRANSACTION $name");
 902 }
 903
 904 # A new SAVE TRANSACTION with the same name releases the previous one.
 905 sub _exec_svp_release { 1 }
 906
 907 sub _exec_svp_rollback {
 908   my ($self, $name) = @_;
 909
 910   $self->_dbh->do("ROLLBACK TRANSACTION $name");
 911 }
 912
 913 package # hide from PAUSE
 914   DBIx::Class::Storage::DBI::Sybase::ASE::DateTime::Format;
 915
 916 my $datetime_parse_format  = '%Y-%m-%dT%H:%M:%S.%3NZ';
 917 my $datetime_format_format = '%m/%d/%Y %H:%M:%S.%3N';
 918
 919 my ($datetime_parser, $datetime_formatter);
 920
 921 sub parse_datetime {
 922   shift;
 923   require DateTime::Format::Strptime;
 924   $datetime_parser ||= DateTime::Format::Strptime->new(
 925     pattern  => $datetime_parse_format,
 926     on_error => 'croak',
 927   );
 928   return $datetime_parser->parse_datetime(shift);
 929 }
 930
 931 sub format_datetime {
 932   shift;
 933   require DateTime::Format::Strptime;
 934   $datetime_formatter ||= DateTime::Format::Strptime->new(
 935     pattern  => $datetime_format_format,
 936     on_error => 'croak',
 937   );
 938   return $datetime_formatter->format_datetime(shift);
 939 }
 940
 941 1;
 942
 943 =head1 Schema::Loader Support
 944
 945 As of version C<0.05000>, L<DBIx::Class::Schema::Loader> should work well with
 946 most versions of Sybase ASE.
 947
 948 =head1 FreeTDS
 949
 950 This driver supports L<DBD::Sybase> compiled against FreeTDS
 951 (L<http://www.freetds.org/>) to the best of our ability, however it is
 952 recommended that you recompile L<DBD::Sybase> against the Sybase Open Client
 953 libraries. They are a part of the Sybase ASE distribution:
 954
 955 The Open Client FAQ is here:
 956 L<http://www.isug.com/Sybase_FAQ/ASE/section7.html>.
 957
 958 Sybase ASE for Linux (which comes with the Open Client libraries) may be
 959 downloaded here: L<http://response.sybase.com/forms/ASE_Linux_Download>.
 960
 961 To see if you're using FreeTDS check C<< $schema->storage->using_freetds >>, or run:
 962
 963   perl -MDBI -le 'my $dbh = DBI->connect($dsn, $user, $pass); print $dbh->{syb_oc_version}'
 964
 965 It is recommended to set C<tds version> for your ASE server to C<5.0> in
 966 C</etc/freetds/freetds.conf>.
 967
 968 Some versions or configurations of the libraries involved will not support
 969 placeholders, in which case the storage will be reblessed to
 970 L<DBIx::Class::Storage::DBI::Sybase::ASE::NoBindVars>.
 971
 972 In some configurations, placeholders will work but will throw implicit type
 973 conversion errors for anything that's not expecting a string. In such a case,
 974 the C<auto_cast> option from L<DBIx::Class::Storage::DBI::AutoCast> is
 975 automatically set, which you may enable on connection with
 976 L<connect_call_set_auto_cast|DBIx::Class::Storage::DBI::AutoCast/connect_call_set_auto_cast>.
 977 The type info for the C<CAST>s is taken from the
 978 L<DBIx::Class::ResultSource/data_type> definitions in your Result classes, and
 979 are mapped to a Sybase type (if it isn't already) using a mapping based on
 980 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 unnecessary and not used, as there are no concurrency issues with C<SELECT
 999 @@IDENTITY> which is a session variable.
1000
1001 =head1 TRANSACTIONS
1002
1003 Due to limitations of the TDS protocol and L<DBD::Sybase>, you cannot begin a
1004 transaction while there are active cursors, nor can you use multiple active
1005 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, as C<BCP -Y> is not yet supported in DBD::Sybase .
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     inflate_datetime => 1,
1117   }
1118
1119 The C<data_type> must exist and must be C<undef>. Then empty inserts will work
1120 on tables with such columns.
1121
1122 =head1 TIMESTAMP COLUMNS
1123
1124 C<timestamp> columns in Sybase ASE are not really timestamps, see:
1125 L<http://dba.fyicenter.com/Interview-Questions/SYBASE/The_timestamp_datatype_in_Sybase_.html>.
1126
1127 They should be defined in your Result classes as:
1128
1129   ts => {
1130     data_type => 'timestamp',
1131     is_nullable => 0,
1132     inflate_datetime => 0,
1133   }
1134
1135 The C<<inflate_datetime => 0>> is necessary if you use
1136 L<DBIx::Class::InflateColumn::DateTime>, and most people do, and still want to
1137 be able to read these values.
1138
1139 The values will come back as hexadecimal.
1140
1141 =head1 TODO
1142
1143 =over
1144
1145 =item *
1146
1147 Transitions to AutoCommit=0 (starting a transaction) mode by exhausting
1148 any active cursors, using eager cursors.
1149
1150 =item *
1151
1152 Real limits and limited counts using stored procedures deployed on startup.
1153
1154 =item *
1155
1156 Blob update with a LIKE query on a blob, without invalidating the WHERE condition.
1157
1158 =item *
1159
1160 bulk_insert using prepare_cached (see comments.)
1161
1162 =back
1163
1164 =head1 AUTHOR
1165
1166 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
1167
1168 =head1 LICENSE
1169
1170 You may distribute this code under the same terms as Perl itself.
1171
1172 =cut
1173 # vim:sts=2 sw=2: