[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / Storage / DBI / Sybase.pm

package DBIx::Class::Storage::DBI::Sybase;

use strict;
use warnings;

use base qw/
    DBIx::Class::Storage::DBI::Sybase::Base
    DBIx::Class::Storage::DBI
/;
use mro 'c3';
use Carp::Clan qw/^DBIx::Class/;
use List::Util ();

__PACKAGE__->mk_group_accessors('simple' =>
    qw/_identity _blob_log_on_update/
);

=head1 NAME

DBIx::Class::Storage::DBI::Sybase - Sybase support for DBIx::Class

=head1 SYNOPSIS

This subclass supports L<DBD::Sybase> for real Sybase databases.  If you are
using an MSSQL database via L<DBD::Sybase>, your storage will be reblessed to
L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.

=head1 DESCRIPTION

If your version of Sybase does not support placeholders, then your storage
will be reblessed to L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>. You can
also enable that driver explicitly, see the documentation for more details.

With this driver there is unfortunately no way to get the C<last_insert_id>
without doing a C<select max(col)>.

But your queries will be cached.

You need a version of L<DBD::Sybase> compiled with the Sybase OpenClient
libraries, B<NOT> FreeTDS, for placeholder support. Otherwise your storage will
be automatically reblessed into C<::NoBindVars>.

A recommended L<DBIx::Class::Storage::DBI/connect_info> setting:

  on_connect_call => [['datetime_setup'], ['blob_setup', log_on_update => 0]]

=head1 METHODS

=cut

sub _rebless {
  my $self = shift;

  if (ref($self) eq 'DBIx::Class::Storage::DBI::Sybase') {
    my $dbtype = eval {
      @{$self->dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
    } || '';

    my $exception = $@;
    $dbtype =~ s/\W/_/gi;
    my $subclass = "DBIx::Class::Storage::DBI::Sybase::${dbtype}";

    if (!$exception && $dbtype && $self->load_optional_class($subclass)) {
      bless $self, $subclass;
      $self->_rebless;
    } else { # real Sybase
      my $no_bind_vars = 'DBIx::Class::Storage::DBI::Sybase::NoBindVars';

      if ($self->_using_freetds) {
        carp <<'EOF';

Your version of Sybase potentially supports placeholders and query caching,
however you seem to be using FreeTDS which does not (yet?) support this.

Please recompile DBD::Sybase with the Sybase OpenClient libraries if you want
these features.

TEXT/IMAGE column support will also not work under FreeTDS.

See perldoc DBIx::Class::Storage::DBI::Sybase for more details.
EOF
        $self->ensure_class_loaded($no_bind_vars);
        bless $self, $no_bind_vars;
        $self->_rebless;
      }

      if (not $self->dbh->{syb_dynamic_supported}) {
        $self->ensure_class_loaded($no_bind_vars);
        bless $self, $no_bind_vars;
        $self->_rebless;
      }
 
      $self->_set_maxConnect;
    }
  }
}

sub _using_freetds {
  my $self = shift;

  return $self->_dbh->{syb_oc_version} =~ /freetds/i;
}

sub _set_maxConnect {
  my $self = shift;

  my $dsn = $self->_dbi_connect_info->[0];

  return if ref($dsn) eq 'CODE';

  if ($dsn !~ /maxConnect=/) {
    $self->_dbi_connect_info->[0] = "$dsn;maxConnect=256";
    my $connected = defined $self->_dbh;
    $self->disconnect;
    $self->ensure_connected if $connected;
  }
}

=head2 connect_call_blob_setup

Used as:

  on_connect_call => [ [ 'blob_setup', log_on_update => 0 ] ]

Does C<< $dbh->{syb_binary_images} = 1; >> to return C<IMAGE> data as raw binary
instead of as a hex string.

Recommended.

Also sets the C<log_on_update> value for blob write operations. The default is
C<1>, but C<0> is better if your database is configured for it.

See
L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.

=cut

sub connect_call_blob_setup {
  my $self = shift;
  my %args = @_;
  my $dbh = $self->_dbh;
  $dbh->{syb_binary_images} = 1;

  $self->_blob_log_on_update($args{log_on_update})
    if exists $args{log_on_update};
}

sub _is_lob_type {
  my $self = shift;
  my $type = shift;
  $type && $type =~ /(?:text|image|lob|bytea|binary|memo)/i;
}

## This will be useful if we ever implement BLOB filehandle inflation and will
## need to use the API, but for now it isn't.
#
#sub order_columns_for_select {
#  my ($self, $source, $columns) = @_;
#
#  my (@non_blobs, @blobs);
#
#  for my $col (@$columns) {
#    if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
#      push @blobs, $col;
#    } else {
#      push @non_blobs, $col;
#    }
#  }
#
#  croak "cannot select more than a one TEXT/IMAGE column at a time"
#    if @blobs > 1;
#
#  return (@non_blobs, @blobs);
#}

# the select-piggybacking-on-insert trick stolen from odbc/mssql
sub _prep_for_execute {
  my $self = shift;
  my ($op, $extra_bind, $ident, $args) = @_;

  my ($sql, $bind) = $self->next::method (@_);

  if ($op eq 'insert') {
    my $table = $ident->from;

    my $bind_info = $self->_resolve_column_info($ident, [map $_->[0], @{$bind}]);
    my $identity_col =
List::Util::first { $bind_info->{$_}{is_auto_increment} } (keys %$bind_info);

    if ($identity_col) {
      $sql =
"SET IDENTITY_INSERT $table ON\n" .
"$sql\n" .
"SET IDENTITY_INSERT $table OFF"
    } else {
      $identity_col = List::Util::first {
        $ident->column_info($_)->{is_auto_increment}
      } $ident->columns;
    }

    if ($identity_col) {
# Sybase has nested transactions, only the outermost is actually committed
      $sql =
        "BEGIN TRANSACTION\n" .
        "$sql\n" .
        $self->_fetch_identity_sql($ident, $identity_col) . "\n" .
        "COMMIT";
    }
  }

  return ($sql, $bind);
}

sub _fetch_identity_sql {
  my ($self, $source, $col) = @_;

  return "SELECT MAX($col) FROM ".$source->from;
}

sub _execute {
  my $self = shift;
  my ($op) = @_;

  my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);

  if ($op eq 'insert') {
    $self->_identity($sth->fetchrow_array);
    $sth->finish;
  }

  return wantarray ? ($rv, $sth, @bind) : $rv;
}

sub last_insert_id { shift->_identity }

# override to handle TEXT/IMAGE
sub insert {
  my ($self, $source, $to_insert) = splice @_, 0, 3;
  my $dbh = $self->_dbh;

  my $blob_cols = $self->_remove_blob_cols($source, $to_insert);

  my $updated_cols = $self->next::method($source, $to_insert, @_);

  $self->_insert_blobs($source, $blob_cols, $to_insert) if %$blob_cols;

  return $updated_cols;
}

sub update {
  my ($self, $source)  = splice @_, 0, 2;
  my ($fields, $where) = @_;
  my $wantarray        = wantarray;

  my $blob_cols = $self->_remove_blob_cols($source, $fields);

  my @res;
  if ($wantarray) {
    @res    = $self->next::method($source, @_);
  } else {
    $res[0] = $self->next::method($source, @_);
  }

  $self->_update_blobs($source, $blob_cols, $where) if %$blob_cols;

  return $wantarray ? @res : $res[0];
}

sub _remove_blob_cols {
  my ($self, $source, $fields) = @_;

  my %blob_cols;

  for my $col (keys %$fields) {
    if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
      $blob_cols{$col} = delete $fields->{$col};
      $fields->{$col} = \"''";
    }
  }

  return \%blob_cols;
}

