Commit | Line | Data |
e46df41a |
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) { |
d77ee505 |
63 | my @trig_cols = map |
64 | { /^"([^"]+)/ ? $1 : uc($_) } |
65 | $trigger =~ /new\.("?\w+"?)/ig |
66 | ; |
e46df41a |
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 | |
90d7422f |
84 | sub _exec_svp_begin { |
e46df41a |
85 | my ($self, $name) = @_; |
86 | |
87 | $self->_dbh->do("SAVEPOINT $name"); |
88 | } |
89 | |
90d7422f |
90 | sub _exec_svp_release { |
e46df41a |
91 | my ($self, $name) = @_; |
92 | |
93 | $self->_dbh->do("RELEASE SAVEPOINT $name"); |
94 | } |
95 | |
90d7422f |
96 | sub _exec_svp_rollback { |
e46df41a |
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: |