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