1package SQL::Abstract::Test; # see doc at end of file 2 3use strict; 4use warnings; 5use base qw/Test::Builder::Module Exporter/; 6use Data::Dumper; 7use Carp; 8use Test::Builder; 9use Test::Deep qw(eq_deeply); 10 11our @EXPORT_OK = qw/&is_same_sql_bind &is_same_sql &is_same_bind 12 &eq_sql_bind &eq_sql &eq_bind 13 $case_sensitive $sql_differ/; 14 15our $case_sensitive = 0; 16our $parenthesis_significant = 0; 17our $sql_differ; # keeps track of differing portion between SQLs 18our $tb = __PACKAGE__->builder; 19 20# Parser states for _recurse_parse() 21use constant PARSE_TOP_LEVEL => 0; 22use constant PARSE_IN_EXPR => 1; 23use constant PARSE_IN_PARENS => 2; 24use constant PARSE_RHS => 3; 25 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). 31my @expression_terminator_sql_keywords = ( 32 'SELECT', 33 'FROM', 34 '(?: 35 (?: 36 (?: \b (?: LEFT | RIGHT | FULL ) \s+ )? 37 (?: \b (?: CROSS | INNER | OUTER ) \s+ )? 38 )? 39 JOIN 40 )', 41 'ON', 42 'WHERE', 43 'EXISTS', 44 'GROUP \s+ BY', 45 'HAVING', 46 'ORDER \s+ BY', 47 'LIMIT', 48 'OFFSET', 49 'FOR', 50 'UNION', 51 'INTERSECT', 52 'EXCEPT', 53 'RETURNING', 54); 55 56# These are binary operator keywords always a single LHS and RHS 57# * AND/OR are handled separately as they are N-ary 58# * so is NOT as being unary 59# * BETWEEN without paranthesis around the ANDed arguments (which 60# makes it a non-binary op) is detected and accomodated in 61# _recurse_parse() 62my $stuff_around_mathops = qr/[\w\s\`\'\"\)]/; 63my @binary_op_keywords = ( 64 ( map 65 { 66 ' ^ ' . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ", 67 " (?<= $stuff_around_mathops)" . quotemeta ($_) . "(?= \$ | $stuff_around_mathops ) ", 68 } 69 (qw/< > != <> = <= >=/) 70 ), 71 ( map 72 { '\b (?: NOT \s+)?' . $_ . '\b' } 73 (qw/IN BETWEEN LIKE/) 74 ), 75); 76 77my $tokenizer_re_str = join("\n\t|\n", 78 ( map { '\b' . $_ . '\b' } @expression_terminator_sql_keywords, 'AND', 'OR', 'NOT'), 79 @binary_op_keywords, 80); 81 82my $tokenizer_re = qr/ \s* ( $tokenizer_re_str | \( | \) | \? ) \s* /xi; 83 84# All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics 85my @unrollable_ops = ( 86 'ON', 87 'WHERE', 88 'GROUP \s+ BY', 89 'HAVING', 90 'ORDER \s+ BY', 91); 92 93sub is_same_sql_bind { 94 my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_; 95 96 # compare 97 my $same_sql = eq_sql($sql1, $sql2); 98 my $same_bind = eq_bind($bind_ref1, $bind_ref2); 99 100 # call Test::Builder::ok 101 my $ret = $tb->ok($same_sql && $same_bind, $msg); 102 103 # add debugging info 104 if (!$same_sql) { 105 _sql_differ_diag($sql1, $sql2); 106 } 107 if (!$same_bind) { 108 _bind_differ_diag($bind_ref1, $bind_ref2); 109 } 110 111 # pass ok() result further 112 return $ret; 113} 114 115sub is_same_sql { 116 my ($sql1, $sql2, $msg) = @_; 117 118 # compare 119 my $same_sql = eq_sql($sql1, $sql2); 120 121 # call Test::Builder::ok 122 my $ret = $tb->ok($same_sql, $msg); 123 124 # add debugging info 125 if (!$same_sql) { 126 _sql_differ_diag($sql1, $sql2); 127 } 128 129 # pass ok() result further 130 return $ret; 131} 132 133sub is_same_bind { 134 my ($bind_ref1, $bind_ref2, $msg) = @_; 135 136 # compare 137 my $same_bind = eq_bind($bind_ref1, $bind_ref2); 138 139 # call Test::Builder::ok 140 my $ret = $tb->ok($same_bind, $msg); 141 142 # add debugging info 143 if (!$same_bind) { 144 _bind_differ_diag($bind_ref1, $bind_ref2); 145 } 146 147 # pass ok() result further 148 return $ret; 149} 150 151sub _sql_differ_diag { 152 my ($sql1, $sql2) = @_; 153 154 $tb->diag("SQL expressions differ\n" 155 ." got: $sql1\n" 156 ."expected: $sql2\n" 157 ."differing in :\n$sql_differ\n" 158 ); 159} 160 161sub _bind_differ_diag { 162 my ($bind_ref1, $bind_ref2) = @_; 163 164 $tb->diag("BIND values differ\n" 165 ." got: " . Dumper($bind_ref1) 166 ."expected: " . Dumper($bind_ref2) 167 ); 168} 169 170sub eq_sql_bind { 171 my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_; 172 173 return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2); 174} 175 176 177sub eq_bind { 178 my ($bind_ref1, $bind_ref2) = @_; 179 180 return eq_deeply($bind_ref1, $bind_ref2); 181} 182 183sub eq_sql { 184 my ($sql1, $sql2) = @_; 185 186 # parse 187 my $tree1 = parse($sql1); 188 my $tree2 = parse($sql2); 189 190 return 1 if _eq_sql($tree1, $tree2); 191} 192 193sub _eq_sql { 194 my ($left, $right) = @_; 195 196 # one is defined the other not 197 if ( (defined $left) xor (defined $right) ) { 198 return 0; 199 } 200 # one is undefined, then so is the other 201 elsif (not defined $left) { 202 return 1; 203 } 204 # one is a list, the other is an op with a list 205 elsif (ref $left->[0] xor ref $right->[0]) { 206 $sql_differ = sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) ); 207 return 0; 208 } 209 # one is a list, so is the other 210 elsif (ref $left->[0]) { 211 for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) { 212 return 0 if (not _eq_sql ($left->[$i], $right->[$i]) ); 213 } 214 return 1; 215 } 216 # both are an op-list combo 217 else { 218 219 # unroll parenthesis if possible/allowed 220 _parenthesis_unroll ($_) for ($left, $right); 221 222 # if operators are different 223 if ( $left->[0] ne $right->[0] ) { 224 $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n", 225 unparse($left), 226 unparse($right); 227 return 0; 228 } 229 # elsif operators are identical, compare operands 230 else { 231 if ($left->[0] eq 'LITERAL' ) { # unary 232 (my $l = " $left->[1][0] " ) =~ s/\s+/ /g; 233 (my $r = " $right->[1][0] ") =~ s/\s+/ /g; 234 my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r); 235 $sql_differ = "[$l] != [$r]\n" if not $eq; 236 return $eq; 237 } 238 else { 239 my $eq = _eq_sql($left->[1], $right->[1]); 240 $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { unparse ($_) } ($left, $right) ) if not $eq; 241 return $eq; 242 } 243 } 244 } 245} 246 247sub parse { 248 my $s = shift; 249 250 # tokenize string, and remove all optional whitespace 251 my $tokens = []; 252 foreach my $token (split $tokenizer_re, $s) { 253 push @$tokens, $token if (length $token) && ($token =~ /\S/); 254 } 255 256 my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL); 257 return $tree; 258} 259 260sub _recurse_parse { 261 my ($tokens, $state) = @_; 262 263 my $left; 264 while (1) { # left-associative parsing 265 266 my $lookahead = $tokens->[0]; 267 if ( not defined($lookahead) 268 or 269 ($state == PARSE_IN_PARENS && $lookahead eq ')') 270 or 271 ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords ) ) 272 or 273 ($state == PARSE_RHS && grep { $lookahead =~ /^ $_ $/xi } ('\)', @expression_terminator_sql_keywords, @binary_op_keywords, 'AND', 'OR', 'NOT' ) ) 274 ) { 275 return $left; 276 } 277 278 my $token = shift @$tokens; 279 280 # nested expression in () 281 if ($token eq '(' ) { 282 my $right = _recurse_parse($tokens, PARSE_IN_PARENS); 283 $token = shift @$tokens or croak "missing closing ')' around block " . unparse ($right); 284 $token eq ')' or croak "unexpected token '$token' terminating block " . unparse ($right); 285 $left = $left ? [@$left, [PAREN => [$right] ]] 286 : [PAREN => [$right] ]; 287 } 288 # AND/OR 289 elsif ($token =~ /^ (?: OR | AND ) $/xi ) { 290 my $op = uc $token; 291 my $right = _recurse_parse($tokens, PARSE_IN_EXPR); 292 293 # Merge chunks if logic matches 294 if (ref $right and $op eq $right->[0]) { 295 $left = [ (shift @$right ), [$left, map { @$_ } @$right] ]; 296 } 297 else { 298 $left = [$op => [$left, $right]]; 299 } 300 } 301 # binary operator keywords 302 elsif (grep { $token =~ /^ $_ $/xi } @binary_op_keywords ) { 303 my $op = uc $token; 304 my $right = _recurse_parse($tokens, PARSE_RHS); 305 306 # A between with a simple LITERAL for a 1st RHS argument needs a 307 # rerun of the search to (hopefully) find the proper AND construct 308 if ($op eq 'BETWEEN' and $right->[0] eq 'LITERAL') { 309 unshift @$tokens, $right->[1][0]; 310 $right = _recurse_parse($tokens, PARSE_IN_EXPR); 311 } 312 313 $left = [$op => [$left, $right] ]; 314 } 315 # expression terminator keywords (as they start a new expression) 316 elsif (grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) { 317 my $op = uc $token; 318 my $right = _recurse_parse($tokens, PARSE_IN_EXPR); 319 $left = $left ? [@$left, [$op => [$right] ]] 320 : [[ $op => [$right] ]]; 321 } 322 # NOT (last as to allow all other NOT X pieces first) 323 elsif ( $token =~ /^ not $/ix ) { 324 my $op = uc $token; 325 my $right = _recurse_parse ($tokens, PARSE_RHS); 326 $left = $left ? [ @$left, [$op => [$right] ]] 327 : [[ $op => [$right] ]]; 328 329 } 330 # literal (eat everything on the right until RHS termination) 331 else { 332 my $right = _recurse_parse ($tokens, PARSE_RHS); 333 $left = $left ? [$left, [LITERAL => [join ' ', $token, unparse($right)||()] ] ] 334 : [ LITERAL => [join ' ', $token, unparse($right)||()] ]; 335 } 336 } 337} 338 339sub _parenthesis_unroll { 340 my $ast = shift; 341 342 return if $parenthesis_significant; 343 return unless (ref $ast and ref $ast->[1]); 344 345 my $changes; 346 do { 347 my @children; 348 $changes = 0; 349 350 for my $child (@{$ast->[1]}) { 351 if (not ref $child or not $child->[0] eq 'PAREN') { 352 push @children, $child; 353 next; 354 } 355 356 # unroll nested parenthesis 357 while ($child->[1][0][0] eq 'PAREN') { 358 $child = $child->[1][0]; 359 $changes++; 360 } 361 362 # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list 363 if ( 364 ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR') 365 and 366 $child->[1][0][0] eq $ast->[0] 367 ) { 368 push @children, @{$child->[1][0][1]}; 369 $changes++; 370 } 371 372 # if the parent operator explcitly allows it nuke the parenthesis 373 elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) { 374 push @children, $child->[1][0]; 375 $changes++; 376 } 377 378 # only one LITERAL element in the parenthesis 379 elsif ( 380 @{$child->[1]} == 1 && $child->[1][0][0] eq 'LITERAL' 381 ) { 382 push @children, $child->[1][0]; 383 $changes++; 384 } 385 386 # only one element in the parenthesis which is a binary op with two LITERAL sub-children 387 elsif ( 388 @{$child->[1]} == 1 389 and 390 grep { $child->[1][0][0] =~ /^ $_ $/xi } (@binary_op_keywords) 391 and 392 $child->[1][0][1][0][0] eq 'LITERAL' 393 and 394 $child->[1][0][1][1][0] eq 'LITERAL' 395 ) { 396 push @children, $child->[1][0]; 397 $changes++; 398 } 399 400 # otherwise no more mucking for this pass 401 else { 402 push @children, $child; 403 } 404 } 405 406 $ast->[1] = \@children; 407 408 } while ($changes); 409 410} 411 412sub unparse { 413 my $tree = shift; 414 415 if (not $tree ) { 416 return ''; 417 } 418 elsif (ref $tree->[0]) { 419 return join (" ", map { unparse ($_) } @$tree); 420 } 421 elsif ($tree->[0] eq 'LITERAL') { 422 return $tree->[1][0]; 423 } 424 elsif ($tree->[0] eq 'PAREN') { 425 return sprintf '(%s)', join (" ", map {unparse($_)} @{$tree->[1]}); 426 } 427 elsif ($tree->[0] eq 'OR' or $tree->[0] eq 'AND' or (grep { $tree->[0] =~ /^ $_ $/xi } @binary_op_keywords ) ) { 428 return join (" $tree->[0] ", map {unparse($_)} @{$tree->[1]}); 429 } 430 else { 431 return sprintf '%s %s', $tree->[0], unparse ($tree->[1]); 432 } 433} 434 435 4361; 437 438 439__END__ 440 441=head1 NAME 442 443SQL::Abstract::Test - Helper function for testing SQL::Abstract 444 445=head1 SYNOPSIS 446 447 use SQL::Abstract; 448 use Test::More; 449 use SQL::Abstract::Test import => [qw/ 450 is_same_sql_bind is_same_sql is_same_bind 451 eq_sql_bind eq_sql eq_bind 452 /]; 453 454 my ($sql, @bind) = SQL::Abstract->new->select(%args); 455 456 is_same_sql_bind($given_sql, \@given_bind, 457 $expected_sql, \@expected_bind, $test_msg); 458 459 is_same_sql($given_sql, $expected_sql, $test_msg); 460 is_same_bind(\@given_bind, \@expected_bind, $test_msg); 461 462 my $is_same = eq_sql_bind($given_sql, \@given_bind, 463 $expected_sql, \@expected_bind); 464 465 my $sql_same = eq_sql($given_sql, $expected_sql); 466 my $bind_same = eq_bind(\@given_bind, \@expected_bind); 467 468=head1 DESCRIPTION 469 470This module is only intended for authors of tests on 471L<SQL::Abstract|SQL::Abstract> and related modules; 472it exports functions for comparing two SQL statements 473and their bound values. 474 475The SQL comparison is performed on I<abstract syntax>, 476ignoring differences in spaces or in levels of parentheses. 477Therefore the tests will pass as long as the semantics 478is preserved, even if the surface syntax has changed. 479 480B<Disclaimer> : the semantic equivalence handling is pretty limited. 481A lot of effort goes into distinguishing significant from 482non-significant parenthesis, including AND/OR operator associativity. 483Currently this module does not support commutativity and more 484intelligent transformations like Morgan laws, etc. 485 486For a good overview of what this test framework is capable of refer 487to C<t/10test.t> 488 489=head1 FUNCTIONS 490 491=head2 is_same_sql_bind 492 493 is_same_sql_bind($given_sql, \@given_bind, 494 $expected_sql, \@expected_bind, $test_msg); 495 496Compares given and expected pairs of C<($sql, \@bind)>, and calls 497L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test 498fails, a detailed diagnostic is printed. For clients which use L<Test::More>, 499this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>, 500L</is_same_bind>) that needs to be imported. 501 502=head2 is_same_sql 503 504 is_same_sql($given_sql, $expected_sql, $test_msg); 505 506Compares given and expected SQL statements, and calls L<Test::Builder/ok> on 507the result, with C<$test_msg> as message. If the test fails, a detailed 508diagnostic is printed. For clients which use L<Test::More>, this is the one of 509the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) 510that needs to be imported. 511 512=head2 is_same_bind 513 514 is_same_bind(\@given_bind, \@expected_bind, $test_msg); 515 516Compares given and expected bind values, and calls L<Test::Builder/ok> on the 517result, with C<$test_msg> as message. If the test fails, a detailed diagnostic 518is printed. For clients which use L<Test::More>, this is the one of the three 519functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs 520to be imported. 521 522=head2 eq_sql_bind 523 524 my $is_same = eq_sql_bind($given_sql, \@given_bind, 525 $expected_sql, \@expected_bind); 526 527Compares given and expected pairs of C<($sql, \@bind)>. Similar to 528L</is_same_sql_bind>, but it just returns a boolean value and does not print 529diagnostics or talk to L<Test::Builder>. 530 531=head2 eq_sql 532 533 my $is_same = eq_sql($given_sql, $expected_sql); 534 535Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>, 536but it just returns a boolean value and does not print diagnostics or talk to 537L<Test::Builder>. If the result is false, the global variable L</$sql_differ> 538will contain the SQL portion where a difference was encountered; this is useful 539for printing diagnostics. 540 541=head2 eq_bind 542 543 my $is_same = eq_sql(\@given_bind, \@expected_bind); 544 545Compares two lists of bind values, taking into account the fact that some of 546the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to 547L</is_same_bind>, but it just returns a boolean value and does not print 548diagnostics or talk to L<Test::Builder>. 549 550=head1 GLOBAL VARIABLES 551 552=head2 $case_sensitive 553 554If true, SQL comparisons will be case-sensitive. Default is false; 555 556=head2 $parenthesis_significant 557 558If true, SQL comparison will preserve and report difference in nested 559parenthesis. Useful for testing the C<-nest> modifier. Defaults to false; 560 561=head2 $sql_differ 562 563When L</eq_sql> returns false, the global variable 564C<$sql_differ> contains the SQL portion 565where a difference was encountered. 566 567 568=head1 SEE ALSO 569 570L<SQL::Abstract>, L<Test::More>, L<Test::Builder>. 571 572=head1 AUTHORS 573 574Laurent Dami, E<lt>laurent.dami AT etat geneve chE<gt> 575 576Norbert Buchmuller <norbi@nix.hu> 577 578Peter Rabbitson <ribasushi@cpan.org> 579 580=head1 COPYRIGHT AND LICENSE 581 582Copyright 2008 by Laurent Dami. 583 584This library is free software; you can redistribute it and/or modify 585it under the same terms as Perl itself. 586