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