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