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