lib/DBIx/Class/Storage/DBI/InsertReturning.pm

   1 package DBIx::Class::Storage::DBI::InsertReturning;
   2
   3 use strict;
   4 use warnings;
   5
   6 use base qw/DBIx::Class::Storage::DBI/;
   7 use mro 'c3';
   8
   9 __PACKAGE__->mk_group_accessors(simple => qw/
  10   _returning_cols
  11 /);
  12
  13 =head1 NAME
  14
  15 DBIx::Class::Storage::DBI::InsertReturning - Storage component for RDBMSes
  16 supporting INSERT ... RETURNING
  17
  18 =head1 DESCRIPTION
  19
  20 Provides Auto-PK and
  21 L<is_auto_increment|DBIx::Class::ResultSource/is_auto_increment> support for
  22 databases supporting the C<INSERT ... RETURNING> syntax. Currently
  23 L<PostgreSQL|DBIx::Class::Storage::DBI::Pg> and
  24 L<Firebird|DBIx::Class::Storage::DBI::InterBase>.
  25
  26 =cut
  27
  28 sub _prep_for_execute {
  29   my $self = shift;
  30   my ($op, $extra_bind, $ident, $args) = @_;
  31
  32   if ($op eq 'insert') {
  33     $self->_returning_cols([]);
  34
  35     my %pk;
  36     @pk{$ident->primary_columns} = ();
  37
  38     my @auto_inc_cols = grep {
  39       my $inserting = $args->[0]{$_};
  40
  41       ($ident->column_info($_)->{is_auto_increment}
  42         || exists $pk{$_})
  43       && (
  44         (not defined $inserting)
  45         ||
  46         (ref $inserting eq 'SCALAR' && $$inserting =~ /^null\z/i)
  47       )
  48     } $ident->columns;
  49
  50     if (@auto_inc_cols) {
  51       $args->[1]{returning} = \@auto_inc_cols;
  52
  53       $self->_returning_cols->[0] = \@auto_inc_cols;
  54     }
  55   }
  56
  57   return $self->next::method(@_);
  58 }
  59
  60 sub _execute {
  61   my $self = shift;
  62   my ($op) = @_;
  63
  64   my ($rv, $sth, @bind) = $self->dbh_do($self->can('_dbh_execute'), @_);
  65
  66   if ($op eq 'insert' && $self->_returning_cols) {
  67     local $@;
  68     my (@returning_cols) = eval {
  69       local $SIG{__WARN__} = sub {};
  70       $sth->fetchrow_array
  71     };
  72     $self->_returning_cols->[1] = \@returning_cols;
  73     $sth->finish;
  74   }
  75
  76   return wantarray ? ($rv, $sth, @bind) : $rv;
  77 }
  78
  79 sub insert {
  80   my $self = shift;
  81
  82   my $updated_cols = $self->next::method(@_);
  83
  84   if ($self->_returning_cols->[0]) {
  85     my %returning_cols;
  86     @returning_cols{ @{ $self->_returning_cols->[0] } } = @{ $self->_returning_cols->[1] };
  87
  88     $updated_cols = { %$updated_cols, %returning_cols };
  89   }
  90
  91   return $updated_cols;
  92 }
  93
  94 sub last_insert_id {
  95   my ($self, $source, @cols) = @_;
  96   my @result;
  97
  98   my %returning_cols;
  99   @returning_cols{ @{ $self->_returning_cols->[0] } } =
 100     @{ $self->_returning_cols->[1] };
 101
 102   push @result, $returning_cols{$_} for @cols;
 103
 104   return @result;
 105 }
 106
 107 =head1 AUTHOR
 108
 109 See L<DBIx::Class/AUTHOR> and L<DBIx::Class/CONTRIBUTORS>
 110
 111 =head1 LICENSE
 112
 113 You may distribute this code under the same terms as Perl itself.
 114
 115 =cut
 116
 117 1;