[Bast-commits] r4890 - SQL-Abstract/2.000/trunk/t
dami at dev.catalyst.perl.org
dami at dev.catalyst.perl.org
Mon Oct 6 11:18:46 BST 2008
Author: dami
Date: 2008-10-06 11:18:45 +0100 (Mon, 06 Oct 2008)
New Revision: 4890
Added:
SQL-Abstract/2.000/trunk/t/07subqueries.t
SQL-Abstract/2.000/trunk/t/08special_ops.t
SQL-Abstract/2.000/trunk/t/TestSqlAbstract.pm
Log:
missing test files
Added: SQL-Abstract/2.000/trunk/t/07subqueries.t
===================================================================
--- SQL-Abstract/2.000/trunk/t/07subqueries.t (rev 0)
+++ SQL-Abstract/2.000/trunk/t/07subqueries.t 2008-10-06 10:18:45 UTC (rev 4890)
@@ -0,0 +1,95 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+use FindBin;
+use lib "$FindBin::Bin";
+use TestSqlAbstract;
+
+plan tests => 5;
+
+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_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind});
+}
+
+
+
+
+
Added: SQL-Abstract/2.000/trunk/t/08special_ops.t
===================================================================
--- SQL-Abstract/2.000/trunk/t/08special_ops.t (rev 0)
+++ SQL-Abstract/2.000/trunk/t/08special_ops.t 2008-10-06 10:18:45 UTC (rev 4890)
@@ -0,0 +1,71 @@
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use Test::More;
+
+use FindBin;
+use lib "$FindBin::Bin";
+use TestSqlAbstract;
+
+plan tests => 2;
+
+use SQL::Abstract;
+
+my $sqlmaker = SQL::Abstract->new(special_ops => [
+
+ # special op for MySql MATCH (field) AGAINST(word1, word2, ...)
+ {regex => qr/^match$/i,
+ handler => sub {
+ my ($self, $field, $op, $arg) = @_;
+ $arg = [$arg] if not ref $arg;
+ my $label = $self->_quote($field);
+ my ($placeholder) = $self->_convert('?');
+ my $placeholders = join ", ", (($placeholder) x @$arg);
+ my $sql = $self->_sqlcase('match') . " ($label) "
+ . $self->_sqlcase('against') . " ($placeholders) ";
+ my @bind = $self->_bindtype($field, @$arg);
+ return ($sql, @bind);
+ }
+ },
+
+ # special op for Basis+ NATIVE
+ {regex => qr/^native$/i,
+ handler => sub {
+ my ($self, $field, $op, $arg) = @_;
+ $arg =~ s/'/''/g;
+ my $sql = "NATIVE (' $field $arg ')";
+ return ($sql);
+ }
+ },
+
+]);
+
+my @tests = (
+
+ #1
+ { where => {foo => {-match => 'foo'},
+ bar => {-match => [qw/foo bar/]}},
+ stmt => " WHERE ( MATCH (bar) AGAINST (?, ?) AND MATCH (foo) AGAINST (?) )",
+ bind => [qw/foo bar foo/],
+ },
+
+ #2
+ { where => {foo => {-native => "PH IS 'bar'"}},
+ stmt => " WHERE ( NATIVE (' foo PH IS ''bar'' ') )",
+ bind => [],
+ },
+
+);
+
+
+for (@tests) {
+
+ my($stmt, @bind) = $sqlmaker->where($_->{where}, $_->{order});
+ is_same_sql_bind($stmt, \@bind, $_->{stmt}, $_->{bind});
+}
+
+
+
+
+
Added: SQL-Abstract/2.000/trunk/t/TestSqlAbstract.pm
===================================================================
--- SQL-Abstract/2.000/trunk/t/TestSqlAbstract.pm (rev 0)
+++ SQL-Abstract/2.000/trunk/t/TestSqlAbstract.pm 2008-10-06 10:18:45 UTC (rev 4890)
@@ -0,0 +1,137 @@
+package TestSqlAbstract;
+
+# compares two SQL expressions on their abstract syntax,
+# ignoring differences in levels of parentheses.
+
+use strict;
+use warnings;
+use Test::More;
+use base 'Exporter';
+use Data::Dumper;
+
+our @EXPORT = qw/is_same_sql_bind/;
+
+
+my $last_differ;
+
+sub is_same_sql_bind {
+ my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
+
+ my $tree1 = parse($sql1);
+ my $tree2 = parse($sql2);
+ my $same_sql = eq_tree($tree1, $tree2);
+ my $same_bind = stringify_bind($bind_ref1) eq stringify_bind($bind_ref2);
+ ok($same_sql && $same_bind, $msg);
+ if (!$same_sql) {
+ diag "SQL expressions differ\n"
+ ." got: $sql1\n"
+ ."expected: $sql2\n"
+ ."differing in :\n$last_differ\n";
+ ;
+ }
+ if (!$same_bind) {
+ diag "BIND values differ\n"
+ ." got: " . Dumper($bind_ref1)
+ ."expected: " . Dumper($bind_ref2)
+ ;
+ }
+}
+
+sub stringify_bind {
+ my $bind_ref = shift || [];
+ return join "///", map {ref $_ ? join('=>', @$_) : ($_ || '')}
+ @$bind_ref;
+}
+
+
+
+sub eq_tree {
+ my ($left, $right) = @_;
+
+ # ignore top-level parentheses
+ while ($left->[0] eq 'PAREN') {$left = $left->[1] }
+ while ($right->[0] eq 'PAREN') {$right = $right->[1]}
+
+ if ($left->[0] ne $right->[0]) { # if operators are different
+ $last_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
+ unparse($left),
+ unparse($right);
+ return 0;
+ }
+ else { # else compare operands
+ if ($left->[0] eq 'EXPR' ) {
+ if ($left->[1] ne $right->[1]) {
+ $last_differ = "[$left->[1]] != [$right->[1]]\n";
+ return 0;
+ }
+ else {
+ return 1;
+ }
+ }
+ else {
+ my $eq_left = eq_tree($left->[1][0], $right->[1][0]);
+ my $eq_right = eq_tree($left->[1][1], $right->[1][1]);
+ return $eq_left && $eq_right;
+ }
+ }
+}
+
+
+my @tokens;
+
+sub parse {
+ my $s = shift;
+
+ # tokenize string
+ @tokens = grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s;
+
+ my $tree = _recurse_parse();
+ return $tree;
+}
+
+sub _recurse_parse {
+
+ my $left;
+ while (1) {
+
+ my $lookahead = $tokens[0];
+ return $left if !defined($lookahead) || $lookahead eq ')';
+
+ my $token = shift @tokens;
+
+ if ($token eq '(') {
+ my $right = _recurse_parse();
+ $token = shift @tokens
+ or die "missing ')'";
+ $token eq ')'
+ or die "unexpected token : $token";
+ $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
+ : [PAREN => $right];
+ }
+ elsif ($token eq 'AND' || $token eq 'OR') {
+ my $right = _recurse_parse();
+ $left = [$token => [$left, $right]];
+ }
+ else {
+ $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
+ : [EXPR => $token];
+ }
+ }
+}
+
+
+
+sub unparse {
+ my $tree = shift;
+ my $dispatch = {
+ EXPR => sub {$tree->[1] },
+ PAREN => sub {"(" . unparse($tree->[1]) . ")" },
+ CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}},
+ AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
+ OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}},
+ };
+ $dispatch->{$tree->[0]}->();
+}
+
+
+1;
More information about the Bast-commits
mailing list