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