support INSERT ... RETURNING in Oracle 8i and later

Changes

@@ -12,6 +12,7 @@ Revision history for DBIx::Class
           values to DBI: search({ array_col => { -value => [1,2,3] }})
         - +columns now behaves just like columns by not stripping a
           fully-qualified 'as' spec (i.e. foo.bar results in $obj->foo->bar)
+        - Add full INSERT...RETURNING support for Oracle
 
     * Fixes
         - Fixed read-only attribute set attempt in ::Storage::Replicated

Makefile.PL

@@ -68,7 +68,7 @@ my $runtime_requires = {
   'Module::Find'             => '0.06',
   'Path::Class'              => '0.18',
   'Scope::Guard'             => '0.03',
-  'SQL::Abstract'            => '1.71',
+  'SQL::Abstract'            => '1.72',
   'Try::Tiny'                => '0.04',
 
   # XS (or XS-dependent) libs

lib/DBIx/Class/SQLMaker.pm

@@ -220,15 +220,18 @@ sub insert {
   # which is sadly understood only by MySQL. Change default behavior here,
   # until SQLA2 comes with proper dialect support
   if (! $_[2] or (ref $_[2] eq 'HASH' and !keys %{$_[2]} ) ) {
+    my @bind;
     my $sql = sprintf(
       'INSERT INTO %s DEFAULT VALUES', $_[0]->_quote($_[1])
     );
 
-    if (my $ret = ($_[3]||{})->{returning} ) {
-      $sql .= $_[0]->_insert_returning ($ret);
+    if ( ($_[3]||{})->{returning} ) {
+      my $s;
+      ($s, @bind) = $_[0]->_insert_returning ($_[3]);
+      $sql .= $s;
     }
 
-    return $sql;
+    return ($sql, @bind);
   }
 
   next::method(@_);

lib/DBIx/Class/SQLMaker/Oracle.pm

@@ -183,4 +183,48 @@ sub _unqualify_colname {
   return $self->_shorten_identifier($self->next::method($fqcn));
 }
 
+#
+# Oracle has a different INSERT...RETURNING syntax
+#
+
+sub _insert_returning {
+  my ($self, $options) = @_;
+
+  my $f = $options->{returning};
+
+  my ($f_list, @f_names) = $self->_SWITCH_refkind($f, {
+    ARRAYREF => sub {
+      (join ', ', map { $self->_quote($_) } @$f),
+      @$f
+    },
+    SCALAR => sub {
+      $self->_quote($f),
+      $f,
+    },
+    SCALARREF => sub {
+      $$f,
+      $$f,
+    },
+  });
+
+  my $rc_ref = $options->{returning_container}
+    or croak ('No returning container supplied for IR values');
+
+  @$rc_ref = (undef) x @f_names;
+
+  return (
+    ( join (' ',
+      $self->_sqlcase(' returning'),
+      $f_list,
+      $self->_sqlcase('into'),
+      join (', ', ('?') x @f_names ),
+    )),
+    map {
+      $self->{bindtype} eq 'columns'
+        ? [ $f_names[$_] => \$rc_ref->[$_] ]
+        : \$rc_ref->[$_]
+    } (0 .. $#f_names),
+  );
+}
+
 1;

lib/DBIx/Class/Storage/DBI.pm

@@ -16,6 +16,7 @@ use Data::Dumper::Concise 'Dumper';
 use Sub::Name 'subname';
 use Try::Tiny;
 use File::Path 'make_path';
+use overload ();
 use namespace::clean;
 
 
@@ -54,7 +55,13 @@ __PACKAGE__->mk_group_accessors('simple' => @storage_options);
 # will get the same rdbms version). _determine_supports_X does not need to
 # exist on a driver, as we ->can for it before calling.
 
-my @capabilities = (qw/insert_returning placeholders typeless_placeholders join_optimizer/);
+my @capabilities = (qw/
+  insert_returning
+  insert_returning_bound
+  placeholders
+  typeless_placeholders
+  join_optimizer
+/);
 __PACKAGE__->mk_group_accessors( dbms_capability => map { "_supports_$_" } @capabilities );
 __PACKAGE__->mk_group_accessors( use_dbms_capability => map { "_use_$_" } (@capabilities ) );
 
@@ -1554,10 +1561,21 @@ sub _dbh_execute {
 
     foreach my $data (@data) {
       my $ref = ref $data;
-      $data = $ref && $ref ne 'ARRAY' ? ''.$data : $data; # stringify args (except arrayrefs)
 
-      $sth->bind_param($placeholder_index, $data, $attributes);
-      $placeholder_index++;
+      if ($ref and overload::Method($data, '""') ) {
+        $data = "$data";
+      }
+      elsif ($ref eq 'SCALAR') {  # any scalarrefs are assumed to be bind_inouts
+        $sth->bind_param_inout(
+          $placeholder_index++,
+          $data,
+          $self->_max_column_bytesize($ident, $column_name),
+          $attributes
+        );
+        next;
+      }
+
+      $sth->bind_param($placeholder_index++, $data, $attributes);
     }
   }
 
@@ -1616,19 +1634,19 @@ sub insert {
   # list of primary keys we try to fetch from the database
   # both not-exsists and scalarrefs are considered
   my %fetch_pks;
-  %fetch_pks = ( map
-    { $_ => scalar keys %fetch_pks }  # so we can preserve order for prettyness
-    grep
-      { ! exists $to_insert->{$_} or ref $to_insert->{$_} eq 'SCALAR' }
-      $source->primary_columns
-  );
+  for ($source->primary_columns) {
+    $fetch_pks{$_} = scalar keys %fetch_pks  # so we can preserve order for prettyness
+      if ! exists $to_insert->{$_} or ref $to_insert->{$_} eq 'SCALAR';
+  }
 
-  my $sqla_opts;
+  my ($sqla_opts, @ir_container);
   if ($self->_use_insert_returning) {
 
     # retain order as declared in the resultsource
     for (sort { $fetch_pks{$a} <=> $fetch_pks{$b} } keys %fetch_pks ) {
       push @{$sqla_opts->{returning}}, $_;
+      $sqla_opts->{returning_container} = \@ir_container
+        if $self->_use_insert_returning_bound;
     }
   }
 
@@ -1639,14 +1657,14 @@ sub insert {
   my %returned_cols;
 
   if (my $retlist = $sqla_opts->{returning}) {
-    my @ret_vals = try {
+    @ir_container = try {
       local $SIG{__WARN__} = sub {};
       my @r = $sth->fetchrow_array;
       $sth->finish;
       @r;
-    };
+    } unless @ir_container;
 
-    @returned_cols{@$retlist} = @ret_vals if @ret_vals;
+    @returned_cols{@$retlist} = @ir_container if @ir_container;
   }
 
   return { %$prefetched_values, %returned_cols };
@@ -2776,6 +2794,50 @@ sub relname_to_table_alias {
   return $alias;
 }
 
+# The size in bytes to use for DBI's ->bind_param_inout, this is the generic
+# version and it may be necessary to amend or override it for a specific storage
+# if such binds are necessary.
+sub _max_column_bytesize {
+  my ($self, $source, $col) = @_;
+
+  my $inf = $source->column_info($col);
+  return $inf->{_max_bytesize} ||= do {
+
+    my $max_size;
+
+    if (my $data_type = $inf->{data_type}) {
+      $data_type = lc($data_type);
+
+      # String/sized-binary types
+      if ($data_type =~ /^(?:l?(?:var)?char(?:acter)?(?:\s*varying)?
+                             |(?:var)?binary(?:\s*varying)?|raw)\b/x
+      ) {
+        $max_size = $inf->{size};
+      }
+      # Other charset/unicode types, assume scale of 4
+      elsif ($data_type =~ /^(?:national\s*character(?:\s*varying)?|nchar
+                              |univarchar
+                              |nvarchar)\b/x
+      ) {
+        $max_size = $inf->{size} * 4 if $inf->{size};
+      }
+      # Blob types
+      elsif ($data_type =~ /(?:blob|clob|bfile|text|image|bytea)/
+          || $data_type =~ /^long(?:\s*(?:raw|bit\s*varying|varbit|binary
+                                        |varchar|character\s*varying|nvarchar
+                                        |national\s*character\s*varying))?$/
+      ) {
+        # default to longreadlen
+      }
+      else {
+        $max_size = 100;  # for all other (numeric?) datatypes
+      }
+    }
+
+    $max_size ||= $self->_get_dbh->{LongReadLen} || 8000;
+  };
+}
+
 1;
 
 =head1 USAGE NOTES

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

@@ -9,21 +9,15 @@ use Try::Tiny;
 use namespace::clean;
 
 sub _rebless {
-    my ($self) = @_;
+  my ($self) = @_;
 
-    try {
-      my $version = $self->_get_dbh->get_info(18);
+  # Default driver
+  my $class = $self->_server_info->{normalized_dbms_version} <= 8
+    ? 'DBIx::Class::Storage::DBI::Oracle::WhereJoins'
+    : 'DBIx::Class::Storage::DBI::Oracle::Generic';
 
-      my ($major, $minor, $patchlevel) = split(/\./, $version);
-
-      # Default driver
-      my $class = $major <= 8
-        ? 'DBIx::Class::Storage::DBI::Oracle::WhereJoins'
-        : 'DBIx::Class::Storage::DBI::Oracle::Generic';
-
-      $self->ensure_class_loaded ($class);
-      bless $self, $class;
-    };
+  $self->ensure_class_loaded ($class);
+  bless $self, $class;
 }
 
 1;

lib/DBIx/Class/Storage/DBI/Oracle/Generic.pm

@@ -80,6 +80,20 @@ use mro 'c3';
 
 __PACKAGE__->sql_maker_class('DBIx::Class::SQLMaker::Oracle');
 
+sub _determine_supports_insert_returning {
+  my $self = shift;
+
+# TODO find out which version supports the RETURNING syntax
+# 8i has it and earlier docs are a 404 on oracle.com
+
+  return 1
+    if $self->_server_info->{normalized_dbms_version} >= 8.001;
+
+  return 0;
+}
+
+__PACKAGE__->_use_insert_returning_bound (1);
+
 sub deployment_statements {
   my $self = shift;;
   my ($schema, $type, $version, $dir, $sqltargs, @rest) = @_;

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

@@ -379,6 +379,7 @@ my @unimplemented = qw(
   _group_over_selection
   _prefetch_autovalues
   _extract_order_criteria
+  _max_column_bytesize
 );
 
 # the capability framework