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::Base
   8     DBIx::Class::Storage::DBI
   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/
  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)>.
  36
  37 But your queries will be cached.
  38
  39 You need a version of L<DBD::Sybase> compiled with the Sybase OpenClient
  40 libraries, B<NOT> FreeTDS, for placeholder support. Otherwise your storage will
  41 be automatically reblessed into C<::NoBindVars>.
  42
  43 A recommended L<DBIx::Class::Storage::DBI/connect_info> setting:
  44
  45   on_connect_call => [['datetime_setup'], ['blob_setup', log_on_update => 0]]
  46
  47 =head1 METHODS
  48
  49 =cut
  50
  51 sub _rebless {
  52   my $self = shift;
  53
  54   if (ref($self) eq 'DBIx::Class::Storage::DBI::Sybase') {
  55     my $dbtype = eval {
  56       @{$self->dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
  57     } || '';
  58
  59     my $exception = $@;
  60     $dbtype =~ s/\W/_/gi;
  61     my $subclass = "DBIx::Class::Storage::DBI::Sybase::${dbtype}";
  62
  63     if (!$exception && $dbtype && $self->load_optional_class($subclass)) {
  64       bless $self, $subclass;
  65       $self->_rebless;
  66     } else { # real Sybase
  67       my $no_bind_vars = 'DBIx::Class::Storage::DBI::Sybase::NoBindVars';
  68
  69       if ($self->_using_freetds) {
  70         carp <<'EOF';
  71
  72 Your version of Sybase potentially supports placeholders and query caching,
  73 however you seem to be using FreeTDS which does not (yet?) support this.
  74
  75 Please recompile DBD::Sybase with the Sybase OpenClient libraries if you want
  76 these features.
  77
  78 TEXT/IMAGE column support will also not work under FreeTDS.
  79
  80 See perldoc DBIx::Class::Storage::DBI::Sybase for more details.
  81 EOF
  82         $self->ensure_class_loaded($no_bind_vars);
  83         bless $self, $no_bind_vars;
  84         $self->_rebless;
  85       }
  86
  87       if (not $self->dbh->{syb_dynamic_supported}) {
  88         $self->ensure_class_loaded($no_bind_vars);
  89         bless $self, $no_bind_vars;
  90         $self->_rebless;
  91       }
  92
  93       $self->_set_maxConnect;
  94     }
  95   }
  96 }
  97
  98 sub _using_freetds {
  99   my $self = shift;
 100
 101   return $self->_dbh->{syb_oc_version} =~ /freetds/i;
 102 }
 103
 104 sub _set_maxConnect {
 105   my $self = shift;
 106
 107   my $dsn = $self->_dbi_connect_info->[0];
 108
 109   return if ref($dsn) eq 'CODE';
 110
 111   if ($dsn !~ /maxConnect=/) {
 112     $self->_dbi_connect_info->[0] = "$dsn;maxConnect=256";
 113     my $connected = defined $self->_dbh;
 114     $self->disconnect;
 115     $self->ensure_connected if $connected;
 116   }
 117 }
 118
 119 =head2 connect_call_blob_setup
 120
 121 Used as:
 122
 123   on_connect_call => [ [ 'blob_setup', log_on_update => 0 ] ]
 124
 125 Does C<< $dbh->{syb_binary_images} = 1; >> to return C<IMAGE> data as raw binary
 126 instead of as a hex string.
 127
 128 Recommended.
 129
 130 Also sets the C<log_on_update> value for blob write operations. The default is
 131 C<1>, but C<0> is better if your database is configured for it.
 132
 133 See
 134 L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.
 135
 136 =cut
 137
 138 sub connect_call_blob_setup {
 139   my $self = shift;
 140   my %args = @_;
 141   my $dbh = $self->_dbh;
 142   $dbh->{syb_binary_images} = 1;
 143
 144   $self->_blob_log_on_update($args{log_on_update})
 145     if exists $args{log_on_update};
 146 }
 147
 148 sub _is_lob_type {
 149   my $self = shift;
 150   my $type = shift;
 151   $type && $type =~ /(?:text|image|lob|bytea|binary|memo)/i;
 152 }
 153
 154 ## This will be useful if we ever implement BLOB filehandle inflation and will
 155 ## need to use the API, but for now it isn't.
 156 #
 157 #sub order_columns_for_select {
 158 #  my ($self, $source, $columns) = @_;
 159 #
 160 #  my (@non_blobs, @blobs);
 161 #
 162 #  for my $col (@$columns) {
 163 #    if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
 164 #      push @blobs, $col;
 165 #    } else {
 166 #      push @non_blobs, $col;
 167 #    }
 168 #  }
 169 #
 170 #  croak "cannot select more than a one TEXT/IMAGE column at a time"
 171 #    if @blobs > 1;
 172 #
 173 #  return (@non_blobs, @blobs);
 174 #}
 175
 176 # the select-piggybacking-on-insert trick stolen from odbc/mssql
 177 sub _prep_for_execute {
 178   my $self = shift;
 179   my ($op, $extra_bind, $ident, $args) = @_;
 180
 181   my ($sql, $bind) = $self->next::method (@_);
 182
 183   if ($op eq 'insert') {
 184     my $table = $ident->from;
 185
 186     my $bind_info = $self->_resolve_column_info($ident, [map $_->[0], @{$bind}]);
 187     my $identity_col =
 188 List::Util::first { $bind_info->{$_}{is_auto_increment} } (keys %$bind_info);
 189
 190     if ($identity_col) {
 191       $sql =
 192 "SET IDENTITY_INSERT $table ON\n" .
 193 "$sql\n" .
 194 "SET IDENTITY_INSERT $table OFF"
 195     } else {
 196       $identity_col = List::Util::first {
 197         $ident->column_info($_)->{is_auto_increment}
 198       } $ident->columns;
 199     }
 200
 201     if ($identity_col) {
 202 # Sybase has nested transactions, only the outermost is actually committed
 203       $sql =
 204         "BEGIN TRANSACTION\n" .
 205         "$sql\n" .
 206         $self->_fetch_identity_sql($ident, $identity_col) . "\n" .
 207         "COMMIT";
 208     }
 209   }
 210
 211   return ($sql, $bind);
 212 }
 213
 214 sub _fetch_identity_sql {
 215   my ($self, $source, $col) = @_;
 216
 217   return "SELECT MAX($col) FROM ".$source->from;
 218 }
 219
 220 sub _execute {
 221   my $self = shift;
 222   my ($op) = @_;
 223
 224   my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
 225
 226   if ($op eq 'insert') {
 227     $self->_identity($sth->fetchrow_array);
 228     $sth->finish;
 229   }
 230
 231   return wantarray ? ($rv, $sth, @bind) : $rv;
 232 }
 233
 234 sub last_insert_id { shift->_identity }
 235
 236 # override to handle TEXT/IMAGE
 237 sub insert {
 238   my ($self, $source, $to_insert) = splice @_, 0, 3;
 239   my $dbh = $self->_dbh;
 240
 241   my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
 242
 243   my $updated_cols = $self->next::method($source, $to_insert, @_);
 244
 245   $self->_insert_blobs($source, $blob_cols, $to_insert) if %$blob_cols;
 246
 247   return $updated_cols;
 248 }
 249
 250 sub update {
 251   my ($self, $source)  = splice @_, 0, 2;
 252   my ($fields, $where) = @_;
 253   my $wantarray        = wantarray;
 254
 255   my $blob_cols = $self->_remove_blob_cols($source, $fields);
 256
 257   my @res;
 258   if ($wantarray) {
 259     @res    = $self->next::method($source, @_);
 260   } else {
 261     $res[0] = $self->next::method($source, @_);
 262   }
 263
 264   $self->_update_blobs($source, $blob_cols, $where) if %$blob_cols;
 265
 266   return $wantarray ? @res : $res[0];
 267 }
 268
 269 sub _remove_blob_cols {
 270   my ($self, $source, $fields) = @_;
 271
 272   my %blob_cols;
 273
 274   for my $col (keys %$fields) {
 275     if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
 276       $blob_cols{$col} = delete $fields->{$col};
 277       $fields->{$col} = \"''";
 278     }
 279   }
 280
 281   return \%blob_cols;
 282 }
 283
 284 sub _update_blobs {
 285   my ($self, $source, $blob_cols, $where) = @_;
 286
 287   my (@primary_cols) = $source->primary_columns;
 288
 289   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 290     unless @primary_cols;
 291
 292 # check if we're updating a single row by PK
 293   my $pk_cols_in_where = 0;
 294   for my $col (@primary_cols) {
 295     $pk_cols_in_where++ if defined $where->{$col};
 296   }
 297   my @rows;
 298
 299   if ($pk_cols_in_where == @primary_cols) {
 300     my %row_to_update;
 301     @row_to_update{@primary_cols} = @{$where}{@primary_cols};
 302     @rows = \%row_to_update;
 303   } else {
 304     my $rs = $source->resultset->search(
 305       $where,
 306       {
 307         result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 308         select => \@primary_cols
 309       }
 310     );
 311     @rows = $rs->all; # statement must finish
 312   }
 313
 314   for my $row (@rows) {
 315     $self->_insert_blobs($source, $blob_cols, $row);
 316   }
 317 }
 318
 319 sub _insert_blobs {
 320   my ($self, $source, $blob_cols, $row) = @_;
 321   my $dbh = $self->dbh;
 322
 323   my $table = $source->from;
 324
 325   my %row = %$row;
 326   my (@primary_cols) = $source->primary_columns;
 327
 328   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 329     unless @primary_cols;
 330
 331   if ((grep { defined $row{$_} } @primary_cols) != @primary_cols) {
 332     if (@primary_cols == 1) {
 333       my $col = $primary_cols[0];
 334       $row{$col} = $self->last_insert_id($source, $col);
 335     } else {
 336       croak "Cannot update TEXT/IMAGE column(s) without primary key values";
 337     }
 338   }
 339
 340   for my $col (keys %$blob_cols) {
 341     my $blob = $blob_cols->{$col};
 342     my $sth;
 343
 344     if (not $self->isa('DBIx::Class::Storage::DBI::NoBindVars')) {
 345       my $search_cond = join ',' => map "$_ = ?", @primary_cols;
 346
 347       $sth = $self->sth(
 348         "select $col from $table where $search_cond"
 349       );
 350       $sth->execute(map $row{$_}, @primary_cols);
 351     } else {
 352       my $search_cond = join ',' => map "$_ = $row{$_}", @primary_cols;
 353
 354       $sth = $dbh->prepare(
 355         "select $col from $table where $search_cond"
 356       );
 357       $sth->execute;
 358     }
 359
 360     eval {
 361       while ($sth->fetch) {
 362         $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
 363       }
 364       $sth->func('ct_prepare_send') or die $sth->errstr;
 365
 366       my $log_on_update = $self->_blob_log_on_update;
 367       $log_on_update    = 1 if not defined $log_on_update;
 368
 369       $sth->func('CS_SET', 1, {
 370         total_txtlen => length($blob),
 371         log_on_update => $log_on_update
 372       }, 'ct_data_info') or die $sth->errstr;
 373
 374       $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
 375
 376       $sth->func('ct_finish_send') or die $sth->errstr;
 377     };
 378     my $exception = $@;
 379     $sth->finish;
 380     croak $exception if $exception;
 381   }
 382 }
 383
 384 =head2 connect_call_datetime_setup
 385
 386 Used as:
 387
 388   on_connect_call => 'datetime_setup'
 389
 390 In L<DBIx::Class::Storage::DBI/connect_info> to set:
 391
 392   $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
 393   $dbh->do('set dateformat mdy');   # input fmt:  08/13/1979 18:08:55.080
 394
 395 On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
 396 L<DateTime::Format::Sybase>, which you will need to install.
 397
 398 This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
 399 C<SMALLDATETIME> columns only have minute precision.
 400
 401 =cut
 402
 403 {
 404   my $old_dbd_warned = 0;
 405
 406   sub connect_call_datetime_setup {
 407     my $self = shift;
 408     my $dbh = $self->_dbh;
 409
 410     if ($dbh->can('syb_date_fmt')) {
 411       $dbh->syb_date_fmt('ISO_strict');
 412     } elsif (not $old_dbd_warned) {
 413       carp "Your DBD::Sybase is too old to support ".
 414       "DBIx::Class::InflateColumn::DateTime, please upgrade!";
 415       $old_dbd_warned = 1;
 416     }
 417
 418     $dbh->do('set dateformat mdy');
 419
 420     1;
 421   }
 422 }
 423
 424 sub datetime_parser_type { "DateTime::Format::Sybase" }
 425
 426 # savepoint support using ASE syntax
 427
 428 sub _svp_begin {
 429   my ($self, $name) = @_;
 430
 431   $self->dbh->do("SAVE TRANSACTION $name");
 432 }
 433
 434 # A new SAVE TRANSACTION with the same name releases the previous one.
 435 sub _svp_release { 1 }
 436
 437 sub _svp_rollback {
 438   my ($self, $name) = @_;
 439
 440   $self->dbh->do("ROLLBACK TRANSACTION $name");
 441 }
 442
 443 1;
 444
 445 =head1 MAXIMUM CONNECTIONS
 446
 447 L<DBD::Sybase> makes separate connections to the server for active statements in
 448 the background. By default the number of such connections is limited to 25, on
 449 both the client side and the server side.
 450
 451 This is a bit too low, so on connection the clientside setting is set to C<256>
 452 (see L<DBD::Sybase/maxConnect>.) You can override it to whatever setting you
 453 like in the DSN.
 454
 455 See
 456 L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
 457 for information on changing the setting on the server side.
 458
 459 =head1 DATES
 460
 461 See L</connect_call_datetime_setup> to setup date formats
 462 for L<DBIx::Class::InflateColumn::DateTime>.
 463
 464 =head1 IMAGE AND TEXT COLUMNS
 465
 466 L<DBD::Sybase> compiled with FreeTDS will B<NOT> work with C<TEXT/IMAGE>
 467 columns.
 468
 469 See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
 470 setting you need to work with C<IMAGE> columns.
 471
 472 =head1 AUTHORS
 473
 474 See L<DBIx::Class/CONTRIBUTORS>.
 475
 476 =head1 LICENSE
 477
 478 You may distribute this code under the same terms as Perl itself.
 479
 480 =cut
 481 # vim:sts=2 sw=2: