X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=f8518deeeeb2be216383e8624102ecf18d7bb96c;hb=2af21cb852b6c6c629ce0eda1116fd366cea666b;hp=91f5c3af262c5d2118e8d9e92813800c12c93e84;hpb=977fb4f105957fe06675f5ff1919bfb5f7096295;p=dbsrgits%2FSQL-Abstract.git

diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm
index 91f5c3a..f8518de 100644
--- a/lib/SQL/Abstract.pm
+++ b/lib/SQL/Abstract.pm
@@ -155,7 +155,8 @@ sub new {
   $opt{sqlfalse} ||= '0=1';
 
   # special operators
-  $opt{user_special_ops} = [ @{$opt{special_ops} ||= []} ];
+  $opt{special_ops} ||= [];
+
   # regexes are applied in order, thus push after user-defines
   push @{$opt{special_ops}}, @BUILTIN_SPECIAL_OPS;
 
@@ -176,6 +177,13 @@ sub new {
     ^ \s* go \s
   /xmi;
 
+  $opt{node_types} = +{
+    map +("-$_" => '_render_'.$_),
+      qw(op func value bind ident literal)
+  };
+
+  $opt{expand_unary} = {};
+
   return bless \%opt, $class;
 }
 
@@ -224,12 +232,12 @@ sub _returning {
 
   my $f = $options->{returning};
 
-  my $fieldlist = $self->_SWITCH_refkind($f, {
-    ARRAYREF     => sub {join ', ', map { $self->_quote($_) } @$f;},
-    SCALAR       => sub {$self->_quote($f)},
-    SCALARREF    => sub {$$f},
-  });
-  return $self->_sqlcase(' returning ') . $fieldlist;
+  my ($sql, @bind) = $self->_render_expr(
+    $self->_expand_maybe_list_expr($f, undef, -ident)
+  );
+  return wantarray
+    ? $self->_sqlcase(' returning ') . $sql
+    : ($self->_sqlcase(' returning ').$sql, @bind);
 }
 
 sub _insert_HASHREF { # explicit list of fields and then values
@@ -295,50 +303,33 @@ sub _insert_values {
 sub _insert_value {
   my ($self, $column, $v) = @_;
 
-  my (@values, @all_bind);
-  $self->_SWITCH_refkind($v, {
-
-    ARRAYREF => sub {
-      if ($self->{array_datatypes}) { # if array datatype are activated
-        push @values, '?';
-        push @all_bind, $self->_bindtype($column, $v);
-      }
-      else {                  # else literal SQL with bind
-        my ($sql, @bind) = @$v;
-        $self->_assert_bindval_matches_bindtype(@bind);
-        push @values, $sql;
-        push @all_bind, @bind;
-      }
-    },
-
-    ARRAYREFREF => sub {        # literal SQL with bind
-      my ($sql, @bind) = @${$v};
-      $self->_assert_bindval_matches_bindtype(@bind);
-      push @values, $sql;
-      push @all_bind, @bind;
-    },
-
-    # THINK: anything useful to do with a HASHREF ?
-    HASHREF => sub {       # (nothing, but old SQLA passed it through)
-      #TODO in SQLA >= 2.0 it will die instead
-      belch "HASH ref as bind value in insert is not supported";
-      push @values, '?';
-      push @all_bind, $self->_bindtype($column, $v);
-    },
-
-    SCALARREF => sub {          # literal SQL without bind
-      push @values, $$v;
-    },
-
-    SCALAR_or_UNDEF => sub {
-      push @values, '?';
-      push @all_bind, $self->_bindtype($column, $v);
-    },
+  return $self->_render_expr(
+    $self->_expand_insert_value($column, $v)
+  );
+}
 
-  });
+sub _expand_insert_value {
+  my ($self, $column, $v) = @_;
 
-  my $sql = join(", ", @values);
-  return ($sql, @all_bind);
+  if (ref($v) eq 'ARRAY') {
+    if ($self->{array_datatypes}) {
+      return +{ -bind => [ $column, $v ] };
+    }
+    my ($sql, @bind) = @$v;
+    $self->_assert_bindval_matches_bindtype(@bind);
+    return +{ -literal => $v };
+  }
+  if (ref($v) eq 'HASH') {
+    if (grep !/^-/, keys %$v) {
+      belch "HASH ref as bind value in insert is not supported";
+      return +{ -bind => [ $column, $v ] };
+    }
+  }
+  if (!defined($v)) {
+    return +{ -bind => [ $column, undef ] };
+  }
+  local our $Cur_Col_Meta = $column;
+  return $self->_expand_expr($v);
 }
 
 
@@ -381,59 +372,33 @@ sub update {
 sub _update_set_values {
   my ($self, $data) = @_;
 
-  my (@set, @all_bind);
-  for my $k (sort keys %$data) {
-    my $v = $data->{$k};
-    my $r = ref $v;
-    my $label = $self->_quote($k);
-
-    $self->_SWITCH_refkind($v, {
-      ARRAYREF => sub {
-        if ($self->{array_datatypes}) { # array datatype
-          push @set, "$label = ?";
-          push @all_bind, $self->_bindtype($k, $v);
-        }
-        else {                          # literal SQL with bind
-          my ($sql, @bind) = @$v;
-          $self->_assert_bindval_matches_bindtype(@bind);
-          push @set, "$label = $sql";
-          push @all_bind, @bind;
-        }
-      },
-      ARRAYREFREF => sub { # literal SQL with bind
-        my ($sql, @bind) = @${$v};
-        $self->_assert_bindval_matches_bindtype(@bind);
-        push @set, "$label = $sql";
-        push @all_bind, @bind;
-      },
-      SCALARREF => sub {  # literal SQL without bind
-        push @set, "$label = $$v";
-      },
-      HASHREF => sub {
-        my ($op, $arg, @rest) = %$v;
-
-        puke 'Operator calls in update must be in the form { -op => $arg }'
-          if (@rest or not $op =~ /^\-(.+)/);
-
-        local our $Cur_Col_Meta = $k;
-        my ($sql, @bind) = $self->_render_expr(
-          $self->_expand_expr_hashpair($op, $arg)
-        );
-
-        push @set, "$label = $sql";
-        push @all_bind, @bind;
-      },
-      SCALAR_or_UNDEF => sub {
-        push @set, "$label = ?";
-        push @all_bind, $self->_bindtype($k, $v);
-      },
-    });
-  }
-
-  # generate sql
-  my $sql = join ', ', @set;
+  return $self->_render_expr(
+    $self->_expand_update_set_values($data),
+  );
+}
 
-  return ($sql, @all_bind);
+sub _expand_update_set_values {
+  my ($self, $data) = @_;
+  $self->_expand_maybe_list_expr( [
+    map {
+      my ($k, $set) = @$_;
+      $set = { -bind => $_ } unless defined $set;
+      +{ -op => [ '=', { -ident => $k }, $set ] };
+    }
+    map {
+      my $k = $_;
+      my $v = $data->{$k};
+      (ref($v) eq 'ARRAY'
+        ? ($self->{array_datatypes}
+            ? [ $k, +{ -bind => [ $k, $v ] } ]
+            : [ $k, +{ -literal => $v } ])
+        : do {
+            local our $Cur_Col_Meta = $k;
+            [ $k, $self->_expand_expr($v) ]
+          }
+      );
+    } sort keys %$data
+  ] );
 }
 
 # So that subclasses can override UPDATE ... RETURNING separately from
@@ -468,8 +433,10 @@ sub select {
 
 sub _select_fields {
   my ($self, $fields) = @_;
-  return ref $fields eq 'ARRAY' ? join ', ', map { $self->_quote($_) } @$fields
-                                : $fields;
+  return $fields unless ref($fields);
+  return $self->_render_expr(
+    $self->_expand_maybe_list_expr($fields, undef, '-ident')
+  );
 }
 
 #======================================================================
@@ -511,6 +478,8 @@ sub _delete_returning { shift->_returning(@_) }
 sub where {
   my ($self, $where, $order) = @_;
 
+  local $self->{convert_where} = $self->{convert};
+
   # where ?
   my ($sql, @bind) = defined($where)
    ? $self->_recurse_where($where)
@@ -528,7 +497,8 @@ sub where {
 }
 
 sub _expand_expr {
-  my ($self, $expr, $logic) = @_;
+  my ($self, $expr, $logic, $default_scalar_to) = @_;
+  local our $Default_Scalar_To = $default_scalar_to if $default_scalar_to;
   return undef unless defined($expr);
   if (ref($expr) eq 'HASH') {
     if (keys %$expr > 1) {
@@ -572,6 +542,9 @@ sub _expand_expr {
     return +{ -literal => $literal };
   }
   if (!ref($expr) or Scalar::Util::blessed($expr)) {
+    if (my $d = $Default_Scalar_To) {
+      return +{ $d => $expr };
+    }
     if (my $m = our $Cur_Col_Meta) {
       return +{ -bind => [ $m, $expr ] };
     }
@@ -628,13 +601,18 @@ sub _expand_expr_hashpair {
     
       # top level special ops are illegal in general
       puke "Illegal use of top-level '-$op'"
-        if !(defined $self->{_nested_func_lhs})
-        and List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}};
+        if List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}};
+      if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
+        return { -op => [ $op, $v ] };
+      }
     }
     if ($k eq '-value' and my $m = our $Cur_Col_Meta) {
       return +{ -bind => [ $m, $v ] };
     }
-    if ($k eq '-op' or $k eq '-ident' or $k eq '-value' or $k eq '-bind' or $k eq '-literal' or $k eq '-func') {
+    if (my $custom = $self->{expand_unary}{$k}) {
+      return $self->$custom($v);
+    }
+    if ($self->{node_types}{$k}) {
       return { $k => $v };
     }
     if (
@@ -660,11 +638,12 @@ sub _expand_expr_hashpair {
     return $self->_expand_expr_hashpair($k => { $self->{cmp} => undef });
   }
   if (!ref($v) or Scalar::Util::blessed($v)) {
+    my $d = our $Default_Scalar_To;
     return +{
       -op => [
         $self->{cmp},
         { -ident => $k },
-        { -bind => [ $k, $v ] }
+        ($d ? { $d => $v } : { -bind => [ $k, $v ] })
       ]
     };
   }
@@ -731,8 +710,8 @@ sub _expand_expr_hashpair {
       ] };
     }
     if ($vk eq 'ident') {
-      if (! defined $vv or ref $vv) {
-        puke "-$vk requires a single plain scalar argument (a quotable identifier)";
+      if (! defined $vv or (ref($vv) and ref($vv) eq 'ARRAY')) {
+        puke "-$vk requires a single plain scalar argument (a quotable identifier) or an arrayref of identifier parts";
       }
       return +{ -op => [
         $self->{cmp},
@@ -768,9 +747,16 @@ sub _expand_expr_hashpair {
         ] };
       }
     }
-    if (my $us = List::Util::first { $vk =~ $_->{regex} } @{$self->{user_special_ops}}) {
+    if (my $us = List::Util::first { $vk =~ $_->{regex} } @{$self->{special_ops}}) {
       return { -op => [ $vk, { -ident => $k }, $vv ] };
     }
+    if (my $us = List::Util::first { $vk =~ $_->{regex} } @{$self->{unary_ops}}) {
+      return { -op => [
+        $self->{cmp},
+        { -ident => $k },
+        { -op => [ $vk, $vv ] }
+      ] };
+    }
     if (ref($vv) eq 'ARRAY') {
       my ($logic, @values) = (
         (defined($vv->[0]) and $vv->[0] =~ /^-(and|or)$/i)
@@ -865,10 +851,8 @@ sub _render_expr {
   my ($self, $expr) = @_;
   my ($k, $v, @rest) = %$expr;
   die "No" if @rest;
-  my %op = map +("-$_" => '_where_op_'.uc($_)),
-    qw(op func value bind ident literal);
-  if (my $meth = $op{$k}) {
-    return $self->$meth(undef, $v);
+  if (my $meth = $self->{node_types}{$k}) {
+    return $self->$meth($v);
   }
   die "notreached: $k";
 }
@@ -900,31 +884,22 @@ sub _recurse_where {
   }
 }
 
-sub _where_op_IDENT {
-  my $self = shift;
-  my ($op, $rhs) = splice @_, -2;
-  if (! defined $rhs or length ref $rhs) {
-    puke "-$op requires a single plain scalar argument (a quotable identifier)";
-  }
+sub _render_ident {
+  my ($self, $ident) = @_;
 
-  # in case we are called as a top level special op (no '=')
-  my $has_lhs = my $lhs = shift;
-
-  $_ = $self->_convert($self->_quote($_)) for ($lhs, $rhs);
-
-  return $has_lhs
-    ? "$lhs = $rhs"
-    : $rhs
-  ;
+  return $self->_convert($self->_quote($ident));
 }
 
-sub _where_op_VALUE {
-  my ($self, undef, $value) = @_;
+sub _render_value {
+  my ($self, $value) = @_;
 
   return ($self->_convert('?'), $self->_bindtype(undef, $value));
 }
 
-my %unop_postfix = map +($_ => 1), 'is null', 'is not null';
+my %unop_postfix = map +($_ => 1),
+  'is null', 'is not null',
+  'asc', 'desc',
+;
 
 my %special = (
   (map +($_ => do {
@@ -972,20 +947,22 @@ my %special = (
   }), 'in', 'not in'),
 );
 
-sub _where_op_OP {
-  my ($self, undef, $v) = @_;
+sub _render_op {
+  my ($self, $v) = @_;
   my ($op, @args) = @$v;
   $op =~ s/^-// if length($op) > 1;
   $op = lc($op);
-  local $self->{_nested_func_lhs};
   if (my $h = $special{$op}) {
     return $self->$h(\@args);
   }
-  if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{user_special_ops}}) {
+  if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{special_ops}}) {
     puke "Special op '${op}' requires first value to be identifier"
       unless my ($k) = map $_->{-ident}, grep ref($_) eq 'HASH', $args[0];
     return $self->${\($us->{handler})}($k, $op, $args[1]);
   }
+  if (my $us = List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
+    return $self->${\($us->{handler})}($op, $args[0]);
+  }
   my $final_op = $op =~ /^(?:is|not)_/ ? join(' ', split '_', $op) : $op;
   if (@args == 1 and $op !~ /^(and|or)$/) {
     my ($expr_sql, @bind) = $self->_render_expr($args[0]);
@@ -999,7 +976,7 @@ sub _where_op_OP {
   } else {
      my @parts = map [ $self->_render_expr($_) ], @args;
      my ($final_sql) = map +($op =~ /^(and|or)$/ ? "(${_})" : $_), join(
-       ' '.$self->_sqlcase($final_op).' ',
+       ($final_op eq ',' ? '' : ' ').$self->_sqlcase($final_op).' ',
        map $_->[0], @parts
      );
      return (
@@ -1010,8 +987,8 @@ sub _where_op_OP {
   die "unhandled";
 }
 
-sub _where_op_FUNC {
-  my ($self, undef, $rest) = @_;
+sub _render_func {
+  my ($self, $rest) = @_;
   my ($func, @args) = @$rest;
   my @arg_sql;
   my @bind = map {
@@ -1022,13 +999,13 @@ sub _where_op_FUNC {
   return ($self->_sqlcase($func).'('.join(', ', @arg_sql).')', @bind);
 }
 
-sub _where_op_BIND {
-  my ($self, undef, $bind) = @_;
+sub _render_bind {
+  my ($self,  $bind) = @_;
   return ($self->_convert('?'), $self->_bindtype(@$bind));
 }
 
-sub _where_op_LITERAL {
-  my ($self, undef, $literal) = @_;
+sub _render_literal {
+  my ($self, $literal) = @_;
   $self->_assert_bindval_matches_bindtype(@{$literal}[1..$#$literal]);
   return @$literal;
 }
@@ -1068,85 +1045,63 @@ sub _open_outer_paren {
 # ORDER BY
 #======================================================================
 
-sub _order_by {
+sub _expand_order_by {
   my ($self, $arg) = @_;
 
-  my (@sql, @bind);
-  for my $c ($self->_order_by_chunks($arg) ) {
-    $self->_SWITCH_refkind($c, {
-      SCALAR => sub { push @sql, $c },
-      ARRAYREF => sub { push @sql, shift @$c; push @bind, @$c },
-    });
-  }
+  return unless defined($arg) and not (ref($arg) eq 'ARRAY' and !@$arg);
 
-  my $sql = @sql
-    ? sprintf('%s %s',
-        $self->_sqlcase(' order by'),
-        join(', ', @sql)
-      )
-    : ''
-  ;
+  my $expander = sub {
+    my ($self, $dir, $expr) = @_;
+    my @to_expand = ref($expr) eq 'ARRAY' ? @$expr : $expr;
+    foreach my $arg (@to_expand) {
+      if (
+        ref($arg) eq 'HASH'
+        and keys %$arg > 1
+        and grep /^-(asc|desc)$/, keys %$arg
+      ) {
+        puke "ordering direction hash passed to order by must have exactly one key (-asc or -desc)";
+      }
+    }
+    my @exp = map +(defined($dir) ? { -op => [ $dir => $_ ] } : $_),
+                map $self->_expand_expr($_, undef, -ident), @to_expand;
+    return (@exp > 1 ? { -op => [ ',', @exp ] } : $exp[0]);
+  };
+
+  local @{$self->{expand_unary}}{qw(-asc -desc)} = (
+    sub { shift->$expander(asc => @_) },
+    sub { shift->$expander(desc => @_) },
+  );
 
-  return wantarray ? ($sql, @bind) : $sql;
+  return $self->$expander(undef, $arg);
 }
 
-sub _order_by_chunks {
+sub _order_by {
   my ($self, $arg) = @_;
 
-  return $self->_SWITCH_refkind($arg, {
-
-    ARRAYREF => sub {
-      map { $self->_order_by_chunks($_ ) } @$arg;
-    },
-
-    ARRAYREFREF => sub {
-      my ($s, @b) = @$$arg;
-      $self->_assert_bindval_matches_bindtype(@b);
-      [ $s, @b ];
-    },
-
-    SCALAR    => sub {$self->_quote($arg)},
-
-    UNDEF     => sub {return () },
-
-    SCALARREF => sub {$$arg}, # literal SQL, no quoting
+  return '' unless defined(my $expanded = $self->_expand_order_by($arg));
 
-    HASHREF   => sub {
-      # get first pair in hash
-      my ($key, $val, @rest) = %$arg;
+  my ($sql, @bind) = $self->_render_expr($expanded);
 
-      return () unless $key;
+  my $final_sql = $self->_sqlcase(' order by ').$sql;
 
-      if (@rest or not $key =~ /^-(desc|asc)/i) {
-        puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
-      }
-
-      my $direction = $1;
-
-      my @ret;
-      for my $c ($self->_order_by_chunks($val)) {
-        my ($sql, @bind);
+  return wantarray ? ($final_sql, @bind) : $final_sql;
+}
 
-        $self->_SWITCH_refkind($c, {
-          SCALAR => sub {
-            $sql = $c;
-          },
-          ARRAYREF => sub {
-            ($sql, @bind) = @$c;
-          },
-        });
+sub _order_by_chunks {
+  my ($self, $arg) = @_;
 
-        $sql = $sql . ' ' . $self->_sqlcase($direction);
+  return () unless defined(my $expanded = $self->_expand_order_by($arg));
 
-        push @ret, [ $sql, @bind];
+  for ($expanded) {
+    if (ref() eq 'HASH' and my $op = $_->{-op}) {
+      if ($op->[0] eq ',') {
+        return map [ $self->_render_expr($_) ], @{$op}[1..$#$op];
       }
-
-      return @ret;
-    },
-  });
+    }
+    return [ $self->_render_expr($_) ];
+  }
 }
 
-
 #======================================================================
 # DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
 #======================================================================
@@ -1154,11 +1109,9 @@ sub _order_by_chunks {
 sub _table  {
   my $self = shift;
   my $from = shift;
-  $self->_SWITCH_refkind($from, {
-    ARRAYREF     => sub {join ', ', map { $self->_quote($_) } @$from;},
-    SCALAR       => sub {$self->_quote($from)},
-    SCALARREF    => sub {$$from},
-  });
+  ($self->_render_expr(
+    $self->_expand_maybe_list_expr($from, undef, -ident)
+  ))[0];
 }
 
 
@@ -1166,15 +1119,37 @@ sub _table  {
 # UTILITY FUNCTIONS
 #======================================================================
 
+sub _expand_maybe_list_expr {
+  my ($self, $expr, $logic, $default) = @_;
+  my $e = do {
+    if (ref($expr) eq 'ARRAY') {
+      return { -op => [
+        ',', map $self->_expand_expr($_, $logic, $default), @$expr
+      ] } if @$expr > 1;
+      $expr->[0]
+    } else {
+      $expr
+    }
+  };
+  return $self->_expand_expr($e, $logic, $default);
+}
+
 # highly optimized, as it's called way too often
 sub _quote {
   # my ($self, $label) = @_;
 
   return '' unless defined $_[1];
   return ${$_[1]} if ref($_[1]) eq 'SCALAR';
+  puke 'Identifier cannot be hashref' if ref($_[1]) eq 'HASH';
 
-  $_[0]->{quote_char} or
-    ($_[0]->_assert_pass_injection_guard($_[1]), return $_[1]);
+  unless ($_[0]->{quote_char}) {
+    if (ref($_[1]) eq 'ARRAY') {
+      return join($_[0]->{name_sep}||'.', @{$_[1]});
+    } else {
+      $_[0]->_assert_pass_injection_guard($_[1]);
+      return $_[1];
+    }
+  }
 
   my $qref = ref $_[0]->{quote_char};
   my ($l, $r) =
@@ -1185,9 +1160,21 @@ sub _quote {
   my $esc = $_[0]->{escape_char} || $r;
 
   # parts containing * are naturally unquoted
-  return join($_[0]->{name_sep}||'', map
-    +( $_ eq '*' ? $_ : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r } ),
-    ( $_[0]->{name_sep} ? split (/\Q$_[0]->{name_sep}\E/, $_[1] ) : $_[1] )
+  return join(
+    $_[0]->{name_sep}||'',
+    map +(
+      $_ eq '*'
+        ? $_
+        : do { (my $n = $_) =~ s/(\Q$esc\E|\Q$r\E)/$esc$1/g; $l . $n . $r }
+    ),
+    (ref($_[1]) eq 'ARRAY'
+      ? @{$_[1]}
+      : (
+          $_[0]->{name_sep}
+            ? split (/\Q$_[0]->{name_sep}\E/, $_[1] )
+            : $_[1]
+        )
+    )
   );
 }
 
@@ -1195,8 +1182,8 @@ sub _quote {
 # Conversion, if applicable
 sub _convert {
   #my ($self, $arg) = @_;
-  if ($_[0]->{convert}) {
-    return $_[0]->_sqlcase($_[0]->{convert}) .'(' . $_[1] . ')';
+  if ($_[0]->{convert_where}) {
+    return $_[0]->_sqlcase($_[0]->{convert_where}) .'(' . $_[1] . ')';
   }
   return $_[1];
 }