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 ### XXX This is unsafe in DBD::Pg 2.15.1, it can disconnect for some reason
  65 ###
  66   # use DBD::Pg to fetch the column info if it is recent enough to
  67   # work. otherwise, use custom SQL
  68 #  my $seq_expr =  $DBD::Pg::VERSION >= 2.015001
  69 #      ? eval{ $dbh->column_info(undef,$schema,$table,$col)->fetchrow_hashref->{COLUMN_DEF} }
  70 #      : $self->_dbh_get_column_default( $dbh, $schema, $table, $col );
  71
  72   my $seq_expr = $self->_dbh_get_column_default( $dbh, $schema, $table, $col );
  73
  74   # if no default value is set on the column, or if we can't parse the
  75   # default value as a sequence, throw.
  76   unless ( defined $seq_expr and $seq_expr =~ /^nextval\(+'([^']+)'::(?:text|regclass)\)/i ){
  77     $seq_expr = '' unless defined $seq_expr;
  78     $schema = "$schema." if defined $schema && length $schema;
  79     $self->throw_exception( "no sequence found for $schema$table.$col, check table definition, "
  80                             . "or explicitly set the 'sequence' for this column in the "
  81                             . $source->source_name
  82                             . " class"
  83                           );
  84   }
  85
  86   return $1;
  87 }
  88
  89 # custom method for fetching column default, since column_info has a
  90 # bug with older versions of DBD::Pg
  91 sub _dbh_get_column_default {
  92   my ( $self, $dbh, $schema, $table, $col ) = @_;
  93
  94   # Build and execute a query into the pg_catalog to find the Pg
  95   # expression for the default value for this column in this table.
  96   # If the table name is schema-qualified, query using that specific
  97   # schema name.
  98
  99   # Otherwise, find the table in the standard Postgres way, using the
 100   # search path.  This is done with the pg_catalog.pg_table_is_visible
 101   # function, which returns true if a given table is 'visible',
 102   # meaning the first table of that name to be found in the search
 103   # path.
 104
 105   # I *think* we can be assured that this query will always find the
 106   # correct column according to standard Postgres semantics.
 107   #
 108   # -- rbuels
 109
 110   my $sqlmaker = $self->sql_maker;
 111   local $sqlmaker->{bindtype} = 'normal';
 112
 113   my ($where, @bind) = $sqlmaker->where ({
 114     'a.attnum' => {'>', 0},
 115     'c.relname' => $table,
 116     'a.attname' => $col,
 117     -not_bool => 'a.attisdropped',
 118     (defined $schema && length $schema)
 119       ? ( 'n.nspname' => $schema )
 120       : ( -bool => \'pg_catalog.pg_table_is_visible(c.oid)' )
 121   });
 122
 123   my ($seq_expr) = $dbh->selectrow_array(<<EOS,undef,@bind);
 124
 125 SELECT
 126   (SELECT pg_catalog.pg_get_expr(d.adbin, d.adrelid)
 127    FROM pg_catalog.pg_attrdef d
 128    WHERE d.adrelid = a.attrelid AND d.adnum = a.attnum AND a.atthasdef)
 129 FROM pg_catalog.pg_class c
 130      LEFT JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace
 131      JOIN pg_catalog.pg_attribute a ON a.attrelid = c.oid
 132 $where
 133
 134 EOS
 135
 136   return $seq_expr;
 137 }
 138
 139
 140 sub sqlt_type {
 141   return 'PostgreSQL';
 142 }
 143
 144 sub datetime_parser_type { return "DateTime::Format::Pg"; }
 145
 146 sub bind_attribute_by_data_type {
 147   my ($self,$data_type) = @_;
 148
 149   my $bind_attributes = {
 150     bytea => { pg_type => DBD::Pg::PG_BYTEA },
 151     blob  => { pg_type => DBD::Pg::PG_BYTEA },
 152   };
 153
 154   if( defined $bind_attributes->{$data_type} ) {
 155     return $bind_attributes->{$data_type};
 156   }
 157   else {
 158     return;
 159   }
 160 }
 161
 162 sub _sequence_fetch {
 163   my ( $self, $type, $seq ) = @_;
 164   my ($id) = $self->_get_dbh->selectrow_array("SELECT nextval('${seq}')");
 165   return $id;
 166 }
 167
 168 sub _svp_begin {
 169     my ($self, $name) = @_;
 170
 171     $self->_get_dbh->pg_savepoint($name);
 172 }
 173
 174 sub _svp_release {
 175     my ($self, $name) = @_;
 176
 177     $self->_get_dbh->pg_release($name);
 178 }
 179
 180 sub _svp_rollback {
 181     my ($self, $name) = @_;
 182
 183     $self->_get_dbh->pg_rollback_to($name);
 184 }
 185
 186 1;
 187
 188 __END__
 189
 190 =head1 NAME
 191
 192 DBIx::Class::Storage::DBI::Pg - Automatic primary key class for PostgreSQL
 193
 194 =head1 SYNOPSIS
 195
 196   # In your table classes
 197   __PACKAGE__->load_components(qw/PK::Auto Core/);
 198   __PACKAGE__->set_primary_key('id');
 199   __PACKAGE__->sequence('mysequence');
 200
 201 =head1 DESCRIPTION
 202
 203 This class implements autoincrements for PostgreSQL.
 204
 205 =head1 POSTGRESQL SCHEMA SUPPORT
 206
 207 This driver supports multiple PostgreSQL schemas, with one caveat: for
 208 performance reasons, data about the search path, sequence names, and
 209 so forth is queried as needed and CACHED for subsequent uses.
 210
 211 For this reason, once your schema is instantiated, you should not
 212 change the PostgreSQL schema search path for that schema's database
 213 connection. If you do, Bad Things may happen.
 214
 215 You should do any necessary manipulation of the search path BEFORE
 216 instantiating your schema object, or as part of the on_connect_do
 217 option to connect(), for example:
 218
 219    my $schema = My::Schema->connect
 220                   ( $dsn,$user,$pass,
 221                     { on_connect_do =>
 222                         [ 'SET search_path TO myschema, foo, public' ],
 223                     },
 224                   );
 225
 226 =head1 AUTHORS
 227
 228 See L<DBIx::Class/CONTRIBUTORS>
 229
 230 =head1 LICENSE
 231
 232 You may distribute this code under the same terms as Perl itself.
 233
 234 =cut