1 package SQL::Abstract::Test; # see doc at end of file
5 use base qw/Test::Builder::Module Exporter/;
9 use Test::Deep qw(eq_deeply);
11 our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind
12 $case_sensitive $sql_differ/;
14 our $case_sensitive = 0;
15 our $sql_differ; # keeps track of differing portion between SQLs
16 our $tb = __PACKAGE__->builder;
18 # Parser states for _recurse_parse()
25 # These SQL keywords always signal end of the current expression (except inside
26 # of a parenthesized subexpression).
27 # Format: A list of strings that will be compiled to extended syntax (ie.
28 # /.../x) regexes, without capturing parentheses. They will be automatically
29 # anchored to word boundaries to match the whole token).
30 my @expression_terminator_sql_keywords = (
34 (?: \b (?: LEFT | RIGHT | FULL ) \s+ )?
35 (?: \b (?: CROSS | INNER | OUTER ) \s+ )?
52 my $tokenizer_re_str = join('|',
53 map { '\b' . $_ . '\b' }
54 @expression_terminator_sql_keywords, 'AND', 'OR'
57 my $tokenizer_re = qr/
70 sub is_same_sql_bind {
71 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
74 my $same_sql = eq_sql($sql1, $sql2);
75 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
77 # call Test::Builder::ok
78 $tb->ok($same_sql && $same_bind, $msg);
82 $tb->diag("SQL expressions differ\n"
85 ."differing in :\n$sql_differ\n"
89 $tb->diag("BIND values differ\n"
90 ." got: " . Dumper($bind_ref1)
91 ."expected: " . Dumper($bind_ref2)
97 my ($bind_ref1, $bind_ref2) = @_;
99 return eq_deeply($bind_ref1, $bind_ref2);
103 my ($sql1, $sql2) = @_;
106 my $tree1 = parse($sql1);
107 my $tree2 = parse($sql2);
109 return _eq_sql($tree1, $tree2);
113 my ($left, $right) = @_;
115 # ignore top-level parentheses
116 while ($left->[0] eq 'PAREN') {$left = $left->[1] }
117 while ($right->[0] eq 'PAREN') {$right = $right->[1]}
119 # if operators are different
120 if ($left->[0] ne $right->[0]) {
121 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
126 # elsif operators are identical, compare operands
128 if ($left->[0] eq 'EXPR' ) { # unary operator
129 (my $l = " $left->[1] " ) =~ s/\s+/ /g;
130 (my $r = " $right->[1] ") =~ s/\s+/ /g;
131 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
132 $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
135 else { # binary operator
136 return _eq_sql($left->[1][0], $right->[1][0]) # left operand
137 && _eq_sql($left->[1][1], $right->[1][1]); # right operand
146 # tokenize string, and remove all optional whitespace
148 foreach my $token (split $tokenizer_re, $s) {
150 $token =~ s/\s+([^\w\s])/$1/g;
151 $token =~ s/([^\w\s])\s+/$1/g;
152 push @$tokens, $token if $token !~ /^$/;
155 my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
160 my ($tokens, $state) = @_;
163 while (1) { # left-associative parsing
165 my $lookahead = $tokens->[0];
166 return $left if !defined($lookahead)
167 || ($state == PARSE_IN_PARENS && $lookahead eq ')')
168 || ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^$_$/xi }
169 '\)', @expression_terminator_sql_keywords
172 my $token = shift @$tokens;
174 # nested expression in ()
176 my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
177 $token = shift @$tokens or croak "missing ')'";
178 $token eq ')' or croak "unexpected token : $token";
179 $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
183 elsif ($token eq 'AND' || $token eq 'OR') {
184 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
185 $left = [$token => [$left, $right]];
187 # expression terminator keywords (as they start a new expression)
188 elsif (grep { $token =~ /^$_$/xi } @expression_terminator_sql_keywords) {
189 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
190 $left = $left ? [CONCAT => [$left, [CONCAT => [[EXPR => $token], [PAREN => $right]]]]]
191 : [CONCAT => [[EXPR => $token], [PAREN => $right]]];
195 $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
206 EXPR => sub {$tree->[1] },
207 PAREN => sub {"(" . unparse($tree->[1]) . ")" },
208 CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}},
209 AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
210 OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}},
212 $dispatch->{$tree->[0]}->();
223 SQL::Abstract::Test - Helper function for testing SQL::Abstract
229 use SQL::Abstract::Test import => ['is_same_sql_bind'];
231 my ($sql, @bind) = SQL::Abstract->new->select(%args);
232 is_same_sql_bind($given_sql, \@given_bind,
233 $expected_sql, \@expected_bind, $test_msg);
237 This module is only intended for authors of tests on
238 L<SQL::Abstract|SQL::Abstract> and related modules;
239 it exports functions for comparing two SQL statements
240 and their bound values.
242 The SQL comparison is performed on I<abstract syntax>,
243 ignoring differences in spaces or in levels of parentheses.
244 Therefore the tests will pass as long as the semantics
245 is preserved, even if the surface syntax has changed.
247 B<Disclaimer> : this is only a half-cooked semantic equivalence;
248 parsing is simple-minded, and comparison of SQL abstract syntax trees
249 ignores commutativity or associativity of AND/OR operators, Morgan
254 =head2 is_same_sql_bind
256 is_same_sql_bind($given_sql, \@given_bind,
257 $expected_sql, \@expected_bind, $test_msg);
259 Compares given and expected pairs of C<($sql, \@bind)>, and calls
260 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the
261 test fails, a detailed diagnostic is printed. For clients which use
262 L<Test::Build>, this is the only function that needs to be
267 my $is_same = eq_sql($given_sql, $expected_sql);
269 Compares the abstract syntax of two SQL statements. If the result is
270 false, global variable L</sql_differ> will contain the SQL portion
271 where a difference was encountered; this is useful for printing diagnostics.
275 my $is_same = eq_sql(\@given_bind, \@expected_bind);
277 Compares two lists of bind values, taking into account
278 the fact that some of the values may be
279 arrayrefs (see L<SQL::Abstract/bindtype>).
281 =head1 GLOBAL VARIABLES
283 =head2 case_sensitive
285 If true, SQL comparisons will be case-sensitive. Default is false;
289 When L</eq_sql> returns false, the global variable
290 C<$sql_differ> contains the SQL portion
291 where a difference was encountered.
296 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
300 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
302 Norbert Buchmuller <norbi@nix.hu>
304 =head1 COPYRIGHT AND LICENSE
306 Copyright 2008 by Laurent Dami.
308 This library is free software; you can redistribute it and/or modify
309 it under the same terms as Perl itself.