X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=5c7282a31f43cfe55e269d4814aa0fece394b106;hb=e33b58e055c12555fa81a5ad669d5e6a459562f9;hp=c7ca0e5db0a0da555dc172d0c1808c2133fad3c0;hpb=fda0b270e45b2f419edf94e4f7e91d82d31c6f84;p=dbsrgits%2FSQL-Abstract.git

diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm
index c7ca0e5..5c7282a 100644
--- a/lib/SQL/Abstract.pm
+++ b/lib/SQL/Abstract.pm
@@ -28,7 +28,7 @@ BEGIN {
 # GLOBALS
 #======================================================================
 
-our $VERSION  = '1.86';
+our $VERSION  = '1.90_02';
 
 # This would confuse some packagers
 $VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases
@@ -144,6 +144,7 @@ our %Defaults = (
     op => '_expand_op',
     func => '_expand_func',
     values => '_expand_values',
+    list => '_expand_list',
   },
   expand_op => {
     (map +($_ => __PACKAGE__->make_binop_expander('_expand_between')),
@@ -154,6 +155,7 @@ our %Defaults = (
     (map +($_ => '_expand_op_is'), ('is', 'is_not')),
     (map +($_ => __PACKAGE__->make_unop_expander("_expand_${_}")),
       qw(ident value nest)),
+    bind => __PACKAGE__->make_unop_expander(sub { +{ -bind => $_[2] } }),
   },
   render => {
     (map +($_, "_render_$_"),
@@ -278,6 +280,33 @@ sub new {
         [ $_[0]->_order_by($_[2]) ];
       };
     }
+    if (__PACKAGE__->can('_select_fields') ne $class->can('_select_fields')) {
+      $opt{expand_clause}{'select.select'} = sub { $_[2] };
+      $opt{render_clause}{'select.select'} = sub {
+        my @super = $_[0]->_select_fields($_[2]);
+        my $effort = [
+          ref($super[0]) eq 'HASH'
+            ? $_[0]->render_expr($super[0])
+            : @super
+        ];
+        return $_[0]->join_query_parts(
+          ' ', { -keyword => 'select' }, $effort
+        );
+      };
+    }
+    foreach my $type (qw(in between)) {
+      my $meth = "_where_field_".uc($type);
+      if (__PACKAGE__->can($meth) ne $class->can($meth)) {
+        my $exp = sub {
+          my ($self, $op, $v, $k) = @_;
+          $op = join ' ', split '_', $op;
+          return +{ -literal => [
+            $self->$meth($k, $op, $v)
+          ] };
+        };
+        $opt{expand_op}{$_} = $exp for $type, "not_${type}";
+      }
+    }
     if ($class->isa('DBIx::Class::SQLMaker')) {
       $opt{warn_once_on_nest} = 1;
       $opt{disable_old_special_ops} = 1;
@@ -286,6 +315,39 @@ sub new {
         s/\A\s+//, s/\s+\Z// for $sql;
         return [ $sql, @bind ];
       };
+      $opt{expand_op}{ident} = $class->make_unop_expander(sub {
+        my ($self, undef, $body) = @_;
+        $body = $body->from if Scalar::Util::blessed($body);
+        $self->_expand_ident(ident => $body);
+      });
+    }
+    if ($class->isa('SQL::Abstract::More')) {
+      my $orig = $opt{expand_op}{or};
+      $opt{expand_op}{or} = sub {
+        my ($self, $logop, $v, $k) = @_;
+        if ($k and ref($v) eq 'ARRAY') {
+          my ($type, $val) = @$v;
+          my $op;
+          if (
+            ref($type) eq 'HASH' and ref($val) eq 'HASH'
+            and keys %$type == 1 and keys %$val == 1
+            and (keys %$type)[0] eq (keys %$val)[0]
+          ) {
+            ($op) = keys %$type;
+            ($type) = values %$type;
+            ($val) = values %$val;
+          }
+          if ($self->is_bind_value_with_type(my $v = [ $type, $val ])) {
+            return $self->expand_expr(
+              { $k, map +($op ? { $op => $_ } : $_), { -bind => $v } }
+            );
+          }
+        }
+        return $self->$orig($logop, $v, $k);
+      };
+      $opt{render}{bind} = sub {
+        return [ '?', map +(ref($_->[0]) ? $_ : $_->[1]), $_[2] ]
+      };
     }
   }
 
@@ -326,6 +388,16 @@ sub make_binop_expander {
   }
 }
 
+sub plugin {
+  my ($self, $plugin, @args) = @_;
+  unless (ref $plugin) {
+    $plugin =~ s/\A\+/${\__PACKAGE__}::Plugin::/;
+    require(join('/', split '::', $plugin).'.pm');
+  }
+  $plugin->apply_to($self, @args);
+  return $self;
+}
+
 BEGIN {
   foreach my $type (qw(
     expand op_expand render op_render clause_expand clause_render
@@ -333,8 +405,11 @@ BEGIN {
     my $name = join '_', reverse split '_', $type;
     my $singular = "${type}er";
 
-    eval qq{sub ${singular} { shift->${singular}s(\@_) }; 1 }
-      or die "Method builder failed for ${singular}: $@";
+    eval qq{sub ${singular} {
+      my \$self = shift;
+      return \$self->_ext_rw('${name}', \@_) if \@_ == 1;
+      return \$self->${singular}s(\@_)
+    }; 1 } or die "Method builder failed for ${singular}: $@";
     eval qq{sub wrap_${singular} {
       shift->wrap_${singular}s(\@_)
     }; 1 } or die "Method builder failed for wrap_${singular}: $@";
@@ -439,12 +514,12 @@ sub insert {
 }
 
 sub _expand_insert_clause_target {
-  +(target => $_[0]->expand_maybe_list_expr($_[2], -ident));
+  +(target => $_[0]->expand_expr($_[2], -ident));
 }
 
 sub _expand_insert_clause_fields {
   return +{ -row => [
-    $_[0]->expand_maybe_list_expr($_[2], -ident)
+    $_[0]->expand_expr({ -list => $_[2] }, -ident)
   ] } if ref($_[2]) eq 'ARRAY';
   return $_[2]; # should maybe still expand somewhat?
 }
@@ -462,7 +537,7 @@ sub _expand_insert_clause_from {
 }
 
 sub _expand_insert_clause_returning {
-  +(returning => $_[0]->expand_maybe_list_expr($_[2], -ident));
+  +(returning => $_[0]->expand_expr({ -list => $_[2] }, -ident));
 }
 
 sub _expand_insert_values {
@@ -523,9 +598,10 @@ sub _returning {
   my $f = $options->{returning};
 
   my ($sql, @bind) = @{ $self->render_aqt(
-    $self->expand_maybe_list_expr($f, -ident)
+    $self->expand_expr({ -list => $f }, -ident)
   ) };
-  return ($self->_sqlcase(' returning ').$sql, @bind);
+  my $rsql = $self->_sqlcase(' returning ').$sql;
+  return wantarray ? ($rsql, @bind) : $rsql;
 }
 
 sub _expand_insert_value {
@@ -593,7 +669,7 @@ sub _update_set_values {
 
 sub _expand_update_set_values {
   my ($self, undef, $data) = @_;
-  $self->expand_maybe_list_expr( [
+  $self->expand_expr({ -list => [
     map {
       my ($k, $set) = @$_;
       $set = { -bind => $_ } unless defined $set;
@@ -612,12 +688,12 @@ sub _expand_update_set_values {
           }
       );
     } sort keys %$data
-  ] );
+  ] });
 }
 
 sub _expand_update_clause_target {
   my ($self, undef, $target) = @_;
-  +(target => $self->expand_maybe_list_expr($target, -ident));
+  +(target => $self->expand_expr({ -list => $target }, -ident));
 }
 
 sub _expand_update_clause_set {
@@ -630,7 +706,7 @@ sub _expand_update_clause_where {
 }
 
 sub _expand_update_clause_returning {
-  +(returning => $_[0]->expand_maybe_list_expr($_[2], -ident));
+  +(returning => $_[0]->expand_expr({ -list => $_[2] }, -ident));
 }
 
 # So that subclasses can override UPDATE ... RETURNING separately from
@@ -667,12 +743,12 @@ sub select {
 
 sub _expand_select_clause_select {
   my ($self, undef, $select) = @_;
-  +(select => $self->expand_maybe_list_expr($select, -ident));
+  +(select => $self->expand_expr({ -list => $select }, -ident));
 }
 
 sub _expand_select_clause_from {
   my ($self, undef, $from) = @_;
-  +(from => $self->expand_maybe_list_expr($from, -ident));
+  +(from => $self->expand_expr({ -list => $from }, -ident));
 }
 
 sub _expand_select_clause_where {
@@ -725,9 +801,10 @@ sub _expand_select_clause_order_by {
 sub _select_fields {
   my ($self, $fields) = @_;
   return $fields unless ref($fields);
-  return @{ $self->render_aqt(
-    $self->expand_maybe_list_expr($fields, '-ident')
+  my ($sql, @bind) = @{ $self->render_aqt(
+    $self->expand_expr({ -list => $fields }, '-ident')
   ) };
+  return wantarray ? ($sql, @bind) : $sql;
 }
 
 #======================================================================
@@ -754,13 +831,13 @@ sub delete {
 sub _delete_returning { shift->_returning(@_) }
 
 sub _expand_delete_clause_target {
-  +(target => $_[0]->expand_maybe_list_expr($_[2], -ident));
+  +(target => $_[0]->expand_expr({ -list => $_[2] }, -ident));
 }
 
 sub _expand_delete_clause_where { +(where => $_[0]->expand_expr($_[2])); }
 
 sub _expand_delete_clause_returning {
-  +(returning => $_[0]->expand_maybe_list_expr($_[2], -ident));
+  +(returning => $_[0]->expand_expr({ -list => $_[2] }, -ident));
 }
 
 sub _render_delete_clause_target {
@@ -896,7 +973,7 @@ sub _expand_expr {
   if (ref($expr) eq 'HASH') {
     return undef unless my $kc = keys %$expr;
     if ($kc > 1) {
-      return $self->_expand_op_andor(and => $expr);
+      return $self->_expand_logop(and => $expr);
     }
     my ($key, $value) = %$expr;
     if ($key =~ /^-/ and $key =~ s/ [_\s]? \d+ $//x ) {
@@ -906,7 +983,7 @@ sub _expand_expr {
     return $self->_expand_hashpair($key, $value);
   }
   if (ref($expr) eq 'ARRAY') {
-    return $self->_expand_op_andor(lc($self->{logic}), $expr);
+    return $self->_expand_logop(lc($self->{logic}), $expr);
   }
   if (my $literal = is_literal_value($expr)) {
     return +{ -literal => $literal };
@@ -928,7 +1005,7 @@ sub _expand_hashpair {
   }
   if ($k =~ /^-./) {
     return $self->_expand_hashpair_op($k, $v);
-  } elsif ($k =~ /^[^\w]/i) {
+  } elsif ($k =~ /^\W+$/) {
     my ($lhs, @rhs) = ref($v) eq 'ARRAY' ? @$v : $v;
     return $self->_expand_op(
       -op, [ $k, $self->expand_expr($lhs, -ident), @rhs ]
@@ -945,7 +1022,7 @@ sub _expand_hashpair_ident {
   # hash with multiple or no elements is andor
 
   if (ref($v) eq 'HASH' and keys %$v != 1) {
-    return $self->_expand_op_andor(and => $v, $k);
+    return $self->_expand_logop(and => $v, $k);
   }
 
   # undef needs to be re-sent with cmp to achieve IS/IS NOT NULL
@@ -976,7 +1053,7 @@ sub _expand_hashpair_ident {
         ? (shift(@{$v = [ @$v ]}), $1)
         : lc($self->{logic} || 'OR')
     );
-    return $self->_expand_op_andor(
+    return $self->_expand_logop(
       $logic => $v, $k
     );
   }
@@ -1153,7 +1230,7 @@ sub _expand_hashtriple {
         "operator '%s' applied on an empty array (field '$k')"
       ) ? $self->sqlfalse : $self->sqltrue);
     }
-    return $self->_expand_op_andor($logic => \@values, $k);
+    return $self->_expand_logop($logic => \@values, $k);
   }
   if (is_undef_value($vv)) {
     my $is = ($self->_dwim_op_to_is($op,
@@ -1231,6 +1308,9 @@ sub _expand_op {
   if (my $exp = $self->{expand_op}{$op}) {
     return $self->$exp($op, \@opargs);
   }
+  if (List::Util::first { $op =~ $_->{regex} } @{$self->{unary_ops}}) {
+    return { -op => [ $op, @opargs ] };
+  }
   +{ -op => [ $op, map $self->expand_expr($_), @opargs ] };
 }
 
@@ -1243,6 +1323,23 @@ sub _expand_bool {
   return $self->_expand_expr({ -ident => $v });
 }
 
+sub _expand_list {
+  my ($self, undef, $expr) = @_;
+  return { -op => [
+    ',', map $self->expand_expr($_),
+          @{$expr->{-op}}[1..$#{$expr->{-op}}]
+  ] } if ref($expr) eq 'HASH' and ($expr->{-op}||[''])->[0] eq ',';
+  return +{ -op => [ ',',
+    map $self->expand_expr($_),
+      ref($expr) eq 'ARRAY' ? @$expr : $expr
+  ] };
+}
+
+sub _expand_logop {
+  my ($self, $logop, $v, $k) = @_;
+  $self->${\$self->{expand_op}{$logop}}($logop, $v, $k);
+}
+
 sub _expand_op_andor {
   my ($self, $logop, $v, $k) = @_;
   if (defined $k) {
@@ -1631,6 +1728,25 @@ sub _open_outer_paren {
   $sql;
 }
 
+sub _where_field_IN {
+  my ($self, $k, $op, $vals) = @_;
+  @{$self->_render_op_in(
+    $op,
+    [
+      $self->expand_expr($k, -ident),
+      map $self->expand_expr($_, -value),
+        ref($vals) eq 'ARRAY' ? @$vals : $vals
+    ]
+  )};
+}
+
+sub _where_field_BETWEEN {
+  my ($self, $k, $op, $vals) = @_;
+  @{$self->_render_op_between(
+    $op,
+    [ $self->expand_expr($k, -ident), ref($vals) eq 'ARRAY' ? @$vals : $vals ]
+  )};
+}
 
 #======================================================================
 # ORDER BY
@@ -1641,7 +1757,7 @@ sub _expand_order_by {
 
   return unless defined($arg) and not (ref($arg) eq 'ARRAY' and !@$arg);
 
-  return $self->expand_maybe_list_expr($arg)
+  return $self->expand_expr({ -list => $arg })
     if ref($arg) eq 'HASH' and ($arg->{-op}||[''])->[0] eq ',';
 
   my $expander = sub {
@@ -1682,6 +1798,8 @@ sub _order_by {
 
   my $final_sql = $self->_sqlcase(' order by ').$sql;
 
+  return $final_sql unless wantarray;
+
   return ($final_sql, @bind);
 }
 
@@ -1720,7 +1838,7 @@ sub _table  {
   my $self = shift;
   my $from = shift;
   $self->render_aqt(
-    $self->expand_maybe_list_expr($from, -ident)
+    $self->expand_expr({ -list => $from }, -ident)
   )->[0];
 }
 
@@ -1729,18 +1847,6 @@ sub _table  {
 # UTILITY FUNCTIONS
 #======================================================================
 
-sub expand_maybe_list_expr {
-  my ($self, $expr, $default) = @_;
-  return { -op => [
-    ',', map $self->expand_expr($_, $default), 
-          @{$expr->{-op}}[1..$#{$expr->{-op}}]
-  ] } if ref($expr) eq 'HASH' and ($expr->{-op}||[''])->[0] eq ',';
-  return +{ -op => [ ',',
-    map $self->expand_expr($_, $default),
-      ref($expr) eq 'ARRAY' ? @$expr : $expr
-  ] };
-}
-
 # highly optimized, as it's called way too often
 sub _quote {
   # my ($self, $label) = @_;
@@ -3448,11 +3554,17 @@ When supplied with a coderef, it is called as:
 
 =back
 
-=head1 NEW METHODS
+=head1 NEW METHODS (EXPERIMENTAL)
 
 See L<SQL::Abstract::Reference> for the C<expr> versus C<aqt> concept and
 an explanation of what the below extensions are extending.
 
+=head2 plugin
+
+  $sqla->plugin('+Foo');
+
+Enables plugin SQL::Abstract::Plugin::Foo.
+
 =head2 render_expr
 
   my ($sql, @bind) = $sqla->render_expr($expr);
@@ -3471,12 +3583,6 @@ Expression expansion with optional default for scalars.
   my $aqt = $self->expand_expr($expr);
   my $aqt = $self->expand_expr($expr, -ident);
 
-=head2 expand_maybe_list_expr
-
-expand_expr but with commas if there's more than one entry.
-
-  my $aqt = $self->expand_maybe_list_expr([ @exprs ], $default?);
-
 =head2 render_aqt
 
 Top level means avoid parens on statement AQT.