sub _update_blobs {
  my ($self, $source, $blob_cols, $where) = @_;

  my (@primary_cols) = $source->primary_columns;

  croak "Cannot update TEXT/IMAGE column(s) without a primary key"
    unless @primary_cols;

# check if we're updating a single row by PK
  my $pk_cols_in_where = 0;
  for my $col (@primary_cols) {
    $pk_cols_in_where++ if defined $where->{$col};
  }
  my @rows;

  if ($pk_cols_in_where == @primary_cols) {
    my %row_to_update;
    @row_to_update{@primary_cols} = @{$where}{@primary_cols};
    @rows = \%row_to_update;
  } else {
    my $rs = $source->resultset->search(
      $where,
      {
        result_class => 'DBIx::Class::ResultClass::HashRefInflator',
        select => \@primary_cols
      }
    );
    @rows = $rs->all; # statement must finish
  }

  for my $row (@rows) {
    $self->_insert_blobs($source, $blob_cols, $row);
  }
}

sub _insert_blobs {
  my ($self, $source, $blob_cols, $row) = @_;
  my $dbh = $self->dbh;

  my $table = $source->from;

  my %row = %$row;
  my (@primary_cols) = $source->primary_columns;

  croak "Cannot update TEXT/IMAGE column(s) without a primary key"
    unless @primary_cols;

  if ((grep { defined $row{$_} } @primary_cols) != @primary_cols) {
    if (@primary_cols == 1) {
      my $col = $primary_cols[0];
      $row{$col} = $self->last_insert_id($source, $col);
    } else {
      croak "Cannot update TEXT/IMAGE column(s) without primary key values";
    }
  }

  for my $col (keys %$blob_cols) {
    my $blob = $blob_cols->{$col};
    my $sth;

    if (not $self->isa('DBIx::Class::Storage::DBI::NoBindVars')) {
      my $search_cond = join ',' => map "$_ = ?", @primary_cols;

      $sth = $self->sth(
        "select $col from $table where $search_cond"
      );
      $sth->execute(map $row{$_}, @primary_cols);
    } else {
      my $search_cond = join ',' => map "$_ = $row{$_}", @primary_cols;

      $sth = $dbh->prepare(
        "select $col from $table where $search_cond"
      );
      $sth->execute;
    }

    eval {
      while ($sth->fetch) {
        $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
      }
      $sth->func('ct_prepare_send') or die $sth->errstr;

      my $log_on_update = $self->_blob_log_on_update;
      $log_on_update    = 1 if not defined $log_on_update;

      $sth->func('CS_SET', 1, {
        total_txtlen => length($blob),
        log_on_update => $log_on_update
      }, 'ct_data_info') or die $sth->errstr;

      $sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;

      $sth->func('ct_finish_send') or die $sth->errstr;
    };
    my $exception = $@;
    $sth->finish;
    croak $exception if $exception;
  }
}

=head2 connect_call_datetime_setup

Used as:

  on_connect_call => 'datetime_setup'

In L<DBIx::Class::Storage::DBI/connect_info> to set:

  $dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
  $dbh->do('set dateformat mdy');   # input fmt:  08/13/1979 18:08:55.080

On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
L<DateTime::Format::Sybase>, which you will need to install.

This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
C<SMALLDATETIME> columns only have minute precision.

=cut

{
  my $old_dbd_warned = 0;

  sub connect_call_datetime_setup {
    my $self = shift;
    my $dbh = $self->_dbh;

    if ($dbh->can('syb_date_fmt')) {
      $dbh->syb_date_fmt('ISO_strict');
    } elsif (not $old_dbd_warned) {
      carp "Your DBD::Sybase is too old to support ".
      "DBIx::Class::InflateColumn::DateTime, please upgrade!";
      $old_dbd_warned = 1;
    }

    $dbh->do('set dateformat mdy');

    1;
  }
}

sub datetime_parser_type { "DateTime::Format::Sybase" }

# savepoint support using ASE syntax

sub _svp_begin {
  my ($self, $name) = @_;

  $self->dbh->do("SAVE TRANSACTION $name");
}

# A new SAVE TRANSACTION with the same name releases the previous one.
sub _svp_release { 1 }

sub _svp_rollback {
  my ($self, $name) = @_;

  $self->dbh->do("ROLLBACK TRANSACTION $name");
}

1;

=head1 MAXIMUM CONNECTIONS

L<DBD::Sybase> makes separate connections to the server for active statements in
the background. By default the number of such connections is limited to 25, on
both the client side and the server side.

