Commit | Line | Data |
843f8ecd |
1 | package DBIx::Class::Storage::DBI::Pg; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
4ce3b851 |
6 | use base qw/DBIx::Class::Storage::DBI::MultiColumnIn/; |
ac45262b |
7 | use mro 'c3'; |
843f8ecd |
8 | |
ac45262b |
9 | use DBD::Pg qw(:pg_types); |
4d4dc518 |
10 | use Scope::Guard (); |
11 | use Context::Preserve (); |
843f8ecd |
12 | |
ac45262b |
13 | # Ask for a DBD::Pg with array support |
21c63647 |
14 | warn __PACKAGE__.": DBD::Pg 2.9.2 or greater is strongly recommended\n" |
ac45262b |
15 | if ($DBD::Pg::VERSION < 2.009002); # pg uses (used?) version::qv() |
17614944 |
16 | |
4d4dc518 |
17 | __PACKAGE__->mk_group_accessors(simple => qw/ |
18 | _auto_cols |
19 | /); |
20 | |
21 | sub _prep_for_execute { |
22 | my $self = shift; |
23 | my ($op, $extra_bind, $ident, $args) = @_; |
24 | |
25 | if ($op eq 'insert') { |
26 | $self->_auto_cols([]); |
27 | |
28 | my %pk; |
29 | @pk{$ident->primary_columns} = (); |
30 | |
31 | my @auto_inc_cols = grep { |
32 | my $inserting = $args->[0]{$_}; |
33 | |
34 | ($ident->column_info($_)->{is_auto_increment} |
35 | || exists $pk{$_}) |
36 | && ( |
37 | (not defined $inserting) |
38 | || |
39 | (ref $inserting eq 'SCALAR' && $$inserting =~ /^null\z/i) |
40 | ) |
41 | } $ident->columns; |
42 | |
43 | if (@auto_inc_cols) { |
44 | $args->[1]{returning} = \@auto_inc_cols; |
45 | |
46 | $self->_auto_cols->[0] = \@auto_inc_cols; |
47 | } |
48 | } |
49 | |
50 | return $self->next::method(@_); |
51 | } |
52 | |
53 | sub _execute { |
54 | my $self = shift; |
55 | my ($op) = @_; |
56 | |
57 | my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_); |
58 | |
59 | if ($op eq 'insert' && $self->_auto_cols) { |
60 | local $@; |
61 | my (@auto_cols) = eval { |
62 | local $SIG{__WARN__} = sub {}; |
63 | $sth->fetchrow_array |
64 | }; |
65 | $self->_auto_cols->[1] = \@auto_cols; |
66 | $sth->finish; |
67 | } |
68 | |
69 | return wantarray ? ($rv, $sth, @bind) : $rv; |
70 | } |
71 | |
72 | |
e96a93df |
73 | sub with_deferred_fk_checks { |
74 | my ($self, $sub) = @_; |
75 | |
4d4dc518 |
76 | my $txn_scope_guard = $self->txn_scope_guard; |
77 | |
78 | $self->_do_query('SET CONSTRAINTS ALL DEFERRED'); |
79 | |
80 | my $sg = Scope::Guard->new(sub { |
81 | $self->_do_query('SET CONSTRAINTS ALL IMMEDIATE'); |
82 | }); |
83 | |
84 | return Context::Preserve::preserve_context(sub { $sub->() }, |
85 | after => sub { $txn_scope_guard->commit }); |
e96a93df |
86 | } |
87 | |
4d4dc518 |
88 | sub insert { |
89 | my $self = shift; |
6ea2d01b |
90 | |
4d4dc518 |
91 | my $updated_cols = $self->next::method(@_); |
2d424996 |
92 | |
4d4dc518 |
93 | if ($self->_auto_cols->[0]) { |
94 | my %auto_cols; |
95 | @auto_cols{ @{ $self->_auto_cols->[0] } } = @{ $self->_auto_cols->[1] }; |
2d424996 |
96 | |
4d4dc518 |
97 | $updated_cols = { %$updated_cols, %auto_cols }; |
2d424996 |
98 | } |
99 | |
4d4dc518 |
100 | return $updated_cols; |
0680ac39 |
101 | } |
102 | |
4d4dc518 |
103 | sub last_insert_id { |
104 | my ($self, $source, @cols) = @_; |
105 | my @result; |
106 | |
107 | my %auto_cols; |
108 | @auto_cols{ @{ $self->_auto_cols->[0] } } = |
109 | @{ $self->_auto_cols->[1] }; |
110 | |
111 | push @result, $auto_cols{$_} for @cols; |
112 | |
113 | return @result; |
2d424996 |
114 | } |
9a0b7b26 |
115 | |
4d4dc518 |
116 | sub _sequence_fetch { |
117 | my ($self, $function, $sequence) = @_; |
118 | |
119 | $self->throw_exception('No sequence to fetch') unless $sequence; |
120 | |
121 | my ($val) = $self->_get_dbh->selectrow_array( |
122 | sprintf "select $function('%s')", |
123 | $sequence |
124 | ); |
125 | |
126 | return $val; |
127 | } |
9a0b7b26 |
128 | |
2d424996 |
129 | sub _dbh_get_autoinc_seq { |
130 | my ($self, $dbh, $source, $col) = @_; |
0063119f |
131 | |
2d424996 |
132 | my $schema; |
133 | my $table = $source->name; |
0063119f |
134 | |
2d424996 |
135 | # deref table name if it needs it |
136 | $table = $$table |
137 | if ref $table eq 'SCALAR'; |
0063119f |
138 | |
2d424996 |
139 | # parse out schema name if present |
140 | if( $table =~ /^(.+)\.(.+)$/ ) { |
141 | ( $schema, $table ) = ( $1, $2 ); |
142 | } |
0680ac39 |
143 | |
2d424996 |
144 | # get the column default using a Postgres-specific pg_catalog query |
145 | my $seq_expr = $self->_dbh_get_column_default( $dbh, $schema, $table, $col ); |
146 | |
147 | # if no default value is set on the column, or if we can't parse the |
148 | # default value as a sequence, throw. |
5861223d |
149 | unless ( defined $seq_expr and $seq_expr =~ /^nextval\(+'([^']+)'::(?:text|regclass)\)/i ) { |
2d424996 |
150 | $seq_expr = '' unless defined $seq_expr; |
151 | $schema = "$schema." if defined $schema && length $schema; |
d3fdc7b8 |
152 | $self->throw_exception( sprintf ( |
153 | 'no sequence found for %s%s.%s, check the RDBMS table definition or explicitly set the '. |
154 | "'sequence' for this column in %s", |
155 | $schema ? "$schema." : '', |
156 | $table, |
157 | $col, |
158 | $source->source_name, |
159 | )); |
777f7527 |
160 | } |
2d424996 |
161 | |
162 | return $1; |
777f7527 |
163 | } |
164 | |
2d424996 |
165 | # custom method for fetching column default, since column_info has a |
166 | # bug with older versions of DBD::Pg |
167 | sub _dbh_get_column_default { |
168 | my ( $self, $dbh, $schema, $table, $col ) = @_; |
169 | |
170 | # Build and execute a query into the pg_catalog to find the Pg |
171 | # expression for the default value for this column in this table. |
172 | # If the table name is schema-qualified, query using that specific |
173 | # schema name. |
174 | |
175 | # Otherwise, find the table in the standard Postgres way, using the |
176 | # search path. This is done with the pg_catalog.pg_table_is_visible |
177 | # function, which returns true if a given table is 'visible', |
178 | # meaning the first table of that name to be found in the search |
179 | # path. |
180 | |
181 | # I *think* we can be assured that this query will always find the |
182 | # correct column according to standard Postgres semantics. |
183 | # |
184 | # -- rbuels |
185 | |
186 | my $sqlmaker = $self->sql_maker; |
187 | local $sqlmaker->{bindtype} = 'normal'; |
188 | |
189 | my ($where, @bind) = $sqlmaker->where ({ |
190 | 'a.attnum' => {'>', 0}, |
191 | 'c.relname' => $table, |
192 | 'a.attname' => $col, |
193 | -not_bool => 'a.attisdropped', |
194 | (defined $schema && length $schema) |
195 | ? ( 'n.nspname' => $schema ) |
196 | : ( -bool => \'pg_catalog.pg_table_is_visible(c.oid)' ) |
197 | }); |
198 | |
199 | my ($seq_expr) = $dbh->selectrow_array(<<EOS,undef,@bind); |
200 | |
201 | SELECT |
202 | (SELECT pg_catalog.pg_get_expr(d.adbin, d.adrelid) |
203 | FROM pg_catalog.pg_attrdef d |
204 | WHERE d.adrelid = a.attrelid AND d.adnum = a.attnum AND a.atthasdef) |
205 | FROM pg_catalog.pg_class c |
206 | LEFT JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace |
207 | JOIN pg_catalog.pg_attribute a ON a.attrelid = c.oid |
208 | $where |
209 | |
210 | EOS |
211 | |
212 | return $seq_expr; |
213 | } |
214 | |
215 | |
4f533e8c |
216 | sub sqlt_type { |
217 | return 'PostgreSQL'; |
218 | } |
219 | |
45fa8288 |
220 | sub datetime_parser_type { return "DateTime::Format::Pg"; } |
221 | |
a71859b4 |
222 | sub bind_attribute_by_data_type { |
223 | my ($self,$data_type) = @_; |
224 | |
225 | my $bind_attributes = { |
eda28767 |
226 | bytea => { pg_type => DBD::Pg::PG_BYTEA }, |
5ba88f68 |
227 | blob => { pg_type => DBD::Pg::PG_BYTEA }, |
a71859b4 |
228 | }; |
d4daee7b |
229 | |
a71859b4 |
230 | if( defined $bind_attributes->{$data_type} ) { |
9fdf90df |
231 | return $bind_attributes->{$data_type}; |
a71859b4 |
232 | } |
233 | else { |
234 | return; |
235 | } |
236 | } |
237 | |
adb3554a |
238 | sub _svp_begin { |
eeb8cfeb |
239 | my ($self, $name) = @_; |
adb3554a |
240 | |
9ae966b9 |
241 | $self->_get_dbh->pg_savepoint($name); |
adb3554a |
242 | } |
243 | |
244 | sub _svp_release { |
eeb8cfeb |
245 | my ($self, $name) = @_; |
adb3554a |
246 | |
9ae966b9 |
247 | $self->_get_dbh->pg_release($name); |
adb3554a |
248 | } |
249 | |
250 | sub _svp_rollback { |
eeb8cfeb |
251 | my ($self, $name) = @_; |
adb3554a |
252 | |
9ae966b9 |
253 | $self->_get_dbh->pg_rollback_to($name); |
adb3554a |
254 | } |
255 | |
843f8ecd |
256 | 1; |
257 | |
fd159e2a |
258 | __END__ |
259 | |
75d07914 |
260 | =head1 NAME |
843f8ecd |
261 | |
262 | DBIx::Class::Storage::DBI::Pg - Automatic primary key class for PostgreSQL |
263 | |
264 | =head1 SYNOPSIS |
265 | |
d88ecca6 |
266 | # In your result (table) classes |
267 | use base 'DBIx::Class::Core'; |
843f8ecd |
268 | __PACKAGE__->set_primary_key('id'); |
269 | __PACKAGE__->sequence('mysequence'); |
270 | |
271 | =head1 DESCRIPTION |
272 | |
273 | This class implements autoincrements for PostgreSQL. |
274 | |
7c0176a1 |
275 | =head1 POSTGRESQL SCHEMA SUPPORT |
276 | |
4f609014 |
277 | This driver supports multiple PostgreSQL schemas, with one caveat: for |
6ff1d58c |
278 | performance reasons, data about the search path, sequence names, and |
279 | so forth is queried as needed and CACHED for subsequent uses. |
7c0176a1 |
280 | |
4f609014 |
281 | For this reason, once your schema is instantiated, you should not |
282 | change the PostgreSQL schema search path for that schema's database |
283 | connection. If you do, Bad Things may happen. |
284 | |
285 | You should do any necessary manipulation of the search path BEFORE |
286 | instantiating your schema object, or as part of the on_connect_do |
287 | option to connect(), for example: |
7c0176a1 |
288 | |
289 | my $schema = My::Schema->connect |
290 | ( $dsn,$user,$pass, |
291 | { on_connect_do => |
292 | [ 'SET search_path TO myschema, foo, public' ], |
293 | }, |
294 | ); |
295 | |
7ff926e6 |
296 | =head1 AUTHORS |
7c0176a1 |
297 | |
7ff926e6 |
298 | See L<DBIx::Class/CONTRIBUTORS> |
843f8ecd |
299 | |
300 | =head1 LICENSE |
301 | |
302 | You may distribute this code under the same terms as Perl itself. |
303 | |
304 | =cut |