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); |
843f8ecd |
10 | |
ac45262b |
11 | # Ask for a DBD::Pg with array support |
c70c716e |
12 | warn "DBD::Pg 2.9.2 or greater is strongly recommended\n" |
ac45262b |
13 | if ($DBD::Pg::VERSION < 2.009002); # pg uses (used?) version::qv() |
17614944 |
14 | |
e96a93df |
15 | sub with_deferred_fk_checks { |
16 | my ($self, $sub) = @_; |
17 | |
9ae966b9 |
18 | $self->_get_dbh->do('SET CONSTRAINTS ALL DEFERRED'); |
e96a93df |
19 | $sub->(); |
20 | } |
21 | |
843f8ecd |
22 | sub last_insert_id { |
ca48cd7d |
23 | my ($self,$source,$col) = @_; |
0063119f |
24 | my $seq = ( $source->column_info($col)->{sequence} ||= $self->dbh_do('_dbh_get_autoinc_seq', $source, $col) ) |
5f70776f |
25 | or $self->throw_exception( "could not determine sequence for " |
26 | . $source->name |
27 | . ".$col, please consider adding a " |
28 | . "schema-qualified sequence to its column info" |
29 | ); |
9a0b7b26 |
30 | |
31 | $self->_dbh_last_insert_id ($self->_dbh, $seq); |
0680ac39 |
32 | } |
33 | |
9a0b7b26 |
34 | # there seems to be absolutely no reason to have this as a separate method, |
35 | # but leaving intact in case someone is already overriding it |
36 | sub _dbh_last_insert_id { |
37 | my ($self, $dbh, $seq) = @_; |
38 | $dbh->last_insert_id(undef, undef, undef, undef, {sequence => $seq}); |
39 | } |
40 | |
41 | |
d4f16b21 |
42 | sub _dbh_get_autoinc_seq { |
0063119f |
43 | my ($self, $dbh, $source, $col) = @_; |
44 | |
45 | my $schema; |
46 | my $table = $source->name; |
47 | |
48 | # deref table name if it needs it |
49 | $table = $$table |
50 | if ref $table eq 'SCALAR'; |
51 | |
52 | # parse out schema name if present |
53 | if( $table =~ /^(.+)\.(.+)$/ ) { |
54 | ( $schema, $table ) = ( $1, $2 ); |
55 | } |
0680ac39 |
56 | |
96e1048b |
57 | # use DBD::Pg to fetch the column info if it is recent enough to |
58 | # work. otherwise, use custom SQL |
777f7527 |
59 | my $seq_expr = $DBD::Pg::VERSION > 2.015001 |
777f7527 |
60 | ? eval{ $dbh->column_info(undef,$schema,$table,$col)->fetchrow_hashref->{COLUMN_DEF} } |
777f7527 |
61 | : $self->_dbh_get_column_default( $dbh, $schema, $table, $col ); |
62 | |
63 | # if no default value is set on the column, or if we can't parse the |
64 | # default value as a sequence, throw. |
65 | unless ( defined $seq_expr and $seq_expr =~ /^nextval\(+'([^']+)'::(?:text|regclass)\)/i ){ |
66 | $seq_expr = '' unless defined $seq_expr; |
67 | $schema = "$schema." if defined $schema && length $schema; |
68 | $self->throw_exception( "no sequence found for $schema$table.$col, check table definition, " |
69 | . "or explicitly set the 'sequence' for this column in the " |
70 | . $source->source_name |
71 | . " class" |
72 | ); |
73 | } |
74 | |
75 | return $1; |
76 | } |
77 | |
78 | # custom method for fetching column default, since column_info has a |
79 | # bug with older versions of DBD::Pg |
80 | sub _dbh_get_column_default { |
81 | my ( $self, $dbh, $schema, $table, $col ) = @_; |
82 | |
46ae368d |
83 | # Build and execute a query into the pg_catalog to find the Pg |
84 | # expression for the default value for this column in this table. |
85 | # If the table name is schema-qualified, query using that specific |
86 | # schema name. |
87 | |
88 | # Otherwise, find the table in the standard Postgres way, using the |
89 | # search path. This is done with the pg_catalog.pg_table_is_visible |
90 | # function, which returns true if a given table is 'visible', |
91 | # meaning the first table of that name to be found in the search |
92 | # path. |
93 | |
94 | # I *think* we can be assured that this query will always find the |
95 | # correct column according to standard Postgres semantics. |
96 | # |
97 | # -- rbuels |
98 | |
20f43d0c |
99 | my $sqlmaker = $self->sql_maker; |
100 | local $sqlmaker->{bindtype} = 'normal'; |
101 | |
0063119f |
102 | my ($where, @bind) = $sqlmaker->where ({ |
20f43d0c |
103 | 'a.attnum' => {'>', 0}, |
104 | 'c.relname' => $table, |
105 | 'a.attname' => $col, |
106 | -not_bool => 'a.attisdropped', |
107 | (defined $schema && length $schema) |
108 | ? ( 'n.nspname' => $schema ) |
109 | : ( -bool => \'pg_catalog.pg_table_is_visible(c.oid)' ) |
110 | }); |
5e14a204 |
111 | |
112 | my ($seq_expr) = $dbh->selectrow_array(<<EOS,undef,@bind); |
20f43d0c |
113 | |
5e14a204 |
114 | SELECT |
115 | (SELECT pg_catalog.pg_get_expr(d.adbin, d.adrelid) |
116 | FROM pg_catalog.pg_attrdef d |
117 | WHERE d.adrelid = a.attrelid AND d.adnum = a.attnum AND a.atthasdef) |
118 | FROM pg_catalog.pg_class c |
0063119f |
119 | LEFT JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace |
5e14a204 |
120 | JOIN pg_catalog.pg_attribute a ON a.attrelid = c.oid |
20f43d0c |
121 | $where |
122 | |
5e14a204 |
123 | EOS |
124 | |
777f7527 |
125 | return $seq_expr; |
843f8ecd |
126 | } |
127 | |
843f8ecd |
128 | |
4f533e8c |
129 | sub sqlt_type { |
130 | return 'PostgreSQL'; |
131 | } |
132 | |
45fa8288 |
133 | sub datetime_parser_type { return "DateTime::Format::Pg"; } |
134 | |
a71859b4 |
135 | sub bind_attribute_by_data_type { |
136 | my ($self,$data_type) = @_; |
137 | |
138 | my $bind_attributes = { |
eda28767 |
139 | bytea => { pg_type => DBD::Pg::PG_BYTEA }, |
5ba88f68 |
140 | blob => { pg_type => DBD::Pg::PG_BYTEA }, |
a71859b4 |
141 | }; |
d4daee7b |
142 | |
a71859b4 |
143 | if( defined $bind_attributes->{$data_type} ) { |
9fdf90df |
144 | return $bind_attributes->{$data_type}; |
a71859b4 |
145 | } |
146 | else { |
147 | return; |
148 | } |
149 | } |
150 | |
f04b2839 |
151 | sub _sequence_fetch { |
152 | my ( $self, $type, $seq ) = @_; |
9ae966b9 |
153 | my ($id) = $self->_get_dbh->selectrow_array("SELECT nextval('${seq}')"); |
f04b2839 |
154 | return $id; |
155 | } |
156 | |
adb3554a |
157 | sub _svp_begin { |
eeb8cfeb |
158 | my ($self, $name) = @_; |
adb3554a |
159 | |
9ae966b9 |
160 | $self->_get_dbh->pg_savepoint($name); |
adb3554a |
161 | } |
162 | |
163 | sub _svp_release { |
eeb8cfeb |
164 | my ($self, $name) = @_; |
adb3554a |
165 | |
9ae966b9 |
166 | $self->_get_dbh->pg_release($name); |
adb3554a |
167 | } |
168 | |
169 | sub _svp_rollback { |
eeb8cfeb |
170 | my ($self, $name) = @_; |
adb3554a |
171 | |
9ae966b9 |
172 | $self->_get_dbh->pg_rollback_to($name); |
adb3554a |
173 | } |
174 | |
843f8ecd |
175 | 1; |
176 | |
fd159e2a |
177 | __END__ |
178 | |
75d07914 |
179 | =head1 NAME |
843f8ecd |
180 | |
181 | DBIx::Class::Storage::DBI::Pg - Automatic primary key class for PostgreSQL |
182 | |
183 | =head1 SYNOPSIS |
184 | |
185 | # In your table classes |
186 | __PACKAGE__->load_components(qw/PK::Auto Core/); |
187 | __PACKAGE__->set_primary_key('id'); |
188 | __PACKAGE__->sequence('mysequence'); |
189 | |
190 | =head1 DESCRIPTION |
191 | |
192 | This class implements autoincrements for PostgreSQL. |
193 | |
7c0176a1 |
194 | =head1 POSTGRESQL SCHEMA SUPPORT |
195 | |
4f609014 |
196 | This driver supports multiple PostgreSQL schemas, with one caveat: for |
6ff1d58c |
197 | performance reasons, data about the search path, sequence names, and |
198 | so forth is queried as needed and CACHED for subsequent uses. |
7c0176a1 |
199 | |
4f609014 |
200 | For this reason, once your schema is instantiated, you should not |
201 | change the PostgreSQL schema search path for that schema's database |
202 | connection. If you do, Bad Things may happen. |
203 | |
204 | You should do any necessary manipulation of the search path BEFORE |
205 | instantiating your schema object, or as part of the on_connect_do |
206 | option to connect(), for example: |
7c0176a1 |
207 | |
208 | my $schema = My::Schema->connect |
209 | ( $dsn,$user,$pass, |
210 | { on_connect_do => |
211 | [ 'SET search_path TO myschema, foo, public' ], |
212 | }, |
213 | ); |
214 | |
7ff926e6 |
215 | =head1 AUTHORS |
7c0176a1 |
216 | |
7ff926e6 |
217 | See L<DBIx::Class/CONTRIBUTORS> |
843f8ecd |
218 | |
219 | =head1 LICENSE |
220 | |
221 | You may distribute this code under the same terms as Perl itself. |
222 | |
223 | =cut |