1 package DBIx::Class::Storage::DBI::Pg;
6 use base qw/DBIx::Class::Storage::DBI::MultiColumnIn/;
9 use DBD::Pg qw(:pg_types);
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()
15 sub with_deferred_fk_checks {
16 my ($self, $sub) = @_;
18 $self->_get_dbh->do('SET CONSTRAINTS ALL DEFERRED');
23 my ($self,$source,$col) = @_;
24 my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col))
25 or $self->throw_exception( "could not determine sequence for "
27 . ".$col, please consider adding a "
28 . "schema-qualified sequence to its column info"
31 $self->_dbh_last_insert_id ($self->_dbh, $seq);
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});
42 sub _get_pg_search_path {
44 # cache the search path as ['schema','schema',...] in the storage
46 $self->{_pg_search_path} ||= do {
48 my ($sp_string) = $dbh->selectrow_array('SHOW search_path');
49 while( $sp_string =~ s/("[^"]+"|[^,]+),?// ) {
50 unless( defined $1 and length $1 ) {
51 $self->throw_exception("search path sanity check failed: '$1'")
53 push @search_path, $1;
59 sub _dbh_get_autoinc_seq {
60 my ($self, $dbh, $schema, $table, $col) = @_;
63 my @where = ( 'c.relname = ?', 'a.attname = ?' );
64 my @bind = ($table, $col);
65 if( defined $schema && length $schema ) {
66 push @where, 'n.nspname = ?';
69 push @where, 'pg_catalog.pg_table_is_visible(c.oid)';
71 my $where = join ' AND ', @where;
73 my ($seq_expr) = $dbh->selectrow_array(<<EOS,undef,@bind);
75 (SELECT pg_catalog.pg_get_expr(d.adbin, d.adrelid)
76 FROM pg_catalog.pg_attrdef d
77 WHERE d.adrelid = a.attrelid AND d.adnum = a.attnum AND a.atthasdef)
78 FROM pg_catalog.pg_class c
79 JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace
80 JOIN pg_catalog.pg_attribute a ON a.attrelid = c.oid
83 AND a.attnum > 0 AND NOT a.attisdropped
86 $seq_expr =~ /^nextval\(+'([^']+)'::(?:text|regclass)\)/i
87 or $self->throw_exception("could not parse sequence expression '$seq_expr'");
93 my ($self,$source,$col) = @_;
96 my $table = $source->name;
98 if (ref $table eq 'SCALAR') {
101 elsif ($table =~ /^(.+)\.(.+)$/) {
102 ($schema, $table) = ($1, $2);
105 $self->dbh_do('_dbh_get_autoinc_seq', $schema, $table, $col);
112 sub datetime_parser_type { return "DateTime::Format::Pg"; }
114 sub bind_attribute_by_data_type {
115 my ($self,$data_type) = @_;
117 my $bind_attributes = {
118 bytea => { pg_type => DBD::Pg::PG_BYTEA },
119 blob => { pg_type => DBD::Pg::PG_BYTEA },
122 if( defined $bind_attributes->{$data_type} ) {
123 return $bind_attributes->{$data_type};
130 sub _sequence_fetch {
131 my ( $self, $type, $seq ) = @_;
132 my ($id) = $self->_get_dbh->selectrow_array("SELECT nextval('${seq}')");
137 my ($self, $name) = @_;
139 $self->_get_dbh->pg_savepoint($name);
143 my ($self, $name) = @_;
145 $self->_get_dbh->pg_release($name);
149 my ($self, $name) = @_;
151 $self->_get_dbh->pg_rollback_to($name);
160 DBIx::Class::Storage::DBI::Pg - Automatic primary key class for PostgreSQL
164 # In your table classes
165 __PACKAGE__->load_components(qw/PK::Auto Core/);
166 __PACKAGE__->set_primary_key('id');
167 __PACKAGE__->sequence('mysequence');
171 This class implements autoincrements for PostgreSQL.
173 =head1 POSTGRESQL SCHEMA SUPPORT
175 This supports multiple PostgreSQL schemas, with one caveat: for
176 performance reasons, the schema search path is queried the first time it is
177 needed and CACHED for subsequent uses.
179 For this reason, you should do any necessary manipulation of the
180 PostgreSQL search path BEFORE instantiating your schema object, or as
181 part of the on_connect_do option to connect(), for example:
183 my $schema = My::Schema->connect
186 [ 'SET search_path TO myschema, foo, public' ],
192 See L<DBIx::Class/CONTRIBUTORS>
196 You may distribute this code under the same terms as Perl itself.