1 package SQL::Abstract::Test; # see doc at end of file
\r
10 our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind
\r
11 $case_sensitive $sql_differ/;
\r
13 our $case_sensitive = 0;
\r
14 our $sql_differ; # keeps track of differing portion between SQLs
\r
16 sub is_same_sql_bind {
\r
17 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
\r
20 my $tree1 = parse($sql1);
\r
21 my $tree2 = parse($sql2);
\r
22 my $same_sql = eq_sql($tree1, $tree2);
\r
23 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
\r
25 # call Test::More::ok
\r
26 ok($same_sql && $same_bind, $msg);
\r
28 # add debugging info
\r
30 diag "SQL expressions differ\n"
\r
32 ."expected: $sql2\n"
\r
33 ."differing in :\n$sql_differ\n";
\r
37 diag "BIND values differ\n"
\r
38 ." got: " . Dumper($bind_ref1)
\r
39 ."expected: " . Dumper($bind_ref2)
\r
46 my ($bind_ref1, $bind_ref2) = @_;
\r
47 return stringify_bind($bind_ref1) eq stringify_bind($bind_ref2);
\r
50 sub stringify_bind {
\r
51 my $bind_ref = shift || [];
\r
53 # some bind values can be arrayrefs (see L<SQL::Abstract/bindtype>),
\r
54 # so stringify them.
\r
55 my @strings = map {ref $_ ? join('=>', @$_) : ($_ || '')} @$bind_ref;
\r
57 # join all values into a single string
\r
58 return join "///", @strings;
\r
62 my ($left, $right) = @_;
\r
64 # ignore top-level parentheses
\r
65 while ($left->[0] eq 'PAREN') {$left = $left->[1] }
\r
66 while ($right->[0] eq 'PAREN') {$right = $right->[1]}
\r
68 # if operators are different
\r
69 if ($left->[0] ne $right->[0]) {
\r
70 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
\r
75 # elsif operators are identical, compare operands
\r
77 if ($left->[0] eq 'EXPR' ) { # unary operator
\r
78 (my $l = " $left->[1] " ) =~ s/\s+/ /g;
\r
79 (my $r = " $right->[1] ") =~ s/\s+/ /g;
\r
80 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
\r
81 $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
\r
84 else { # binary operator
\r
85 return eq_sql($left->[1][0], $right->[1][0]) # left operand
\r
86 && eq_sql($left->[1][1], $right->[1][1]); # right operand
\r
96 my $tokens = [grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s];
\r
98 my $tree = _recurse_parse($tokens);
\r
102 sub _recurse_parse {
\r
103 my $tokens = shift;
\r
106 while (1) { # left-associative parsing
\r
108 my $lookahead = $tokens->[0];
\r
109 return $left if !defined($lookahead) || $lookahead eq ')';
\r
111 my $token = shift @$tokens;
\r
113 # nested expression in ()
\r
114 if ($token eq '(') {
\r
115 my $right = _recurse_parse($tokens);
\r
116 $token = shift @$tokens or croak "missing ')'";
\r
117 $token eq ')' or croak "unexpected token : $token";
\r
118 $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
\r
119 : [PAREN => $right];
\r
122 elsif ($token eq 'AND' || $token eq 'OR') {
\r
123 my $right = _recurse_parse($tokens);
\r
124 $left = [$token => [$left, $right]];
\r
128 $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
\r
129 : [EXPR => $token];
\r
139 EXPR => sub {$tree->[1] },
\r
140 PAREN => sub {"(" . unparse($tree->[1]) . ")" },
\r
141 CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}},
\r
142 AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
\r
143 OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}},
\r
145 $dispatch->{$tree->[0]}->();
\r
156 SQL::Abstract::Test - Helper function for testing SQL::Abstract
\r
162 use SQL::Abstract::Test qw/is_same_sql_bind/;
\r
164 my ($sql, @bind) = SQL::Abstract->new->select(%args);
\r
165 is_same_sql_bind($given_sql, \@given_bind,
\r
166 $expected_sql, \@expected_bind, $test_msg);
\r
170 This module is only intended for authors of tests on
\r
171 L<SQL::Abstract|SQL::Abstract> and related modules;
\r
172 it exports functions for comparing two SQL statements
\r
173 and their bound values.
\r
175 The SQL comparison is performed on I<abstract syntax>,
\r
176 ignoring differences in spaces or in levels of parentheses.
\r
177 Therefore the tests will pass as long as the semantics
\r
178 is preserved, even if the surface syntax has changed.
\r
180 B<Disclaimer> : this is only a half-cooked semantic equivalence;
\r
181 parsing is simple-minded, and comparison of SQL abstract syntax trees
\r
182 ignores commutativity or associativity of AND/OR operators, Morgan
\r
187 =head2 is_same_sql_bind
\r
189 is_same_sql_bind($given_sql, \@given_bind,
\r
190 $expected_sql, \@expected_bind, $test_msg);
\r
192 Compares given and expected pairs of C<($sql, \@bind)>, and calls
\r
193 L<Test::More/ok> on the result, with C<$test_msg> as message. If the
\r
194 test fails, a detailed diagnostic is printed. For clients which use
\r
195 L<Test::More|Test::More>, this is the only function that needs to be
\r
200 my $is_same = eq_sql($given_sql, $expected_sql);
\r
202 Compares the abstract syntax of two SQL statements. If the result is
\r
203 false, global variable L</sql_differ> will contain the SQL portion
\r
204 where a difference was encountered; this is useful for printing diagnostics.
\r
208 my $is_same = eq_sql(\@given_bind, \@expected_bind);
\r
210 Compares two lists of bind values, taking into account
\r
211 the fact that some of the values may be
\r
212 arrayrefs (see L<SQL::Abstract/bindtype>).
\r
214 =head1 GLOBAL VARIABLES
\r
216 =head2 case_sensitive
\r
218 If true, SQL comparisons will be case-sensitive. Default is false;
\r
222 When L</eq_sql> returns false, the global variable
\r
223 C<$sql_differ> contains the SQL portion
\r
224 where a difference was encountered.
\r
229 L<SQL::Abstract>, L<Test::More>.
\r
233 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
\r
235 =head1 COPYRIGHT AND LICENSE
\r
237 Copyright 2008 by Laurent Dami.
\r
239 This library is free software; you can redistribute it and/or modify
\r
240 it under the same terms as Perl itself.
\r