lib/SQL/Abstract/Test.pm

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