This is a bit too low, so on connection the clientside setting is set to C<256>
(see L<DBD::Sybase/maxConnect>.) You can override it to whatever setting you
like in the DSN.

See
L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
for information on changing the setting on the server side.

=head1 DATES

See L</connect_call_datetime_setup> to setup date formats
for L<DBIx::Class::InflateColumn::DateTime>.

=head1 IMAGE AND TEXT COLUMNS

L<DBD::Sybase> compiled with FreeTDS will B<NOT> work with C<TEXT/IMAGE>
columns.

See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
setting you need to work with C<IMAGE> columns.

=head1 AUTHORS

See L<DBIx::Class/CONTRIBUTORS>.

=head1 LICENSE

You may distribute this code under the same terms as Perl itself.

=cut
# vim:sts=2 sw=2:
Commit	Line	Data
3885cff6	1	package DBIx::Class::Storage::DBI::Sybase;
	2
	3	use strict;
	4	use warnings;
2ad62d97	5
eabab5d0	6	use base qw/
64f4e691	7	DBIx::Class::Storage::DBI::Sybase::Base
b0b44f97	8	DBIx::Class::Storage::DBI
eabab5d0	9	/;
2ad62d97	10	use mro 'c3';
6b1f5ef7	11	use Carp::Clan qw/^DBIx::Class/;
289877b0	12	use List::Util ();
6b1f5ef7	13
285baccb	14	__PACKAGE__->mk_group_accessors('simple' =>
	15	qw/_identity _blob_log_on_update/
	16	);
	17
98259fe4	18	=head1 NAME
98259fe4	19
928f0af8	20	DBIx::Class::Storage::DBI::Sybase - Sybase support for DBIx::Class
98259fe4	21
	22	=head1 SYNOPSIS
	23
	24	This subclass supports L<DBD::Sybase> for real Sybase databases. If you are
	25	using an MSSQL database via L<DBD::Sybase>, your storage will be reblessed to
	26	L<DBIx::Class::Storage::DBI::Sybase::Microsoft_SQL_Server>.
	27
	28	=head1 DESCRIPTION
	29
	30	If your version of Sybase does not support placeholders, then your storage
	31	will be reblessed to L<DBIx::Class::Storage::DBI::Sybase::NoBindVars>. You can
	32	also enable that driver explicitly, see the documentation for more details.
	33
	34	With this driver there is unfortunately no way to get the C<last_insert_id>
	35	without doing a C<select max(col)>.
	36
	37	But your queries will be cached.
	38
8c4b6c50	39	You need a version of L<DBD::Sybase> compiled with the Sybase OpenClient
	40	libraries, B<NOT> FreeTDS, for placeholder support. Otherwise your storage will
	41	be automatically reblessed into C<::NoBindVars>.
5703eb14	42
61cfaef7	43	A recommended L<DBIx::Class::Storage::DBI/connect_info> setting:
98259fe4	44
61cfaef7	45	on_connect_call => [['datetime_setup'], ['blob_setup', log_on_update => 0]]
98259fe4	46
	47	=head1 METHODS
	48
	49	=cut
	50
47d9646a	51	sub _rebless {
b50a5275	52	my $self = shift;
c5ce7cd6	53
	54	if (ref($self) eq 'DBIx::Class::Storage::DBI::Sybase') {
	55	my $dbtype = eval {
	56	@{$self->dbh->selectrow_arrayref(qq{sp_server_info \@attribute_id=1})}[2]
	57	} \|\| '';
	58
	59	my $exception = $@;
	60	$dbtype =~ s/\W/_/gi;
	61	my $subclass = "DBIx::Class::Storage::DBI::Sybase::${dbtype}";
	62
	63	if (!$exception && $dbtype && $self->load_optional_class($subclass)) {
	64	bless $self, $subclass;
	65	$self->_rebless;
5703eb14	66	} else { # real Sybase
	67	my $no_bind_vars = 'DBIx::Class::Storage::DBI::Sybase::NoBindVars';
	68
8c4b6c50	69	if ($self->_using_freetds) {
5703eb14	70	carp <<'EOF';
	71
	72	Your version of Sybase potentially supports placeholders and query caching,
8c4b6c50	73	however you seem to be using FreeTDS which does not (yet?) support this.
5703eb14	74
8c4b6c50	75	Please recompile DBD::Sybase with the Sybase OpenClient libraries if you want
	76	these features.
	77
	78	TEXT/IMAGE column support will also not work under FreeTDS.
5703eb14	79
	80	See perldoc DBIx::Class::Storage::DBI::Sybase for more details.
	81	EOF
	82	$self->ensure_class_loaded($no_bind_vars);
	83	bless $self, $no_bind_vars;
683f73ec	84	$self->_rebless;
683f73ec	85	}
61cfaef7	86
	87	if (not $self->dbh->{syb_dynamic_supported}) {
	88	$self->ensure_class_loaded($no_bind_vars);
	89	bless $self, $no_bind_vars;
	90	$self->_rebless;
	91	}
	92
41c93b1b	93	$self->_set_maxConnect;
47d9646a	94	}
c5ce7cd6	95	}
b50a5275	96	}
b50a5275	97
61cfaef7	98	sub _using_freetds {
61cfaef7	99	my $self = shift;
8c4b6c50	100
61cfaef7	101	return $self->_dbh->{syb_oc_version} =~ /freetds/i;
8c4b6c50	102	}
8c4b6c50	103
41c93b1b	104	sub _set_maxConnect {
	105	my $self = shift;
	106
	107	my $dsn = $self->_dbi_connect_info->[0];
	108
	109	return if ref($dsn) eq 'CODE';
	110
	111	if ($dsn !~ /maxConnect=/) {
	112	$self->_dbi_connect_info->[0] = "$dsn;maxConnect=256";
41c93b1b	113	my $connected = defined $self->_dbh;
	114	$self->disconnect;
	115	$self->ensure_connected if $connected;
	116	}
	117	}
	118
63d46bb3	119	=head2 connect_call_blob_setup
	120
	121	Used as:
	122
61cfaef7	123	on_connect_call => [ [ 'blob_setup', log_on_update => 0 ] ]
63d46bb3	124
	125	Does C<< $dbh->{syb_binary_images} = 1; >> to return C<IMAGE> data as raw binary
	126	instead of as a hex string.
	127
6636ad53	128	Recommended.
6636ad53	129
fd5a07e4	130	Also sets the C<log_on_update> value for blob write operations. The default is
	131	C<1>, but C<0> is better if your database is configured for it.
	132
	133	See
	134	L<DBD::Sybase/Handling_IMAGE/TEXT_data_with_syb_ct_get_data()/syb_ct_send_data()>.
	135
63d46bb3	136	=cut
	137
	138	sub connect_call_blob_setup {
	139	my $self = shift;
fd5a07e4	140	my %args = @_;
63d46bb3	141	my $dbh = $self->_dbh;
63d46bb3	142	$dbh->{syb_binary_images} = 1;
fd5a07e4	143
	144	$self->_blob_log_on_update($args{log_on_update})
	145	if exists $args{log_on_update};
	146	}
	147
	148	sub _is_lob_type {
	149	my $self = shift;
5703eb14	150	my $type = shift;
078a332f	151	$type && $type =~ /(?:text\|image\|lob\|bytea\|binary\|memo)/i;
fd5a07e4	152	}
fd5a07e4	153
b5453fbb	154	## This will be useful if we ever implement BLOB filehandle inflation and will
b5453fbb	155	## need to use the API, but for now it isn't.
5703eb14	156	#
b5453fbb	157	#sub order_columns_for_select {
61cfaef7	158	# my ($self, $source, $columns) = @_;
5703eb14	159	#
	160	# my (@non_blobs, @blobs);
	161	#
61cfaef7	162	# for my $col (@$columns) {
b5453fbb	163	# if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
5703eb14	164	# push @blobs, $col;
	165	# } else {
	166	# push @non_blobs, $col;
	167	# }
	168	# }
	169	#
