Add support for UPDATE ... RETURNING ...

[dbsrgits/SQL-Abstract.git] / lib / SQL / Abstract.pm

diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm
index 24a062f..2683f2e 100644 (file)
--- a/lib/SQL/Abstract.pm
+++ b/lib/SQL/Abstract.pm
@@ -27,7 +27,7 @@ BEGIN {
 # GLOBALS
 #======================================================================
 
-our $VERSION  = '1.79';
+our $VERSION  = '1.81';
 
 # This would confuse some packagers
 $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
@@ -219,7 +219,7 @@ sub insert {
   $sql = join " ", $self->_sqlcase('insert into'), $table, $sql;
 
   if ($options->{returning}) {
-    my ($s, @b) = $self->_insert_returning ($options);
+    my ($s, @b) = $self->_returning ($options);
     $sql .= $s;
     push @bind, @b;
   }
@@ -227,7 +227,7 @@ sub insert {
   return wantarray ? ($sql, @bind) : $sql;
 }
 
-sub _insert_returning {
+sub _returning {
   my ($self, $options) = @_;
 
   my $f = $options->{returning};
@@ -348,10 +348,11 @@ sub _insert_values {
 
 
 sub update {
-  my $self  = shift;
-  my $table = $self->_table(shift);
-  my $data  = shift || return;
-  my $where = shift;
+  my $self    = shift;
+  my $table   = $self->_table(shift);
+  my $data    = shift || return;
+  my $where   = shift;
+  my $options = shift;
 
   # first build the 'SET' part of the sql statement
   my (@set, @all_bind);
@@ -414,6 +415,12 @@ sub update {
     push @all_bind, @where_bind;
   }
 
+  if ($options->{returning}) {
+    my ($returning_sql, @returning_bind) = $self->_returning ($options);
+    $sql .= $returning_sql;
+    push @all_bind, @returning_bind;
+  }
+
   return wantarray ? ($sql, @all_bind) : $sql;
 }
 
@@ -629,6 +636,11 @@ sub _where_HASHREF {
 sub _where_unary_op {
   my ($self, $op, $rhs) = @_;
 
+  # top level special ops are illegal in general
+  # this includes the -ident/-value ops (dual purpose unary and special)
+  puke "Illegal use of top-level '-$op'"
+    if ! defined $self->{_nested_func_lhs} and List::Util::first {$op =~ $_->{regex}} @{$self->{special_ops}};
+
   if (my $op_entry = List::Util::first {$op =~ $_->{regex}} @{$self->{unary_ops}}) {
     my $handler = $op_entry->{handler};
 
@@ -653,7 +665,7 @@ sub _where_unary_op {
 
   my ($sql, @bind) = $self->_SWITCH_refkind ($rhs, {
     SCALAR =>   sub {
-      puke "Illegal use of top-level '$op'"
+      puke "Illegal use of top-level '-$op'"
         unless defined $self->{_nested_func_lhs};
 
       return (
@@ -1237,8 +1249,29 @@ sub _where_field_IN {
 # adding them back in the corresponding method
 sub _open_outer_paren {
   my ($self, $sql) = @_;
-  $sql = $1 while $sql =~ /^ \s* \( (.*) \) \s* $/xs;
-  return $sql;
+
+  while ( my ($inner) = $sql =~ /^ \s* \( (.*) \) \s* $/xs ) {
+
+    # there are closing parens inside, need the heavy duty machinery
+    # to reevaluate the extraction starting from $sql (full reevaluation)
+    if ( $inner =~ /\)/ ) {
+      require Text::Balanced;
+
+      my (undef, $remainder) = do {
+        # idiotic design - writes to $@ but *DOES NOT* throw exceptions
+        local $@;
+        Text::Balanced::extract_bracketed( $sql, '()', qr/\s*/ );
+      };
+
+      # the entire expression needs to be a balanced bracketed thing
+      # (after an extract no remainder sans trailing space)
+      last if defined $remainder and $remainder =~ /\S/;
+    }
+
+    $sql = $inner;
+  }
+
+  $sql;
 }
 
 
@@ -2044,7 +2077,7 @@ be supported by all database engines.
 
 =back
 
-=head2 update($table, \%fieldvals, \%where)
+=head2 update($table, \%fieldvals, \%where, \%options)
 
 This takes a table, hashref of field/value pairs, and an optional
 hashref L<WHERE clause|/WHERE CLAUSES>. It returns an SQL UPDATE function and a list
@@ -2053,6 +2086,19 @@ See the sections on L</"Inserting and Updating Arrays"> and
 L</"Inserting and Updating SQL"> for information on how to insert
 with those data types.
 
+The optional C<\%options> hash reference may contain additional
+options to generate the update SQL. Currently supported options
+are:
+
+=over 4
+
+=item returning
+
+See the C<returning> option to
+L<insert|/insert($table, \@values || \%fieldvals, \%options)>.
+
+=back
+
 =head2 select($source, $fields, $where, $order)
 
 This returns a SQL SELECT statement and associated list of bind values, as