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

   1 package DBIx::Class::Storage::DBI::Sybase;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/
   7     DBIx::Class::Storage::DBI::Sybase::Base
   8     DBIx::Class::Storage::DBI
   9 /;
  10 use mro 'c3';
  11 use Carp::Clan qw/^DBIx::Class/;
  12 use List::Util ();
  13
  14 __PACKAGE__->mk_group_accessors('simple' =>
  15     qw/_identity _blob_log_on_update _auto_cast _insert_txn/
  16 );
  17
  18 =head1 NAME
  19
  20 DBIx::Class::Storage::DBI::Sybase - Sybase support for DBIx::Class
  21
  22 =head1 SYNOPSIS
  23
  24 This subclass supports L<DBD::Sybase> for real Sybase databases.  If you are
  25 using an MSSQL database via L<DBD::Sybase>, your storage will be reblessed to
  26 L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
  27
  28 =head1 DESCRIPTION
  29
  30 If your version of Sybase does not support placeholders, then your storage
  31 will be reblessed to L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>. You can
  32 also enable that driver explicitly, see the documentation for more details.
  33
  34 With this driver there is unfortunately no way to get the C<last_insert_id>
  35 without doing a C<SELECT MAX(col)>.
  36
  37 But your queries will be cached.
  38
  39 You need a version of L<DBD::Sybase> compiled with the Sybase OpenClient
  40 libraries, B<NOT> FreeTDS, for placeholder support. Otherwise your storage will
  41 be automatically reblessed into C<::NoBindVars>.
  42
  43 A recommended L<DBIx::Class::Storage::DBI/connect_info> setting:
  44
  45   on_connect_call => [['datetime_setup'], ['blob_setup', log_on_update => 0]]
  46
  47 =head1 METHODS
  48
  49 =cut
  50
  51 sub _rebless {
  52   my $self = shift;
  53
  54   if (ref($self) eq 'DBIx::Class::Storage::DBI::Sybase') {
  55     my $dbtype = eval {
  56       @{$self->dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
  57     } || '';
  58
  59     my $exception = $@;
  60     $dbtype =~ s/\W/_/gi;
  61     my $subclass = "DBIx::Class::Storage::DBI::Sybase::${dbtype}";
  62
  63     if (!$exception && $dbtype && $self->load_optional_class($subclass)) {
  64       bless $self, $subclass;
  65       $self->_rebless;
  66     } else { # real Sybase
  67       my $no_bind_vars = 'DBIx::Class::Storage::DBI::Sybase::NoBindVars';
  68
  69 # This is reset to 0 in ::NoBindVars, only necessary because we use max(col) to
  70 # get the identity.
  71       $self->_insert_txn(1);
  72
  73       if ($self->_using_freetds) {
  74         carp <<'EOF' unless $ENV{DBIC_SYBASE_FREETDS_NOWARN};
  75
  76 You are using FreeTDS with Sybase.
  77
  78 We will do our best to support this configuration, but please consider this
  79 support experimental.
  80
  81 TEXT/IMAGE columns will definitely not work.
  82
  83 You are encouraged to recompile DBD::Sybase with the Sybase OpenClient libraries
  84 instead.
  85
  86 See perldoc DBIx::Class::Storage::DBI::Sybase for more details.
  87
  88 To turn off this warning set the DBIC_SYBASE_FREETDS_NOWARN environment
  89 variable.
  90 EOF
  91         if (not $self->_placeholders_with_type_conversion_supported) {
  92           if ($self->_placeholders_supported) {
  93             $self->_auto_cast(1);
  94           } else {
  95             $self->ensure_class_loaded($no_bind_vars);
  96             bless $self, $no_bind_vars;
  97             $self->_rebless;
  98           }
  99         }
 100       }
 101
 102       if (not $self->dbh->{syb_dynamic_supported}) {
 103         $self->ensure_class_loaded($no_bind_vars);
 104         bless $self, $no_bind_vars;
 105         $self->_rebless;
 106       }
 107
 108       $self->_set_max_connect(256);
 109     }
 110   }
 111 }
 112
 113 # Make sure we have CHAINED mode turned on if AutoCommit is off in non-FreeTDS
 114 # DBD::Sybase (since we don't know how DBD::Sybase was compiled.) If however
 115 # we're using FreeTDS, CHAINED mode turns on an implicit transaction which we
 116 # only want when AutoCommit is off.
 117 sub _populate_dbh {
 118   my $self = shift;
 119
 120   $self->next::method(@_);
 121
 122   if (not $self->_using_freetds) {
 123     $self->_dbh->{syb_chained_txn} = 1;
 124   } else {
 125     if ($self->_dbh_autocommit) {
 126       $self->_dbh->do('SET CHAINED OFF');
 127     } else {
 128       $self->_dbh->do('SET CHAINED ON');
 129     }
 130   }
 131 }
 132
 133 =head2 connect_call_blob_setup
 134
 135 Used as:
 136
 137   on_connect_call => [ [ 'blob_setup', log_on_update => 0 ] ]
 138
 139 Does C<< $dbh->{syb_binary_images} = 1; >> to return C<IMAGE> data as raw binary
 140 instead of as a hex string.
 141
 142 Recommended.
 143
 144 Also sets the C<log_on_update> value for blob write operations. The default is
 145 C<1>, but C<0> is better if your database is configured for it.
 146
 147 See
 148 L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.
 149
 150 =cut
 151
 152 sub connect_call_blob_setup {
 153   my $self = shift;
 154   my %args = @_;
 155   my $dbh = $self->_dbh;
 156   $dbh->{syb_binary_images} = 1;
 157
 158   $self->_blob_log_on_update($args{log_on_update})
 159     if exists $args{log_on_update};
 160 }
 161
 162 sub _is_lob_type {
 163   my $self = shift;
 164   my $type = shift;
 165   $type && $type =~ /(?:text|image|lob|bytea|binary|memo)/i;
 166 }
 167
 168 # The select-piggybacking-on-insert trick stolen from odbc/mssql
 169 sub _prep_for_execute {
 170   my $self = shift;
 171   my ($op, $extra_bind, $ident, $args) = @_;
 172
 173   my ($sql, $bind) = $self->next::method (@_);
 174
 175 # Some combinations of FreeTDS and Sybase throw implicit conversion errors for
 176 # all placeeholders, so we convert them into CASTs here.
 177 # Based on code in ::DBI::NoBindVars .
 178 #
 179 # If we're using ::NoBindVars, there are no binds by this point so this code
 180 # gets skippeed.
 181   if ($self->_auto_cast && @$bind) {
 182     my $new_sql;
 183     my @sql_part = split /\?/, $sql;
 184     my $col_info = $self->_resolve_column_info($ident,[ map $_->[0], @$bind ]);
 185
 186     foreach my $bound (@$bind) {
 187       my $col = $bound->[0];
 188       my $syb_type = $self->_syb_base_type($col_info->{$col}{data_type});
 189
 190       foreach my $data (@{$bound}[1..$#$bound]) {
 191         $new_sql .= shift(@sql_part) .
 192           ($syb_type ? "CAST(? AS $syb_type)" : '?');
 193       }
 194     }
 195     $new_sql .= join '', @sql_part;
 196     $sql = $new_sql;
 197   }
 198
 199   if ($op eq 'insert') {
 200     my $table = $ident->from;
 201
 202     my $bind_info = $self->_resolve_column_info(
 203       $ident, [map $_->[0], @{$bind}]
 204     );
 205     my $identity_col =
 206 List::Util::first { $bind_info->{$_}{is_auto_increment} } (keys %$bind_info);
 207
 208     if ($identity_col) {
 209       $sql =
 210 "SET IDENTITY_INSERT $table ON\n" .
 211 "$sql\n" .
 212 "SET IDENTITY_INSERT $table OFF"
 213     } else {
 214       $identity_col = List::Util::first {
 215         $ident->column_info($_)->{is_auto_increment}
 216       } $ident->columns;
 217     }
 218
 219     if ($identity_col) {
 220       $sql =
 221         "$sql\n" .
 222         $self->_fetch_identity_sql($ident, $identity_col);
 223     }
 224   }
 225
 226   return ($sql, $bind);
 227 }
 228
 229 # Stolen from SQLT, with some modifications. This will likely change when the
 230 # SQLT Sybase stuff is redone/fixed-up.
 231 my %TYPE_MAPPING  = (
 232     number    => 'numeric',
 233     money     => 'money',
 234     varchar   => 'varchar',
 235     varchar2  => 'varchar',
 236     timestamp => 'datetime',
 237     text      => 'varchar',
 238     real      => 'double precision',
 239     comment   => 'text',
 240     bit       => 'bit',
 241     tinyint   => 'smallint',
 242     float     => 'double precision',
 243     serial    => 'numeric',
 244     bigserial => 'numeric',
 245     boolean   => 'varchar',
 246     long      => 'varchar',
 247 );
 248
 249 sub _syb_base_type {
 250   my ($self, $type) = @_;
 251
 252   $type = lc $type;
 253   $type =~ s/ identity//;
 254
 255   return uc($TYPE_MAPPING{$type} || $type);
 256 }
 257
 258 sub _fetch_identity_sql {
 259   my ($self, $source, $col) = @_;
 260
 261   return "SELECT MAX($col) FROM ".$source->from;
 262 }
 263
 264 sub _execute {
 265   my $self = shift;
 266   my ($op) = @_;
 267
 268   my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
 269
 270   if ($op eq 'insert') {
 271     $self->_identity($sth->fetchrow_array);
 272     $sth->finish;
 273   }
 274
 275   return wantarray ? ($rv, $sth, @bind) : $rv;
 276 }
 277
 278 sub last_insert_id { shift->_identity }
 279
 280 # override to handle TEXT/IMAGE and to do a transaction if necessary
 281 sub insert {
 282   my ($self, $source, $to_insert) = splice @_, 0, 3;
 283   my $dbh = $self->_dbh;
 284
 285   my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
 286
 287 # We have to do the insert in a transaction to avoid race conditions with the
 288 # SELECT MAX(COL) identity method used when placeholders are enabled.
 289   my $updated_cols = do {
 290     if ($self->_insert_txn && (not $self->{transaction_depth})) {
 291       my $args = \@_;
 292       my $method = $self->next::can;
 293       $self->txn_do(
 294         sub { $self->$method($source, $to_insert, @$args) }
 295       );
 296     } else {
 297       $self->next::method($source, $to_insert, @_);
 298     }
 299   };
 300
 301   $self->_insert_blobs($source, $blob_cols, $to_insert) if %$blob_cols;
 302
 303   return $updated_cols;
 304 }
 305
 306 sub update {
 307   my ($self, $source)  = splice @_, 0, 2;
 308   my ($fields, $where) = @_;
 309   my $wantarray        = wantarray;
 310
 311   my $blob_cols = $self->_remove_blob_cols($source, $fields);
 312
 313   my @res;
 314   if ($wantarray) {
 315     @res    = $self->next::method($source, @_);
 316   } else {
 317     $res[0] = $self->next::method($source, @_);
 318   }
 319
 320   $self->_update_blobs($source, $blob_cols, $where) if %$blob_cols;
 321
 322   return $wantarray ? @res : $res[0];
 323 }
 324
 325 sub _remove_blob_cols {
 326   my ($self, $source, $fields) = @_;
 327
 328   my %blob_cols;
 329
 330   for my $col (keys %$fields) {
 331     if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
 332       $blob_cols{$col} = delete $fields->{$col};
 333       $fields->{$col} = \"''";
 334     }
 335   }
 336
 337   return \%blob_cols;
 338 }
 339
 340 sub _update_blobs {
 341   my ($self, $source, $blob_cols, $where) = @_;
 342
 343   my (@primary_cols) = $source->primary_columns;
 344
 345   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 346     unless @primary_cols;
 347
 348 # check if we're updating a single row by PK
 349   my $pk_cols_in_where = 0;
 350   for my $col (@primary_cols) {
 351     $pk_cols_in_where++ if defined $where->{$col};
 352   }
 353   my @rows;
 354
 355   if ($pk_cols_in_where == @primary_cols) {
 356     my %row_to_update;
 357     @row_to_update{@primary_cols} = @{$where}{@primary_cols};
 358     @rows = \%row_to_update;
 359   } else {
 360     my $rs = $source->resultset->search(
 361       $where,
 362       {
 363         result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 364         select => \@primary_cols
 365       }
 366     );
 367     @rows = $rs->all; # statement must finish
 368   }
 369
 370   for my $row (@rows) {
 371     $self->_insert_blobs($source, $blob_cols, $row);
 372   }
 373 }
 374
 375 sub _insert_blobs {
 376   my ($self, $source, $blob_cols, $row) = @_;
 377   my $dbh = $self->dbh;
 378
 379   my $table = $source->from;
 380
 381   my %row = %$row;
 382   my (@primary_cols) = $source->primary_columns;
 383
 384   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 385     unless @primary_cols;
 386
 387   if ((grep { defined $row{$_} } @primary_cols) != @primary_cols) {
 388     if (@primary_cols == 1) {
 389       my $col = $primary_cols[0];
 390       $row{$col} = $self->last_insert_id($source, $col);
 391     } else {
 392       croak "Cannot update TEXT/IMAGE column(s) without primary key values";
 393     }
 394   }
 395
 396   for my $col (keys %$blob_cols) {
 397     my $blob = $blob_cols->{$col};
 398     my $sth;
 399
 400     my %where = map { ($_, $row{$_}) } @primary_cols;
 401     my $cursor = $source->resultset->search(\%where, {
 402       select => [$col]
 403     })->cursor;
 404     $cursor->next;
 405     $sth = $cursor->sth;
 406
 407     eval {
 408       do {
 409         $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
 410       } while $sth->fetch;
 411
 412       $sth->func('ct_prepare_send') or die $sth->errstr;
 413
 414       my $log_on_update = $self->_blob_log_on_update;
 415       $log_on_update    = 1 if not defined $log_on_update;
 416
 417       $sth->func('CS_SET', 1, {
 418         total_txtlen => length($blob),
 419         log_on_update => $log_on_update
 420       }, 'ct_data_info') or die $sth->errstr;
 421
 422       $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
 423
 424       $sth->func('ct_finish_send') or die $sth->errstr;
 425     };
 426     my $exception = $@;
 427     $sth->finish if $sth;
 428     if ($exception) {
 429       if ($self->_using_freetds) {
 430         croak
 431 "TEXT/IMAGE operation failed, probably because you're using FreeTDS: " .
 432 $exception;
 433       } else {
 434         croak $exception;
 435       }
 436     }
 437   }
 438 }
 439
 440 =head2 connect_call_datetime_setup
 441
 442 Used as:
 443
 444   on_connect_call => 'datetime_setup'
 445
 446 In L<DBIx::Class::Storage::DBI/connect_info> to set:
 447
 448   $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
 449   $dbh->do('set dateformat mdy');   # input fmt:  08/13/1979 18:08:55.080
 450
 451 On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
 452 L<DateTime::Format::Sybase>, which you will need to install.
 453
 454 This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
 455 C<SMALLDATETIME> columns only have minute precision.
 456
 457 =cut
 458
 459 {
 460   my $old_dbd_warned = 0;
 461
 462   sub connect_call_datetime_setup {
 463     my $self = shift;
 464     my $dbh = $self->_dbh;
 465
 466     if ($dbh->can('syb_date_fmt')) {
 467       $dbh->syb_date_fmt('ISO_strict');
 468     } elsif (not $old_dbd_warned) {
 469       carp "Your DBD::Sybase is too old to support ".
 470       "DBIx::Class::InflateColumn::DateTime, please upgrade!";
 471       $old_dbd_warned = 1;
 472     }
 473
 474     $dbh->do('set dateformat mdy');
 475
 476     1;
 477   }
 478 }
 479
 480 sub datetime_parser_type { "DateTime::Format::Sybase" }
 481
 482 # ->begin_work and such have no effect with FreeTDS
 483
 484 sub _dbh_begin_work {
 485   my $self = shift;
 486   if (not $self->_using_freetds) {
 487     return $self->next::method(@_);
 488   } else {
 489     $self->dbh->do('BEGIN TRAN');
 490   }
 491 }
 492
 493 sub _dbh_commit {
 494   my $self = shift;
 495   if (not $self->_using_freetds) {
 496     return $self->next::method(@_);
 497   } else {
 498     $self->_dbh->do('COMMIT');
 499   }
 500 }
 501
 502 sub _dbh_rollback {
 503   my $self = shift;
 504   if (not $self->_using_freetds) {
 505     return $self->next::method(@_);
 506   } else {
 507     $self->_dbh->do('ROLLBACK');
 508   }
 509 }
 510
 511 # savepoint support using ASE syntax
 512
 513 sub _svp_begin {
 514   my ($self, $name) = @_;
 515
 516   $self->dbh->do("SAVE TRANSACTION $name");
 517 }
 518
 519 # A new SAVE TRANSACTION with the same name releases the previous one.
 520 sub _svp_release { 1 }
 521
 522 sub _svp_rollback {
 523   my ($self, $name) = @_;
 524
 525   $self->dbh->do("ROLLBACK TRANSACTION $name");
 526 }
 527
 528 1;
 529
 530 =head1 MAXIMUM CONNECTIONS
 531
 532 L<DBD::Sybase> makes separate connections to the server for active statements in
 533 the background. By default the number of such connections is limited to 25, on
 534 both the client side and the server side.
 535
 536 This is a bit too low, so on connection the clientside setting is set to C<256>
 537 (see L<DBD::Sybase/maxConnect>.) You can override it to whatever setting you
 538 like in the DSN.
 539
 540 See
 541 L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
 542 for information on changing the setting on the server side.
 543
 544 =head1 DATES
 545
 546 See L</connect_call_datetime_setup> to setup date formats
 547 for L<DBIx::Class::InflateColumn::DateTime>.
 548
 549 =head1 IMAGE AND TEXT COLUMNS
 550
 551 L<DBD::Sybase> compiled with FreeTDS will B<NOT> allow you to insert or update
 552 C<TEXT/IMAGE> columns.
 553
 554 C<< $dbh->{LongReadLen} >> will also not work with FreeTDS use:
 555
 556   $schema->storage->dbh->do("SET TEXTSIZE <bytes>")
 557
 558 instead.
 559
 560 See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
 561 setting you need to work with C<IMAGE> columns.
 562
 563 =head1 AUTHORS
 564
 565 See L<DBIx::Class/CONTRIBUTORS>.
 566
 567 =head1 LICENSE
 568
 569 You may distribute this code under the same terms as Perl itself.
 570
 571 =cut
 572 # vim:sts=2 sw=2: