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