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 =head1 NAME
  15
  16 DBIx::Class::Storage::DBI::Sybase - Sybase support for DBIx::Class
  17
  18 =head1 SYNOPSIS
  19
  20 This subclass supports L<DBD::Sybase> for real Sybase databases.  If you are
  21 using an MSSQL database via L<DBD::Sybase>, your storage will be reblessed to
  22 L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
  23
  24 =head1 DESCRIPTION
  25
  26 If your version of Sybase does not support placeholders, then your storage
  27 will be reblessed to L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>. You can
  28 also enable that driver explicitly, see the documentation for more details.
  29
  30 With this driver there is unfortunately no way to get the C<last_insert_id>
  31 without doing a C<select max(col)>.
  32
  33 But your queries will be cached.
  34
  35 You need a version of L<DBD::Sybase> compiled with the Sybase OpenClient
  36 libraries, B<NOT> FreeTDS, for placeholder support. Otherwise your storage will
  37 be automatically reblessed into C<::NoBindVars>.
  38
  39 A recommended L<DBIx::Class::Storage::DBI/connect_info> setting:
  40
  41   on_connect_call => [['datetime_setup'], ['blob_setup', log_on_update => 0]]
  42
  43 =head1 METHODS
  44
  45 =cut
  46
  47 __PACKAGE__->mk_group_accessors('simple' =>
  48     qw/_blob_log_on_update/
  49 );
  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 # override to handle TEXT/IMAGE
 177 sub insert {
 178   my ($self, $source, $to_insert) = splice @_, 0, 3;
 179   my $dbh = $self->_dbh;
 180
 181   my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
 182
 183 # check if we need to set IDENTITY_INSERT
 184   my $identity_insert = 0;
 185   my %col_info = map { ($_, $source->column_info($_)) } keys %$to_insert;
 186   my $table    = $source->from;
 187
 188   if (List::Util::first { $_->{is_auto_increment} } (values %col_info)) {
 189     $identity_insert = 1;
 190     $dbh->do("SET IDENTITY_INSERT $table ON");
 191   }
 192
 193   my $updated_cols = $self->next::method($source, $to_insert, @_);
 194
 195   $dbh->do("SET IDENTITY_INSERT $table OFF") if $identity_insert;
 196
 197   $self->_insert_blobs($source, $blob_cols, $to_insert) if %$blob_cols;
 198
 199   return $updated_cols;
 200 }
 201
 202 sub update {
 203   my ($self, $source)  = splice @_, 0, 2;
 204   my ($fields, $where) = @_;
 205   my $wantarray        = wantarray;
 206
 207   my $blob_cols = $self->_remove_blob_cols($source, $fields);
 208
 209   my @res;
 210   if ($wantarray) {
 211     @res    = $self->next::method($source, @_);
 212   } else {
 213     $res[0] = $self->next::method($source, @_);
 214   }
 215
 216   $self->_update_blobs($source, $blob_cols, $where) if %$blob_cols;
 217
 218   return $wantarray ? @res : $res[0];
 219 }
 220
 221 sub _remove_blob_cols {
 222   my ($self, $source, $fields) = @_;
 223
 224   my %blob_cols;
 225
 226   for my $col (keys %$fields) {
 227     if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
 228       $blob_cols{$col} = delete $fields->{$col};
 229       $fields->{$col} = \"''";
 230     }
 231   }
 232
 233   return \%blob_cols;
 234 }
 235
 236 sub _update_blobs {
 237   my ($self, $source, $blob_cols, $where) = @_;
 238
 239   my (@primary_cols) = $source->primary_columns;
 240
 241   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 242     unless @primary_cols;
 243
 244 # check if we're updating a single row by PK
 245   my $pk_cols_in_where = 0;
 246   for my $col (@primary_cols) {
 247     $pk_cols_in_where++ if defined $where->{$col};
 248   }
 249   my @rows;
 250
 251   if ($pk_cols_in_where == @primary_cols) {
 252     my %row_to_update;
 253     @row_to_update{@primary_cols} = @{$where}{@primary_cols};
 254     @rows = \%row_to_update;
 255   } else {
 256     my $rs = $source->resultset->search(
 257       $where,
 258       {
 259         result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 260         select => \@primary_cols
 261       }
 262     );
 263     @rows = $rs->all; # statement must finish
 264   }
 265
 266   for my $row (@rows) {
 267     $self->_insert_blobs($source, $blob_cols, $row);
 268   }
 269 }
 270
 271 sub _insert_blobs {
 272   my ($self, $source, $blob_cols, $row) = @_;
 273   my $dbh = $self->dbh;
 274
 275   my $table = $source->from;
 276
 277   my %row = %$row;
 278   my (@primary_cols) = $source->primary_columns;
 279
 280   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 281     unless @primary_cols;
 282
 283   if ((grep { defined $row{$_} } @primary_cols) != @primary_cols) {
 284     if (@primary_cols == 1) {
 285       my $col = $primary_cols[0];
 286       $row{$col} = $self->last_insert_id($source, $col);
 287     } else {
 288       croak "Cannot update TEXT/IMAGE column(s) without primary key values";
 289     }
 290   }
 291
 292   for my $col (keys %$blob_cols) {
 293     my $blob = $blob_cols->{$col};
 294     my $sth;
 295
 296     if (not $self->isa('DBIx::Class::Storage::DBI::NoBindVars')) {
 297       my $search_cond = join ',' => map "$_ = ?", @primary_cols;
 298
 299       $sth = $self->sth(
 300         "select $col from $table where $search_cond"
 301       );
 302       $sth->execute(map $row{$_}, @primary_cols);
 303     } else {
 304       my $search_cond = join ',' => map "$_ = $row{$_}", @primary_cols;
 305
 306       $sth = $dbh->prepare(
 307         "select $col from $table where $search_cond"
 308       );
 309       $sth->execute;
 310     }
 311
 312     eval {
 313       while ($sth->fetch) {
 314         $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
 315       }
 316       $sth->func('ct_prepare_send') or die $sth->errstr;
 317
 318       my $log_on_update = $self->_blob_log_on_update;
 319       $log_on_update    = 1 if not defined $log_on_update;
 320
 321       $sth->func('CS_SET', 1, {
 322         total_txtlen => length($blob),
 323         log_on_update => $log_on_update
 324       }, 'ct_data_info') or die $sth->errstr;
 325
 326       $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
 327
 328       $sth->func('ct_finish_send') or die $sth->errstr;
 329     };
 330     my $exception = $@;
 331     $sth->finish;
 332     croak $exception if $exception;
 333   }
 334 }
 335
 336 =head2 connect_call_datetime_setup
 337
 338 Used as:
 339
 340   on_connect_call => 'datetime_setup'
 341
 342 In L<DBIx::Class::Storage::DBI/connect_info> to set:
 343
 344   $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
 345   $dbh->do('set dateformat mdy');   # input fmt:  08/13/1979 18:08:55.080
 346
 347 On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
 348 L<DateTime::Format::Sybase>, which you will need to install.
 349
 350 This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
 351 C<SMALLDATETIME> columns only have minute precision.
 352
 353 =cut
 354
 355 {
 356   my $old_dbd_warned = 0;
 357
 358   sub connect_call_datetime_setup {
 359     my $self = shift;
 360     my $dbh = $self->_dbh;
 361
 362     if ($dbh->can('syb_date_fmt')) {
 363       $dbh->syb_date_fmt('ISO_strict');
 364     } elsif (not $old_dbd_warned) {
 365       carp "Your DBD::Sybase is too old to support ".
 366       "DBIx::Class::InflateColumn::DateTime, please upgrade!";
 367       $old_dbd_warned = 1;
 368     }
 369
 370     $dbh->do('set dateformat mdy');
 371
 372     1;
 373   }
 374 }
 375
 376 sub datetime_parser_type { "DateTime::Format::Sybase" }
 377
 378 sub _dbh_last_insert_id {
 379   my ($self, $dbh, $source, $col) = @_;
 380
 381   # sorry, there's no other way!
 382   my $sth = $self->sth("select max($col) from ".$source->from);
 383   my ($id) = $dbh->selectrow_array($sth);
 384   $sth->finish;
 385
 386   return $id;
 387 }
 388
 389 # savepoint support using ASE syntax
 390
 391 sub _svp_begin {
 392   my ($self, $name) = @_;
 393
 394   $self->dbh->do("SAVE TRANSACTION $name");
 395 }
 396
 397 # A new SAVE TRANSACTION with the same name releases the previous one.
 398 sub _svp_release { 1 }
 399
 400 sub _svp_rollback {
 401   my ($self, $name) = @_;
 402
 403   $self->dbh->do("ROLLBACK TRANSACTION $name");
 404 }
 405
 406 1;
 407
 408 =head1 MAXIMUM CONNECTIONS
 409
 410 L<DBD::Sybase> makes separate connections to the server for active statements in
 411 the background. By default the number of such connections is limited to 25, on
 412 both the client side and the server side.
 413
 414 This is a bit too low, so on connection the clientside setting is set to C<256>
 415 (see L<DBD::Sybase/maxConnect>.) You can override it to whatever setting you
 416 like in the DSN.
 417
 418 See
 419 L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
 420 for information on changing the setting on the server side.
 421
 422 =head1 DATES
 423
 424 See L</connect_call_datetime_setup> to setup date formats
 425 for L<DBIx::Class::InflateColumn::DateTime>.
 426
 427 =head1 IMAGE AND TEXT COLUMNS
 428
 429 L<DBD::Sybase> compiled with FreeTDS will B<NOT> work with C<TEXT/IMAGE>
 430 columns.
 431
 432 See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
 433 setting you need to work with C<IMAGE> columns.
 434
 435 =head1 AUTHORS
 436
 437 See L<DBIx::Class/CONTRIBUTORS>.
 438
 439 =head1 LICENSE
 440
 441 You may distribute this code under the same terms as Perl itself.
 442
 443 =cut
 444 # vim:sts=2 sw=2: