X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2FStorage%2FDBI%2FSybase.pm;h=68c2e20eef6a4c316caedb25b4cd36546b3e2133;hb=51ac7136944f82aa2675cc133a8d080c5fb367b1;hp=b47127516ff0a8450d48662737a75576ef911108;hpb=aa56ff9a9024085a54833d427505e0f57937731d;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/Storage/DBI/Sybase.pm b/lib/DBIx/Class/Storage/DBI/Sybase.pm index b471275..68c2e20 100644 --- a/lib/DBIx/Class/Storage/DBI/Sybase.pm +++ b/lib/DBIx/Class/Storage/DBI/Sybase.pm @@ -3,17 +3,56 @@ package DBIx::Class::Storage::DBI::Sybase; use strict; use warnings; -use Class::C3; -use base qw/DBIx::Class::Storage::DBI/; - +use base qw/ + DBIx::Class::Storage::DBI::Sybase::Common + DBIx::Class::Storage::DBI::AutoCast +/; +use mro 'c3'; use Carp::Clan qw/^DBIx::Class/; +use List::Util (); + +__PACKAGE__->mk_group_accessors('simple' => + qw/_identity _blob_log_on_update unsafe_insert _insert_dbh/ +); + +=head1 NAME + +DBIx::Class::Storage::DBI::Sybase - Sybase support for DBIx::Class + +=head1 SYNOPSIS + +This subclass supports L for real Sybase databases. If you are +using an MSSQL database via L, your storage will be reblessed to +L. + +=head1 DESCRIPTION + +If your version of Sybase does not support placeholders, then your storage +will be reblessed to L. 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 +without doing a C when placeholders are enabled. + +When using C transactions are +disabled. + +To turn off transactions for inserts (for an application that doesn't need +concurrency, or a loader, for example) use this setting in +L, + + on_connect_call => ['unsafe_insert'] + +To manipulate this setting at runtime, use: + + $schema->storage->unsafe_insert(0|1); + +=cut + +sub connect_call_unsafe_insert { + my $self = shift; + $self->unsafe_insert(1); +} + +sub _is_lob_type { + my $self = shift; + my $type = shift; + $type && $type =~ /(?:text|image|lob|bytea|binary|memo)/i; +} + +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 = join ("\n", + "SET IDENTITY_INSERT $table ON", + $sql, + "SET IDENTITY_INSERT $table OFF", + ); + } + else { + $identity_col = List::Util::first + { $ident->column_info($_)->{is_auto_increment} } + $ident->columns + ; + } + + if ($identity_col) { + $sql = + "$sql\n" . + $self->_fetch_identity_sql($ident, $identity_col); } } + + return ($sql, $bind); } +# Stolen from SQLT, with some modifications. This is a makeshift +# solution before a sane type-mapping library is available, thus +# the 'our' for easy overrides. +our %TYPE_MAPPING = ( + number => 'numeric', + money => 'money', + varchar => 'varchar', + varchar2 => 'varchar', + timestamp => 'datetime', + text => 'varchar', + real => 'double precision', + comment => 'text', + bit => 'bit', + tinyint => 'smallint', + float => 'double precision', + serial => 'numeric', + bigserial => 'numeric', + boolean => 'varchar', + long => 'varchar', +); + +sub _native_data_type { + my ($self, $type) = @_; + + $type = lc $type; + $type =~ s/\s* identity//x; + + return uc($TYPE_MAPPING{$type} || $type); +} + +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 } + +# handles TEXT/IMAGE and transaction for last_insert_id +sub insert { + my $self = shift; + my ($source, $to_insert) = @_; + + my $blob_cols = $self->_remove_blob_cols($source, $to_insert); + +# insert+blob insert done atomically + my $guard = $self->txn_scope_guard if $blob_cols; + + my $need_last_insert_id = 0; + + my ($identity_col) = + map $_->[0], + grep $_->[1]{is_auto_increment}, + map [ $_, $source->column_info($_) ], + $source->columns; + + $need_last_insert_id = 1 + if $identity_col && (not exists $to_insert->{$identity_col}); + + # We have to do the insert in a transaction to avoid race conditions with the + # SELECT MAX(COL) identity method used when placeholders are enabled. + my $updated_cols = do { + if ( + $need_last_insert_id && !$self->unsafe_insert && !$self->{transaction_depth} + ) { + $self->_insert_dbh($self->_connect(@{ $self->_dbi_connect_info })) + unless $self->_insert_dbh; + local $self->{_dbh} = $self->_insert_dbh; + my $guard = $self->txn_scope_guard; + my $upd_cols = $self->next::method (@_); + $guard->commit; + $self->_insert_dbh($self->_dbh); + $upd_cols; + } + else { + $self->next::method(@_); + } + }; + + $self->_insert_blobs($source, $blob_cols, $to_insert) if $blob_cols; + + $guard->commit if $guard; + + return $updated_cols; +} + +sub update { + my $self = shift; + my ($source, $fields, $where) = @_; + + my $wantarray = wantarray; + + my $blob_cols = $self->_remove_blob_cols($source, $fields); + +# update+blob update(s) done atomically + my $guard = $self->txn_scope_guard if $blob_cols; + + my @res; + if ($wantarray) { + @res = $self->next::method(@_); + } + elsif (defined $wantarray) { + $res[0] = $self->next::method(@_); + } + else { + $self->next::method(@_); + } + + $self->_update_blobs($source, $blob_cols, $where) if $blob_cols; + + $guard->commit if $guard; + + 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 keys %blob_cols ? \%blob_cols : undef; +} + +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->_get_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 %where = map { ($_, $row{$_}) } @primary_cols; + my $cursor = $source->resultset->search(\%where, { + select => [$col] + })->cursor; + $cursor->next; + my $sth = $cursor->sth; + + eval { + do { + $sth->func('CS_GET', 1, 'ct_data_info') or die $sth->errstr; + } while $sth->fetch; + + $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 if $sth; + if ($exception) { + if ($self->using_freetds) { + croak ( + 'TEXT/IMAGE operation failed, probably because you are using FreeTDS: ' + . $exception + ); + } else { + croak $exception; + } + } + } +} + +=head2 connect_call_datetime_setup + +Used as: + + on_connect_call => 'datetime_setup' + +In L 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, using +L, which you will need to install. + +This works for both C and C columns, although +C columns only have minute precision. + +=cut + { my $old_dbd_warned = 0; - sub _populate_dbh { + sub connect_call_datetime_setup { my $self = shift; - $self->next::method(@_); my $dbh = $self->_dbh; if ($dbh->can('syb_date_fmt')) { + # amazingly, this works with FreeTDS $dbh->syb_date_fmt('ISO_strict'); } elsif (not $old_dbd_warned) { carp "Your DBD::Sybase is too old to support ". @@ -46,85 +512,174 @@ sub _rebless { $old_dbd_warned = 1; } - $dbh->do('set dateformat mdy'); + $dbh->do('SET DATEFORMAT mdy'); 1; } } -sub _dbh_last_insert_id { - my ($self, $dbh, $source, $col) = @_; +sub datetime_parser_type { "DateTime::Format::Sybase" } - # sorry, there's no other way! - my $sth = $dbh->prepare_cached("select max($col) from ".$source->from); - return ($dbh->selectrow_array($sth))[0]; -} +# ->begin_work and such have no effect with FreeTDS but we run them anyway to +# let the DBD keep any state it needs to. +# +# If they ever do start working, the extra statements will do no harm (because +# Sybase supports nested transactions.) -sub count { +sub _dbh_begin_work { my $self = shift; - my ($source, $attrs) = @_; + $self->next::method(@_); + if ($self->using_freetds) { + $self->_get_dbh->do('BEGIN TRAN'); + } +} - if (not exists $attrs->{rows}) { - return $self->next::method(@_); +sub _dbh_commit { + my $self = shift; + if ($self->using_freetds) { + $self->_dbh->do('COMMIT'); } + return $self->next::method(@_); +} - my $offset = $attrs->{offset} || 0; - my $total = $attrs->{rows} + $offset; +sub _dbh_rollback { + my $self = shift; + if ($self->using_freetds) { + $self->_dbh->do('ROLLBACK'); + } + return $self->next::method(@_); +} - my $new_attrs = $self->_trim_attributes_for_count($source, $attrs); - $new_attrs->{select} = '1'; - $new_attrs->{as} = ['dummy']; +# savepoint support using ASE syntax - my $tmp_rs = $source->resultset_class->new($source, $new_attrs); +sub _svp_begin { + my ($self, $name) = @_; - $self->dbh->{syb_rowcount} = $total; + $self->_get_dbh->do("SAVE TRANSACTION $name"); +} - my $count = 0; - $count++ while $tmp_rs->cursor->next; +# A new SAVE TRANSACTION with the same name releases the previous one. +sub _svp_release { 1 } - $self->dbh->{syb_rowcount} = 0; +sub _svp_rollback { + my ($self, $name) = @_; - return $count - $offset; + $self->_get_dbh->do("ROLLBACK TRANSACTION $name"); } -sub datetime_parser_type { "DBIx::Class::Storage::DBI::Sybase::DateTime" } - 1; -=head1 NAME +=head1 Schema::Loader Support -DBIx::Class::Storage::DBI::Sybase - Storage::DBI subclass for Sybase +There is an experimental branch of L that will +allow you to dump a schema from most (if not all) versions of Sybase. -=head1 SYNOPSIS +It is available via subversion from: -This subclass supports L for real Sybase databases. If you are -using an MSSQL database via L, your storage will be reblessed to -L. + http://dev.catalyst.perl.org/repos/bast/branches/DBIx-Class-Schema-Loader/current/ -=head1 DESCRIPTION +=head1 FreeTDS -If your version of Sybase does not support placeholders, then your storage -will be reblessed to L. You can -also enable that driver explicitly, see the documentation for more details. +This driver supports L compiled against FreeTDS +(L) to the best of our ability, however it is +recommended that you recompile L against the Sybase Open Client +libraries. They are a part of the Sybase ASE distribution: -With this driver there is unfortunately no way to get the C -without doing a C