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