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,$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 "
  26                                  . $source->name
  27                                  . ".$col, please consider adding a "
  28                                  . "schema-qualified sequence to its column info"
  29                                );
  30
  31   $self->_dbh_last_insert_id ($self->_dbh, $seq);
  32 }
  33
  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
  42 # get the postgres search path, and cache it
  43 sub _get_pg_search_path {
  44     my ($self,$dbh) = @_;
  45     # cache the search path as ['schema','schema',...] in the storage
  46     # obj
  47     $self->{_pg_search_path} ||= do {
  48         my @search_path;
  49         my ($sp_string) = $dbh->selectrow_array('SHOW search_path');
  50         while( $sp_string =~ s/("[^"]+"|[^,]+),?// ) {
  51             unless( defined $1 and length $1 ) {
  52                 $self->throw_exception("search path sanity check failed: '$1'")
  53             }
  54             push @search_path, $1;
  55         }
  56         \@search_path
  57     };
  58 }
  59
  60 sub _dbh_get_autoinc_seq {
  61   my ($self, $dbh, $schema, $table, $col) = @_;
  62
  63
  64   my @where = ( 'c.relname = ?', 'a.attname = ?' );
  65   my @bind  = ($table, $col);
  66   if( defined $schema && length $schema ) {
  67       push @where, 'n.nspname = ?';
  68       push @bind, $schema;
  69   } else {
  70       push @where, 'pg_catalog.pg_table_is_visible(c.oid)';
  71   }
  72   my $where = join ' AND ', @where;
  73
  74   my ($seq_expr) = $dbh->selectrow_array(<<EOS,undef,@bind);
  75 SELECT
  76   (SELECT pg_catalog.pg_get_expr(d.adbin, d.adrelid)
  77    FROM pg_catalog.pg_attrdef d
  78    WHERE d.adrelid = a.attrelid AND d.adnum = a.attnum AND a.atthasdef)
  79 FROM pg_catalog.pg_class c
  80      JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace
  81      JOIN pg_catalog.pg_attribute a ON a.attrelid = c.oid
  82 WHERE
  83   $where
  84   AND a.attnum > 0 AND NOT a.attisdropped
  85 EOS
  86
  87   $seq_expr =~ /^nextval\(+'([^']+)'::(?:text|regclass)\)/i
  88       or $self->throw_exception("could not parse sequence expression '$seq_expr'");
  89
  90   return $1;
  91 }
  92
  93 sub get_autoinc_seq {
  94   my ($self,$source,$col) = @_;
  95
  96   my $schema;
  97   my $table = $source->name;
  98
  99   if (ref $table eq 'SCALAR') {
 100     $table = $$table;
 101   }
 102   elsif ($table =~ /^(.+)\.(.+)$/) {
 103     ($schema, $table) = ($1, $2);
 104   }
 105
 106   $self->dbh_do('_dbh_get_autoinc_seq', $schema, $table, $col);
 107 }
 108
 109 sub sqlt_type {
 110   return 'PostgreSQL';
 111 }
 112
 113 sub datetime_parser_type { return "DateTime::Format::Pg"; }
 114
 115 sub bind_attribute_by_data_type {
 116   my ($self,$data_type) = @_;
 117
 118   my $bind_attributes = {
 119     bytea => { pg_type => DBD::Pg::PG_BYTEA },
 120     blob  => { pg_type => DBD::Pg::PG_BYTEA },
 121   };
 122
 123   if( defined $bind_attributes->{$data_type} ) {
 124     return $bind_attributes->{$data_type};
 125   }
 126   else {
 127     return;
 128   }
 129 }
 130
 131 sub _sequence_fetch {
 132   my ( $self, $type, $seq ) = @_;
 133   my ($id) = $self->_get_dbh->selectrow_array("SELECT nextval('${seq}')");
 134   return $id;
 135 }
 136
 137 sub _svp_begin {
 138     my ($self, $name) = @_;
 139
 140     $self->_get_dbh->pg_savepoint($name);
 141 }
 142
 143 sub _svp_release {
 144     my ($self, $name) = @_;
 145
 146     $self->_get_dbh->pg_release($name);
 147 }
 148
 149 sub _svp_rollback {
 150     my ($self, $name) = @_;
 151
 152     $self->_get_dbh->pg_rollback_to($name);
 153 }
 154
 155 1;
 156
 157 __END__
 158
 159 =head1 NAME
 160
 161 DBIx::Class::Storage::DBI::Pg - Automatic primary key class for PostgreSQL
 162
 163 =head1 SYNOPSIS
 164
 165   # In your table classes
 166   __PACKAGE__->load_components(qw/PK::Auto Core/);
 167   __PACKAGE__->set_primary_key('id');
 168   __PACKAGE__->sequence('mysequence');
 169
 170 =head1 DESCRIPTION
 171
 172 This class implements autoincrements for PostgreSQL.
 173
 174 =head1 POSTGRESQL SCHEMA SUPPORT
 175
 176 This driver supports multiple PostgreSQL schemas, with one caveat: for
 177 performance reasons, data about the search path, sequence names, and
 178 so forth is queried as needed and CACHED for subsequent uses.
 179
 180 For this reason, once your schema is instantiated, you should not
 181 change the PostgreSQL schema search path for that schema's database
 182 connection. If you do, Bad Things may happen.
 183
 184 You should do any necessary manipulation of the search path BEFORE
 185 instantiating your schema object, or as part of the on_connect_do
 186 option to connect(), for example:
 187
 188    my $schema = My::Schema->connect
 189                   ( $dsn,$user,$pass,
 190                     { on_connect_do =>
 191                         [ 'SET search_path TO myschema, foo, public' ],
 192                     },
 193                   );
 194
 195 =head1 AUTHORS
 196
 197 See L<DBIx::Class/CONTRIBUTORS>
 198
 199 =head1 LICENSE
 200
 201 You may distribute this code under the same terms as Perl itself.
 202
 203 =cut