b5453fbb	170	# croak "cannot select more than a one TEXT/IMAGE column at a time"
5703eb14	171	# if @blobs > 1;
5703eb14	172	#
b5453fbb	173	# return (@non_blobs, @blobs);
5703eb14	174	#}
5703eb14	175
285baccb	176	# the select-piggybacking-on-insert trick stolen from odbc/mssql
	177	sub _prep_for_execute {
	178	my $self = shift;
	179	my ($op, $extra_bind, $ident, $args) = @_;
	180
	181	my ($sql, $bind) = $self->next::method (@_);
	182
	183	if ($op eq 'insert') {
285baccb	184	my $table = $ident->from;
	185
	186	my $bind_info = $self->_resolve_column_info($ident, [map $_->[0], @{$bind}]);
ec15b3fe	187	my $identity_col =
285baccb	188	List::Util::first { $bind_info->{$_}{is_auto_increment} } (keys %$bind_info);
	189
	190	if ($identity_col) {
ec15b3fe	191	$sql =
	192	"SET IDENTITY_INSERT $table ON\n" .
	193	"$sql\n" .
	194	"SET IDENTITY_INSERT $table OFF"
285baccb	195	} else {
	196	$identity_col = List::Util::first {
	197	$ident->column_info($_)->{is_auto_increment}
	198	} $ident->columns;
	199	}
	200
	201	if ($identity_col) {
	202	# Sybase has nested transactions, only the outermost is actually committed
	203	$sql =
	204	"BEGIN TRANSACTION\n" .
285baccb	205	"$sql\n" .
285baccb	206	$self->_fetch_identity_sql($ident, $identity_col) . "\n" .
	207	"COMMIT";
	208	}
	209	}
	210
	211	return ($sql, $bind);
	212	}
	213
	214	sub _fetch_identity_sql {
	215	my ($self, $source, $col) = @_;
	216
	217	return "SELECT MAX($col) FROM ".$source->from;
	218	}
	219
	220	sub _execute {
	221	my $self = shift;
	222	my ($op) = @_;
	223
	224	my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
	225
	226	if ($op eq 'insert') {
	227	$self->_identity($sth->fetchrow_array);
	228	$sth->finish;
	229	}
	230
	231	return wantarray ? ($rv, $sth, @bind) : $rv;
	232	}
	233
	234	sub last_insert_id { shift->_identity }
	235
5703eb14	236	# override to handle TEXT/IMAGE
fd5a07e4	237	sub insert {
7d17f469	238	my ($self, $source, $to_insert) = splice @_, 0, 3;
289877b0	239	my $dbh = $self->_dbh;
7d17f469	240
	241	my $blob_cols = $self->_remove_blob_cols($source, $to_insert);
	242
	243	my $updated_cols = $self->next::method($source, $to_insert, @_);
	244
078a332f	245	$self->_insert_blobs($source, $blob_cols, $to_insert) if %$blob_cols;
7d17f469	246
	247	return $updated_cols;
	248	}
	249
078a332f	250	sub update {
	251	my ($self, $source) = splice @_, 0, 2;
	252	my ($fields, $where) = @_;
	253	my $wantarray = wantarray;
	254
	255	my $blob_cols = $self->_remove_blob_cols($source, $fields);
	256
	257	my @res;
	258	if ($wantarray) {
	259	@res = $self->next::method($source, @_);
	260	} else {
	261	$res[0] = $self->next::method($source, @_);
	262	}
	263
	264	$self->_update_blobs($source, $blob_cols, $where) if %$blob_cols;
	265
	266	return $wantarray ? @res : $res[0];
	267	}
