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 Scalar::Util qw(looks_like_number blessed reftype);
   7 use Data::Dumper;
   8 use Carp;
   9 use Test::Builder;
  10 use Test::Deep qw(eq_deeply);
  11
  12 our @EXPORT_OK = qw/&is_same_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     $tb->diag("SQL expressions differ\n"
  84         ."     got: $sql1\n"
  85         ."expected: $sql2\n"
  86         ."differing in :\n$sql_differ\n"
  87         );
  88   }
  89   if (!$same_bind) {
  90     $tb->diag("BIND values differ\n"
  91         ."     got: " . Dumper($bind_ref1)
  92         ."expected: " . Dumper($bind_ref2)
  93         );
  94   }
  95 }
  96
  97 sub eq_bind {
  98   my ($bind_ref1, $bind_ref2) = @_;
  99
 100   return eq_deeply($bind_ref1, $bind_ref2);
 101 }
 102
 103 sub eq_sql {
 104   my ($sql1, $sql2) = @_;
 105
 106   # parse
 107   my $tree1 = parse($sql1);
 108   my $tree2 = parse($sql2);
 109
 110   return _eq_sql($tree1, $tree2);
 111 }
 112
 113 sub _eq_sql {
 114   my ($left, $right) = @_;
 115
 116   # ignore top-level parentheses
 117   while ($left->[0]  eq 'PAREN') {$left  = $left->[1] }
 118   while ($right->[0] eq 'PAREN') {$right = $right->[1]}
 119
 120   # if operators are different
 121   if ($left->[0] ne $right->[0]) {
 122     $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
 123       unparse($left),
 124       unparse($right);
 125     return 0;
 126   }
 127   # elsif operators are identical, compare operands
 128   else {
 129     if ($left->[0] eq 'EXPR' ) { # unary operator
 130       (my $l = " $left->[1] " ) =~ s/\s+/ /g;
 131       (my $r = " $right->[1] ") =~ s/\s+/ /g;
 132       my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
 133       $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
 134       return $eq;
 135     }
 136     else { # binary operator
 137       return _eq_sql($left->[1][0], $right->[1][0])  # left operand
 138           && _eq_sql($left->[1][1], $right->[1][1]); # right operand
 139     }
 140   }
 141 }
 142
 143
 144 sub parse {
 145   my $s = shift;
 146
 147   # tokenize string, and remove all optional whitespace
 148   my $tokens = [];
 149   foreach my $token (split $tokenizer_re, $s) {
 150     $token =~ s/\s+/ /g;
 151     $token =~ s/\s+([^\w\s])/$1/g;
 152     $token =~ s/([^\w\s])\s+/$1/g;
 153     push @$tokens, $token if $token !~ /^$/;
 154   }
 155
 156   my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
 157   return $tree;
 158 }
 159
 160 sub _recurse_parse {
 161   my ($tokens, $state) = @_;
 162
 163   my $left;
 164   while (1) { # left-associative parsing
 165
 166     my $lookahead = $tokens->[0];
 167     return $left if !defined($lookahead)
 168       || ($state == PARSE_IN_PARENS && $lookahead eq ')')
 169       || ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^$_$/xi }
 170             '\)', @expression_terminator_sql_keywords
 171          );
 172
 173     my $token = shift @$tokens;
 174
 175     # nested expression in ()
 176     if ($token eq '(') {
 177       my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
 178       $token = shift @$tokens   or croak "missing ')'";
 179       $token eq ')'             or croak "unexpected token : $token";
 180       $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
 181                     : [PAREN  => $right];
 182     }
 183     # AND/OR
 184     elsif ($token eq 'AND' || $token eq 'OR')  {
 185       my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
 186       $left = [$token => [$left, $right]];
 187     }
 188     # expression terminator keywords (as they start a new expression)
 189     elsif (grep { $token =~ /^$_$/xi } @expression_terminator_sql_keywords) {
 190       my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
 191       $left = $left ? [CONCAT => [$left, [CONCAT => [[EXPR => $token], [PAREN => $right]]]]]
 192                     : [CONCAT => [[EXPR => $token], [PAREN  => $right]]];
 193     }
 194     # leaf expression
 195     else {
 196       $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
 197                     : [EXPR   => $token];
 198     }
 199   }
 200 }
 201
 202
 203
 204 sub unparse {
 205   my $tree = shift;
 206   my $dispatch = {
 207     EXPR   => sub {$tree->[1]                                   },
 208     PAREN  => sub {"(" . unparse($tree->[1]) . ")"              },
 209     CONCAT => sub {join " ",     map {unparse($_)} @{$tree->[1]}},
 210     AND    => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
 211     OR     => sub {join " OR ",  map {unparse($_)} @{$tree->[1]}},
 212    };
 213   $dispatch->{$tree->[0]}->();
 214 }
 215
 216
 217 1;
 218
 219
 220 __END__
 221
 222 =head1 NAME
 223
 224 SQL::Abstract::Test - Helper function for testing SQL::Abstract
 225
 226 =head1 SYNOPSIS
 227
 228   use SQL::Abstract;
 229   use Test::More;
 230   use SQL::Abstract::Test import => ['is_same_sql_bind'];
 231
 232   my ($sql, @bind) = SQL::Abstract->new->select(%args);
 233   is_same_sql_bind($given_sql,    \@given_bind,
 234                    $expected_sql, \@expected_bind, $test_msg);
 235
 236 =head1 DESCRIPTION
 237
 238 This module is only intended for authors of tests on
 239 L<SQL::Abstract|SQL::Abstract> and related modules;
 240 it exports functions for comparing two SQL statements
 241 and their bound values.
 242
 243 The SQL comparison is performed on I<abstract syntax>,
 244 ignoring differences in spaces or in levels of parentheses.
 245 Therefore the tests will pass as long as the semantics
 246 is preserved, even if the surface syntax has changed.
 247
 248 B<Disclaimer> : this is only a half-cooked semantic equivalence;
 249 parsing is simple-minded, and comparison of SQL abstract syntax trees
 250 ignores commutativity or associativity of AND/OR operators, Morgan
 251 laws, etc.
 252
 253 =head1 FUNCTIONS
 254
 255 =head2 is_same_sql_bind
 256
 257   is_same_sql_bind($given_sql,    \@given_bind,
 258                    $expected_sql, \@expected_bind, $test_msg);
 259
 260 Compares given and expected pairs of C<($sql, \@bind)>, and calls
 261 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the
 262 test fails, a detailed diagnostic is printed. For clients which use
 263 L<Test::Build>, this is the only function that needs to be
 264 imported.
 265
 266 =head2 eq_sql
 267
 268   my $is_same = eq_sql($given_sql, $expected_sql);
 269
 270 Compares the abstract syntax of two SQL statements.  If the result is
 271 false, global variable L</sql_differ> will contain the SQL portion
 272 where a difference was encountered; this is useful for printing diagnostics.
 273
 274 =head2 eq_bind
 275
 276   my $is_same = eq_sql(\@given_bind, \@expected_bind);
 277
 278 Compares two lists of bind values, taking into account
 279 the fact that some of the values may be
 280 arrayrefs (see L<SQL::Abstract/bindtype>).
 281
 282 =head1 GLOBAL VARIABLES
 283
 284 =head2 case_sensitive
 285
 286 If true, SQL comparisons will be case-sensitive. Default is false;
 287
 288 =head2 sql_differ
 289
 290 When L</eq_sql> returns false, the global variable
 291 C<$sql_differ> contains the SQL portion
 292 where a difference was encountered.
 293
 294
 295 =head1 SEE ALSO
 296
 297 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
 298
 299 =head1 AUTHORS
 300
 301 Laurent Dami, E<lt>laurent.dami AT etat  geneve  chE<gt>
 302
 303 Norbert Buchmuller <norbi@nix.hu>
 304
 305 =head1 COPYRIGHT AND LICENSE
 306
 307 Copyright 2008 by Laurent Dami.
 308
 309 This library is free software; you can redistribute it and/or modify
 310 it under the same terms as Perl itself.