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       $left = $left ? [@$left, [PAREN => [$right] ]]
 288                     : [PAREN  => [$right] ];
 289     }
 290     # AND/OR
 291     elsif ($token =~ /^ (?: OR | AND ) $/xi )  {
 292       my $op = uc $token;
 293       my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
 294
 295       # Merge chunks if logic matches
 296       if (ref $right and $op eq $right->[0]) {
 297         $left = [ (shift @$right ), [$left, map { @$_ } @$right] ];
 298       }
 299       else {
 300        $left = [$op => [$left, $right]];
 301       }
 302     }
 303     # binary operator keywords
 304     elsif (grep { $token =~ /^ $_ $/xi } @binary_op_keywords ) {
 305       my $op = uc $token;
 306       my $right = _recurse_parse($tokens, PARSE_RHS);
 307
 308       # A between with a simple LITERAL for a 1st RHS argument needs a
 309       # rerun of the search to (hopefully) find the proper AND construct
 310       if ($op eq 'BETWEEN' and $right->[0] eq 'LITERAL') {
 311         unshift @$tokens, $right->[1][0];
 312         $right = _recurse_parse($tokens, PARSE_IN_EXPR);
 313       }
 314
 315       $left = [$op => [$left, $right] ];
 316     }
 317     # expression terminator keywords (as they start a new expression)
 318     elsif (grep { $token =~ /^ $_ $/xi } @expression_terminator_sql_keywords ) {
 319       my $op = uc $token;
 320       my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
 321       $left = $left ? [@$left,  [$op => [$right] ]]
 322                     : [[ $op => [$right] ]];
 323     }
 324     # NOT (last as to allow all other NOT X pieces first)
 325     elsif ( $token =~ /^ not $/ix ) {
 326       my $op = uc $token;
 327       my $right = _recurse_parse ($tokens, PARSE_RHS);
 328       $left = $left ? [ @$left, [$op => [$right] ]]
 329                     : [[ $op => [$right] ]];
 330
 331     }
 332     # literal (eat everything on the right until RHS termination)
 333     else {
 334       my $right = _recurse_parse ($tokens, PARSE_RHS);
 335       $left = $left ? [$left, [LITERAL => [join ' ', $token, unparse($right)||()] ] ]
 336                     : [ LITERAL => [join ' ', $token, unparse($right)||()] ];
 337     }
 338   }
 339 }
 340
 341 sub _parenthesis_unroll {
 342   my $ast = shift;
 343
 344   return if $parenthesis_significant;
 345   return unless (ref $ast and ref $ast->[1]);
 346
 347   my $changes;
 348   do {
 349     my @children;
 350     $changes = 0;
 351
 352     for my $child (@{$ast->[1]}) {
 353       if (not ref $child or not $child->[0] eq 'PAREN') {
 354         push @children, $child;
 355         next;
 356       }
 357
 358       # unroll nested parenthesis
 359       while ($child->[1][0][0] eq 'PAREN') {
 360         $child = $child->[1][0];
 361         $changes++;
 362       }
 363
 364       # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
 365       if (
 366         ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
 367             and
 368           $child->[1][0][0] eq $ast->[0]
 369       ) {
 370         push @children, @{$child->[1][0][1]};
 371         $changes++;
 372       }
 373
 374       # if the parent operator explcitly allows it nuke the parenthesis
 375       elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) {
 376         push @children, $child->[1][0];
 377         $changes++;
 378       }
 379
 380       # only one LITERAL element in the parenthesis
 381       elsif (
 382         @{$child->[1]} == 1 && $child->[1][0][0] eq 'LITERAL'
 383       ) {
 384         push @children, $child->[1][0];
 385         $changes++;
 386       }
 387
 388       # only one element in the parenthesis which is a binary op with two LITERAL sub-children
 389       elsif (
 390         @{$child->[1]} == 1
 391           and
 392         grep { $child->[1][0][0] =~ /^ $_ $/xi } (@binary_op_keywords)
 393           and
 394         $child->[1][0][1][0][0] eq 'LITERAL'
 395           and
 396         $child->[1][0][1][1][0] eq 'LITERAL'
 397       ) {
 398         push @children, $child->[1][0];
 399         $changes++;
 400       }
 401
 402       # otherwise no more mucking for this pass
 403       else {
 404         push @children, $child;
 405       }
 406     }
 407
 408     $ast->[1] = \@children;
 409
 410   } while ($changes);
 411
 412 }
 413
 414 sub unparse {
 415   my $tree = shift;
 416
 417   if (not $tree ) {
 418     return '';
 419   }
 420   elsif (ref $tree->[0]) {
 421     return join (" ", map { unparse ($_) } @$tree);
 422   }
 423   elsif ($tree->[0] eq 'LITERAL') {
 424     return $tree->[1][0];
 425   }
 426   elsif ($tree->[0] eq 'PAREN') {
 427     return sprintf '(%s)', join (" ", map {unparse($_)} @{$tree->[1]});
 428   }
 429   elsif ($tree->[0] eq 'OR' or $tree->[0] eq 'AND' or (grep { $tree->[0] =~ /^ $_ $/xi } @binary_op_keywords ) ) {
 430     return join (" $tree->[0] ", map {unparse($_)} @{$tree->[1]});
 431   }
 432   else {
 433     return sprintf '%s %s', $tree->[0], unparse ($tree->[1]);
 434   }
 435 }
 436
 437
 438 1;
 439
 440
 441 __END__
 442
 443 =head1 NAME
 444
 445 SQL::Abstract::Test - Helper function for testing SQL::Abstract
 446
 447 =head1 SYNOPSIS
 448
 449   use SQL::Abstract;
 450   use Test::More;
 451   use SQL::Abstract::Test import => [qw/
 452     is_same_sql_bind is_same_sql is_same_bind
 453     eq_sql_bind eq_sql eq_bind
 454   /];
 455
 456   my ($sql, @bind) = SQL::Abstract->new->select(%args);
 457
 458   is_same_sql_bind($given_sql,    \@given_bind,
 459                    $expected_sql, \@expected_bind, $test_msg);
 460
 461   is_same_sql($given_sql, $expected_sql, $test_msg);
 462   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 463
 464   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 465                             $expected_sql, \@expected_bind);
 466
 467   my $sql_same = eq_sql($given_sql, $expected_sql);
 468   my $bind_same = eq_bind(\@given_bind, \@expected_bind);
 469
 470 =head1 DESCRIPTION
 471
 472 This module is only intended for authors of tests on
 473 L<SQL::Abstract|SQL::Abstract> and related modules;
 474 it exports functions for comparing two SQL statements
 475 and their bound values.
 476
 477 The SQL comparison is performed on I<abstract syntax>,
 478 ignoring differences in spaces or in levels of parentheses.
 479 Therefore the tests will pass as long as the semantics
 480 is preserved, even if the surface syntax has changed.
 481
 482 B<Disclaimer> : the semantic equivalence handling is pretty limited.
 483 A lot of effort goes into distinguishing significant from
 484 non-significant parenthesis, including AND/OR operator associativity.
 485 Currently this module does not support commutativity and more
 486 intelligent transformations like Morgan laws, etc.
 487
 488 For a good overview of what this test framework is capable of refer
 489 to C<t/10test.t>
 490
 491 =head1 FUNCTIONS
 492
 493 =head2 is_same_sql_bind
 494
 495   is_same_sql_bind($given_sql,    \@given_bind,
 496                    $expected_sql, \@expected_bind, $test_msg);
 497
 498 Compares given and expected pairs of C<($sql, \@bind)>, and calls
 499 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
 500 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
 501 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
 502 L</is_same_bind>) that needs to be imported.
 503
 504 =head2 is_same_sql
 505
 506   is_same_sql($given_sql, $expected_sql, $test_msg);
 507
 508 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
 509 the result, with C<$test_msg> as message. If the test fails, a detailed
 510 diagnostic is printed. For clients which use L<Test::More>, this is the one of
 511 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
 512 that needs to be imported.
 513
 514 =head2 is_same_bind
 515
 516   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 517
 518 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
 519 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
 520 is printed. For clients which use L<Test::More>, this is the one of the three
 521 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
 522 to be imported.
 523
 524 =head2 eq_sql_bind
 525
 526   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 527                             $expected_sql, \@expected_bind);
 528
 529 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
 530 L</is_same_sql_bind>, but it just returns a boolean value and does not print
 531 diagnostics or talk to L<Test::Builder>.
 532
 533 =head2 eq_sql
 534
 535   my $is_same = eq_sql($given_sql, $expected_sql);
 536
 537 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
 538 but it just returns a boolean value and does not print diagnostics or talk to
 539 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
 540 will contain the SQL portion where a difference was encountered; this is useful
 541 for printing diagnostics.
 542
 543 =head2 eq_bind
 544
 545   my $is_same = eq_sql(\@given_bind, \@expected_bind);
 546
 547 Compares two lists of bind values, taking into account the fact that some of
 548 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
 549 L</is_same_bind>, but it just returns a boolean value and does not print
 550 diagnostics or talk to L<Test::Builder>.
 551
 552 =head1 GLOBAL VARIABLES
 553
 554 =head2 $case_sensitive
 555
 556 If true, SQL comparisons will be case-sensitive. Default is false;
 557
 558 =head2 $parenthesis_significant
 559
 560 If true, SQL comparison will preserve and report difference in nested
 561 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
 562
 563 =head2 $sql_differ
 564
 565 When L</eq_sql> returns false, the global variable
 566 C<$sql_differ> contains the SQL portion
 567 where a difference was encountered.
 568
 569
 570 =head1 SEE ALSO
 571
 572 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
 573
 574 =head1 AUTHORS
 575
 576 Laurent Dami, E<lt>laurent.dami AT etat  geneve  chE<gt>
 577
 578 Norbert Buchmuller <norbi@nix.hu>
 579
 580 Peter Rabbitson <ribasushi@cpan.org>
 581
 582 =head1 COPYRIGHT AND LICENSE
 583
 584 Copyright 2008 by Laurent Dami.
 585
 586 This library is free software; you can redistribute it and/or modify
 587 it under the same terms as Perl itself.