From: Rafael Kitover <rkitover@cpan.org>
Date: Tue, 2 Feb 2010 12:21:13 +0000 (+0000)
Subject: ASA last_insert_id and limit support, still needs BLOB support
X-Git-Tag: v0.08116~14^2~6
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f200d74bc27c2143237595dde6b6913098045114;p=dbsrgits%2FDBIx-Class.git

ASA last_insert_id and limit support, still needs BLOB support
---

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index e07f116..ccd1cf2 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -2586,7 +2586,10 @@ sub DESTROY {
   # some databases need this to stop spewing warnings
   if (my $dbh = $self->_dbh) {
     local $@;
-    eval { $dbh->disconnect };
+    eval {
+      %{ $dbh->{CachedKids} } = ();
+      $dbh->disconnect;
+    };
   }
 
   $self->_dbh(undef);
diff --git a/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm b/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm
new file mode 100644
index 0000000..7d56057
--- /dev/null
+++ b/lib/DBIx/Class/Storage/DBI/SQLAnywhere.pm
@@ -0,0 +1,19 @@
+package # hide from PAUSE
+  DBIx::Class::Storage::DBI::SQLAnywhere;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Storage::DBI/;
+use mro 'c3';
+
+sub _rebless {
+  my $self = shift;
+
+  if (ref $self eq __PACKAGE__) {
+    require DBIx::Class::Storage::DBI::Sybase::ASA;
+    bless $self, 'DBIx::Class::Storage::DBI::Sybase::ASA';
+    $self->_rebless;
+  }
+}
+
+1;
diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASA.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASA.pm
new file mode 100644
index 0000000..9820060
--- /dev/null
+++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASA.pm
@@ -0,0 +1,79 @@
+package DBIx::Class::Storage::DBI::Sybase::ASA;
+
+use strict;
+use warnings;
+use base qw/DBIx::Class::Storage::DBI/;
+use mro 'c3';
+use List::Util ();
+
+__PACKAGE__->mk_group_accessors(simple => qw/
+  _identity
+/);
+
+=head1 NAME
+
+DBIx::Class::Storage::DBI::Sybase::ASA - Driver for Sybase SQL Anywhere
+
+=head1 DESCRIPTION
+
+This class implements autoincrements for Sybase SQL Anywhere and selects the
+RowNumberOver limit implementation.
+
+You need the C<DBD::SQLAnywhere> driver that comes with the SQL Anywhere
+distribution, B<NOT> the one on CPAN. It is usually under a path such as:
+
+    /opt/sqlanywhere11/sdk/perl
+
+=cut
+
+sub last_insert_id { shift->_identity }
+
+sub insert {
+  my $self = shift;
+  my ($source, $to_insert) = @_;
+
+  my $supplied_col_info = $self->_resolve_column_info($source, [keys %$to_insert]);
+
+  my $is_identity_insert = (List::Util::first { $_->{is_auto_increment} } (values %$supplied_col_info) )
+     ? 1
+     : 0;
+
+  if (not $is_identity_insert) {
+    my ($identity_col) = grep $source->column_info($_)->{is_auto_increment},
+      $source->primary_columns;
+    my $dbh = $self->_get_dbh;
+    my $table_name = $source->from;
+
+    my ($identity) = $dbh->selectrow_array("SELECT GET_IDENTITY('$table_name')");
+
+    $to_insert->{$identity_col} = $identity;
+
+    $self->_identity($identity);
+  }
+
+  return $self->next::method(@_);
+}
+
+# stolen from DB2
+
+sub _sql_maker_opts {
+  my ( $self, $opts ) = @_;
+
+  if ( $opts ) {
+    $self->{_sql_maker_opts} = { %$opts };
+  }
+
+  return { limit_dialect => 'RowNumberOver', %{$self->{_sql_maker_opts}||{}} };
+}
+
+1;
+
+=head1 AUTHOR
+
+See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
+
+=head1 LICENSE
+
+You may distribute this code under the same terms as Perl itself.
+
+=cut
diff --git a/t/749sybase_asa.t b/t/749sybase_asa.t
new file mode 100644
index 0000000..f18a3d3
--- /dev/null
+++ b/t/749sybase_asa.t
@@ -0,0 +1,82 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Exception;
+use lib qw(t/lib);
+use DBICTest;
+
+my ($dsn, $user, $pass) = @ENV{map { "DBICTEST_SYBASE_ASA_${_}" } qw/DSN USER PASS/};
+
+#warn "$dsn $user $pass";
+
+plan skip_all => 'Set $ENV{DBICTEST_SYBASE_ASA_DSN}, _USER and _PASS to run this test'
+  unless ($dsn && $user);
+
+my $schema = DBICTest::Schema->connect($dsn, $user, $pass);
+
+my $dbh = $schema->storage->dbh;
+
+eval { $dbh->do("DROP TABLE artist") };
+
+$dbh->do("CREATE TABLE artist (artistid INT IDENTITY PRIMARY KEY, name VARCHAR(255), charfield CHAR(10), rank INT DEFAULT 13)");
+
+my $ars = $schema->resultset('Artist');
+is ( $ars->count, 0, 'No rows at first' );
+
+# test primary key handling
+my $new = $ars->create({ name => 'foo' });
+ok($new->artistid, "Auto-PK worked");
+
+# test explicit key spec
+$new = $ars->create ({ name => 'bar', artistid => 66 });
+is($new->artistid, 66, 'Explicit PK worked');
+$new->discard_changes;
+is($new->artistid, 66, 'Explicit PK assigned');
+
+# test populate
+lives_ok (sub {
+  my @pop;
+  for (1..2) {
+    push @pop, { name => "Artist_$_" };
+  }
+  $ars->populate (\@pop);
+});
+
+# test populate with explicit key
+lives_ok (sub {
+  my @pop;
+  for (1..2) {
+    push @pop, { name => "Artist_expkey_$_", artistid => 100 + $_ };
+  }
+  $ars->populate (\@pop);
+});
+
+# count what we did so far
+is ($ars->count, 6, 'Simple count works');
+
+# test LIMIT support
+my $lim = $ars->search( {},
+  {
+    rows => 3,
+    offset => 4,
+    order_by => 'artistid'
+  }
+);
+is( $lim->count, 2, 'ROWS+OFFSET count ok' );
+is( $lim->all, 2, 'Number of ->all objects matches count' );
+
+# test iterator
+$lim->reset;
+is( $lim->next->artistid, 101, "iterator->next ok" );
+is( $lim->next->artistid, 102, "iterator->next ok" );
+is( $lim->next, undef, "next past end of resultset ok" );
+
+
+done_testing;
+
+# clean up our mess
+END {
+    my $dbh = eval { $schema->storage->_dbh };
+    $dbh->do("DROP TABLE artist") if $dbh;
+}