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/
  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       if ($self->_using_freetds) {
  70         carp <<'EOF';
  71
  72 Your version of Sybase potentially supports placeholders and query caching,
  73 however you seem to be using FreeTDS which does not (yet?) support this.
  74
  75 Please recompile DBD::Sybase with the Sybase OpenClient libraries if you want
  76 these features.
  77
  78 TEXT/IMAGE column support will also not work under FreeTDS.
  79
  80 See perldoc DBIx::Class::Storage::DBI::Sybase for more details.
  81 EOF
  82         $self->ensure_class_loaded($no_bind_vars);
  83         bless $self, $no_bind_vars;
  84         $self->_rebless;
  85       }
  86
  87       if (not $self->dbh->{syb_dynamic_supported}) {
  88         $self->ensure_class_loaded($no_bind_vars);
  89         bless $self, $no_bind_vars;
  90         $self->_rebless;
  91       }
  92
  93       $self->_set_maxConnect;
  94     }
  95   }
  96 }
  97
  98 # Make sure we have CHAINED mode turned on, we don't know how DBD::Sybase was
  99 # compiled.
 100 sub _populate_dbh {
 101   my $self = shift;
 102   $self->next::method(@_);
 103   $self->_dbh->{syb_chained_txn} = 1;
 104 }
 105
 106 sub _using_freetds {
 107   my $self = shift;
 108
 109   return $self->_dbh->{syb_oc_version} =~ /freetds/i;
 110 }
 111
 112 sub _set_maxConnect {
 113   my $self = shift;
 114
 115   my $dsn = $self->_dbi_connect_info->[0];
 116
 117   return if ref($dsn) eq 'CODE';
 118
 119   if ($dsn !~ /maxConnect=/) {
 120     $self->_dbi_connect_info->[0] = "$dsn;maxConnect=256";
 121     my $connected = defined $self->_dbh;
 122     $self->disconnect;
 123     $self->ensure_connected if $connected;
 124   }
 125 }
 126
 127 =head2 connect_call_blob_setup
 128
 129 Used as:
 130
 131   on_connect_call => [ [ 'blob_setup', log_on_update => 0 ] ]
 132
 133 Does C<< $dbh->{syb_binary_images} = 1; >> to return C<IMAGE> data as raw binary
 134 instead of as a hex string.
 135
 136 Recommended.
 137
 138 Also sets the C<log_on_update> value for blob write operations. The default is
 139 C<1>, but C<0> is better if your database is configured for it.
 140
 141 See
 142 L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.
 143
 144 =cut
 145
 146 sub connect_call_blob_setup {
 147   my $self = shift;
 148   my %args = @_;
 149   my $dbh = $self->_dbh;
 150   $dbh->{syb_binary_images} = 1;
 151
 152   $self->_blob_log_on_update($args{log_on_update})
 153     if exists $args{log_on_update};
 154 }
 155
 156 sub _is_lob_type {
 157   my $self = shift;
 158   my $type = shift;
 159   $type && $type =~ /(?:text|image|lob|bytea|binary|memo)/i;
 160 }
 161
 162 ## This will be useful if we ever implement BLOB filehandle inflation and will
 163 ## need to use the API, but for now it isn't.
 164 #
 165 #sub order_columns_for_select {
 166 #  my ($self, $source, $columns) = @_;
 167 #
 168 #  my (@non_blobs, @blobs);
 169 #
 170 #  for my $col (@$columns) {
 171 #    if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
 172 #      push @blobs, $col;
 173 #    } else {
 174 #      push @non_blobs, $col;
 175 #    }
 176 #  }
 177 #
 178 #  croak "cannot select more than a one TEXT/IMAGE column at a time"
 179 #    if @blobs > 1;
 180 #
 181 #  return (@non_blobs, @blobs);
 182 #}
 183
 184 # the select-piggybacking-on-insert trick stolen from odbc/mssql
 185 sub _prep_for_execute {
 186   my $self = shift;
 187   my ($op, $extra_bind, $ident, $args) = @_;
 188
 189   my ($sql, $bind) = $self->next::method (@_);
 190
 191   if ($op eq 'insert') {
 192     my $table = $ident->from;
 193
 194     my $bind_info = $self->_resolve_column_info($ident, [map $_->[0], @{$bind}]);
 195     my $identity_col =
 196 List::Util::first { $bind_info->{$_}{is_auto_increment} } (keys %$bind_info);
 197
 198     if ($identity_col) {
 199       $sql =
 200 "SET IDENTITY_INSERT $table ON\n" .
 201 "$sql\n" .
 202 "SET IDENTITY_INSERT $table OFF"
 203     } else {
 204       $identity_col = List::Util::first {
 205         $ident->column_info($_)->{is_auto_increment}
 206       } $ident->columns;
 207     }
 208
 209     if ($identity_col) {
 210       $sql =
 211         "$sql\n" .
 212         $self->_fetch_identity_sql($ident, $identity_col) . "\n";
 213     }
 214   }
 215
 216   return ($sql, $bind);
 217 }
 218
 219 sub _fetch_identity_sql {
 220   my ($self, $source, $col) = @_;
 221
 222   return "SELECT MAX($col) FROM ".$source->from;
 223 }
 224
 225 sub _execute {
 226   my $self = shift;
 227   my ($op) = @_;
 228
 229   my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
 230
 231   if ($op eq 'insert') {
 232     $self->_identity($sth->fetchrow_array);
 233     $sth->finish;
 234   }
 235
 236   return wantarray ? ($rv, $sth, @bind) : $rv;
 237 }
 238
 239 sub last_insert_id { shift->_identity }
 240
 241 # override to handle TEXT/IMAGE and nested txn
 242 sub insert {
 243   my ($self, $source, $to_insert) = splice @_, 0, 3;
 244   my $dbh = $self->_dbh;
 245
 246   my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
 247
 248 # Sybase has nested transactions fortunately, because we have to do the insert
 249 # in a transaction to avoid race conditions with the SELECT MAX(COL) identity
 250 # method used when placeholders are enabled.
 251   my $updated_cols = do {
 252     local $self->{auto_savepoint} = 1;
 253     my $args = \@_;
 254     my $method = $self->next::can;
 255     $self->txn_do(
 256       sub { $self->$method($source, $to_insert, @$args) }
 257     );
 258   };
 259
 260   $self->_insert_blobs($source, $blob_cols, $to_insert) if %$blob_cols;
 261
 262   return $updated_cols;
 263 }
 264
 265 sub update {
 266   my ($self, $source)  = splice @_, 0, 2;
 267   my ($fields, $where) = @_;
 268   my $wantarray        = wantarray;
 269
 270   my $blob_cols = $self->_remove_blob_cols($source, $fields);
 271
 272   my @res;
 273   if ($wantarray) {
 274     @res    = $self->next::method($source, @_);
 275   } else {
 276     $res[0] = $self->next::method($source, @_);
 277   }
 278
 279   $self->_update_blobs($source, $blob_cols, $where) if %$blob_cols;
 280
 281   return $wantarray ? @res : $res[0];
 282 }
 283
 284 sub _remove_blob_cols {
 285   my ($self, $source, $fields) = @_;
 286
 287   my %blob_cols;
 288
 289   for my $col (keys %$fields) {
 290     if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
 291       $blob_cols{$col} = delete $fields->{$col};
 292       $fields->{$col} = \"''";
 293     }
 294   }
 295
 296   return \%blob_cols;
 297 }
 298
 299 sub _update_blobs {
 300   my ($self, $source, $blob_cols, $where) = @_;
 301
 302   my (@primary_cols) = $source->primary_columns;
 303
 304   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 305     unless @primary_cols;
 306
 307 # check if we're updating a single row by PK
 308   my $pk_cols_in_where = 0;
 309   for my $col (@primary_cols) {
 310     $pk_cols_in_where++ if defined $where->{$col};
 311   }
 312   my @rows;
 313
 314   if ($pk_cols_in_where == @primary_cols) {
 315     my %row_to_update;
 316     @row_to_update{@primary_cols} = @{$where}{@primary_cols};
 317     @rows = \%row_to_update;
 318   } else {
 319     my $rs = $source->resultset->search(
 320       $where,
 321       {
 322         result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 323         select => \@primary_cols
 324       }
 325     );
 326     @rows = $rs->all; # statement must finish
 327   }
 328
 329   for my $row (@rows) {
 330     $self->_insert_blobs($source, $blob_cols, $row);
 331   }
 332 }
 333
 334 sub _insert_blobs {
 335   my ($self, $source, $blob_cols, $row) = @_;
 336   my $dbh = $self->dbh;
 337
 338   my $table = $source->from;
 339
 340   my %row = %$row;
 341   my (@primary_cols) = $source->primary_columns;
 342
 343   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 344     unless @primary_cols;
 345
 346   if ((grep { defined $row{$_} } @primary_cols) != @primary_cols) {
 347     if (@primary_cols == 1) {
 348       my $col = $primary_cols[0];
 349       $row{$col} = $self->last_insert_id($source, $col);
 350     } else {
 351       croak "Cannot update TEXT/IMAGE column(s) without primary key values";
 352     }
 353   }
 354
 355   for my $col (keys %$blob_cols) {
 356     my $blob = $blob_cols->{$col};
 357     my $sth;
 358
 359     if (not $self->isa('DBIx::Class::Storage::DBI::NoBindVars')) {
 360       my $search_cond = join ',' => map "$_ = ?", @primary_cols;
 361
 362       $sth = $self->sth(
 363         "select $col from $table where $search_cond"
 364       );
 365       $sth->execute(map $row{$_}, @primary_cols);
 366     } else {
 367       my $search_cond = join ',' => map "$_ = $row{$_}", @primary_cols;
 368
 369       $sth = $dbh->prepare(
 370         "select $col from $table where $search_cond"
 371       );
 372       $sth->execute;
 373     }
 374
 375     eval {
 376       while ($sth->fetch) {
 377         $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
 378       }
 379       $sth->func('ct_prepare_send') or die $sth->errstr;
 380
 381       my $log_on_update = $self->_blob_log_on_update;
 382       $log_on_update    = 1 if not defined $log_on_update;
 383
 384       $sth->func('CS_SET', 1, {
 385         total_txtlen => length($blob),
 386         log_on_update => $log_on_update
 387       }, 'ct_data_info') or die $sth->errstr;
 388
 389       $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
 390
 391       $sth->func('ct_finish_send') or die $sth->errstr;
 392     };
 393     my $exception = $@;
 394     $sth->finish;
 395     croak $exception if $exception;
 396   }
 397 }
 398
 399 =head2 connect_call_datetime_setup
 400
 401 Used as:
 402
 403   on_connect_call => 'datetime_setup'
 404
 405 In L<DBIx::Class::Storage::DBI/connect_info> to set:
 406
 407   $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
 408   $dbh->do('set dateformat mdy');   # input fmt:  08/13/1979 18:08:55.080
 409
 410 On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
 411 L<DateTime::Format::Sybase>, which you will need to install.
 412
 413 This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
 414 C<SMALLDATETIME> columns only have minute precision.
 415
 416 =cut
 417
 418 {
 419   my $old_dbd_warned = 0;
 420
 421   sub connect_call_datetime_setup {
 422     my $self = shift;
 423     my $dbh = $self->_dbh;
 424
 425     if ($dbh->can('syb_date_fmt')) {
 426       $dbh->syb_date_fmt('ISO_strict');
 427     } elsif (not $old_dbd_warned) {
 428       carp "Your DBD::Sybase is too old to support ".
 429       "DBIx::Class::InflateColumn::DateTime, please upgrade!";
 430       $old_dbd_warned = 1;
 431     }
 432
 433     $dbh->do('set dateformat mdy');
 434
 435     1;
 436   }
 437 }
 438
 439 sub datetime_parser_type { "DateTime::Format::Sybase" }
 440
 441 # savepoint support using ASE syntax
 442
 443 sub _svp_begin {
 444   my ($self, $name) = @_;
 445
 446   $self->dbh->do("SAVE TRANSACTION $name");
 447 }
 448
 449 # A new SAVE TRANSACTION with the same name releases the previous one.
 450 sub _svp_release { 1 }
 451
 452 sub _svp_rollback {
 453   my ($self, $name) = @_;
 454
 455   $self->dbh->do("ROLLBACK TRANSACTION $name");
 456 }
 457
 458 1;
 459
 460 =head1 MAXIMUM CONNECTIONS
 461
 462 L<DBD::Sybase> makes separate connections to the server for active statements in
 463 the background. By default the number of such connections is limited to 25, on
 464 both the client side and the server side.
 465
 466 This is a bit too low, so on connection the clientside setting is set to C<256>
 467 (see L<DBD::Sybase/maxConnect>.) You can override it to whatever setting you
 468 like in the DSN.
 469
 470 See
 471 L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
 472 for information on changing the setting on the server side.
 473
 474 =head1 DATES
 475
 476 See L</connect_call_datetime_setup> to setup date formats
 477 for L<DBIx::Class::InflateColumn::DateTime>.
 478
 479 =head1 IMAGE AND TEXT COLUMNS
 480
 481 L<DBD::Sybase> compiled with FreeTDS will B<NOT> work with C<TEXT/IMAGE>
 482 columns.
 483
 484 See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
 485 setting you need to work with C<IMAGE> columns.
 486
 487 =head1 AUTHORS
 488
 489 See L<DBIx::Class/CONTRIBUTORS>.
 490
 491 =head1 LICENSE
 492
 493 You may distribute this code under the same terms as Perl itself.
 494
 495 =cut
 496 # vim:sts=2 sw=2: