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