Skip Menu |
 

This queue is for tickets about the Class-DBI-Sybase CPAN distribution.

Report information
The Basics
Id: 21130
Status: new
Priority: 0/
Queue: Class-DBI-Sybase

People
Owner: theothermike [...] gmail.com
Requestors: useEvil [...] gmail.com
Cc:
AdminCc:

Bug Information
Severity: Critical
Broken in: 0.4
Fixed in: (no value)



Subject: INDENTITY updates
Download (untitled) / with headers
text/plain 468b
In trying to use Class::DBI::Sybase, I found a defect in the updating methods. IDENTITY columns are getting assigned as changed. But, you cannot change the an IDENTITY value unless you've set IDENTITY_INSERT to ON. I patched the code so that the IDENTITY column is omitted from the changed columns. I implemented the changes in much the same way as the TEXT column exclusion code, although I expect there would only be one IDENTITY column, as is that is the norm.
Subject: Sybase.pm
Download Sybase.pm
text/x-perl 5.4k
package Class::DBI::Sybase; =head1 NAME Class::DBI::Sybase - Extensions to Class::DBI for Sybase =head1 SYNOPSIS package Music::DBI; use base 'Class::DBI::Sybase'; Music::DBI->set_db('Main', 'dbi:Sybase:server=$server', 'username', 'password'); package Artist; use base 'Music::DBI'; __PACKAGE__->set_up_table('Artist'); # ... see the Class::DBI documentation for details on Class::DBI usage =head1 DESCRIPTION This is an extension to Class::DBI that currently implements: * Automatic column name discovery. * Works with IDENTITY columns to auto-generate primary keys. * Works with TEXT columns for create() and update() Instead of setting Class::DBI as your base class, use this. =head1 BUGS DBD::Sybase currently has a bug where a statement handle can be marked as active, even though it's not. We override sth_to_objects to call finish() on the handle. =head1 AUTHORS Dan Sully E<lt>daniel@cpan.orgE<gt> Michael Wojcikewicz E<lt>theothermike@gmail.com<gt> Paul Sandulescu E<lt>paul.sandulescu@mail.mcgill.com<gt> =head1 SEE ALSO L<Class::DBI>, L<DBD::Sybase> =cut use strict; use base 'Class::DBI'; use vars qw($VERSION); $VERSION = '0.4'; sub _die { require Carp; Carp::croak(@_); } # This is necessary to get the last ID back __PACKAGE__->set_sql(MakeNewObj => <<''); SET NOCOUNT ON INSERT INTO __TABLE__ (%s) VALUES (%s) SELECT @@IDENTITY sub set_up_table { my($class, $table) = @_; my $dbh = $class->db_Main(); $class->table($table); # find the primary key and column names. my $sth = $dbh->prepare("sp_columns $table"); $sth->execute(); my $col = $sth->fetchall_arrayref; $sth->finish(); _die('The "'. $class->table() . '" table has no primary key') unless $col->[0][3]; $class->columns(All => map {$_->[3]} @$col); $class->columns(Primary => $col->[0][3]); # find any text columns that will get quoted upon INSERT $class->columns(TEXT => map { $_->[5] eq 'text' ? $_->[3] : () } @$col); # now find the IDENTITY column $sth = $dbh->prepare("sp_help $table"); $sth -> execute(); # the first two resultsets contain no info about finding the identity column $sth -> fetchall_arrayref() for 1 .. 2; $col = $sth -> fetchall_arrayref(); my ($identity) = grep( $_ -> [9] == 1, @$col ); # the 10th column contains a boolean denoting whether it's an IDENTITY $class -> columns(IDENTITY => $identity -> [0]) if $identity; # store the IDENTITY column } # Fixes a DBD::Sybase problem where the handle is still active. sub sth_to_objects { my ($class, $sth, $args) = @_; $class->_croak("sth_to_objects needs a statement handle") unless $sth; unless (UNIVERSAL::isa($sth => "DBI::st")) { my $meth = "sql_$sth"; $sth = $class->$meth(); } $sth->finish() if $sth->{Active}; return $class->SUPER::sth_to_objects($sth, $args); } sub _column_placeholder { my $self = shift; my $column = shift; my $data = shift; my @text_columns = $self -> columns('TEXT'); # if its a text column, we need to $dbh -> quote() it, rather than using a placeholder, limitation of Sybase TDS libraries if ($data && grep { $_ eq $column } @text_columns) { return $self -> db_Main -> quote($data); } else { return $self -> SUPER::_column_placeholder( $column ); } } sub _insert_row { my $self = shift; my $data = shift; my @identity_columns = $self -> primary_columns; my @text_columns = $self -> columns('TEXT'); eval { my @columns; my @values; # Omit the IDENTITY column to let it be Auto Generated for my $column (keys %$data) { next if defined $identity_columns[0] && $column eq $identity_columns[0]; push @columns, $column; # Omit the text column since it needs to be quoted push @values, $data -> {$column} unless grep { $_ eq $column } @text_columns; } my $sth = $self->sql_MakeNewObj( join(', ', @columns), join(', ', map $self->_column_placeholder($_, $data -> {$_}), @columns), # this uses the new placeholder methods that quotes ); $self->_bind_param($sth, \@columns); $sth->execute(@values); my $id = $sth -> fetchrow_arrayref() -> [0]; $data->{ $identity_columns[0] } = $id if @identity_columns == 1 && !defined $data->{ $identity_columns[0] }; $sth->finish if $sth -> {Active}; }; if ($@) { my $class = ref $self; return $self->_croak( "Can't insert new $class: $@", err => $@, method => 'create' ); } return 1; } sub _update_vals { my $self = shift; my @text_columns = $self -> columns('TEXT'); my @ident_columns = $self -> columns('IDENTITY'); my @changed = $self -> is_changed(); my @columns; foreach my $changed (@changed) { # omit TEXT columns from the update clause since they are quoted next if grep { $_ eq $changed } @ident_columns; push @columns, $changed unless grep { $_ eq $changed } @text_columns; } return $self -> _attrs(@columns); } sub _update_line { my $self = shift; my @changed = $self -> is_changed; my @ident_columns = $self -> columns('IDENTITY'); my @columns; foreach my $changed (@changed) { # omit IDENTITY columns from the update clause since they are cannot be # changed without first setting IDENTITY_INSERT to ON push @columns, $changed unless grep { $_ eq $changed } @ident_columns; } # use our custom _column_placeholder that quotes TEXT columns return join(', ', map "$_ = " . $self -> _column_placeholder($_, $self -> $_()), @columns); } 1; # TODO: LIMIT ?


This service is sponsored and maintained by Best Practical Solutions and runs on Perl.org infrastructure.

Please report any issues with rt.cpan.org to rt-cpan-admin@bestpractical.com.