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