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