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 sub _get_pg_search_path {
  43     my ($self,$dbh) = @_;
  44     # cache the search path as ['schema','schema',...] in the storage
  45     # obj
  46     $self->{_pg_search_path} ||= do {
  47         my @search_path;
  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'")
  52             }
  53             push @search_path, $1;
  54         }
  55         \@search_path
  56     };
  57 }
  58
  59 sub _dbh_get_autoinc_seq {
  60   my ($self, $dbh, $schema, $table, @pri) = @_;
  61
  62   # get the list of postgres schemas to search.  if we have a schema
  63   # specified, use that.  otherwise, use the search path
  64   my @search_path;
  65   if( defined $schema and length $schema ) {
  66       @search_path = ( $schema );
  67   } else {
  68       @search_path = @{ $self->_get_pg_search_path($dbh) };
  69   }
  70
  71   foreach my $search_schema (@search_path) {
  72       foreach my $col (@pri) {
  73           my $info = $dbh->column_info(undef,$search_schema,$table,$col)->fetchrow_hashref;
  74           if($info) {
  75               # if we get here, we have definitely found the right
  76               # column.
  77               if( defined $info->{COLUMN_DEF} and
  78                   $info->{COLUMN_DEF}
  79                     =~ /^nextval\(+'([^']+)'::(?:text|regclass)\)/i
  80                 ) {
  81                   my $seq = $1;
  82
  83                   # have not figured out a 100% reliable way to tell
  84                   # what sequence is meant if it is not
  85                   # schema-qualified.  see TODO tests in 72pg.t
  86                   if( $seq =~ /\./ ) {
  87                       return $seq;
  88                   } else {
  89                       # this guess is going to be incorrect some of
  90                       # the time, which could lead to problems that
  91                       # could be pretty hairy to trace.  thus the
  92                       # warning.
  93                       $seq = $info->{TABLE_SCHEM} . "." . $seq;
  94                       warn "WARNING: guessing sequence '$seq' for key $search_schema.$table.$col\n";
  95                       return $seq;
  96                   }
  97
  98                   # return our (schema-qualified) seq
  99                   return $seq;
 100               } else {
 101                   # we have found the column, but cannot figure out
 102                   # the nextval seq
 103                   return;
 104               }
 105           }
 106       }
 107   }
 108   return;
 109 }
 110
 111 sub get_autoinc_seq {
 112   my ($self,$source,$col) = @_;
 113
 114   my @pri = $source->primary_columns;
 115
 116   my $schema;
 117   my $table = $source->name;
 118
 119   if (ref $table eq 'SCALAR') {
 120     $table = $$table;
 121   }
 122   elsif ($table =~ /^(.+)\.(.+)$/) {
 123     ($schema, $table) = ($1, $2);
 124   }
 125
 126   $self->dbh_do('_dbh_get_autoinc_seq', $schema, $table, @pri);
 127 }
 128
 129 sub sqlt_type {
 130   return 'PostgreSQL';
 131 }
 132
 133 sub datetime_parser_type { return "DateTime::Format::Pg"; }
 134
 135 sub bind_attribute_by_data_type {
 136   my ($self,$data_type) = @_;
 137
 138   my $bind_attributes = {
 139     bytea => { pg_type => DBD::Pg::PG_BYTEA },
 140     blob  => { pg_type => DBD::Pg::PG_BYTEA },
 141   };
 142
 143   if( defined $bind_attributes->{$data_type} ) {
 144     return $bind_attributes->{$data_type};
 145   }
 146   else {
 147     return;
 148   }
 149 }
 150
 151 sub _sequence_fetch {
 152   my ( $self, $type, $seq ) = @_;
 153   my ($id) = $self->_get_dbh->selectrow_array("SELECT nextval('${seq}')");
 154   return $id;
 155 }
 156
 157 sub _svp_begin {
 158     my ($self, $name) = @_;
 159
 160     $self->_get_dbh->pg_savepoint($name);
 161 }
 162
 163 sub _svp_release {
 164     my ($self, $name) = @_;
 165
 166     $self->_get_dbh->pg_release($name);
 167 }
 168
 169 sub _svp_rollback {
 170     my ($self, $name) = @_;
 171
 172     $self->_get_dbh->pg_rollback_to($name);
 173 }
 174
 175 1;
 176
 177 =head1 NAME
 178
 179 DBIx::Class::Storage::DBI::Pg - Automatic primary key class for PostgreSQL
 180
 181 =head1 SYNOPSIS
 182
 183   # In your table classes
 184   __PACKAGE__->load_components(qw/PK::Auto Core/);
 185   __PACKAGE__->set_primary_key('id');
 186   __PACKAGE__->sequence('mysequence');
 187
 188 =head1 DESCRIPTION
 189
 190 This class implements autoincrements for PostgreSQL.
 191
 192 =head1 POSTGRESQL SCHEMA SUPPORT
 193
 194 This supports multiple PostgreSQL schemas, with one caveat: for
 195 performance reasons, the schema search path is queried the first time it is
 196 needed and CACHED for subsequent uses.
 197
 198 For this reason, you should do any necessary manipulation of the
 199 PostgreSQL search path BEFORE instantiating your schema object, or as
 200 part of the on_connect_do option to connect(), for example:
 201
 202    my $schema = My::Schema->connect
 203                   ( $dsn,$user,$pass,
 204                     { on_connect_do =>
 205                         [ 'SET search_path TO myschema, foo, public' ],
 206                     },
 207                   );
 208
 209 =head1 AUTHORS
 210
 211 See L<DBIx::Class/CONTRIBUTORS>
 212
 213 =head1 LICENSE
 214
 215 You may distribute this code under the same terms as Perl itself.
 216
 217 =cut