1 package DBIx::Class::Storage::DBI::Firebird::Common;
5 use base qw/DBIx::Class::Storage::DBI/;
7 use List::Util 'first';
12 DBIx::Class::Storage::DBI::Firebird::Common - Driver Base Class for the Firebird RDBMS
16 This class implements autoincrements for Firebird using C<RETURNING> as well as
17 L<auto_nextval|DBIx::Class::ResultSource/auto_nextval>, savepoints and server
23 __PACKAGE__->_use_insert_returning (1);
24 __PACKAGE__->sql_limit_dialect ('FirstSkip');
25 __PACKAGE__->sql_quote_char ('"');
28 my ($self, $nextval, $sequence) = @_;
30 $self->throw_exception("Can only fetch 'nextval' for a sequence")
31 if $nextval !~ /^nextval$/i;
33 $self->throw_exception('No sequence to fetch') unless $sequence;
35 my ($val) = $self->_get_dbh->selectrow_array(sprintf
36 'SELECT GEN_ID(%s, 1) FROM rdb$database',
37 $self->sql_maker->_quote($sequence)
43 sub _dbh_get_autoinc_seq {
44 my ($self, $dbh, $source, $col) = @_;
46 my $table_name = $source->from;
47 $table_name = $$table_name if ref $table_name;
48 $table_name = $self->sql_maker->quote_char ? $table_name : uc($table_name);
50 local $dbh->{LongReadLen} = 100000;
51 local $dbh->{LongTruncOk} = 1;
53 my $sth = $dbh->prepare(<<'EOF');
54 SELECT t.rdb$trigger_source
56 WHERE t.rdb$relation_name = ?
57 AND t.rdb$system_flag = 0 -- user defined
58 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
60 $sth->execute($table_name);
62 while (my ($trigger) = $sth->fetchrow_array) {
64 /^"([^"]+)/ ? $1 : uc($1)
65 } $trigger =~ /new\.("?\w+"?)/ig;
67 my ($quoted, $generator) = $trigger =~
68 /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
71 $generator = uc $generator unless $quoted;
75 $self->sql_maker->quote_char ? ($_ eq $col) : (uc($_) eq uc($col))
84 my ($self, $name) = @_;
86 $self->_dbh->do("SAVEPOINT $name");
89 sub _exec_svp_release {
90 my ($self, $name) = @_;
92 $self->_dbh->do("RELEASE SAVEPOINT $name");
95 sub _exec_svp_rollback {
96 my ($self, $name) = @_;
98 $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
101 # http://www.firebirdfaq.org/faq223/
102 sub _get_server_version {
105 return $self->_get_dbh->selectrow_array(q{
106 SELECT rdb$get_context('SYSTEM', 'ENGINE_VERSION') FROM rdb$database
118 C<last_insert_id> support by default only works for Firebird versions 2 or
119 greater, L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> however should
120 work with earlier versions.
126 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
130 You may distribute this code under the same terms as Perl itself.