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