7d17f469	268
	269	sub _remove_blob_cols {
	270	my ($self, $source, $fields) = @_;
fd5a07e4	271
	272	my %blob_cols;
	273
7d17f469	274	for my $col (keys %$fields) {
9b3dabe0	275	if ($self->_is_lob_type($source->column_info($col)->{data_type})) {
	276	$blob_cols{$col} = delete $fields->{$col};
	277	$fields->{$col} = \"''";
	278	}
fd5a07e4	279	}
fd5a07e4	280
7d17f469	281	return \%blob_cols;
fd5a07e4	282	}
	283
	284	sub _update_blobs {
078a332f	285	my ($self, $source, $blob_cols, $where) = @_;
	286
	287	my (@primary_cols) = $source->primary_columns;
	288
	289	croak "Cannot update TEXT/IMAGE column(s) without a primary key"
	290	unless @primary_cols;
	291
	292	# check if we're updating a single row by PK
	293	my $pk_cols_in_where = 0;
	294	for my $col (@primary_cols) {
	295	$pk_cols_in_where++ if defined $where->{$col};
	296	}
	297	my @rows;
	298
	299	if ($pk_cols_in_where == @primary_cols) {
	300	my %row_to_update;
	301	@row_to_update{@primary_cols} = @{$where}{@primary_cols};
	302	@rows = \%row_to_update;
	303	} else {
	304	my $rs = $source->resultset->search(
	305	$where,
	306	{
	307	result_class => 'DBIx::Class::ResultClass::HashRefInflator',
	308	select => \@primary_cols
	309	}
	310	);
	311	@rows = $rs->all; # statement must finish
	312	}
	313
	314	for my $row (@rows) {
	315	$self->_insert_blobs($source, $blob_cols, $row);
	316	}
	317	}
	318
	319	sub _insert_blobs {
	320	my ($self, $source, $blob_cols, $row) = @_;
fd5a07e4	321	my $dbh = $self->dbh;
	322
	323	my $table = $source->from;
	324
078a332f	325	my %row = %$row;
fd5a07e4	326	my (@primary_cols) = $source->primary_columns;
fd5a07e4	327
9b3dabe0	328	croak "Cannot update TEXT/IMAGE column(s) without a primary key"
fd5a07e4	329	unless @primary_cols;
fd5a07e4	330
078a332f	331	if ((grep { defined $row{$_} } @primary_cols) != @primary_cols) {
9b3dabe0	332	if (@primary_cols == 1) {
9b3dabe0	333	my $col = $primary_cols[0];
078a332f	334	$row{$col} = $self->last_insert_id($source, $col);
9b3dabe0	335	} else {
	336	croak "Cannot update TEXT/IMAGE column(s) without primary key values";
	337	}
	338	}
fd5a07e4	339
	340	for my $col (keys %$blob_cols) {
	341	my $blob = $blob_cols->{$col};
9b3dabe0	342	my $sth;
fd5a07e4	343
9b3dabe0	344	if (not $self->isa('DBIx::Class::Storage::DBI::NoBindVars')) {
	345	my $search_cond = join ',' => map "$_ = ?", @primary_cols;
	346
	347	$sth = $self->sth(
	348	"select $col from $table where $search_cond"
	349	);
078a332f	350	$sth->execute(map $row{$_}, @primary_cols);
9b3dabe0	351	} else {
078a332f	352	my $search_cond = join ',' => map "$_ = $row{$_}", @primary_cols;
9b3dabe0	353
	354	$sth = $dbh->prepare(
	355	"select $col from $table where $search_cond"
	356	);
	357	$sth->execute;
	358	}
fd5a07e4	359
	360	eval {
	361	while ($sth->fetch) {
	362	$sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr;
	363	}
	364	$sth->func('ct_prepare_send') or die $sth->errstr;
	365
	366	my $log_on_update = $self->_blob_log_on_update;
	367	$log_on_update = 1 if not defined $log_on_update;
	368
	369	$sth->func('CS_SET', 1, {
	370	total_txtlen => length($blob),
	371	log_on_update => $log_on_update
	372	}, 'ct_data_info') or die $sth->errstr;
	373
	374	$sth->func($blob, length($blob), 'ct_send_data') or die $sth->errstr;
	375
	376	$sth->func('ct_finish_send') or die $sth->errstr;
	377	};
	378	my $exception = $@;
	379	$sth->finish;
	380	croak $exception if $exception;
	381	}
63d46bb3	382	}
63d46bb3	383
9539eeb1	384	=head2 connect_call_datetime_setup
	385
	386	Used as:
	387
	388	on_connect_call => 'datetime_setup'
	389
	390	In L<DBIx::Class::Storage::DBI/connect_info> to set:
	391
3abafb11	392	$dbh->syb_date_fmt('ISO_strict'); # output fmt: 2004-08-21T14:36:48.080Z
3abafb11	393	$dbh->do('set dateformat mdy'); # input fmt: 08/13/1979 18:08:55.080
9539eeb1	394
9539eeb1	395	On connection for use with L<DBIx::Class::InflateColumn::DateTime>, using
3abafb11	396	L<DateTime::Format::Sybase>, which you will need to install.
	397
	398	This works for both C<DATETIME> and C<SMALLDATETIME> columns, although
	399	C<SMALLDATETIME> columns only have minute precision.
9539eeb1	400
	401	=cut
	402
9041a97a	403	{
	404	my $old_dbd_warned = 0;
	405
9539eeb1	406	sub connect_call_datetime_setup {
6b1f5ef7	407	my $self = shift;
6b1f5ef7	408	my $dbh = $self->_dbh;
	409
	410	if ($dbh->can('syb_date_fmt')) {
	411	$dbh->syb_date_fmt('ISO_strict');
	412	} elsif (not $old_dbd_warned) {
	413	carp "Your DBD::Sybase is too old to support ".
	414	"DBIx::Class::InflateColumn::DateTime, please upgrade!";
	415	$old_dbd_warned = 1;
	416	}
	417
	418	$dbh->do('set dateformat mdy');
c5ce7cd6	419
6b1f5ef7	420	1;
c5ce7cd6	421	}
6b1f5ef7	422	}
6b1f5ef7	423
6636ad53	424	sub datetime_parser_type { "DateTime::Format::Sybase" }
6636ad53	425
1816be4f	426	# savepoint support using ASE syntax
	427
	428	sub _svp_begin {
	429	my ($self, $name) = @_;
	430
	431	$self->dbh->do("SAVE TRANSACTION $name");
	432	}
	433
	434	# A new SAVE TRANSACTION with the same name releases the previous one.
	435	sub _svp_release { 1 }
	436
	437	sub _svp_rollback {
	438	my ($self, $name) = @_;
	439
	440	$self->dbh->do("ROLLBACK TRANSACTION $name");
	441	}
	442
3885cff6	443	1;
3885cff6	444
41c93b1b	445	=head1 MAXIMUM CONNECTIONS
	446
	447	L<DBD::Sybase> makes separate connections to the server for active statements in
	448	the background. By default the number of such connections is limited to 25, on
	449	both the client side and the server side.
	450
	451	This is a bit too low, so on connection the clientside setting is set to C<256>
	452	(see L<DBD::Sybase/maxConnect>.) You can override it to whatever setting you
	453	like in the DSN.
	454
	455	See
	456	L<http://infocenter.sybase.com/help/index.jsp?topic=/com.sybase.help.ase_15.0.sag1/html/sag1/sag1272.htm>
	457	for information on changing the setting on the server side.
	458
c5ce7cd6	459	=head1 DATES
c5ce7cd6	460
3abafb11	461	See L</connect_call_datetime_setup> to setup date formats
3abafb11	462	for L<DBIx::Class::InflateColumn::DateTime>.
c5ce7cd6	463
6636ad53	464	=head1 IMAGE AND TEXT COLUMNS
63d46bb3	465
8c4b6c50	466	L<DBD::Sybase> compiled with FreeTDS will B<NOT> work with C<TEXT/IMAGE>
8c4b6c50	467	columns.
5703eb14	468
63d46bb3	469	See L</connect_call_blob_setup> for a L<DBIx::Class::Storage::DBI/connect_info>
	470	setting you need to work with C<IMAGE> columns.
	471
3885cff6	472	=head1 AUTHORS
3885cff6	473
7e8cecc1	474	See L<DBIx::Class/CONTRIBUTORS>.
c5ce7cd6	475
3885cff6	476	=head1 LICENSE
	477
	478	You may distribute this code under the same terms as Perl itself.
	479
	480	=cut
c5ce7cd6	481	# vim:sts=2 sw=2: