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