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 use Scope::Guard ();
  11 use Context::Preserve ();
  12
  13 # Ask for a DBD::Pg with array support
  14 warn __PACKAGE__.": DBD::Pg 2.9.2 or greater is strongly recommended\n"
  15   if ($DBD::Pg::VERSION < 2.009002);  # pg uses (used?) version::qv()
  16
  17 __PACKAGE__->mk_group_accessors(simple => qw/
  18   _auto_cols
  19 /);
  20
  21 sub _prep_for_execute {
  22   my $self = shift;
  23   my ($op, $extra_bind, $ident, $args) = @_;
  24
  25   if ($op eq 'insert') {
  26     $self->_auto_cols([]);
  27
  28     my %pk;
  29     @pk{$ident->primary_columns} = ();
  30
  31     my @auto_inc_cols = grep {
  32       my $inserting = $args->[0]{$_};
  33
  34       ($ident->column_info($_)->{is_auto_increment}
  35         || exists $pk{$_})
  36       && (
  37         (not defined $inserting)
  38         ||
  39         (ref $inserting eq 'SCALAR' && $$inserting =~ /^null\z/i)
  40       )
  41     } $ident->columns;
  42
  43     if (@auto_inc_cols) {
  44       $args->[1]{returning} = \@auto_inc_cols;
  45
  46       $self->_auto_cols->[0] = \@auto_inc_cols;
  47     }
  48   }
  49
  50   return $self->next::method(@_);
  51 }
  52
  53 sub _execute {
  54   my $self = shift;
  55   my ($op) = @_;
  56
  57   my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
  58
  59   if ($op eq 'insert' && $self->_auto_cols) {
  60     local $@;
  61     my (@auto_cols) = eval {
  62       local $SIG{__WARN__} = sub {};
  63       $sth->fetchrow_array
  64     };
  65     $self->_auto_cols->[1] = \@auto_cols;
  66     $sth->finish;
  67   }
  68
  69   return wantarray ? ($rv, $sth, @bind) : $rv;
  70 }
  71
  72
  73 sub with_deferred_fk_checks {
  74   my ($self, $sub) = @_;
  75
  76   my $txn_scope_guard = $self->txn_scope_guard;
  77
  78   $self->_do_query('SET CONSTRAINTS ALL DEFERRED');
  79
  80   my $sg = Scope::Guard->new(sub {
  81     $self->_do_query('SET CONSTRAINTS ALL IMMEDIATE');
  82   });
  83
  84   return Context::Preserve::preserve_context(sub { $sub->() },
  85     after => sub { $txn_scope_guard->commit });
  86 }
  87
  88 sub insert {
  89   my $self = shift;
  90
  91   my $updated_cols = $self->next::method(@_);
  92
  93   if ($self->_auto_cols->[0]) {
  94     my %auto_cols;
  95     @auto_cols{ @{ $self->_auto_cols->[0] } } = @{ $self->_auto_cols->[1] };
  96
  97     $updated_cols = { %$updated_cols, %auto_cols };
  98   }
  99
 100   return $updated_cols;
 101 }
 102
 103 sub last_insert_id {
 104   my ($self, $source, @cols) = @_;
 105   my @result;
 106
 107   my %auto_cols;
 108   @auto_cols{ @{ $self->_auto_cols->[0] } } =
 109     @{ $self->_auto_cols->[1] };
 110
 111   push @result, $auto_cols{$_} for @cols;
 112
 113   return @result;
 114 }
 115
 116 sub _sequence_fetch {
 117   my ($self, $function, $sequence) = @_;
 118
 119   $self->throw_exception('No sequence to fetch') unless $sequence;
 120
 121   my ($val) = $self->_get_dbh->selectrow_array(
 122     sprintf "select $function('%s')",
 123       $sequence
 124   );
 125
 126   return $val;
 127 }
 128
 129 sub _dbh_get_autoinc_seq {
 130   my ($self, $dbh, $source, $col) = @_;
 131
 132   my $schema;
 133   my $table = $source->name;
 134
 135   # deref table name if it needs it
 136   $table = $$table
 137       if ref $table eq 'SCALAR';
 138
 139   # parse out schema name if present
 140   if( $table =~ /^(.+)\.(.+)$/ ) {
 141     ( $schema, $table ) = ( $1, $2 );
 142   }
 143
 144   # get the column default using a Postgres-specific pg_catalog query
 145   my $seq_expr = $self->_dbh_get_column_default( $dbh, $schema, $table, $col );
 146
 147   # if no default value is set on the column, or if we can't parse the
 148   # default value as a sequence, throw.
 149   unless ( defined $seq_expr and $seq_expr =~ /^nextval\(+'([^']+)'::(?:text|regclass)\)/i ) {
 150     $seq_expr = '' unless defined $seq_expr;
 151     $schema = "$schema." if defined $schema && length $schema;
 152     $self->throw_exception( sprintf (
 153       'no sequence found for %s%s.%s, check the RDBMS table definition or explicitly set the '.
 154       "'sequence' for this column in %s",
 155         $schema ? "$schema." : '',
 156         $table,
 157         $col,
 158         $source->source_name,
 159     ));
 160   }
 161
 162   return $1;
 163 }
 164
 165 # custom method for fetching column default, since column_info has a
 166 # bug with older versions of DBD::Pg
 167 sub _dbh_get_column_default {
 168   my ( $self, $dbh, $schema, $table, $col ) = @_;
 169
 170   # Build and execute a query into the pg_catalog to find the Pg
 171   # expression for the default value for this column in this table.
 172   # If the table name is schema-qualified, query using that specific
 173   # schema name.
 174
 175   # Otherwise, find the table in the standard Postgres way, using the
 176   # search path.  This is done with the pg_catalog.pg_table_is_visible
 177   # function, which returns true if a given table is 'visible',
 178   # meaning the first table of that name to be found in the search
 179   # path.
 180
 181   # I *think* we can be assured that this query will always find the
 182   # correct column according to standard Postgres semantics.
 183   #
 184   # -- rbuels
 185
 186   my $sqlmaker = $self->sql_maker;
 187   local $sqlmaker->{bindtype} = 'normal';
 188
 189   my ($where, @bind) = $sqlmaker->where ({
 190     'a.attnum' => {'>', 0},
 191     'c.relname' => $table,
 192     'a.attname' => $col,
 193     -not_bool => 'a.attisdropped',
 194     (defined $schema && length $schema)
 195       ? ( 'n.nspname' => $schema )
 196       : ( -bool => \'pg_catalog.pg_table_is_visible(c.oid)' )
 197   });
 198
 199   my ($seq_expr) = $dbh->selectrow_array(<<EOS,undef,@bind);
 200
 201 SELECT
 202   (SELECT pg_catalog.pg_get_expr(d.adbin, d.adrelid)
 203    FROM pg_catalog.pg_attrdef d
 204    WHERE d.adrelid = a.attrelid AND d.adnum = a.attnum AND a.atthasdef)
 205 FROM pg_catalog.pg_class c
 206      LEFT JOIN pg_catalog.pg_namespace n ON n.oid = c.relnamespace
 207      JOIN pg_catalog.pg_attribute a ON a.attrelid = c.oid
 208 $where
 209
 210 EOS
 211
 212   return $seq_expr;
 213 }
 214
 215
 216 sub sqlt_type {
 217   return 'PostgreSQL';
 218 }
 219
 220 sub datetime_parser_type { return "DateTime::Format::Pg"; }
 221
 222 sub bind_attribute_by_data_type {
 223   my ($self,$data_type) = @_;
 224
 225   my $bind_attributes = {
 226     bytea => { pg_type => DBD::Pg::PG_BYTEA },
 227     blob  => { pg_type => DBD::Pg::PG_BYTEA },
 228   };
 229
 230   if( defined $bind_attributes->{$data_type} ) {
 231     return $bind_attributes->{$data_type};
 232   }
 233   else {
 234     return;
 235   }
 236 }
 237
 238 sub _svp_begin {
 239     my ($self, $name) = @_;
 240
 241     $self->_get_dbh->pg_savepoint($name);
 242 }
 243
 244 sub _svp_release {
 245     my ($self, $name) = @_;
 246
 247     $self->_get_dbh->pg_release($name);
 248 }
 249
 250 sub _svp_rollback {
 251     my ($self, $name) = @_;
 252
 253     $self->_get_dbh->pg_rollback_to($name);
 254 }
 255
 256 1;
 257
 258 __END__
 259
 260 =head1 NAME
 261
 262 DBIx::Class::Storage::DBI::Pg - Automatic primary key class for PostgreSQL
 263
 264 =head1 SYNOPSIS
 265
 266   # In your result (table) classes
 267   use base 'DBIx::Class::Core';
 268   __PACKAGE__->set_primary_key('id');
 269   __PACKAGE__->sequence('mysequence');
 270
 271 =head1 DESCRIPTION
 272
 273 This class implements autoincrements for PostgreSQL.
 274
 275 =head1 POSTGRESQL SCHEMA SUPPORT
 276
 277 This driver supports multiple PostgreSQL schemas, with one caveat: for
 278 performance reasons, data about the search path, sequence names, and
 279 so forth is queried as needed and CACHED for subsequent uses.
 280
 281 For this reason, once your schema is instantiated, you should not
 282 change the PostgreSQL schema search path for that schema's database
 283 connection. If you do, Bad Things may happen.
 284
 285 You should do any necessary manipulation of the search path BEFORE
 286 instantiating your schema object, or as part of the on_connect_do
 287 option to connect(), for example:
 288
 289    my $schema = My::Schema->connect
 290                   ( $dsn,$user,$pass,
 291                     { on_connect_do =>
 292                         [ 'SET search_path TO myschema, foo, public' ],
 293                     },
 294                   );
 295
 296 =head1 AUTHORS
 297
 298 See L<DBIx::Class/CONTRIBUTORS>
 299
 300 =head1 LICENSE
 301
 302 You may distribute this code under the same terms as Perl itself.
 303
 304 =cut