1 package SQL::Abstract::Test; # see doc at end of file
10 our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind
11 $case_sensitive $sql_differ/;
13 our $case_sensitive = 0;
14 our $sql_differ; # keeps track of differing portion between SQLs
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);
26 ok($same_sql && $same_bind, $msg);
30 diag "SQL expressions differ\n"
33 ."differing in :\n$sql_differ\n";
37 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 my @strings = map {ref $_ eq 'ARRAY' ? join('=>', @$_) : ($_ || '')}
58 # join all values into a single string
59 return join "///", @strings;
63 my ($left, $right) = @_;
65 # ignore top-level parentheses
66 while ($left->[0] eq 'PAREN') {$left = $left->[1] }
67 while ($right->[0] eq 'PAREN') {$right = $right->[1]}
69 # if operators are different
70 if ($left->[0] ne $right->[0]) {
71 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
76 # elsif operators are identical, compare operands
78 if ($left->[0] eq 'EXPR' ) { # unary operator
79 (my $l = " $left->[1] " ) =~ s/\s+/ /g;
80 (my $r = " $right->[1] ") =~ s/\s+/ /g;
81 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
82 $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
85 else { # binary operator
86 return eq_sql($left->[1][0], $right->[1][0]) # left operand
87 && eq_sql($left->[1][1], $right->[1][1]); # right operand
97 my $tokens = [grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s];
99 my $tree = _recurse_parse($tokens);
107 while (1) { # left-associative parsing
109 my $lookahead = $tokens->[0];
110 return $left if !defined($lookahead) || $lookahead eq ')';
112 my $token = shift @$tokens;
114 # nested expression in ()
116 my $right = _recurse_parse($tokens);
117 $token = shift @$tokens or croak "missing ')'";
118 $token eq ')' or croak "unexpected token : $token";
119 $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
123 elsif ($token eq 'AND' || $token eq 'OR') {
124 my $right = _recurse_parse($tokens);
125 $left = [$token => [$left, $right]];
129 $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
140 EXPR => sub {$tree->[1] },
141 PAREN => sub {"(" . unparse($tree->[1]) . ")" },
142 CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}},
143 AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
144 OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}},
146 $dispatch->{$tree->[0]}->();
157 SQL::Abstract::Test - Helper function for testing SQL::Abstract
163 use SQL::Abstract::Test qw/is_same_sql_bind/;
165 my ($sql, @bind) = SQL::Abstract->new->select(%args);
166 is_same_sql_bind($given_sql, \@given_bind,
167 $expected_sql, \@expected_bind, $test_msg);
171 This module is only intended for authors of tests on
172 L<SQL::Abstract|SQL::Abstract> and related modules;
173 it exports functions for comparing two SQL statements
174 and their bound values.
176 The SQL comparison is performed on I<abstract syntax>,
177 ignoring differences in spaces or in levels of parentheses.
178 Therefore the tests will pass as long as the semantics
179 is preserved, even if the surface syntax has changed.
181 B<Disclaimer> : this is only a half-cooked semantic equivalence;
182 parsing is simple-minded, and comparison of SQL abstract syntax trees
183 ignores commutativity or associativity of AND/OR operators, Morgan
188 =head2 is_same_sql_bind
190 is_same_sql_bind($given_sql, \@given_bind,
191 $expected_sql, \@expected_bind, $test_msg);
193 Compares given and expected pairs of C<($sql, \@bind)>, and calls
194 L<Test::More/ok> on the result, with C<$test_msg> as message. If the
195 test fails, a detailed diagnostic is printed. For clients which use
196 L<Test::More|Test::More>, this is the only function that needs to be
201 my $is_same = eq_sql($given_sql, $expected_sql);
203 Compares the abstract syntax of two SQL statements. If the result is
204 false, global variable L</sql_differ> will contain the SQL portion
205 where a difference was encountered; this is useful for printing diagnostics.
209 my $is_same = eq_sql(\@given_bind, \@expected_bind);
211 Compares two lists of bind values, taking into account
212 the fact that some of the values may be
213 arrayrefs (see L<SQL::Abstract/bindtype>).
215 =head1 GLOBAL VARIABLES
217 =head2 case_sensitive
219 If true, SQL comparisons will be case-sensitive. Default is false;
223 When L</eq_sql> returns false, the global variable
224 C<$sql_differ> contains the SQL portion
225 where a difference was encountered.
230 L<SQL::Abstract>, L<Test::More>.
234 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
236 =head1 COPYRIGHT AND LICENSE
238 Copyright 2008 by Laurent Dami.
240 This library is free software; you can redistribute it and/or modify
241 it under the same terms as Perl itself.