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