From: Rafael Kitover <rkitover@cpan.org>
Date: Fri, 5 Mar 2010 23:06:31 +0000 (+0000)
Subject: auto_nextval support for Firebird
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=e1958268b5faaf856f1c5b29d585da848eb2edb3;p=dbsrgits%2FDBIx-Class-Historic.git

auto_nextval support for Firebird
---

diff --git a/lib/DBIx/Class/ResultSource.pm b/lib/DBIx/Class/ResultSource.pm
index 4b6ec45..b849696 100644
--- a/lib/DBIx/Class/ResultSource.pm
+++ b/lib/DBIx/Class/ResultSource.pm
@@ -250,9 +250,9 @@ sequence, if you do not use a trigger to get the nextval, you have to set the
 L</sequence> value as well.
 
 Also set this for MSSQL columns with the 'uniqueidentifier'
-L<DBIx::Class::ResultSource/data_type> whose values you want to automatically
-generate using C<NEWID()>, unless they are a primary key in which case this will
-be done anyway.
+L<data_type|DBIx::Class::ResultSource/data_type> whose values you want to
+automatically generate using C<NEWID()>, unless they are a primary key in which
+case this will be done anyway.
 
 =item extra
 
diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index a51b278..a1e3055 100644
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -1375,7 +1375,7 @@ sub insert {
         $updated_cols->{$col} = $to_insert->{$col} = $self->_sequence_fetch(
           'nextval',
           $col_info->{sequence} ||
-            $self->_dbh_get_autoinc_seq($self->_get_dbh, $source)
+            $self->_dbh_get_autoinc_seq($self->_get_dbh, $source, $col)
         );
       }
     }
diff --git a/lib/DBIx/Class/Storage/DBI/InterBase.pm b/lib/DBIx/Class/Storage/DBI/InterBase.pm
index d82e9be..6fd783f 100644
--- a/lib/DBIx/Class/Storage/DBI/InterBase.pm
+++ b/lib/DBIx/Class/Storage/DBI/InterBase.pm
@@ -86,6 +86,62 @@ sub _execute {
   return wantarray ? ($rv, $sth, @bind) : $rv;
 }
 
+sub _sequence_fetch {
+  my ($self, $nextval, $sequence) = @_;
+
+  if ($nextval ne 'nextval') {
+    $self->throw_exception("Can only fetch 'nextval' for a sequence");
+  }
+
+  $self->throw_exception('No sequence to fetch') unless $sequence;
+  
+  my ($val) = $self->_get_dbh->selectrow_array(
+'SELECT GEN_ID(' . $self->sql_maker->_quote($sequence) .
+', 1) FROM rdb$database');
+
+  return $val;
+} 
+
+sub _dbh_get_autoinc_seq {
+  my ($self, $dbh, $source, $col) = @_;
+
+  my $table_name = $source->from;
+  $table_name    = $$table_name if ref $table_name;
+  $table_name    = $self->sql_maker->quote_char ? $table_name : uc($table_name);
+
+  local $dbh->{LongReadLen} = 100000;
+  local $dbh->{LongTruncOk} = 1;
+
+  my $sth = $dbh->prepare(<<'EOF');
+SELECT t.rdb$trigger_source
+FROM rdb$triggers t
+WHERE t.rdb$relation_name = ?
+AND t.rdb$system_flag = 0 -- user defined
+AND t.rdb$trigger_type = 1 -- BEFORE INSERT
+EOF
+  $sth->execute($table_name);
+
+  while (my ($trigger) = $sth->fetchrow_array) {
+    my @trig_cols = map {
+      /^"([^"]+)/ ? $1 : uc($1)
+    } $trigger =~ /new\.("?\w+"?)/ig;
+
+    my ($quoted, $generator) = $trigger =~
+/(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
+
+    if ($generator) {
+      $generator = uc $generator unless $quoted;
+
+      return $generator
+        if List::Util::first {
+          $self->sql_maker->quote_char ? ($_ eq $col) : (uc($_) eq uc($col))
+        } @trig_cols;
+    }
+  }
+
+  return undef;
+}
+
 sub last_insert_id {
   my ($self, $source, @cols) = @_;
   my @result;
@@ -296,9 +352,9 @@ affects performance.
 
 =item *
 
-C<last_insert_id> support only works for Firebird versions 2 or greater. To
-work with earlier versions, we'll need to figure out how to retrieve the bodies
-of C<BEFORE INSERT> triggers and parse them for the C<GENERATOR> name.
+C<last_insert_id> support by default only works for Firebird versions 2 or
+greater, L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> however should
+work with earlier versions.
 
 =item *
 
diff --git a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
index a993977..a6081a6 100644
--- a/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
+++ b/lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm
@@ -149,7 +149,7 @@ sub _dbh_execute {
 
   $self->throw_exception($exception) if $exception;
 
-  wantarray ? @res : $res[0]
+  $wantarray ? @res : $res[0]
 }
 
 =head2 get_autoinc_seq
diff --git a/t/750firebird.t b/t/750firebird.t
index 4a9d35e..27879a6 100644
--- a/t/750firebird.t
+++ b/t/750firebird.t
@@ -60,6 +60,24 @@ EOF
     NEW."artistid" = GEN_ID("gen_artist_artistid",1);
   END
 EOF
+  eval { $dbh->do('DROP TABLE "sequence_test"') };
+  $dbh->do(<<EOF);
+  CREATE TABLE "sequence_test" (
+    "pkid1" INT NOT NULL,
+    "pkid2" INT NOT NULL,
+    "nonpkid" INT,
+    "name" VARCHAR(255)
+  )
+EOF
+  $dbh->do('ALTER TABLE "sequence_test" ADD CONSTRAINT "sequence_test_constraint" PRIMARY KEY ("pkid1", "pkid2")');
+  eval { $dbh->do('DROP GENERATOR "pkid1_seq"') };
+  eval { $dbh->do('DROP GENERATOR "pkid2_seq"') };
+  eval { $dbh->do('DROP GENERATOR "nonpkid_seq"') };
+  $dbh->do('CREATE GENERATOR "pkid1_seq"');
+  $dbh->do('CREATE GENERATOR "pkid2_seq"');
+  $dbh->do('SET GENERATOR "pkid2_seq" TO 9');
+  $dbh->do('CREATE GENERATOR "nonpkid_seq"');
+  $dbh->do('SET GENERATOR "nonpkid_seq" TO 19');
 
   my $ars = $schema->resultset('Artist');
   is ( $ars->count, 0, 'No rows at first' );
@@ -68,6 +86,16 @@ EOF
   my $new = $ars->create({ name => 'foo' });
   ok($new->artistid, "Auto-PK worked");
 
+# test auto increment using generators WITHOUT triggers
+  for (1..5) {
+      my $st = $schema->resultset('SequenceTest')->create({ name => 'foo' });
+      is($st->pkid1, $_, "Firebird Auto-PK without trigger: First primary key");
+      is($st->pkid2, $_ + 9, "Firebird Auto-PK without trigger: Second primary key");
+      is($st->nonpkid, $_ + 19, "Firebird Auto-PK without trigger: Non-primary key");
+  }
+  my $st = $schema->resultset('SequenceTest')->create({ name => 'foo', pkid1 => 55 });
+  is($st->pkid1, 55, "Firebird Auto-PK without trigger: First primary key set manually");
+
 # test savepoints
   eval {
     $schema->txn_do(sub {
@@ -96,6 +124,7 @@ EOF
   $new->discard_changes;
   is($new->artistid, 66, 'Explicit PK assigned');
 
+# row update
   lives_ok {
     $new->update({ name => 'baz' })
   } 'update survived';
@@ -123,7 +152,7 @@ EOF
 # count what we did so far
   is ($ars->count, 6, 'Simple count works');
 
-# test UPDATE
+# test ResultSet UPDATE
   lives_and {
     $ars->search({ name => 'foo' })->update({ rank => 4 });
 
@@ -169,39 +198,37 @@ EOF
   }
 
 # test blobs (stolen from 73oracle.t)
-  SKIP: {
-    eval { $dbh->do('DROP TABLE "bindtype_test2"') };
-    $dbh->do(q[
-    CREATE TABLE "bindtype_test2"
-    (
-      "id"     INT PRIMARY KEY,
-      "bytea"  INT,
-      "a_blob" BLOB,
-      "a_clob" BLOB SUB_TYPE TEXT
-    )
-    ]);
-
-    my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
-    $binstr{'large'} = $binstr{'small'} x 1024;
-
-    my $maxloblen = length $binstr{'large'};
-    local $dbh->{'LongReadLen'} = $maxloblen;
-
-    my $rs = $schema->resultset('BindType2');
-    my $id = 0;
-
-    foreach my $type (qw( a_blob a_clob )) {
-      foreach my $size (qw( small large )) {
-        $id++;
+  eval { $dbh->do('DROP TABLE "bindtype_test2"') };
+  $dbh->do(q[
+  CREATE TABLE "bindtype_test2"
+  (
+    "id"     INT PRIMARY KEY,
+    "bytea"  INT,
+    "a_blob" BLOB,
+    "a_clob" BLOB SUB_TYPE TEXT
+  )
+  ]);
+
+  my %binstr = ( 'small' => join('', map { chr($_) } ( 1 .. 127 )) );
+  $binstr{'large'} = $binstr{'small'} x 1024;
+
+  my $maxloblen = length $binstr{'large'};
+  local $dbh->{'LongReadLen'} = $maxloblen;
+
+  my $rs = $schema->resultset('BindType2');
+  my $id = 0;
+
+  foreach my $type (qw( a_blob a_clob )) {
+    foreach my $size (qw( small large )) {
+      $id++;
 
 # turn off horrendous binary DBIC_TRACE output
-        local $schema->storage->{debug} = 0;
+      local $schema->storage->{debug} = 0;
 
-        lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
-        "inserted $size $type without dying";
+      lives_ok { $rs->create( { 'id' => $id, $type => $binstr{$size} } ) }
+      "inserted $size $type without dying";
 
-        ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
-      }
+      ok($rs->find($id)->$type eq $binstr{$size}, "verified inserted $size $type" );
     }
   }
 }
@@ -221,11 +248,14 @@ sub cleanup {
   eval { $dbh->do('DROP TRIGGER "artist_bi"') };
   diag $@ if $@;
 
-  eval { $dbh->do('DROP GENERATOR "gen_artist_artistid"') };
-  diag $@ if $@;
+  foreach my $generator (qw/gen_artist_artistid pkid1_seq pkid2_seq
+                            nonpkid_seq/) {
+    eval { $dbh->do(qq{DROP GENERATOR "$generator"}) };
+    diag $@ if $@;
+  }
 
-  foreach my $table (qw/artist bindtype_test/) {
+  foreach my $table (qw/artist bindtype_test2 sequence_test/) {
     eval { $dbh->do(qq[DROP TABLE "$table"]) };
-    #diag $@ if $@;
+    diag $@ if $@;
   }
 }