2f2768834d83c62aabf7b2524ec76385ddbedb6c
[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 # 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: