1 package SQL::Abstract::Test; # see doc at end of file
5 use base qw/Test::Builder::Module Exporter/;
6 use Scalar::Util qw(looks_like_number blessed reftype);
10 use Test::Deep qw(eq_deeply);
12 our @EXPORT_OK = qw/&is_same_sql_bind &eq_sql &eq_bind
13 $case_sensitive $sql_differ/;
15 our $case_sensitive = 0;
16 our $sql_differ; # keeps track of differing portion between SQLs
17 our $tb = __PACKAGE__->builder;
19 # Parser states for _recurse_parse()
26 # These SQL keywords always signal end of the current expression (except inside
27 # of a parenthesized subexpression).
28 # Format: A list of strings that will be compiled to extended syntax (ie.
29 # /.../x) regexes, without capturing parentheses. They will be automatically
30 # anchored to word boundaries to match the whole token).
31 my @expression_terminator_sql_keywords = (
35 (?: \b (?: LEFT | RIGHT | FULL ) \s+ )?
36 (?: \b (?: CROSS | INNER | OUTER ) \s+ )?
53 my $tokenizer_re_str = join('|',
54 map { '\b' . $_ . '\b' }
55 @expression_terminator_sql_keywords, 'AND', 'OR'
58 my $tokenizer_re = qr/
71 sub is_same_sql_bind {
72 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
75 my $same_sql = eq_sql($sql1, $sql2);
76 my $same_bind = eq_bind($bind_ref1, $bind_ref2);
78 # call Test::Builder::ok
79 $tb->ok($same_sql && $same_bind, $msg);
83 $tb->diag("SQL expressions differ\n"
86 ."differing in :\n$sql_differ\n"
90 $tb->diag("BIND values differ\n"
91 ." got: " . Dumper($bind_ref1)
92 ."expected: " . Dumper($bind_ref2)
98 my ($bind_ref1, $bind_ref2) = @_;
100 return eq_deeply($bind_ref1, $bind_ref2);
104 my ($sql1, $sql2) = @_;
107 my $tree1 = parse($sql1);
108 my $tree2 = parse($sql2);
110 return _eq_sql($tree1, $tree2);
114 my ($left, $right) = @_;
116 # ignore top-level parentheses
117 while ($left->[0] eq 'PAREN') {$left = $left->[1] }
118 while ($right->[0] eq 'PAREN') {$right = $right->[1]}
120 # if operators are different
121 if ($left->[0] ne $right->[0]) {
122 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
127 # elsif operators are identical, compare operands
129 if ($left->[0] eq 'EXPR' ) { # unary operator
130 (my $l = " $left->[1] " ) =~ s/\s+/ /g;
131 (my $r = " $right->[1] ") =~ s/\s+/ /g;
132 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
133 $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
136 else { # binary operator
137 return _eq_sql($left->[1][0], $right->[1][0]) # left operand
138 && _eq_sql($left->[1][1], $right->[1][1]); # right operand
147 # tokenize string, and remove all optional whitespace
149 foreach my $token (split $tokenizer_re, $s) {
151 $token =~ s/\s+([^\w\s])/$1/g;
152 $token =~ s/([^\w\s])\s+/$1/g;
153 push @$tokens, $token if $token !~ /^$/;
156 my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
161 my ($tokens, $state) = @_;
164 while (1) { # left-associative parsing
166 my $lookahead = $tokens->[0];
167 return $left if !defined($lookahead)
168 || ($state == PARSE_IN_PARENS && $lookahead eq ')')
169 || ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^$_$/xi }
170 '\)', @expression_terminator_sql_keywords
173 my $token = shift @$tokens;
175 # nested expression in ()
177 my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
178 $token = shift @$tokens or croak "missing ')'";
179 $token eq ')' or croak "unexpected token : $token";
180 $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
184 elsif ($token eq 'AND' || $token eq 'OR') {
185 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
186 $left = [$token => [$left, $right]];
188 # expression terminator keywords (as they start a new expression)
189 elsif (grep { $token =~ /^$_$/xi } @expression_terminator_sql_keywords) {
190 my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
191 $left = $left ? [CONCAT => [$left, [CONCAT => [[EXPR => $token], [PAREN => $right]]]]]
192 : [CONCAT => [[EXPR => $token], [PAREN => $right]]];
196 $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
207 EXPR => sub {$tree->[1] },
208 PAREN => sub {"(" . unparse($tree->[1]) . ")" },
209 CONCAT => sub {join " ", map {unparse($_)} @{$tree->[1]}},
210 AND => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
211 OR => sub {join " OR ", map {unparse($_)} @{$tree->[1]}},
213 $dispatch->{$tree->[0]}->();
224 SQL::Abstract::Test - Helper function for testing SQL::Abstract
230 use SQL::Abstract::Test import => ['is_same_sql_bind'];
232 my ($sql, @bind) = SQL::Abstract->new->select(%args);
233 is_same_sql_bind($given_sql, \@given_bind,
234 $expected_sql, \@expected_bind, $test_msg);
238 This module is only intended for authors of tests on
239 L<SQL::Abstract|SQL::Abstract> and related modules;
240 it exports functions for comparing two SQL statements
241 and their bound values.
243 The SQL comparison is performed on I<abstract syntax>,
244 ignoring differences in spaces or in levels of parentheses.
245 Therefore the tests will pass as long as the semantics
246 is preserved, even if the surface syntax has changed.
248 B<Disclaimer> : this is only a half-cooked semantic equivalence;
249 parsing is simple-minded, and comparison of SQL abstract syntax trees
250 ignores commutativity or associativity of AND/OR operators, Morgan
255 =head2 is_same_sql_bind
257 is_same_sql_bind($given_sql, \@given_bind,
258 $expected_sql, \@expected_bind, $test_msg);
260 Compares given and expected pairs of C<($sql, \@bind)>, and calls
261 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the
262 test fails, a detailed diagnostic is printed. For clients which use
263 L<Test::Build>, this is the only function that needs to be
268 my $is_same = eq_sql($given_sql, $expected_sql);
270 Compares the abstract syntax of two SQL statements. If the result is
271 false, global variable L</sql_differ> will contain the SQL portion
272 where a difference was encountered; this is useful for printing diagnostics.
276 my $is_same = eq_sql(\@given_bind, \@expected_bind);
278 Compares two lists of bind values, taking into account
279 the fact that some of the values may be
280 arrayrefs (see L<SQL::Abstract/bindtype>).
282 =head1 GLOBAL VARIABLES
284 =head2 case_sensitive
286 If true, SQL comparisons will be case-sensitive. Default is false;
290 When L</eq_sql> returns false, the global variable
291 C<$sql_differ> contains the SQL portion
292 where a difference was encountered.
297 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
301 Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt>
303 Norbert Buchmuller <norbi@nix.hu>
305 =head1 COPYRIGHT AND LICENSE
307 Copyright 2008 by Laurent Dami.
309 This library is free software; you can redistribute it and/or modify
310 it under the same terms as Perl itself.