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::Common
   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->_get_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->_typeless_placeholders_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
 423     my %where = map { ($_, $row{$_}) } @primary_cols;
 424     my $cursor = $source->resultset->search(\%where, {
 425       select => [$col]
 426     })->cursor;
 427     $cursor->next;
 428     my $sth = $cursor->sth;
 429
 430     eval {
 431       do {
 432         $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
 433       } while $sth->fetch;
 434
 435       $sth->func('ct_prepare_send') or die $sth->errstr;
 436
 437       my $log_on_update = $self->_blob_log_on_update;
 438       $log_on_update    = 1 if not defined $log_on_update;
 439
 440       $sth->func('CS_SET', 1, {
 441         total_txtlen => length($blob),
 442         log_on_update => $log_on_update
 443       }, 'ct_data_info') or die $sth->errstr;
 444
 445       $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
 446
 447       $sth->func('ct_finish_send') or die $sth->errstr;
 448     };
 449     my $exception = $@;
 450     $sth->finish if $sth;
 451     if ($exception) {
 452       if ($self->using_freetds) {
 453         croak
 454 "TEXT/IMAGE operation failed, probably because you're using FreeTDS: " .
 455 $exception;
 456       } else {
 457         croak $exception;
 458       }
 459     }
 460   }
 461 }
 462
 463 =head2 connect_call_datetime_setup
 464
 465 Used as:
 466
 467   on_connect_call => 'datetime_setup'
 468
 469 In L<DBIx::Class::Storage::DBI/connect_info> to set:
 470
 471   $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
 472   $dbh->do('set dateformat mdy');   # input fmt:  08/13/1979 18:08:55.080
 473
 474 On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
 475 L<DateTime::Format::Sybase>, which you will need to install.
 476
 477 This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
 478 C<SMALLDATETIME> columns only have minute precision.
 479
 480 =cut
 481
 482 {
 483   my $old_dbd_warned = 0;
 484
 485   sub connect_call_datetime_setup {
 486     my $self = shift;
 487     my $dbh = $self->_dbh;
 488
 489     if ($dbh->can('syb_date_fmt')) {
 490 # amazingly, this works with FreeTDS
 491       $dbh->syb_date_fmt('ISO_strict');
 492     } elsif (not $old_dbd_warned) {
 493       carp "Your DBD::Sybase is too old to support ".
 494       "DBIx::Class::InflateColumn::DateTime, please upgrade!";
 495       $old_dbd_warned = 1;
 496     }
 497
 498     $dbh->do('SET DATEFORMAT mdy');
 499
 500     1;
 501   }
 502 }
 503
 504 sub datetime_parser_type { "DateTime::Format::Sybase" }
 505
 506 # ->begin_work and such have no effect with FreeTDS but we run them anyway to
 507 # let the DBD keep any state it needs to.
 508 #
 509 # If they ever do start working, the extra statements will do no harm (because
 510 # Sybase supports nested transactions.)
 511
 512 sub _dbh_begin_work {
 513   my $self = shift;
 514   $self->next::method(@_);
 515   if ($self->using_freetds) {
 516     $self->dbh->do('BEGIN TRAN');
 517   }
 518 }
 519
 520 sub _dbh_commit {
 521   my $self = shift;
 522   if ($self->using_freetds) {
 523     $self->_dbh->do('COMMIT');
 524   }
 525   return $self->next::method(@_);
 526 }
 527
 528 sub _dbh_rollback {
 529   my $self = shift;
 530   if ($self->using_freetds) {
 531     $self->_dbh->do('ROLLBACK');
 532   }
 533   return $self->next::method(@_);
 534 }
 535
 536 # savepoint support using ASE syntax
 537
 538 sub _svp_begin {
 539   my ($self, $name) = @_;
 540
 541   $self->dbh->do("SAVE TRANSACTION $name");
 542 }
 543
 544 # A new SAVE TRANSACTION with the same name releases the previous one.
 545 sub _svp_release { 1 }
 546
 547 sub _svp_rollback {
 548   my ($self, $name) = @_;
 549
 550   $self->dbh->do("ROLLBACK TRANSACTION $name");
 551 }
 552
 553 1;
 554
 555 =head1 Schema::Loader Support
 556
 557 There is an experimental branch of L<DBIx::Class::Schema::Loader> that will
 558 allow you to dump a schema from most (if not all) versions of Sybase.
 559
 560 It is available via subversion from:
 561
 562   http://dev.catalyst.perl.org/repos/bast/branches/DBIx-Class-Schema-Loader/mssql_tweaks
 563
 564 =head1 FreeTDS
 565
 566 This driver supports L<DBD::Sybase> compiled against FreeTDS
 567 (L<http://www.freetds.org/>) to the best of our ability, however it is
 568 recommended that you recompile L<DBD::Sybase> against the Sybase Open Client
 569 libraries. They are a part of the Sybase ASE distribution:
 570
 571 The Open Client FAQ is here:
 572 L<http://www.isug.com/Sybase_FAQ/ASE/section7.html>.
 573
 574 Sybase ASE for Linux (which comes with the Open Client libraries) may be
 575 downloaded here: L<http://response.sybase.com/forms/ASE_Linux_Download>.
 576
 577 To see if you're using FreeTDS check C<< $schema->storage->using_freetds >>, or run:
 578
 579   perl -MDBI -le 'my $dbh = DBI->connect($dsn, $user, $pass); print $dbh->{syb_oc_version}'
 580
 581 Some versions of the libraries involved will not support placeholders, in which
 582 case the storage will be reblessed to
 583 L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>.
 584
 585 In some configurations, placeholders will work but will throw implicit
 586 conversion errors for anything that's not expecting a string. In such a case,
 587 the C<auto_cast> option is automatically set, which you may enable yourself with
 588 L</connect_call_set_auto_cast> (see the description of that method for more
 589 details.)
 590
 591 In other configurations, placeholers will work just as they do with the Sybase
 592 Open Client libraries.
 593
 594 Inserts or updates of TEXT/IMAGE columns will B<NOT> work with FreeTDS.
 595
 596 =head1 MAXIMUM CONNECTIONS
 597
 598 The TDS protocol makes separate connections to the server for active statements
 599 in the background. By default the number of such connections is limited to 25,
 600 on both the client side and the server side.
 601
 602 This is a bit too low for a complex L<DBIx::Class> application, so on connection
 603 the client side setting is set to C<256> (see L<DBD::Sybase/maxConnect>.) You
 604 can override it to whatever setting you like in the DSN.
 605
 606 See
 607 L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
 608 for information on changing the setting on the server side.
 609
 610 =head1 DATES
 611
 612 See L</connect_call_datetime_setup> to setup date formats
 613 for L<DBIx::Class::InflateColumn::DateTime>.
 614
 615 =head1 TEXT/IMAGE COLUMNS
 616
 617 L<DBD::Sybase> compiled with FreeTDS will B<NOT> allow you to insert or update
 618 C<TEXT/IMAGE> columns.
 619
 620 Setting C<< $dbh->{LongReadLen} >> will also not work with FreeTDS use either:
 621
 622   $schema->storage->dbh->do("SET TEXTSIZE $bytes");
 623
 624 or
 625
 626   $schema->storage->set_textsize($bytes);
 627
 628 instead.
 629
 630 However, the C<LongReadLen> you pass in
 631 L<DBIx::Class::Storage::DBI/connect_info> is used to execute the equivalent
 632 C<SET TEXTSIZE> command on connection.
 633
 634 See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
 635 setting you need to work with C<IMAGE> columns.
 636
 637 =head1 AUTHORS
 638
 639 See L<DBIx::Class/CONTRIBUTORS>.
 640
 641 =head1 LICENSE
 642
 643 You may distribute this code under the same terms as Perl itself.
 644
 645 =cut
 646 # vim:sts=2 sw=2: