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