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