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 # override to handle TEXT/IMAGE and to do a transaction if necessary
 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   my $need_last_insert_id = 0;
 300
 301   my ($identity_col) =
 302     map $_->[0],
 303     grep $_->[1]{is_auto_increment},
 304     map [ $_, $source->column_info($_) ],
 305     $source->columns;
 306
 307   $need_last_insert_id = 1
 308     if $identity_col && (not exists $to_insert->{$identity_col});
 309
 310   # We have to do the insert in a transaction to avoid race conditions with the
 311   # SELECT MAX(COL) identity method used when placeholders are enabled.
 312   my $updated_cols = do {
 313     if ($need_last_insert_id && $self->insert_txn &&
 314         (not $self->{transaction_depth})) {
 315       my $guard = $self->txn_scope_guard;
 316       my $upd_cols = $self->next::method (@_);
 317       $guard->commit;
 318       $upd_cols;
 319     }
 320     else {
 321       $self->next::method(@_);
 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 = shift;
 332   my ($source, $fields, $where) = @_;
 333
 334   my $wantarray = wantarray;
 335
 336   my $blob_cols = $self->_remove_blob_cols($source, $fields);
 337
 338   my @res;
 339   if ($wantarray) {
 340     @res    = $self->next::method(@_);
 341   }
 342   elsif (defined $wantarray) {
 343     $res[0] = $self->next::method(@_);
 344   }
 345   else {
 346     $self->next::method(@_);
 347   }
 348
 349   $self->_update_blobs($source, $blob_cols, $where) if %$blob_cols;
 350
 351   return $wantarray ? @res : $res[0];
 352 }
 353
 354 sub _remove_blob_cols {
 355   my ($self, $source, $fields) = @_;
 356
 357   my %blob_cols;
 358
 359   for my $col (keys %$fields) {
 360     if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
 361       $blob_cols{$col} = delete $fields->{$col};
 362       $fields->{$col} = \"''";
 363     }
 364   }
 365
 366   return \%blob_cols;
 367 }
 368
 369 sub _update_blobs {
 370   my ($self, $source, $blob_cols, $where) = @_;
 371
 372   my (@primary_cols) = $source->primary_columns;
 373
 374   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 375     unless @primary_cols;
 376
 377 # check if we're updating a single row by PK
 378   my $pk_cols_in_where = 0;
 379   for my $col (@primary_cols) {
 380     $pk_cols_in_where++ if defined $where->{$col};
 381   }
 382   my @rows;
 383
 384   if ($pk_cols_in_where == @primary_cols) {
 385     my %row_to_update;
 386     @row_to_update{@primary_cols} = @{$where}{@primary_cols};
 387     @rows = \%row_to_update;
 388   } else {
 389     my $rs = $source->resultset->search(
 390       $where,
 391       {
 392         result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 393         select => \@primary_cols
 394       }
 395     );
 396     @rows = $rs->all; # statement must finish
 397   }
 398
 399   for my $row (@rows) {
 400     $self->_insert_blobs($source, $blob_cols, $row);
 401   }
 402 }
 403
 404 sub _insert_blobs {
 405   my ($self, $source, $blob_cols, $row) = @_;
 406   my $dbh = $self->_get_dbh;
 407
 408   my $table = $source->from;
 409
 410   my %row = %$row;
 411   my (@primary_cols) = $source->primary_columns;
 412
 413   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 414     unless @primary_cols;
 415
 416   if ((grep { defined $row{$_} } @primary_cols) != @primary_cols) {
 417     if (@primary_cols == 1) {
 418       my $col = $primary_cols[0];
 419       $row{$col} = $self->last_insert_id($source, $col);
 420     } else {
 421       croak "Cannot update TEXT/IMAGE column(s) without primary key values";
 422     }
 423   }
 424
 425   for my $col (keys %$blob_cols) {
 426     my $blob = $blob_cols->{$col};
 427
 428     my %where = map { ($_, $row{$_}) } @primary_cols;
 429     my $cursor = $source->resultset->search(\%where, {
 430       select => [$col]
 431     })->cursor;
 432     $cursor->next;
 433     my $sth = $cursor->sth;
 434
 435     eval {
 436       do {
 437         $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
 438       } while $sth->fetch;
 439
 440       $sth->func('ct_prepare_send') or die $sth->errstr;
 441
 442       my $log_on_update = $self->_blob_log_on_update;
 443       $log_on_update    = 1 if not defined $log_on_update;
 444
 445       $sth->func('CS_SET', 1, {
 446         total_txtlen => length($blob),
 447         log_on_update => $log_on_update
 448       }, 'ct_data_info') or die $sth->errstr;
 449
 450       $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
 451
 452       $sth->func('ct_finish_send') or die $sth->errstr;
 453     };
 454     my $exception = $@;
 455     $sth->finish if $sth;
 456     if ($exception) {
 457       if ($self->using_freetds) {
 458         croak (
 459           'TEXT/IMAGE operation failed, probably because you are using FreeTDS: '
 460           . $exception
 461         );
 462       } else {
 463         croak $exception;
 464       }
 465     }
 466   }
 467 }
 468
 469 =head2 connect_call_datetime_setup
 470
 471 Used as:
 472
 473   on_connect_call => 'datetime_setup'
 474
 475 In L<DBIx::Class::Storage::DBI/connect_info> to set:
 476
 477   $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
 478   $dbh->do('set dateformat mdy');   # input fmt:  08/13/1979 18:08:55.080
 479
 480 On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
 481 L<DateTime::Format::Sybase>, which you will need to install.
 482
 483 This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
 484 C<SMALLDATETIME> columns only have minute precision.
 485
 486 =cut
 487
 488 {
 489   my $old_dbd_warned = 0;
 490
 491   sub connect_call_datetime_setup {
 492     my $self = shift;
 493     my $dbh = $self->_dbh;
 494
 495     if ($dbh->can('syb_date_fmt')) {
 496       # amazingly, this works with FreeTDS
 497       $dbh->syb_date_fmt('ISO_strict');
 498     } elsif (not $old_dbd_warned) {
 499       carp "Your DBD::Sybase is too old to support ".
 500       "DBIx::Class::InflateColumn::DateTime, please upgrade!";
 501       $old_dbd_warned = 1;
 502     }
 503
 504     $dbh->do('SET DATEFORMAT mdy');
 505
 506     1;
 507   }
 508 }
 509
 510 sub datetime_parser_type { "DateTime::Format::Sybase" }
 511
 512 # ->begin_work and such have no effect with FreeTDS but we run them anyway to
 513 # let the DBD keep any state it needs to.
 514 #
 515 # If they ever do start working, the extra statements will do no harm (because
 516 # Sybase supports nested transactions.)
 517
 518 sub _dbh_begin_work {
 519   my $self = shift;
 520   $self->next::method(@_);
 521   if ($self->using_freetds) {
 522     $self->_get_dbh->do('BEGIN TRAN');
 523   }
 524 }
 525
 526 sub _dbh_commit {
 527   my $self = shift;
 528   if ($self->using_freetds) {
 529     $self->_dbh->do('COMMIT');
 530   }
 531   return $self->next::method(@_);
 532 }
 533
 534 sub _dbh_rollback {
 535   my $self = shift;
 536   if ($self->using_freetds) {
 537     $self->_dbh->do('ROLLBACK');
 538   }
 539   return $self->next::method(@_);
 540 }
 541
 542 # savepoint support using ASE syntax
 543
 544 sub _svp_begin {
 545   my ($self, $name) = @_;
 546
 547   $self->_get_dbh->do("SAVE TRANSACTION $name");
 548 }
 549
 550 # A new SAVE TRANSACTION with the same name releases the previous one.
 551 sub _svp_release { 1 }
 552
 553 sub _svp_rollback {
 554   my ($self, $name) = @_;
 555
 556   $self->_get_dbh->do("ROLLBACK TRANSACTION $name");
 557 }
 558
 559 1;
 560
 561 =head1 Schema::Loader Support
 562
 563 There is an experimental branch of L<DBIx::Class::Schema::Loader> that will
 564 allow you to dump a schema from most (if not all) versions of Sybase.
 565
 566 It is available via subversion from:
 567
 568   http://dev.catalyst.perl.org/repos/bast/branches/DBIx-Class-Schema-Loader/current/
 569
 570 =head1 FreeTDS
 571
 572 This driver supports L<DBD::Sybase> compiled against FreeTDS
 573 (L<http://www.freetds.org/>) to the best of our ability, however it is
 574 recommended that you recompile L<DBD::Sybase> against the Sybase Open Client
 575 libraries. They are a part of the Sybase ASE distribution:
 576
 577 The Open Client FAQ is here:
 578 L<http://www.isug.com/Sybase_FAQ/ASE/section7.html>.
 579
 580 Sybase ASE for Linux (which comes with the Open Client libraries) may be
 581 downloaded here: L<http://response.sybase.com/forms/ASE_Linux_Download>.
 582
 583 To see if you're using FreeTDS check C<< $schema->storage->using_freetds >>, or run:
 584
 585   perl -MDBI -le 'my $dbh = DBI->connect($dsn, $user, $pass); print $dbh->{syb_oc_version}'
 586
 587 Some versions of the libraries involved will not support placeholders, in which
 588 case the storage will be reblessed to
 589 L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>.
 590
 591 In some configurations, placeholders will work but will throw implicit type
 592 conversion errors for anything that's not expecting a string. In such a case,
 593 the C<auto_cast> option from L<DBIx::Class::Storage::DBI::AutoCast> is
 594 automatically set, which you may enable on connection with
 595 L<DBIx::Class::Storage::DBI::AutoCast/connect_call_set_auto_cast>. The type info
 596 for the C<CAST>s is taken from the L<DBIx::Class::ResultSource/data_type>
 597 definitions in your Result classes, and are mapped to a Sybase type (if it isn't
 598 already) using a mapping based on L<SQL::Translator>.
 599
 600 In other configurations, placeholers will work just as they do with the Sybase
 601 Open Client libraries.
 602
 603 Inserts or updates of TEXT/IMAGE columns will B<NOT> work with FreeTDS.
 604
 605 =head1 TRANSACTIONS
 606
 607 Due to limitations of the TDS protocol, L<DBD::Sybase>, or both; you cannot
 608 begin a transaction while there are active cursors. An active cursor is, for
 609 example, a L<ResultSet|DBIx::Class::ResultSet> that has been executed using
 610 C<next> or C<first> but has not been exhausted or
 611 L<reset|DBIx::Class::ResultSet/reset>.
 612
 613 Transactions done for inserts in C<AutoCommit> mode when placeholders are in use
 614 are also affected, so this won't work:
 615
 616   while (my $row = $rs1->next) {
 617     $rs2->create({ foo => $row->foo });
 618   }
 619
 620 Some workarounds:
 621
 622 =over 4
 623
 624 =item * set C<< $schema->storage->insert_txn(0) >> temporarily (see
 625 L</connect_call_unsafe_insert>)
 626
 627 =item * use L<DBIx::Class::Storage::DBI::Replicated>
 628
 629 =item * L<connect|DBIx::Class::Schema/connect> another L<Schema|DBIx::Class::Schema>
 630
 631 =item * load the data from your cursor with L<DBIx::Class::ResultSet/all>
 632
 633 =item * enlarge the scope of the transaction
 634
 635 =back
 636
 637 =head1 MAXIMUM CONNECTIONS
 638
 639 The TDS protocol makes separate connections to the server for active statements
 640 in the background. By default the number of such connections is limited to 25,
 641 on both the client side and the server side.
 642
 643 This is a bit too low for a complex L<DBIx::Class> application, so on connection
 644 the client side setting is set to C<256> (see L<DBD::Sybase/maxConnect>.) You
 645 can override it to whatever setting you like in the DSN.
 646
 647 See
 648 L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
 649 for information on changing the setting on the server side.
 650
 651 =head1 DATES
 652
 653 See L</connect_call_datetime_setup> to setup date formats
 654 for L<DBIx::Class::InflateColumn::DateTime>.
 655
 656 =head1 TEXT/IMAGE COLUMNS
 657
 658 L<DBD::Sybase> compiled with FreeTDS will B<NOT> allow you to insert or update
 659 C<TEXT/IMAGE> columns.
 660
 661 Setting C<< $dbh->{LongReadLen} >> will also not work with FreeTDS use either:
 662
 663   $schema->storage->dbh->do("SET TEXTSIZE $bytes");
 664
 665 or
 666
 667   $schema->storage->set_textsize($bytes);
 668
 669 instead.
 670
 671 However, the C<LongReadLen> you pass in
 672 L<DBIx::Class::Storage::DBI/connect_info> is used to execute the equivalent
 673 C<SET TEXTSIZE> command on connection.
 674
 675 See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
 676 setting you need to work with C<IMAGE> columns.
 677
 678 =head1 AUTHOR
 679
 680 See L<DBIx::Class/CONTRIBUTORS>.
 681
 682 =head1 LICENSE
 683
 684 You may distribute this code under the same terms as Perl itself.
 685
 686 =cut
 687 # vim:sts=2 sw=2: