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