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 A recommended L<DBIx::Class::Storage::DBI/connect_info> settings:
  35
  36   on_connect_call => [['datetime_setup'], [blob_setup => log_on_update => 0]]
  37
  38 =head1 METHODS
  39
  40 =cut
  41
  42 __PACKAGE__->mk_group_accessors('simple' =>
  43     qw/_blob_log_on_update/
  44 );
  45
  46 sub _rebless {
  47   my $self = shift;
  48
  49   if (ref($self) eq 'DBIx::Class::Storage::DBI::Sybase') {
  50     my $dbtype = eval {
  51       @{$self->dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
  52     } || '';
  53
  54     my $exception = $@;
  55     $dbtype =~ s/\W/_/gi;
  56     my $subclass = "DBIx::Class::Storage::DBI::Sybase::${dbtype}";
  57
  58     if (!$exception && $dbtype && $self->load_optional_class($subclass)) {
  59       bless $self, $subclass;
  60       $self->_rebless;
  61     } else {
  62       # real Sybase
  63       if (not $self->dbh->{syb_dynamic_supported}) {
  64         $self->ensure_class_loaded('DBIx::Class::Storage::DBI::Sybase::NoBindVars');
  65         bless $self, 'DBIx::Class::Storage::DBI::Sybase::NoBindVars';
  66         $self->_rebless;
  67       }
  68       $self->_set_maxConnect;
  69     }
  70   }
  71 }
  72
  73 sub _set_maxConnect {
  74   my $self = shift;
  75
  76   my $dsn = $self->_dbi_connect_info->[0];
  77
  78   return if ref($dsn) eq 'CODE';
  79
  80   if ($dsn !~ /maxConnect=/) {
  81     $self->_dbi_connect_info->[0] = "$dsn;maxConnect=256";
  82     # will take effect next connection
  83     my $connected = defined $self->_dbh;
  84     $self->disconnect;
  85     $self->ensure_connected if $connected;
  86   }
  87 }
  88
  89 =head2 connect_call_blob_setup
  90
  91 Used as:
  92
  93   on_connect_call => [ [ blob_setup => log_on_update => 0 ] ]
  94
  95 Does C<< $dbh->{syb_binary_images} = 1; >> to return C<IMAGE> data as raw binary
  96 instead of as a hex string.
  97
  98 Recommended.
  99
 100 Also sets the C<log_on_update> value for blob write operations. The default is
 101 C<1>, but C<0> is better if your database is configured for it.
 102
 103 See
 104 L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.
 105
 106 =cut
 107
 108 sub connect_call_blob_setup {
 109   my $self = shift;
 110   my %args = @_;
 111   my $dbh = $self->_dbh;
 112   $dbh->{syb_binary_images} = 1;
 113
 114   $self->_blob_log_on_update($args{log_on_update})
 115     if exists $args{log_on_update};
 116 }
 117
 118 sub _is_lob_type {
 119   my $self = shift;
 120   shift =~ /(?:text|image|lob|bytea|binary)/i;
 121 }
 122
 123 sub insert {
 124   my ($self, $source, $to_insert) = splice @_, 0, 3;
 125
 126   my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
 127
 128   my $updated_cols = $self->next::method($source, $to_insert, @_);
 129
 130   $self->_update_blobs($source, $blob_cols, $to_insert) if %$blob_cols;
 131
 132   return $updated_cols;
 133 }
 134
 135 #sub update {
 136 #  my ($self, $source) = splice @_, 0, 2;
 137 #  my ($fields)        = @_;
 138 #
 139 #  my $blob_cols = $self->_remove_blob_cols($source, $fields);
 140 #
 141 #  my @res = 1;
 142 #
 143 #  if (%$fields) {
 144 #    if (wantarray) {
 145 #      @res    = $self->next::method($source, @_);
 146 #    } else {
 147 #      $res[0] = $self->next::method($source, @_);
 148 #    }
 149 #  }
 150 #
 151 #  $self->_update_blobs($source, $blob_cols, $fields) if %$blob_cols;
 152 #
 153 #  return wantarray ? @res : $res[0];
 154 #}
 155
 156 sub _remove_blob_cols {
 157   my ($self, $source, $fields) = @_;
 158
 159   my %blob_cols;
 160
 161   for my $col (keys %$fields) {
 162     $blob_cols{$col} = delete $fields->{$col}
 163       if $self->_is_lob_type($source->column_info($col)->{data_type});
 164   }
 165
 166   return \%blob_cols;
 167 }
 168
 169 sub _update_blobs {
 170   my ($self, $source, $blob_cols, $inserted) = @_;
 171   my $dbh = $self->dbh;
 172
 173   my $table = $source->from;
 174
 175   my (@primary_cols) = $source->primary_columns;
 176
 177   croak "Cannot update TEXT/IMAGE without a primary key!"
 178     unless @primary_cols;
 179
 180   my $search_cond = join ',' => map "$_ = ?", @primary_cols;
 181
 182   for my $col (keys %$blob_cols) {
 183     my $blob = $blob_cols->{$col};
 184
 185 # First update to empty string in case it's NULL, can't update a NULL blob using
 186 # the API.
 187     my $sth = $dbh->prepare_cached(
 188       qq{update $table set $col = '' where $search_cond}
 189     );
 190     $sth->execute(map $inserted->{$_}, @primary_cols) or die $sth->errstr;
 191     $sth->finish;
 192
 193     $sth = $dbh->prepare_cached(
 194       "select $col from $table where $search_cond"
 195     );
 196     $sth->execute(map $inserted->{$_}, @primary_cols);
 197
 198     eval {
 199       while ($sth->fetch) {
 200         $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
 201       }
 202       $sth->func('ct_prepare_send') or die $sth->errstr;
 203
 204       my $log_on_update = $self->_blob_log_on_update;
 205       $log_on_update    = 1 if not defined $log_on_update;
 206
 207       $sth->func('CS_SET', 1, {
 208         total_txtlen => length($blob),
 209         log_on_update => $log_on_update
 210       }, 'ct_data_info') or die $sth->errstr;
 211
 212       $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
 213
 214       $sth->func('ct_finish_send') or die $sth->errstr;
 215     };
 216     my $exception = $@;
 217     $sth->finish;
 218     croak $exception if $exception;
 219   }
 220 }
 221
 222 =head2 connect_call_datetime_setup
 223
 224 Used as:
 225
 226   on_connect_call => 'datetime_setup'
 227
 228 In L<DBIx::Class::Storage::DBI/connect_info> to set:
 229
 230   $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
 231   $dbh->do('set dateformat mdy');   # input fmt:  08/13/1979 18:08:55.080
 232
 233 On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
 234 L<DateTime::Format::Sybase>, which you will need to install.
 235
 236 This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
 237 C<SMALLDATETIME> columns only have minute precision.
 238
 239 =cut
 240
 241 {
 242   my $old_dbd_warned = 0;
 243
 244   sub connect_call_datetime_setup {
 245     my $self = shift;
 246     my $dbh = $self->_dbh;
 247
 248     if ($dbh->can('syb_date_fmt')) {
 249       $dbh->syb_date_fmt('ISO_strict');
 250     } elsif (not $old_dbd_warned) {
 251       carp "Your DBD::Sybase is too old to support ".
 252       "DBIx::Class::InflateColumn::DateTime, please upgrade!";
 253       $old_dbd_warned = 1;
 254     }
 255
 256     $dbh->do('set dateformat mdy');
 257
 258     1;
 259   }
 260 }
 261
 262 sub datetime_parser_type { "DateTime::Format::Sybase" }
 263
 264 sub _dbh_last_insert_id {
 265   my ($self, $dbh, $source, $col) = @_;
 266
 267   # sorry, there's no other way!
 268   my $sth = $dbh->prepare_cached("select max($col) from ".$source->from);
 269   return ($dbh->selectrow_array($sth))[0];
 270 }
 271
 272 1;
 273
 274 =head1 MAXIMUM CONNECTIONS
 275
 276 L<DBD::Sybase> makes separate connections to the server for active statements in
 277 the background. By default the number of such connections is limited to 25, on
 278 both the client side and the server side.
 279
 280 This is a bit too low, so on connection the clientside setting is set to C<256>
 281 (see L<DBD::Sybase/maxConnect>.) You can override it to whatever setting you
 282 like in the DSN.
 283
 284 See
 285 L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
 286 for information on changing the setting on the server side.
 287
 288 =head1 DATES
 289
 290 See L</connect_call_datetime_setup> to setup date formats
 291 for L<DBIx::Class::InflateColumn::DateTime>.
 292
 293 =head1 IMAGE AND TEXT COLUMNS
 294
 295 See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
 296 setting you need to work with C<IMAGE> columns.
 297
 298 Due to limitations in L<DBD::Sybase> and this driver, it is only possible to
 299 select one C<TEXT> or C<IMAGE> column at a time.
 300
 301 =head1 AUTHORS
 302
 303 See L<DBIx::Class/CONTRIBUTORS>.
 304
 305 =head1 LICENSE
 306
 307 You may distribute this code under the same terms as Perl itself.
 308
 309 =cut
 310 # vim:sts=2 sw=2: