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