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