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