X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=scpubgit%2FQ-Branch.git;a=blobdiff_plain;f=lib%2FSQL%2FAbstract.pm;h=63893940518cc7f9791097f7d31948257299026f;hp=95867df028bf9e070f2a67199a7fd413107e3b63;hb=92d72227a50c23a8fb1a6dce4b43c74c47428476;hpb=5c5cb82f4776a8fd2f0c43230fd5a85d74b9aebc

diff --git a/lib/SQL/Abstract.pm b/lib/SQL/Abstract.pm
index 95867df..6389394 100644
--- a/lib/SQL/Abstract.pm
+++ b/lib/SQL/Abstract.pm
@@ -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')),
@@ -326,6 +327,15 @@ sub make_binop_expander {
   }
 }
 
+sub plugin {
+  my ($self, $plugin, @args) = @_;
+  unless (ref $plugin) {
+    $plugin =~ s/\A\+/${\ref($self)}::Plugin::/;
+    require(join('/', split '::', $plugin).'.pm');
+  }
+  $plugin->apply_to($self, @args);
+}
+
 BEGIN {
   foreach my $type (qw(
     expand op_expand render op_render clause_expand clause_render
@@ -376,7 +386,7 @@ BEGIN {
   }
 }
 
-sub register_op { $_[0]->{is_op}{$_[1]} = 1; $_[0] }
+#sub register_op { $_[0]->{is_op}{$_[1]} = 1; $_[0] }
 
 sub statement_list { sort keys %{$_[0]->{clauses_of}} }
 
@@ -439,12 +449,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 +472,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,7 +533,7 @@ 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);
 }
@@ -593,7 +603,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 +622,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 +640,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 +677,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 {
@@ -726,7 +736,7 @@ sub _select_fields {
   my ($self, $fields) = @_;
   return $fields unless ref($fields);
   return @{ $self->render_aqt(
-    $self->expand_maybe_list_expr($fields, '-ident')
+    $self->expand_expr({ -list => $fields }, '-ident')
   ) };
 }
 
@@ -754,13 +764,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 {
@@ -884,7 +894,7 @@ sub _render_statement {
 sub _normalize_op {
   my ($self, $raw) = @_;
   my $op = lc $raw;
-  return $op if grep $_->{$op}, @{$self}{qw(is_op expand_op render_op)};
+  return $op if grep $_->{$op}, @{$self}{qw(expand_op render_op)};
   s/^-(?=.)//, s/\s+/_/g for $op;
   $op;
 }
@@ -1243,6 +1253,18 @@ 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_op_andor {
   my ($self, $logop, $v, $k) = @_;
   if (defined $k) {
@@ -1641,7 +1663,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 {
@@ -1720,7 +1742,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 +1751,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,9 +3458,57 @@ When supplied with a coderef, it is called as:
 
 =back
 
+=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);
+
+=head2 render_statement
+
+Use this if you may be rendering a top level statement so e.g. a SELECT
+query doesn't get wrapped in parens
+
+  my ($sql, @bind) = $sqla->render_statement($expr);
+
+=head2 expand_expr
+
+Expression expansion with optional default for scalars.
+
+  my $aqt = $self->expand_expr($expr);
+  my $aqt = $self->expand_expr($expr, -ident);
+
+=head2 render_aqt
+
+Top level means avoid parens on statement AQT.
+
+  my $res = $self->render_aqt($aqt, $top_level);
+  my ($sql, @bind) = @$res;
+
+=head2 join_query_parts
+
+Similar to join() but will render hashrefs as nodes for both join and parts,
+and treats arrayref as a nested C<[ $join, @parts ]> structure.
+
+  my $part = $self->join_query_parts($join, @parts);
+
 =head1 NEW EXTENSION SYSTEM
 
-See L<SQL::Abstract::Reference> for concepts.
+=head2 clone
+
+  my $sqla2 = $sqla->clone;
+
+Performs a semi-shallow copy such that extension methods won't leak state
+but excessive depth is avoided.
 
 =head2 expander
 
@@ -3548,6 +3606,39 @@ See L<SQL::Abstract::Reference> for concepts.
 
   my @list = $sqla->statement_list;
 
+=head2 make_unop_expander
+
+  my $exp = $sqla->make_unop_expander(sub { ... });
+
+If the op is found as a binop, assumes it wants a default comparison, so
+the inner expander sub can reliably operate as
+
+  sub { my ($self, $name, $body) = @_; ... }
+
+=head2 make_binop_expander
+
+  my $exp = $sqla->make_binop_expander(sub { ... });
+
+If the op is found as a unop, assumes the value will be an arrayref with the
+LHS as the first entry, and converts that to an ident node if it's a simple
+scalar. So the inner expander sub looks like
+
+  sub {
+    my ($self, $name, $body, $k) = @_;
+    { -blah => [ map $self->expand_expr($_), $k, $body ] }
+  }
+
+=head2 unop_expander
+
+=head2 unop_expanders
+
+=head2 binop_expander
+
+=head2 binop_expanders
+
+The above methods operate exactly like the op_ versions but wrap the coderef
+using the appropriate make_ method first.
+
 =head1 PERFORMANCE
 
 Thanks to some benchmarking by Mark Stosberg, it turns out that