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