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