lib/DBIx/Class/Storage/DBI/Firebird/Common.pm

   1 package DBIx::Class::Storage::DBI::Firebird::Common;
   2
   3 use strict;
   4 use warnings;
   5 use base qw/DBIx::Class::Storage::DBI/;
   6 use mro 'c3';
   7 use List::Util 'first';
   8 use namespace::clean;
   9
  10 =head1 NAME
  11
  12 DBIx::Class::Storage::DBI::Firebird::Common - Driver Base Class for the Firebird RDBMS
  13
  14 =head1 DESCRIPTION
  15
  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
  18 version detection.
  19
  20 =cut
  21
  22 # set default
  23 __PACKAGE__->_use_insert_returning (1);
  24 __PACKAGE__->sql_limit_dialect ('FirstSkip');
  25 __PACKAGE__->sql_quote_char ('"');
  26
  27 sub _sequence_fetch {
  28   my ($self, $nextval, $sequence) = @_;
  29
  30   $self->throw_exception("Can only fetch 'nextval' for a sequence")
  31     if $nextval !~ /^nextval$/i;
  32
  33   $self->throw_exception('No sequence to fetch') unless $sequence;
  34
  35   my ($val) = $self->_get_dbh->selectrow_array(sprintf
  36     'SELECT GEN_ID(%s, 1) FROM rdb$database',
  37     $self->sql_maker->_quote($sequence)
  38   );
  39
  40   return $val;
  41 }
  42
  43 sub _dbh_get_autoinc_seq {
  44   my ($self, $dbh, $source, $col) = @_;
  45
  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);
  49
  50   local $dbh->{LongReadLen} = 100000;
  51   local $dbh->{LongTruncOk} = 1;
  52
  53   my $sth = $dbh->prepare(<<'EOF');
  54 SELECT t.rdb$trigger_source
  55 FROM rdb$triggers t
  56 WHERE t.rdb$relation_name = ?
  57 AND t.rdb$system_flag = 0 -- user defined
  58 AND t.rdb$trigger_type = 1 -- BEFORE INSERT
  59 EOF
  60   $sth->execute($table_name);
  61
  62   while (my ($trigger) = $sth->fetchrow_array) {
  63     my @trig_cols = map
  64       { /^"([^"]+)/ ? $1 : uc($_) }
  65       $trigger =~ /new\.("?\w+"?)/ig
  66     ;
  67
  68     my ($quoted, $generator) = $trigger =~
  69 /(?:gen_id\s* \( \s* |next \s* value \s* for \s*)(")?(\w+)/ix;
  70
  71     if ($generator) {
  72       $generator = uc $generator unless $quoted;
  73
  74       return $generator
  75         if first {
  76           $self->sql_maker->quote_char ? ($_ eq $col) : (uc($_) eq uc($col))
  77         } @trig_cols;
  78     }
  79   }
  80
  81   return undef;
  82 }
  83
  84 sub _exec_svp_begin {
  85   my ($self, $name) = @_;
  86
  87   $self->_dbh->do("SAVEPOINT $name");
  88 }
  89
  90 sub _exec_svp_release {
  91   my ($self, $name) = @_;
  92
  93   $self->_dbh->do("RELEASE SAVEPOINT $name");
  94 }
  95
  96 sub _exec_svp_rollback {
  97   my ($self, $name) = @_;
  98
  99   $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
 100 }
 101
 102 # http://www.firebirdfaq.org/faq223/
 103 sub _get_server_version {
 104   my $self = shift;
 105
 106   return $self->_get_dbh->selectrow_array(q{
 107 SELECT rdb$get_context('SYSTEM', 'ENGINE_VERSION') FROM rdb$database
 108   });
 109 }
 110
 111 1;
 112
 113 =head1 CAVEATS
 114
 115 =over 4
 116
 117 =item *
 118
 119 C<last_insert_id> support by default only works for Firebird versions 2 or
 120 greater, L<auto_nextval|DBIx::Class::ResultSource/auto_nextval> however should
 121 work with earlier versions.
 122
 123 =back
 124
 125 =head1 AUTHOR
 126
 127 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>.
 128
 129 =head1 LICENSE
 130
 131 You may distribute this code under the same terms as Perl itself.
 132
 133 =cut
 134 # vim:sts=2 sw=2: