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)/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->_update_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)        = @_;
 181 #
 182 #  my $blob_cols = $self->_remove_blob_cols($source, $fields);
 183 #
 184 #  my @res = 1;
 185 #
 186 #  if (%$fields) {
 187 #    if (wantarray) {
 188 #      @res    = $self->next::method($source, @_);
 189 #    } else {
 190 #      $res[0] = $self->next::method($source, @_);
 191 #    }
 192 #  }
 193 #
 194 #  $self->_update_blobs($source, $blob_cols, $fields) if %$blob_cols;
 195 #
 196 #  return wantarray ? @res : $res[0];
 197 #}
 198
 199 sub _remove_blob_cols {
 200   my ($self, $source, $fields) = @_;
 201
 202   my %blob_cols;
 203
 204   for my $col (keys %$fields) {
 205     if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
 206       $blob_cols{$col} = delete $fields->{$col};
 207       $fields->{$col} = \"''";
 208     }
 209   }
 210
 211   return \%blob_cols;
 212 }
 213
 214 sub _update_blobs {
 215   my ($self, $source, $blob_cols, $inserted) = @_;
 216   my $dbh = $self->dbh;
 217
 218   my $table = $source->from;
 219
 220   my %inserted = %$inserted;
 221   my (@primary_cols) = $source->primary_columns;
 222
 223   croak "Cannot update TEXT/IMAGE column(s) without a primary key"
 224     unless @primary_cols;
 225
 226   if ((grep { defined $inserted{$_} } @primary_cols) != @primary_cols) {
 227     if (@primary_cols == 1) {
 228       my $col = $primary_cols[0];
 229       $inserted{$col} = $self->last_insert_id($source, $col);
 230     } else {
 231       croak "Cannot update TEXT/IMAGE column(s) without primary key values";
 232     }
 233   }
 234
 235   for my $col (keys %$blob_cols) {
 236     my $blob = $blob_cols->{$col};
 237     my $sth;
 238
 239     if (not $self->isa('DBIx::Class::Storage::DBI::NoBindVars')) {
 240       my $search_cond = join ',' => map "$_ = ?", @primary_cols;
 241
 242       $sth = $self->sth(
 243         "select $col from $table where $search_cond"
 244       );
 245       $sth->execute(map $inserted{$_}, @primary_cols);
 246     } else {
 247       my $search_cond = join ',' => map "$_ = $inserted{$_}", @primary_cols;
 248
 249       $sth = $dbh->prepare(
 250         "select $col from $table where $search_cond"
 251       );
 252       $sth->execute;
 253     }
 254
 255     eval {
 256       while ($sth->fetch) {
 257         $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
 258       }
 259       $sth->func('ct_prepare_send') or die $sth->errstr;
 260
 261       my $log_on_update = $self->_blob_log_on_update;
 262       $log_on_update    = 1 if not defined $log_on_update;
 263
 264       $sth->func('CS_SET', 1, {
 265         total_txtlen => length($blob),
 266         log_on_update => $log_on_update
 267       }, 'ct_data_info') or die $sth->errstr;
 268
 269       $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
 270
 271       $sth->func('ct_finish_send') or die $sth->errstr;
 272     };
 273     my $exception = $@;
 274     $sth->finish;
 275     croak $exception if $exception;
 276   }
 277 }
 278
 279 =head2 connect_call_datetime_setup
 280
 281 Used as:
 282
 283   on_connect_call => 'datetime_setup'
 284
 285 In L<DBIx::Class::Storage::DBI/connect_info> to set:
 286
 287   $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
 288   $dbh->do('set dateformat mdy');   # input fmt:  08/13/1979 18:08:55.080
 289
 290 On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
 291 L<DateTime::Format::Sybase>, which you will need to install.
 292
 293 This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
 294 C<SMALLDATETIME> columns only have minute precision.
 295
 296 =cut
 297
 298 {
 299   my $old_dbd_warned = 0;
 300
 301   sub connect_call_datetime_setup {
 302     my $self = shift;
 303     my $dbh = $self->_dbh;
 304
 305     if ($dbh->can('syb_date_fmt')) {
 306       $dbh->syb_date_fmt('ISO_strict');
 307     } elsif (not $old_dbd_warned) {
 308       carp "Your DBD::Sybase is too old to support ".
 309       "DBIx::Class::InflateColumn::DateTime, please upgrade!";
 310       $old_dbd_warned = 1;
 311     }
 312
 313     $dbh->do('set dateformat mdy');
 314
 315     1;
 316   }
 317 }
 318
 319 sub datetime_parser_type { "DateTime::Format::Sybase" }
 320
 321 sub _dbh_last_insert_id {
 322   my ($self, $dbh, $source, $col) = @_;
 323
 324   # sorry, there's no other way!
 325   my $sth = $dbh->prepare_cached("select max($col) from ".$source->from);
 326   return ($dbh->selectrow_array($sth))[0];
 327 }
 328
 329 1;
 330
 331 =head1 MAXIMUM CONNECTIONS
 332
 333 L<DBD::Sybase> makes separate connections to the server for active statements in
 334 the background. By default the number of such connections is limited to 25, on
 335 both the client side and the server side.
 336
 337 This is a bit too low, so on connection the clientside setting is set to C<256>
 338 (see L<DBD::Sybase/maxConnect>.) You can override it to whatever setting you
 339 like in the DSN.
 340
 341 See
 342 L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
 343 for information on changing the setting on the server side.
 344
 345 =head1 DATES
 346
 347 See L</connect_call_datetime_setup> to setup date formats
 348 for L<DBIx::Class::InflateColumn::DateTime>.
 349
 350 =head1 IMAGE AND TEXT COLUMNS
 351
 352 You need at least version C<1.09> of L<DBD::Sybase> for C<TEXT/IMAGE> column
 353 support.
 354
 355 See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
 356 setting you need to work with C<IMAGE> columns.
 357
 358 Due to limitations in L<DBD::Sybase> and this driver, it is only possible to
 359 select one C<TEXT> or C<IMAGE> column at a time. This is handled automatically
 360 for tables with only one such column, if you have more than one, supply a
 361 C<< select => [qw/col list .../] >> key to your C<< ->search >> calls, with the
 362 single desired C<TEXT/IMAGE> column at the end of the list.
 363
 364 =head1 AUTHORS
 365
 366 See L<DBIx::Class/CONTRIBUTORS>.
 367
 368 =head1 LICENSE
 369
 370 You may distribute this code under the same terms as Perl itself.
 371
 372 =cut
 373 # vim:sts=2 sw=2: