The Perl and Raku Conference 2025: Greenville, South Carolina - June 27-29 Learn more

RIBASUSHI / DBIx-Class-0.08250_03 / lib / DBIx / Class / Storage / DBI / Firebird / Common.pm 

            

              
1
2
3
4
5
6
7
8
—
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
—
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134

              
package DBIx::Class::Storage::DBI::Firebird::Common;
use strict;
use warnings;
use base qw/DBIx::Class::Storage::DBI/;
use mro 'c3';
use List::Util 'first';
use namespace::clean;
=head1 NAME
DBIx::Class::Storage::DBI::Firebird::Common - Driver Base Class for the Firebird RDBMS
=head1 DESCRIPTION
This class implements autoincrements for Firebird using C<RETURNING> as well as
L<auto_nextval|DBIx::Class::ResultSource/auto_nextval>, savepoints and server
version detection.
=cut
# set default
__PACKAGE__->_use_insert_returning (1);
__PACKAGE__->sql_limit_dialect ('FirstSkip');
__PACKAGE__->sql_quote_char ('"');
sub _sequence_fetch {
  my ($self, $nextval, $sequence) = @_;
  $self->throw_exception("Can only fetch 'nextval' for a sequence")
    if $nextval !~ /^nextval$/i;
  $self->throw_exception('No sequence to fetch') unless $sequence;
  my ($val) = $self->_get_dbh->selectrow_array(sprintf
    'SELECT GEN_ID(%s, 1) FROM rdb$database',
    $self->sql_maker->_quote($sequence)
  );
  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($_) }
      $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 first {
          $self->sql_maker->quote_char ? ($_ eq $col) : (uc($_) eq uc($col))
        } @trig_cols;
    }
  }
  return undef;
}
sub _exec_svp_begin {
  my ($self, $name) = @_;
  $self->_dbh->do("SAVEPOINT $name");
}
sub _exec_svp_release {
  my ($self, $name) = @_;
  $self->_dbh->do("RELEASE SAVEPOINT $name");
}
sub _exec_svp_rollback {
  my ($self, $name) = @_;
  $self->_dbh->do("ROLLBACK TO SAVEPOINT $name")
}
# http://www.firebirdfaq.org/faq223/
sub _get_server_version {
  my $self = shift;
  return $self->_get_dbh->selectrow_array(q{
SELECT rdb$get_context('SYSTEM', 'ENGINE_VERSION') FROM rdb$database
  });
}
1;
=head1 CAVEATS
=over 4
=item *
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.
=back
=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
# vim:sts=2 sw=2: