On Fri, 31 Oct 2008 20:30:54 +0100 BUCHMULLER Norbert <[EMAIL PROTECTED]> wrote:
> The attached patch adds subquery support to the 1.x trunk. (Includes the > corresponding tests taken & adapted from 2.000 trunk.) Oops, I forgot the documentation. Here goes the patch again. norbi
Index: t/07subqueries.t =================================================================== --- t/07subqueries.t (revision 0) +++ t/07subqueries.t (revision 0) @@ -0,0 +1,90 @@ +#!/usr/bin/perl + +use strict; +use warnings; +use Test::More; + +use FindBin; +use lib "$FindBin::Bin"; + +plan tests => 10; + +use SQL::Abstract; + +my $sql = SQL::Abstract->new; + +my (@tests, $sub_stmt, @sub_bind, $where); + +#1 +($sub_stmt, @sub_bind) = ("SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?", + 100, "foo%"); +$where = { + foo => 1234, + bar => \["IN ($sub_stmt)" => @sub_bind], + }; +push @tests, { + where => $where, + stmt => " WHERE ( bar IN (SELECT c1 FROM t1 WHERE c2 < ? AND c3 LIKE ?) AND foo = ? )", + bind => [100, "foo%", 1234], +}; + +#2 +($sub_stmt, @sub_bind) + = $sql->select("t1", "c1", {c2 => {"<" => 100}, + c3 => {-like => "foo%"}}); +$where = { + foo => 1234, + bar => \["> ALL ($sub_stmt)" => @sub_bind], + }; +push @tests, { + where => $where, + stmt => " WHERE ( bar > ALL (SELECT c1 FROM t1 WHERE ( c2 < ? AND c3 LIKE ? )) AND foo = ? )", + bind => [100, "foo%", 1234], +}; + +#3 +($sub_stmt, @sub_bind) + = $sql->select("t1", "*", {c1 => 1, c2 => \"> t0.c0"}); +$where = { + foo => 1234, + -nest => \["EXISTS ($sub_stmt)" => @sub_bind], + }; +push @tests, { + where => $where, + stmt => " WHERE ( EXISTS (SELECT * FROM t1 WHERE ( c1 = ? AND c2 > t0.c0 )) AND foo = ? )", + bind => [1, 1234], +}; + +#4 +$where = { + -nest => \["MATCH (col1, col2) AGAINST (?)" => "apples"], + }; +push @tests, { + where => $where, + stmt => " WHERE ( MATCH (col1, col2) AGAINST (?) )", + bind => ["apples"], +}; + + +#5 +($sub_stmt, @sub_bind) + = $sql->where({age => [{"<" => 10}, {">" => 20}]}); +$sub_stmt =~ s/^ where //i; # don't want "WHERE" in the subclause +$where = { + lname => {-like => '%son%'}, + -nest => \["NOT ( $sub_stmt )" => @sub_bind], + }; +push @tests, { + where => $where, + stmt => " WHERE ( NOT ( ( ( ( age < ? ) OR ( age > ? ) ) ) ) AND lname LIKE ? )", + bind => [10, 20, '%son%'], +}; + + + +for (@tests) { + + my($stmt, @bind) = $sql->where($_->{where}, $_->{order}); + is($stmt, $_->{stmt}); + is_deeply([EMAIL PROTECTED], $_->{bind}); +} Index: lib/SQL/Abstract.pm =================================================================== --- lib/SQL/Abstract.pm (revision 5033) +++ lib/SQL/Abstract.pm (working copy) @@ -732,7 +732,13 @@ my $v = $where->{$k}; my $label = $self->_quote($k); - if ($k =~ /^-(\D+)/) { + if (ref $v eq 'REF' && ref $$v eq 'ARRAY') { + # literal SQL with bind values + my ($stmt, @bind) = @$$v; + $self->_debug("ARRAYREF($k) means literal SQL with bind values: [ $stmt @bind ]"); + push @sqlf, ($k ne "-nest") ? "$label $stmt" : $stmt; + push @sqlv, @bind; + } elsif ($k =~ /^-(\D+)/) { # special nesting, like -and, -or, -nest, so shift over my $subjoin = $self->_modlogic($1); $self->_debug("OP(-$1) means special logic ($subjoin), recursing..."); @@ -1273,6 +1279,19 @@ TMTOWTDI. +You can also pass a literal SQL chunk together with bind values as a reference +to an arrayref: + + my %where = ( + priority => { '<', 2 }, + requestor => \["toupper(?)", 'mendel'] + ); + +This would create: + + $stmt = "WHERE priority < ? AND requestor = toupper(?)"; + @bind = ('2', 'mendel'); + These pages could go on for a while, since the nesting of the data structures this module can handle are pretty much unlimited (the module implements the C<WHERE> expansion as a recursive function
_______________________________________________ List: http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/dbix-class IRC: irc.perl.org#dbix-class SVN: http://dev.catalyst.perl.org/repos/bast/DBIx-Class/ Searchable Archive: http://www.grokbase.com/group/dbix-class@lists.scsys.co.uk