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