lib/DBIx/Class/Storage/DBI/Sybase.pm

   1 package DBIx::Class::Storage::DBI::Sybase;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Class::C3;
   7 use base qw/DBIx::Class::Storage::DBI/;
   8
   9 use Carp::Clan qw/^DBIx::Class/;
  10
  11 =head1 NAME
  12
  13 DBIx::Class::Storage::DBI::Sybase - Storage::DBI subclass for Sybase
  14
  15 =head1 SYNOPSIS
  16
  17 This subclass supports L<DBD::Sybase> for real Sybase databases.  If you are
  18 using an MSSQL database via L<DBD::Sybase>, your storage will be reblessed to
  19 L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
  20
  21 =head1 DESCRIPTION
  22
  23 If your version of Sybase does not support placeholders, then your storage
  24 will be reblessed to L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>. You can
  25 also enable that driver explicitly, see the documentation for more details.
  26
  27 With this driver there is unfortunately no way to get the C<last_insert_id>
  28 without doing a C<select max(col)>.
  29
  30 But your queries will be cached.
  31
  32 A recommended L<DBIx::Class::Storage::DBI/connect_info> settings:
  33
  34   on_connect_call => [['datetime_setup'], [blob_setup => log_on_update => 0]]
  35
  36 =head1 METHODS
  37
  38 =cut
  39
  40 __PACKAGE__->mk_group_accessors('simple' =>
  41     qw/_blob_log_on_update/
  42 );
  43
  44 sub _rebless {
  45   my $self = shift;
  46
  47   if (ref($self) eq 'DBIx::Class::Storage::DBI::Sybase') {
  48     my $dbtype = eval {
  49       @{$self->dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
  50     } || '';
  51
  52     my $exception = $@;
  53     $dbtype =~ s/\W/_/gi;
  54     my $subclass = "DBIx::Class::Storage::DBI::Sybase::${dbtype}";
  55
  56     if (!$exception && $dbtype && $self->load_optional_class($subclass)) {
  57       bless $self, $subclass;
  58       $self->_rebless;
  59     } else {
  60       # real Sybase
  61       if (not $self->dbh->{syb_dynamic_supported}) {
  62         bless $self, 'DBIx::Class::Storage:DBI::Sybase::NoBindVars';
  63         $self->_rebless;
  64       }
  65       $self->connect_call_datetime_setup;
  66       $self->connect_call_blob_setup;
  67     }
  68   }
  69 }
  70
  71 sub _populate_dbh {
  72   my $self = shift;
  73   $self->next::method(@_);
  74   $self->connect_call_datetime_setup;
  75   $self->connect_call_blob_setup;
  76   1;
  77 }
  78
  79 =head2 connect_call_blob_setup
  80
  81 Used as:
  82
  83   on_connect_call => [ [ blob_setup => log_on_update => 0 ] ]
  84
  85 Does C<< $dbh->{syb_binary_images} = 1; >> to return C<IMAGE> data as raw binary
  86 instead of as a hex string.
  87
  88 Recommended.
  89
  90 Also sets the C<log_on_update> value for blob write operations. The default is
  91 C<1>, but C<0> is better if your database is configured for it.
  92
  93 See
  94 L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.
  95
  96 =cut
  97
  98 sub connect_call_blob_setup {
  99   my $self = shift;
 100   my %args = @_;
 101   my $dbh = $self->_dbh;
 102   $dbh->{syb_binary_images} = 1;
 103
 104   $self->_blob_log_on_update($args{log_on_update})
 105     if exists $args{log_on_update};
 106 }
 107
 108 sub _is_lob_type {
 109   my $self = shift;
 110   shift =~ /(?:text|image|lob|bytea|binary)/i;
 111 }
 112
 113 sub insert {
 114   my $self = shift;
 115   my ($source, $to_insert) = @_;
 116
 117   my %blob_cols;
 118
 119   for my $col (keys %$to_insert) {
 120     $blob_cols{$col} = delete $to_insert->{$col}
 121       if $self->_is_lob_type($source->column_info($col)->{data_type});
 122   }
 123
 124   my $updated_cols = $self->next::method(@_);
 125
 126   $self->_update_blobs($source, \%blob_cols, $to_insert) if %blob_cols;
 127
 128   return $updated_cols;
 129 }
 130
 131 sub _update_blobs {
 132   my ($self, $source, $blob_cols, $inserted) = @_;
 133   my $dbh = $self->dbh;
 134
 135   my $table = $source->from;
 136
 137   my (@primary_cols) = $source->primary_columns;
 138
 139   croak "Cannot update TEXT/IMAGE without a primary key!"
 140     unless @primary_cols;
 141
 142   my $search_cond = join ',' => map "$_ = ?", @primary_cols;
 143
 144   for my $col (keys %$blob_cols) {
 145     my $blob = $blob_cols->{$col};
 146
 147 # First update to empty string in case it's NULL, can't update a NULL blob using
 148 # the API.
 149     my $sth = $dbh->prepare_cached(
 150       qq{update $table set $col = '' where $search_cond}
 151     );
 152     $sth->execute(map $inserted->{$_}, @primary_cols) or die $sth->errstr;
 153     $sth->finish;
 154
 155     $sth = $dbh->prepare_cached(
 156       "select $col from $table where $search_cond"
 157     );
 158     $sth->execute(map $inserted->{$_}, @primary_cols);
 159
 160     eval {
 161       while ($sth->fetch) {
 162         $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
 163       }
 164       $sth->func('ct_prepare_send') or die $sth->errstr;
 165
 166       my $log_on_update = $self->_blob_log_on_update;
 167       $log_on_update    = 1 if not defined $log_on_update;
 168
 169       $sth->func('CS_SET', 1, {
 170         total_txtlen => length($blob),
 171         log_on_update => $log_on_update
 172       }, 'ct_data_info') or die $sth->errstr;
 173
 174       $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
 175
 176       $sth->func('ct_finish_send') or die $sth->errstr;
 177     };
 178     my $exception = $@;
 179     $sth->finish;
 180     croak $exception if $exception;
 181   }
 182 }
 183
 184 =head2 connect_call_datetime_setup
 185
 186 Used as:
 187
 188   on_connect_call => 'datetime_setup'
 189
 190 In L<DBIx::Class::Storage::DBI/connect_info> to set:
 191
 192   $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
 193   $dbh->do('set dateformat mdy');   # input fmt:  08/13/1979 18:08:55.080
 194
 195 On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
 196 L<DateTime::Format::Sybase>, which you will need to install.
 197
 198 This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
 199 C<SMALLDATETIME> columns only have minute precision.
 200
 201 =cut
 202
 203 {
 204   my $old_dbd_warned = 0;
 205
 206   sub connect_call_datetime_setup {
 207     my $self = shift;
 208     my $dbh = $self->_dbh;
 209
 210     if ($dbh->can('syb_date_fmt')) {
 211       $dbh->syb_date_fmt('ISO_strict');
 212     } elsif (not $old_dbd_warned) {
 213       carp "Your DBD::Sybase is too old to support ".
 214       "DBIx::Class::InflateColumn::DateTime, please upgrade!";
 215       $old_dbd_warned = 1;
 216     }
 217
 218     $dbh->do('set dateformat mdy');
 219
 220     1;
 221   }
 222 }
 223
 224 sub datetime_parser_type { "DateTime::Format::Sybase" }
 225
 226 sub _dbh_last_insert_id {
 227   my ($self, $dbh, $source, $col) = @_;
 228
 229   # sorry, there's no other way!
 230   my $sth = $dbh->prepare_cached("select max($col) from ".$source->from);
 231   return ($dbh->selectrow_array($sth))[0];
 232 }
 233
 234 # previous implementation of limited count for Sybase, does not include
 235 # count_grouped.
 236
 237 #sub _copy_attributes_for_count {
 238 #  my ($self, $source, $attrs) = @_;
 239 #  my %attrs = %$attrs;
 240 #
 241 #  # take off any column specs, any pagers, record_filter is cdbi, and no point of ordering a count
 242 #  delete @attrs{qw/select as rows offset page order_by record_filter/};
 243 #
 244 #  return \%attrs;
 245 #}
 246 #
 247 #=head2 count
 248 #
 249 #Counts for limited queries are emulated by executing select queries and
 250 #returning the number of successful executions minus the offset.
 251 #
 252 #This is necessary due to the limitations of Sybase.
 253 #
 254 #=cut
 255 #
 256 #sub count {
 257 #  my $self = shift;
 258 #  my ($source, $attrs) = @_;
 259 #
 260 #  my $new_attrs = $self->_copy_attributes_for_count($source, $attrs);
 261 #
 262 #  if (exists $attrs->{rows}) {
 263 #    my $offset = $attrs->{offset} || 0;
 264 #    my $total  = $attrs->{rows} + $offset;
 265 #
 266 #    my $first_pk = ($source->primary_columns)[0];
 267 #
 268 #    $new_attrs->{select} = $first_pk ? "me.$first_pk" : 1;
 269 #
 270 #    my $tmp_rs = $source->resultset_class->new($source, $new_attrs);
 271 #
 272 #    $self->dbh->{syb_rowcount} = $total;
 273 #
 274 #    my $count = 0;
 275 #    $count++ while $tmp_rs->cursor->next;
 276 #
 277 #    $self->dbh->{syb_rowcount} = 0;
 278 #
 279 #    return $count - $offset;
 280 #  } else {
 281 #    # overwrite the selector
 282 #    $new_attrs->{select} = { count => '*' };
 283 #
 284 #    my $tmp_rs = $source->resultset_class->new($source, $new_attrs);
 285 #    my ($count) = $tmp_rs->cursor->next;
 286 #
 287 #    # if the offset/rows attributes are still present, we did not use
 288 #    # a subquery, so we need to make the calculations in software
 289 #    $count -= $attrs->{offset} if $attrs->{offset};
 290 #    $count = $attrs->{rows} if $attrs->{rows} and $attrs->{rows} < $count;
 291 #    $count = 0 if ($count < 0);
 292 #
 293 #    return $count;
 294 #  }
 295 #}
 296
 297 1;
 298
 299 =head1 DATES
 300
 301 See L</connect_call_datetime_setup> to setup date formats
 302 for L<DBIx::Class::InflateColumn::DateTime>.
 303
 304 =head1 IMAGE AND TEXT COLUMNS
 305
 306 See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
 307 setting you need to work with C<IMAGE> columns.
 308
 309 Due to limitations in L<DBD::Sybase> and this driver, it is only possible to
 310 select one C<TEXT> or C<IMAGE> column at a time.
 311
 312 =head1 AUTHORS
 313
 314 See L<DBIx::Class/CONTRIBUTORS>.
 315
 316 =head1 LICENSE
 317
 318 You may distribute this code under the same terms as Perl itself.
 319
 320 =cut
 321 # vim:sts=2 sw=2: