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
  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   'FROM',
  31   '(?:
  32     (?:
  33         (?: \b (?: LEFT | RIGHT | FULL ) \s+ )?
  34         (?: \b (?: CROSS | INNER | OUTER ) \s+ )?
  35     )?
  36     JOIN
  37   )',
  38   'ON',
  39   'WHERE',
  40   'GROUP \s+ BY',
  41   'HAVING',
  42   'ORDER \s+ BY',
  43   'LIMIT',
  44   'OFFSET',
  45   'FOR',
  46   'UNION',
  47   'INTERSECT',
  48   'EXCEPT',
  49 );
  50
  51 my $tokenizer_re_str = join('|',
  52   map { '\b' . $_ . '\b' }
  53     @expression_terminator_sql_keywords, 'AND', 'OR'
  54 );
  55
  56 my $tokenizer_re = qr/
  57   \s*
  58   (
  59       \(
  60     |
  61       \)
  62     |
  63       $tokenizer_re_str
  64   )
  65   \s*
  66 /xi;
  67
  68
  69 sub is_same_sql_bind {
  70   my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
  71
  72   # compare
  73   my $same_sql  = eq_sql($sql1, $sql2);
  74   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
  75
  76   # call Test::Builder::ok
  77   $tb->ok($same_sql && $same_bind, $msg);
  78
  79   # add debugging info
  80   if (!$same_sql) {
  81     _sql_differ_diag($sql1, $sql2);
  82   }
  83   if (!$same_bind) {
  84     _bind_differ_diag($bind_ref1, $bind_ref2);
  85   }
  86 }
  87
  88 sub is_same_sql {
  89   my ($sql1, $sql2, $msg) = @_;
  90
  91   # compare
  92   my $same_sql  = eq_sql($sql1, $sql2);
  93
  94   # call Test::Builder::ok
  95   $tb->ok($same_sql, $msg);
  96
  97   # add debugging info
  98   if (!$same_sql) {
  99     _sql_differ_diag($sql1, $sql2);
 100   }
 101 }
 102
 103 sub is_same_bind {
 104   my ($bind_ref1, $bind_ref2, $msg) = @_;
 105
 106   # compare
 107   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
 108
 109   # call Test::Builder::ok
 110   $tb->ok($same_bind, $msg);
 111
 112   # add debugging info
 113   if (!$same_bind) {
 114     _bind_differ_diag($bind_ref1, $bind_ref2);
 115   }
 116 }
 117
 118 sub _sql_differ_diag {
 119   my ($sql1, $sql2) = @_;
 120
 121   $tb->diag("SQL expressions differ\n"
 122       ."     got: $sql1\n"
 123       ."expected: $sql2\n"
 124       ."differing in :\n$sql_differ\n"
 125       );
 126 }
 127
 128 sub _bind_differ_diag {
 129   my ($bind_ref1, $bind_ref2) = @_;
 130
 131   $tb->diag("BIND values differ\n"
 132       ."     got: " . Dumper($bind_ref1)
 133       ."expected: " . Dumper($bind_ref2)
 134       );
 135 }
 136
 137 sub eq_sql_bind {
 138   my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
 139
 140   return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
 141 }
 142
 143
 144 sub eq_bind {
 145   my ($bind_ref1, $bind_ref2) = @_;
 146
 147   return eq_deeply($bind_ref1, $bind_ref2);
 148 }
 149
 150 sub eq_sql {
 151   my ($sql1, $sql2) = @_;
 152
 153   # parse
 154   my $tree1 = parse($sql1);
 155   my $tree2 = parse($sql2);
 156
 157   return _eq_sql($tree1, $tree2);
 158 }
 159
 160 sub _eq_sql {
 161   my ($left, $right) = @_;
 162
 163   # ignore top-level parentheses
 164   while ($left and $left->[0] and $left->[0]  eq 'PAREN') {$left  = $left->[1]}
 165   while ($right and $right->[0] and $right->[0] eq 'PAREN') {$right = $right->[1]}
 166
 167   # one is defined the other not
 168   if ( (defined $left) xor (defined $right) ) {
 169     return 0;
 170   }
 171   # one is undefined, then so is the other
 172   elsif (not defined $left) {
 173     return 1;
 174   }
 175   # if operators are different
 176   elsif ($left->[0] ne $right->[0]) {
 177     $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
 178       unparse($left),
 179       unparse($right);
 180     return 0;
 181   }
 182   # elsif operators are identical, compare operands
 183   else {
 184     if ($left->[0] eq 'EXPR' ) { # unary operator
 185       (my $l = " $left->[1] " ) =~ s/\s+/ /g;
 186       (my $r = " $right->[1] ") =~ s/\s+/ /g;
 187       my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
 188       $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
 189       return $eq;
 190     }
 191     else { # binary operator
 192       return _eq_sql($left->[1][0], $right->[1][0])  # left operand
 193           && _eq_sql($left->[1][1], $right->[1][1]); # right operand
 194     }
 195   }
 196 }
 197
 198
 199 sub parse {
 200   my $s = shift;
 201
 202   # tokenize string, and remove all optional whitespace
 203   my $tokens = [];
 204   foreach my $token (split $tokenizer_re, $s) {
 205     $token =~ s/\s+/ /g;
 206     $token =~ s/\s+([^\w\s])/$1/g;
 207     $token =~ s/([^\w\s])\s+/$1/g;
 208     push @$tokens, $token if $token !~ /^$/;
 209   }
 210
 211   my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
 212   return $tree;
 213 }
 214
 215 sub _recurse_parse {
 216   my ($tokens, $state) = @_;
 217
 218   my $left;
 219   while (1) { # left-associative parsing
 220
 221     my $lookahead = $tokens->[0];
 222     return $left if !defined($lookahead)
 223       || ($state == PARSE_IN_PARENS && $lookahead eq ')')
 224       || ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^$_$/xi }
 225             '\)', @expression_terminator_sql_keywords
 226          );
 227
 228     my $token = shift @$tokens;
 229
 230     # nested expression in ()
 231     if ($token eq '(') {
 232       my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
 233       $token = shift @$tokens   or croak "missing ')'";
 234       $token eq ')'             or croak "unexpected token : $token";
 235       $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
 236                     : [PAREN  => $right];
 237     }
 238     # AND/OR
 239     elsif ($token eq 'AND' || $token eq 'OR')  {
 240       my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
 241       $left = [$token => [$left, $right]];
 242     }
 243     # expression terminator keywords (as they start a new expression)
 244     elsif (grep { $token =~ /^$_$/xi } @expression_terminator_sql_keywords) {
 245       my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
 246       $left = $left ? [CONCAT => [$left, [CONCAT => [[EXPR => $token], [PAREN => $right]]]]]
 247                     : [CONCAT => [[EXPR => $token], [PAREN  => $right]]];
 248     }
 249     # leaf expression
 250     else {
 251       $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
 252                     : [EXPR   => $token];
 253     }
 254   }
 255 }
 256
 257
 258
 259 sub unparse {
 260   my $tree = shift;
 261   my $dispatch = {
 262     EXPR   => sub {$tree->[1]                                   },
 263     PAREN  => sub {"(" . unparse($tree->[1]) . ")"              },
 264     CONCAT => sub {join " ",     map {unparse($_)} @{$tree->[1]}},
 265     AND    => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
 266     OR     => sub {join " OR ",  map {unparse($_)} @{$tree->[1]}},
 267    };
 268   $dispatch->{$tree->[0]}->();
 269 }
 270
 271
 272 1;
 273
 274
 275 __END__
 276
 277 =head1 NAME
 278
 279 SQL::Abstract::Test - Helper function for testing SQL::Abstract
 280
 281 =head1 SYNOPSIS
 282
 283   use SQL::Abstract;
 284   use Test::More;
 285   use SQL::Abstract::Test import => [qw/
 286     is_same_sql_bind is_same_sql is_same_bind
 287     eq_sql_bind eq_sql eq_bind
 288   /];
 289
 290   my ($sql, @bind) = SQL::Abstract->new->select(%args);
 291
 292   is_same_sql_bind($given_sql,    \@given_bind,
 293                    $expected_sql, \@expected_bind, $test_msg);
 294
 295   is_same_sql($given_sql, $expected_sql, $test_msg);
 296   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 297
 298   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 299                             $expected_sql, \@expected_bind);
 300
 301   my $sql_same = eq_sql($given_sql, $expected_sql);
 302   my $bind_same = eq_bind(\@given_bind, \@expected_bind);
 303
 304 =head1 DESCRIPTION
 305
 306 This module is only intended for authors of tests on
 307 L<SQL::Abstract|SQL::Abstract> and related modules;
 308 it exports functions for comparing two SQL statements
 309 and their bound values.
 310
 311 The SQL comparison is performed on I<abstract syntax>,
 312 ignoring differences in spaces or in levels of parentheses.
 313 Therefore the tests will pass as long as the semantics
 314 is preserved, even if the surface syntax has changed.
 315
 316 B<Disclaimer> : this is only a half-cooked semantic equivalence;
 317 parsing is simple-minded, and comparison of SQL abstract syntax trees
 318 ignores commutativity or associativity of AND/OR operators, Morgan
 319 laws, etc.
 320
 321 =head1 FUNCTIONS
 322
 323 =head2 is_same_sql_bind
 324
 325   is_same_sql_bind($given_sql,    \@given_bind,
 326                    $expected_sql, \@expected_bind, $test_msg);
 327
 328 Compares given and expected pairs of C<($sql, \@bind)>, and calls
 329 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
 330 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
 331 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
 332 L</is_same_bind>) that needs to be imported.
 333
 334 =head2 is_same_sql
 335
 336   is_same_sql($given_sql, $expected_sql, $test_msg);
 337
 338 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
 339 the result, with C<$test_msg> as message. If the test fails, a detailed
 340 diagnostic is printed. For clients which use L<Test::More>, this is the one of
 341 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
 342 that needs to be imported.
 343
 344 =head2 is_same_bind
 345
 346   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 347
 348 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
 349 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
 350 is printed. For clients which use L<Test::More>, this is the one of the three
 351 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
 352 to be imported.
 353
 354 =head2 eq_sql_bind
 355
 356   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 357                             $expected_sql, \@expected_bind);
 358
 359 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
 360 L</is_same_sql_bind>, but it just returns a boolean value and does not print
 361 diagnostics or talk to L<Test::Builder>.
 362
 363 =head2 eq_sql
 364
 365   my $is_same = eq_sql($given_sql, $expected_sql);
 366
 367 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
 368 but it just returns a boolean value and does not print diagnostics or talk to
 369 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
 370 will contain the SQL portion where a difference was encountered; this is useful
 371 for printing diagnostics.
 372
 373 =head2 eq_bind
 374
 375   my $is_same = eq_sql(\@given_bind, \@expected_bind);
 376
 377 Compares two lists of bind values, taking into account the fact that some of
 378 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
 379 L</is_same_bind>, but it just returns a boolean value and does not print
 380 diagnostics or talk to L<Test::Builder>.
 381
 382 =head1 GLOBAL VARIABLES
 383
 384 =head2 $case_sensitive
 385
 386 If true, SQL comparisons will be case-sensitive. Default is false;
 387
 388 =head2 $sql_differ
 389
 390 When L</eq_sql> returns false, the global variable
 391 C<$sql_differ> contains the SQL portion
 392 where a difference was encountered.
 393
 394
 395 =head1 SEE ALSO
 396
 397 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
 398
 399 =head1 AUTHORS
 400
 401 Laurent Dami, E<lt>laurent.dami AT etat  geneve  chE<gt>
 402
 403 Norbert Buchmuller <norbi@nix.hu>
 404
 405 =head1 COPYRIGHT AND LICENSE
 406
 407 Copyright 2008 by Laurent Dami.
 408
 409 This library is free software; you can redistribute it and/or modify
 410 it under the same terms as Perl itself.