X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=d4ece748fcb13b384438cd30e6f526f203033d0e;hb=21acf7723e77f244cfac020898e411dc0ab37a52;hp=ad843f60c18c4f74d6a9b407baaecb630d0802b0;hpb=b096cd688f919062454887ef4fce47bcc776ecac;p=dbsrgits%2FSQL-Abstract.git

diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm
index ad843f6..d4ece74 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)
@@ -584,6 +553,8 @@ sub _expand_expr {
   die "notreached";
 }
 
+my $Nest_Warned = 0;
+
 sub _expand_expr_hashpair {
   my ($self, $k, $v, $logic) = @_;
   unless (defined($k) and length($k)) {
@@ -600,6 +571,17 @@ sub _expand_expr_hashpair {
           . "You probably wanted ...-and => [ $k => COND1, $k => COND2 ... ]";
     }
     if ($k eq '-nest') {
+      # DBIx::Class requires a nest warning to be emitted once but the private
+      # method it overrode to do so no longer exists
+      if (ref($self) =~ /^DBIx::Class::SQLMaker/) {
+        unless ($Nest_Warned) {
+          belch(
+            "-nest in search conditions is deprecated, you most probably wanted:\n"
+            .q|{..., -and => [ \%cond0, \@cond1, \'cond2', \[ 'cond3', [ col => bind ] ], etc. ], ... }|
+          );
+          $Nest_Warned = 1;
+        }
+      }
       return $self->_expand_expr($v);
     }
     if ($k eq '-bool') {
@@ -633,16 +615,19 @@ sub _expand_expr_hashpair {
       # top level special ops are illegal in general
       puke "Illegal use of top-level '-$op'"
         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') {
-      return { $k => $v };
-    }
-    if (my $custom = $self->{custom_expansions}{($k =~ /^-(.*)$/)[0]}) {
+    if (my $custom = $self->{expand_unary}{$k}) {
       return $self->$custom($v);
     }
+    if ($self->{node_types}{$k}) {
+      return { $k => $v };
+    }
     if (
       ref($v) eq 'HASH'
       and keys %$v == 1
@@ -666,11 +651,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 ] })
       ]
     };
   }
@@ -737,8 +723,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},
@@ -774,9 +760,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)
@@ -871,9 +864,7 @@ sub _render_expr {
   my ($self, $expr) = @_;
   my ($k, $v, @rest) = %$expr;
   die "No" if @rest;
-  my %op = map +("-$_" => '_render_'.$_),
-    qw(op func value bind ident literal);
-  if (my $meth = $op{$k}) {
+  if (my $meth = $self->{node_types}{$k}) {
     return $self->$meth($v);
   }
   die "notreached: $k";
@@ -884,7 +875,11 @@ sub _recurse_where {
 
 #print STDERR Data::Dumper::Concise::Dumper([ $where, $logic ]);
 
-  my $where_exp = $self->_expand_expr($where, $logic);
+  # Special case: top level simple string treated as literal
+
+  my $where_exp = (ref($where)
+                    ? $self->_expand_expr($where, $logic)
+                    : { -literal => [ $where ] });
 
 #print STDERR Data::Dumper::Concise::Dumper([ EXP => $where_exp ]);
 
@@ -977,11 +972,14 @@ sub _render_op {
   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]);
@@ -994,8 +992,8 @@ sub _render_op {
     return (($op eq 'not' ? '('.$final_sql.')' : $final_sql), @bind);
   } else {
      my @parts = map [ $self->_render_expr($_) ], @args;
-     my ($final_sql) = map +($op =~ /^(and|or)$/ ? "(${_})" : $_), join(
-       ' '.$self->_sqlcase($final_op).' ',
+     my ($final_sql) = map +($op =~ /^(and|or)$/ ? "( ${_} )" : $_), join(
+       ($final_op eq ',' ? '' : ' ').$self->_sqlcase($final_op).' ',
        map $_->[0], @parts
      );
      return (
@@ -1064,25 +1062,41 @@ sub _open_outer_paren {
 # ORDER BY
 #======================================================================
 
-sub _order_by {
+sub _expand_order_by {
   my ($self, $arg) = @_;
 
-  return '' unless defined($arg) and not (ref($arg) eq 'ARRAY' and !@$arg);
+  return unless defined($arg) and not (ref($arg) eq 'ARRAY' and !@$arg);
 
   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),
-                  ref($expr) eq 'ARRAY' ? @$expr : $expr;
+                map ref($_) eq 'ARRAY' ? @$_ : $_, @to_expand;
     return (@exp > 1 ? { -op => [ ',', @exp ] } : $exp[0]);
   };
 
-  local $self->{custom_expansions} = {
-    asc => sub { shift->$expander(asc => @_) },
-    desc => sub { shift->$expander(desc => @_) },
-  };
+  local @{$self->{expand_unary}}{qw(-asc -desc)} = (
+    sub { shift->$expander(asc => @_) },
+    sub { shift->$expander(desc => @_) },
+  );
+
+  return $self->$expander(undef, $arg);
+}
+
+sub _order_by {
+  my ($self, $arg) = @_;
 
-  my $expanded = $self->$expander(undef, $arg);
+  return '' unless defined(my $expanded = $self->_expand_order_by($arg));
 
   my ($sql, @bind) = $self->_render_expr($expanded);
 
@@ -1091,34 +1105,28 @@ sub _order_by {
   return wantarray ? ($final_sql, @bind) : $final_sql;
 }
 
+# _order_by no longer needs to call this so doesn't but DBIC uses it.
+
 sub _order_by_chunks {
   my ($self, $arg) = @_;
 
-  if (ref($arg) eq 'ARRAY') {
-    return map $self->_order_by_chunks($_), @$arg;
-  }
-  if (my $l = is_literal_value($arg)) {
-    return +{ -literal => $l };
-  }
-  if (!ref($arg)) {
-    return +{ -ident => $arg };
-  }
-  if (ref($arg) eq 'HASH') {
-    my ($key, $val, @rest) = %$arg;
+  return () unless defined(my $expanded = $self->_expand_order_by($arg));
 
-    return () unless $key;
+  return $self->_chunkify_order_by($expanded);
+}
 
-    if (@rest or not $key =~ /^-(desc|asc)/i) {
-      puke "hash passed to _order_by must have exactly one key (-desc or -asc)";
+sub _chunkify_order_by {
+  my ($self, $expanded) = @_;
+  for ($expanded) {
+    if (ref() eq 'HASH' and my $op = $_->{-op}) {
+      if ($op->[0] eq ',') {
+        return map $self->_chunkify_order_by($_), @{$op}[1..$#$op];
+      }
     }
-
-    my $dir = $1;
-
-    map +{ -op => [ $dir, $_ ] }, $self->_order_by_chunks($val);
-  };
+    return [ $self->_render_expr($_) ];
+  }
 }
 
-
 #======================================================================
 # DATASOURCE (FOR NOW, JUST PLAIN TABLE OR LIST OF TABLES)
 #======================================================================
@@ -1126,11 +1134,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];
 }
 
 
@@ -1138,15 +1144,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) =
@@ -1157,9 +1185,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]
+        )
+    )
   );
 }
 
@@ -1167,8 +1207,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];
 }