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