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
  13 =head1 NAME
  14
  15 DBIx::Class::Storage::DBI::Sybase - Storage::DBI subclass for Sybase
  16
  17 =head1 SYNOPSIS
  18
  19 This subclass supports L<DBD::Sybase> for real Sybase databases.  If you are
  20 using an MSSQL database via L<DBD::Sybase>, your storage will be reblessed to
  21 L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
  22
  23 =head1 DESCRIPTION
  24
  25 If your version of Sybase does not support placeholders, then your storage
  26 will be reblessed to L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>. You can
  27 also enable that driver explicitly, see the documentation for more details.
  28
  29 With this driver there is unfortunately no way to get the C<last_insert_id>
  30 without doing a C<select max(col)>.
  31
  32 But your queries will be cached.
  33
  34 You need at least version C<1.09> of L<DBD::Sybase> for placeholder support.
  35 Otherwise your storage will be automatically reblessed into C<::NoBindVars>.
  36
  37 A recommended L<DBIx::Class::Storage::DBI/connect_info> settings:
  38
  39   on_connect_call => [['datetime_setup'], [blob_setup => log_on_update => 0]]
  40
  41 =head1 METHODS
  42
  43 =cut
  44
  45 __PACKAGE__->mk_group_accessors('simple' =>
  46     qw/_blob_log_on_update/
  47 );
  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->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       if (not $self->dbh->{syb_dynamic_supported}) {
  68         $self->ensure_class_loaded($no_bind_vars);
  69         bless $self, $no_bind_vars;
  70         $self->_rebless;
  71       }
  72
  73       if ($DBD::Sybase::VERSION < 1.09) {
  74         carp <<'EOF';
  75
  76 Your version of Sybase potentially supports placeholders and query caching,
  77 however your version of DBD::Sybase is too old to do this properly. Please
  78 upgrade to at least version 1.09 if you want this feature.
  79
  80 TEXT/IMAGE column support will also not work in older versions of DBD::Sybase.
  81
  82 See perldoc DBIx::Class::Storage::DBI::Sybase for more details.
  83 EOF
  84         $self->ensure_class_loaded($no_bind_vars);
  85         bless $self, $no_bind_vars;
  86         $self->_rebless;
  87       }
  88       $self->_set_maxConnect;
  89     }
  90   }
  91 }
  92
  93 sub _set_maxConnect {
  94   my $self = shift;
  95
  96   my $dsn = $self->_dbi_connect_info->[0];
  97
  98   return if ref($dsn) eq 'CODE';
  99
 100   if ($dsn !~ /maxConnect=/) {
 101     $self->_dbi_connect_info->[0] = "$dsn;maxConnect=256";
 102     my $connected = defined $self->_dbh;
 103     $self->disconnect;
 104     $self->ensure_connected if $connected;
 105   }
 106 }
 107
 108 =head2 connect_call_blob_setup
 109
 110 Used as:
 111
 112   on_connect_call => [ [ blob_setup => log_on_update => 0 ] ]
 113
 114 Does C<< $dbh->{syb_binary_images} = 1; >> to return C<IMAGE> data as raw binary
 115 instead of as a hex string.
 116
 117 Recommended.
 118
 119 Also sets the C<log_on_update> value for blob write operations. The default is
 120 C<1>, but C<0> is better if your database is configured for it.
 121
 122 See
 123 L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.
 124
 125 =cut
 126
 127 sub connect_call_blob_setup {
 128   my $self = shift;
 129   my %args = @_;
 130   my $dbh = $self->_dbh;
 131   $dbh->{syb_binary_images} = 1;
 132
 133   $self->_blob_log_on_update($args{log_on_update})
 134     if exists $args{log_on_update};
 135 }
 136
 137 sub _is_lob_type {
 138   my $self = shift;
 139   my $type = shift;
 140   $type && $type =~ /(?:text|image|lob|bytea|binary|memo)/i;
 141 }
 142
 143 ## This will be useful if we ever implement BLOB filehandle inflation and will
 144 ## need to use the API, but for now it isn't.
 145 #
 146 #sub order_columns_for_select {
 147 #  my ($self, $source) = @_;
 148 #
 149 #  my (@non_blobs, @blobs);
 150 #
 151 #  for my $col ($source->columns) {
 152 #    if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
 153 #      push @blobs, $col;
 154 #    } else {
 155 #      push @non_blobs, $col;
 156 #    }
 157 #  }
 158 #
 159 #  croak "cannot select more than a one TEXT/IMAGE column at a time"
 160 #    if @blobs > 1;
 161 #
 162 #  return (@non_blobs, @blobs);
 163 #}
 164
 165 # override to handle TEXT/IMAGE
 166 sub insert {
 167   my ($self, $source, $to_insert) = splice @_, 0, 3;
 168
 169   my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
 170
 171   my $updated_cols = $self->next::method($source, $to_insert, @_);
 172
 173   $self->_insert_blobs($source, $blob_cols, $to_insert) if %$blob_cols;
 174
 175   return $updated_cols;
 176 }
 177
 178 sub update {
 179   my ($self, $source)  = splice @_, 0, 2;
 180   my ($fields, $where) = @_;
 181   my $wantarray        = wantarray;
 182
 183   my $blob_cols = $self->_remove_blob_cols($source, $fields);
 184
 185   my @res;
 186   if ($wantarray) {
 187     @res    = $self->next::method($source, @_);
 188   } else {
 189     $res[0] = $self->next::method($source, @_);
 190   }
 191
 192   $self->_update_blobs($source, $blob_cols, $where) if %$blob_cols;
 193
 194   return $wantarray ? @res : $res[0];
 195 }
 196
 197 sub _remove_blob_cols {
 198   my ($self, $source, $fields) = @_;
 199
 200   my %blob_cols;
 201
 202   for my $col (keys %$fields) {
 203     if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
 204       $blob_cols{$col} = delete $fields->{$col};
 205       $fields->{$col} = \"''";
 206     }
 207   }
 208
 209   return \%blob_cols;
 210 }
 211
 212 sub _update_blobs {
 213   my ($self, $source, $blob_cols, $where) = @_;
 214
 215   my (@primary_cols) = $source->primary_columns;
 216
 217   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 218     unless @primary_cols;
 219
 220 # check if we're updating a single row by PK
 221   my $pk_cols_in_where = 0;
 222   for my $col (@primary_cols) {
 223     $pk_cols_in_where++ if defined $where->{$col};
 224   }
 225   my @rows;
 226
 227   if ($pk_cols_in_where == @primary_cols) {
 228     my %row_to_update;
 229     @row_to_update{@primary_cols} = @{$where}{@primary_cols};
 230     @rows = \%row_to_update;
 231   } else {
 232     my $rs = $source->resultset->search(
 233       $where,
 234       {
 235         result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 236         select => \@primary_cols
 237       }
 238     );
 239     @rows = $rs->all; # statement must finish
 240   }
 241
 242   for my $row (@rows) {
 243     $self->_insert_blobs($source, $blob_cols, $row);
 244   }
 245 }
 246
 247 sub _insert_blobs {
 248   my ($self, $source, $blob_cols, $row) = @_;
 249   my $dbh = $self->dbh;
 250
 251   my $table = $source->from;
 252
 253   my %row = %$row;
 254   my (@primary_cols) = $source->primary_columns;
 255
 256   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 257     unless @primary_cols;
 258
 259   if ((grep { defined $row{$_} } @primary_cols) != @primary_cols) {
 260     if (@primary_cols == 1) {
 261       my $col = $primary_cols[0];
 262       $row{$col} = $self->last_insert_id($source, $col);
 263     } else {
 264       croak "Cannot update TEXT/IMAGE column(s) without primary key values";
 265     }
 266   }
 267
 268   for my $col (keys %$blob_cols) {
 269     my $blob = $blob_cols->{$col};
 270     my $sth;
 271
 272     if (not $self->isa('DBIx::Class::Storage::DBI::NoBindVars')) {
 273       my $search_cond = join ',' => map "$_ = ?", @primary_cols;
 274
 275       $sth = $self->sth(
 276         "select $col from $table where $search_cond"
 277       );
 278       $sth->execute(map $row{$_}, @primary_cols);
 279     } else {
 280       my $search_cond = join ',' => map "$_ = $row{$_}", @primary_cols;
 281
 282       $sth = $dbh->prepare(
 283         "select $col from $table where $search_cond"
 284       );
 285       $sth->execute;
 286     }
 287
 288     eval {
 289       while ($sth->fetch) {
 290         $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
 291       }
 292       $sth->func('ct_prepare_send') or die $sth->errstr;
 293
 294       my $log_on_update = $self->_blob_log_on_update;
 295       $log_on_update    = 1 if not defined $log_on_update;
 296
 297       $sth->func('CS_SET', 1, {
 298         total_txtlen => length($blob),
 299         log_on_update => $log_on_update
 300       }, 'ct_data_info') or die $sth->errstr;
 301
 302       $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
 303
 304       $sth->func('ct_finish_send') or die $sth->errstr;
 305     };
 306     my $exception = $@;
 307     $sth->finish;
 308     croak $exception if $exception;
 309   }
 310 }
 311
 312 =head2 connect_call_datetime_setup
 313
 314 Used as:
 315
 316   on_connect_call => 'datetime_setup'
 317
 318 In L<DBIx::Class::Storage::DBI/connect_info> to set:
 319
 320   $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
 321   $dbh->do('set dateformat mdy');   # input fmt:  08/13/1979 18:08:55.080
 322
 323 On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
 324 L<DateTime::Format::Sybase>, which you will need to install.
 325
 326 This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
 327 C<SMALLDATETIME> columns only have minute precision.
 328
 329 =cut
 330
 331 {
 332   my $old_dbd_warned = 0;
 333
 334   sub connect_call_datetime_setup {
 335     my $self = shift;
 336     my $dbh = $self->_dbh;
 337
 338     if ($dbh->can('syb_date_fmt')) {
 339       $dbh->syb_date_fmt('ISO_strict');
 340     } elsif (not $old_dbd_warned) {
 341       carp "Your DBD::Sybase is too old to support ".
 342       "DBIx::Class::InflateColumn::DateTime, please upgrade!";
 343       $old_dbd_warned = 1;
 344     }
 345
 346     $dbh->do('set dateformat mdy');
 347
 348     1;
 349   }
 350 }
 351
 352 sub datetime_parser_type { "DateTime::Format::Sybase" }
 353
 354 sub _dbh_last_insert_id {
 355   my ($self, $dbh, $source, $col) = @_;
 356
 357   # sorry, there's no other way!
 358   my $sth = $self->sth("select max($col) from ".$source->from);
 359   my ($id) = $dbh->selectrow_array($sth);
 360   $sth->finish;
 361
 362   return $id;
 363 }
 364
 365 1;
 366
 367 =head1 MAXIMUM CONNECTIONS
 368
 369 L<DBD::Sybase> makes separate connections to the server for active statements in
 370 the background. By default the number of such connections is limited to 25, on
 371 both the client side and the server side.
 372
 373 This is a bit too low, so on connection the clientside setting is set to C<256>
 374 (see L<DBD::Sybase/maxConnect>.) You can override it to whatever setting you
 375 like in the DSN.
 376
 377 See
 378 L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
 379 for information on changing the setting on the server side.
 380
 381 =head1 DATES
 382
 383 See L</connect_call_datetime_setup> to setup date formats
 384 for L<DBIx::Class::InflateColumn::DateTime>.
 385
 386 =head1 IMAGE AND TEXT COLUMNS
 387
 388 You need at least version C<1.09> of L<DBD::Sybase> for C<TEXT/IMAGE> column
 389 support.
 390
 391 See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
 392 setting you need to work with C<IMAGE> columns.
 393
 394 =head1 AUTHORS
 395
 396 See L<DBIx::Class/CONTRIBUTORS>.
 397
 398 =head1 LICENSE
 399
 400 You may distribute this code under the same terms as Perl itself.
 401
 402 =cut
 403 # vim:sts=2 sw=2: