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