1 package SQL::Abstract::Test; # see doc at end of file
5 use base qw/Test::Builder::Module Exporter/;
9 our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind
10 $case_sensitive $sql_differ/;
12 our $case_sensitive = 0;
13 our $sql_differ; # keeps track of differing portion between SQLs
14 our $tb = __PACKAGE__->builder;
16 sub is_same_sql_bind {
17 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
20 my $tree1 = parse($sql1);
21 my $tree2 = parse($sql2);
22 my $same_sql = eq_sql($tree1, $tree2);
23 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
25 # call Test::Builder::ok
26 $tb->ok($same_sql && $same_bind, $msg);
30 $tb->diag("SQL expressions differ\n"
33 ."differing in :\n$sql_differ\n"
37 $tb->diag("BIND values differ\n"
38 ." got: " . Dumper($bind_ref1)
39 ."expected: " . Dumper($bind_ref2)
46 my ($bind_ref1, $bind_ref2) = @_;
47 return stringify_bind($bind_ref1) eq stringify_bind($bind_ref2);
51 my $bind_ref = shift || [];
53 # some bind values can be arrayrefs (see L<SQL::Abstract/bindtype>),
55 # furthermore, if L<SQL::Abstract/array_datatypes> is set to true, elements
56 # of those arrayrefs can be arrayrefs, too.
61 ? ('[' . join('=>', @$_) . ']')
62 : (defined $_ ? $_ : '')
64 : (defined $_ ? $_ : '')
67 # join all values into a single string
68 return join "///", @strings;
72 my ($left, $right) = @_;
74 # ignore top-level parentheses
75 while ($left->[0] eq 'PAREN') {$left = $left->[1] }
76 while ($right->[0] eq 'PAREN') {$right = $right->[1]}
78 # if operators are different
79 if ($left->[0] ne $right->[0]) {
80 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
85 # elsif operators are identical, compare operands
87 if ($left->[0] eq 'EXPR' ) { # unary operator
88 (my $l = " $left->[1] " ) =~ s/\s+/ /g;
89 (my $r = " $right->[1] ") =~ s/\s+/ /g;
90 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
91 $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
94 else { # binary operator
95 return eq_sql($left->[1][0], $right->[1][0]) # left operand
96 && eq_sql($left->[1][1], $right->[1][1]); # right operand
106 my $tokens = [grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s];
108 my $tree = _recurse_parse($tokens);
116 while (1) { # left-associative parsing
118 my $lookahead = $tokens->[0];
119 return $left if !defined($lookahead) || $lookahead eq ')';
121 my $token = shift @$tokens;
123 # nested expression in ()
125 my $right = _recurse_parse($tokens);
126 $token = shift @$tokens or croak "missing ')'";
127 $token eq ')' or croak "unexpected token : $token";
128 $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
132 elsif ($token eq 'AND' || $token eq 'OR') {
133 my $right = _recurse_parse($tokens);
134 $left = [$token => [$left, $right]];
138 $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
149 EXPR => sub {$tree->[1] },
150 PAREN => sub {"(" . unparse($tree->[1]) . ")" },
151 CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}},
152 AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
153 OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}},
155 $dispatch->{$tree->[0]}->();
166 SQL::Abstract::Test - Helper function for testing SQL::Abstract
172 use SQL::Abstract::Test import => ['is_same_sql_bind'];
174 my ($sql, @bind) = SQL::Abstract->new->select(%args);
175 is_same_sql_bind($given_sql, \@given_bind,
176 $expected_sql, \@expected_bind, $test_msg);
180 This module is only intended for authors of tests on
181 L<SQL::Abstract|SQL::Abstract> and related modules;
182 it exports functions for comparing two SQL statements
183 and their bound values.
185 The SQL comparison is performed on I<abstract syntax>,
186 ignoring differences in spaces or in levels of parentheses.
187 Therefore the tests will pass as long as the semantics
188 is preserved, even if the surface syntax has changed.
190 B<Disclaimer> : this is only a half-cooked semantic equivalence;
191 parsing is simple-minded, and comparison of SQL abstract syntax trees
192 ignores commutativity or associativity of AND/OR operators, Morgan
197 =head2 is_same_sql_bind
199 is_same_sql_bind($given_sql, \@given_bind,
200 $expected_sql, \@expected_bind, $test_msg);
202 Compares given and expected pairs of C<($sql, \@bind)>, and calls
203 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the
204 test fails, a detailed diagnostic is printed. For clients which use
205 L<Test::Build>, this is the only function that needs to be
210 my $is_same = eq_sql($given_sql, $expected_sql);
212 Compares the abstract syntax of two SQL statements. If the result is
213 false, global variable L</sql_differ> will contain the SQL portion
214 where a difference was encountered; this is useful for printing diagnostics.
218 my $is_same = eq_sql(\@given_bind, \@expected_bind);
220 Compares two lists of bind values, taking into account
221 the fact that some of the values may be
222 arrayrefs (see L<SQL::Abstract/bindtype>).
224 =head1 GLOBAL VARIABLES
226 =head2 case_sensitive
228 If true, SQL comparisons will be case-sensitive. Default is false;
232 When L</eq_sql> returns false, the global variable
233 C<$sql_differ> contains the SQL portion
234 where a difference was encountered.
239 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
243 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
245 =head1 COPYRIGHT AND LICENSE
247 Copyright 2008 by Laurent Dami.
249 This library is free software; you can redistribute it and/or modify
250 it under the same terms as Perl itself.