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