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