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