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   if ($identity_insert) {
 196     $dbh->do("SET IDENTITY_INSERT $table OFF");
 197   }
 198
 199   $self->_insert_blobs($source, $blob_cols, $to_insert) if %$blob_cols;
 200
 201   return $updated_cols;
 202 }
 203
 204 sub update {
 205   my ($self, $source)  = splice @_, 0, 2;
 206   my ($fields, $where) = @_;
 207   my $wantarray        = wantarray;
 208
 209   my $blob_cols = $self->_remove_blob_cols($source, $fields);
 210
 211   my @res;
 212   if ($wantarray) {
 213     @res    = $self->next::method($source, @_);
 214   } else {
 215     $res[0] = $self->next::method($source, @_);
 216   }
 217
 218   $self->_update_blobs($source, $blob_cols, $where) if %$blob_cols;
 219
 220   return $wantarray ? @res : $res[0];
 221 }
 222
 223 sub _remove_blob_cols {
 224   my ($self, $source, $fields) = @_;
 225
 226   my %blob_cols;
 227
 228   for my $col (keys %$fields) {
 229     if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
 230       $blob_cols{$col} = delete $fields->{$col};
 231       $fields->{$col} = \"''";
 232     }
 233   }
 234
 235   return \%blob_cols;
 236 }
 237
 238 sub _update_blobs {
 239   my ($self, $source, $blob_cols, $where) = @_;
 240
 241   my (@primary_cols) = $source->primary_columns;
 242
 243   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 244     unless @primary_cols;
 245
 246 # check if we're updating a single row by PK
 247   my $pk_cols_in_where = 0;
 248   for my $col (@primary_cols) {
 249     $pk_cols_in_where++ if defined $where->{$col};
 250   }
 251   my @rows;
 252
 253   if ($pk_cols_in_where == @primary_cols) {
 254     my %row_to_update;
 255     @row_to_update{@primary_cols} = @{$where}{@primary_cols};
 256     @rows = \%row_to_update;
 257   } else {
 258     my $rs = $source->resultset->search(
 259       $where,
 260       {
 261         result_class => 'DBIx::Class::ResultClass::HashRefInflator',
 262         select => \@primary_cols
 263       }
 264     );
 265     @rows = $rs->all; # statement must finish
 266   }
 267
 268   for my $row (@rows) {
 269     $self->_insert_blobs($source, $blob_cols, $row);
 270   }
 271 }
 272
 273 sub _insert_blobs {
 274   my ($self, $source, $blob_cols, $row) = @_;
 275   my $dbh = $self->dbh;
 276
 277   my $table = $source->from;
 278
 279   my %row = %$row;
 280   my (@primary_cols) = $source->primary_columns;
 281
 282   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 283     unless @primary_cols;
 284
 285   if ((grep { defined $row{$_} } @primary_cols) != @primary_cols) {
 286     if (@primary_cols == 1) {
 287       my $col = $primary_cols[0];
 288       $row{$col} = $self->last_insert_id($source, $col);
 289     } else {
 290       croak "Cannot update TEXT/IMAGE column(s) without primary key values";
 291     }
 292   }
 293
 294   for my $col (keys %$blob_cols) {
 295     my $blob = $blob_cols->{$col};
 296     my $sth;
 297
 298     if (not $self->isa('DBIx::Class::Storage::DBI::NoBindVars')) {
 299       my $search_cond = join ',' => map "$_ = ?", @primary_cols;
 300
 301       $sth = $self->sth(
 302         "select $col from $table where $search_cond"
 303       );
 304       $sth->execute(map $row{$_}, @primary_cols);
 305     } else {
 306       my $search_cond = join ',' => map "$_ = $row{$_}", @primary_cols;
 307
 308       $sth = $dbh->prepare(
 309         "select $col from $table where $search_cond"
 310       );
 311       $sth->execute;
 312     }
 313
 314     eval {
 315       while ($sth->fetch) {
 316         $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
 317       }
 318       $sth->func('ct_prepare_send') or die $sth->errstr;
 319
 320       my $log_on_update = $self->_blob_log_on_update;
 321       $log_on_update    = 1 if not defined $log_on_update;
 322
 323       $sth->func('CS_SET', 1, {
 324         total_txtlen => length($blob),
 325         log_on_update => $log_on_update
 326       }, 'ct_data_info') or die $sth->errstr;
 327
 328       $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
 329
 330       $sth->func('ct_finish_send') or die $sth->errstr;
 331     };
 332     my $exception = $@;
 333     $sth->finish;
 334     croak $exception if $exception;
 335   }
 336 }
 337
 338 =head2 connect_call_datetime_setup
 339
 340 Used as:
 341
 342   on_connect_call => 'datetime_setup'
 343
 344 In L<DBIx::Class::Storage::DBI/connect_info> to set:
 345
 346   $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
 347   $dbh->do('set dateformat mdy');   # input fmt:  08/13/1979 18:08:55.080
 348
 349 On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
 350 L<DateTime::Format::Sybase>, which you will need to install.
 351
 352 This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
 353 C<SMALLDATETIME> columns only have minute precision.
 354
 355 =cut
 356
 357 {
 358   my $old_dbd_warned = 0;
 359
 360   sub connect_call_datetime_setup {
 361     my $self = shift;
 362     my $dbh = $self->_dbh;
 363
 364     if ($dbh->can('syb_date_fmt')) {
 365       $dbh->syb_date_fmt('ISO_strict');
 366     } elsif (not $old_dbd_warned) {
 367       carp "Your DBD::Sybase is too old to support ".
 368       "DBIx::Class::InflateColumn::DateTime, please upgrade!";
 369       $old_dbd_warned = 1;
 370     }
 371
 372     $dbh->do('set dateformat mdy');
 373
 374     1;
 375   }
 376 }
 377
 378 sub datetime_parser_type { "DateTime::Format::Sybase" }
 379
 380 sub _dbh_last_insert_id {
 381   my ($self, $dbh, $source, $col) = @_;
 382
 383   # sorry, there's no other way!
 384   my $sth = $self->sth("select max($col) from ".$source->from);
 385   my ($id) = $dbh->selectrow_array($sth);
 386   $sth->finish;
 387
 388   return $id;
 389 }
 390
 391 1;
 392
 393 =head1 MAXIMUM CONNECTIONS
 394
 395 L<DBD::Sybase> makes separate connections to the server for active statements in
 396 the background. By default the number of such connections is limited to 25, on
 397 both the client side and the server side.
 398
 399 This is a bit too low, so on connection the clientside setting is set to C<256>
 400 (see L<DBD::Sybase/maxConnect>.) You can override it to whatever setting you
 401 like in the DSN.
 402
 403 See
 404 L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
 405 for information on changing the setting on the server side.
 406
 407 =head1 DATES
 408
 409 See L</connect_call_datetime_setup> to setup date formats
 410 for L<DBIx::Class::InflateColumn::DateTime>.
 411
 412 =head1 IMAGE AND TEXT COLUMNS
 413
 414 L<DBD::Sybase> compiled with FreeTDS will B<NOT> work with C<TEXT/IMAGE>
 415 columns.
 416
 417 See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
 418 setting you need to work with C<IMAGE> columns.
 419
 420 =head1 AUTHORS
 421
 422 See L<DBIx::Class/CONTRIBUTORS>.
 423
 424 =head1 LICENSE
 425
 426 You may distribute this code under the same terms as Perl itself.
 427
 428 =cut
 429 # vim:sts=2 sw=2: