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