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 &eq_sql &eq_bind
  12                     $case_sensitive $sql_differ/;
  13
  14 our $case_sensitive = 0;
  15 our $sql_differ; # keeps track of differing portion between SQLs
  16 our $tb = __PACKAGE__->builder;
  17
  18 # Parser states for _recurse_parse()
  19 use constant {
  20   PARSE_TOP_LEVEL => 0,
  21   PARSE_IN_EXPR => 1,
  22   PARSE_IN_PARENS => 2,
  23 };
  24
  25 # These SQL keywords always signal end of the current expression (except inside
  26 # of a parenthesized subexpression).
  27 # Format: A list of strings that will be compiled to extended syntax (ie.
  28 # /.../x) regexes, without capturing parentheses. They will be automatically
  29 # anchored to word boundaries to match the whole token).
  30 my @expression_terminator_sql_keywords = (
  31   'FROM',
  32   '(?:
  33     (?:
  34         (?: \b (?: LEFT | RIGHT | FULL ) \s+ )?
  35         (?: \b (?: CROSS | INNER | OUTER ) \s+ )?
  36     )?
  37     JOIN
  38   )',
  39   'ON',
  40   'WHERE',
  41   'GROUP \s+ BY',
  42   'HAVING',
  43   'ORDER \s+ BY',
  44   'LIMIT',
  45   'OFFSET',
  46   'FOR',
  47   'UNION',
  48   'INTERSECT',
  49   'EXCEPT',
  50 );
  51
  52 my $tokenizer_re_str = join('|',
  53   map { '\b' . $_ . '\b' }
  54     @expression_terminator_sql_keywords, 'AND', 'OR'
  55 );
  56
  57 my $tokenizer_re = qr/
  58   \s*
  59   (
  60       \(
  61     |
  62       \)
  63     |
  64       $tokenizer_re_str
  65   )
  66   \s*
  67 /xi;
  68
  69
  70 sub is_same_sql_bind {
  71   my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
  72
  73   # compare
  74   my $same_sql  = eq_sql($sql1, $sql2);
  75   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
  76
  77   # call Test::Builder::ok
  78   $tb->ok($same_sql && $same_bind, $msg);
  79
  80   # add debugging info
  81   if (!$same_sql) {
  82     $tb->diag("SQL expressions differ\n"
  83         ."     got: $sql1\n"
  84         ."expected: $sql2\n"
  85         ."differing in :\n$sql_differ\n"
  86         );
  87   }
  88   if (!$same_bind) {
  89     $tb->diag("BIND values differ\n"
  90         ."     got: " . Dumper($bind_ref1)
  91         ."expected: " . Dumper($bind_ref2)
  92         );
  93   }
  94 }
  95
  96 sub eq_bind {
  97   my ($bind_ref1, $bind_ref2) = @_;
  98
  99   return eq_deeply($bind_ref1, $bind_ref2);
 100 }
 101
 102 sub eq_sql {
 103   my ($sql1, $sql2) = @_;
 104
 105   # parse
 106   my $tree1 = parse($sql1);
 107   my $tree2 = parse($sql2);
 108
 109   return _eq_sql($tree1, $tree2);
 110 }
 111
 112 sub _eq_sql {
 113   my ($left, $right) = @_;
 114
 115   # ignore top-level parentheses
 116   while ($left->[0]  eq 'PAREN') {$left  = $left->[1] }
 117   while ($right->[0] eq 'PAREN') {$right = $right->[1]}
 118
 119   # if operators are different
 120   if ($left->[0] ne $right->[0]) {
 121     $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
 122       unparse($left),
 123       unparse($right);
 124     return 0;
 125   }
 126   # elsif operators are identical, compare operands
 127   else {
 128     if ($left->[0] eq 'EXPR' ) { # unary operator
 129       (my $l = " $left->[1] " ) =~ s/\s+/ /g;
 130       (my $r = " $right->[1] ") =~ s/\s+/ /g;
 131       my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
 132       $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
 133       return $eq;
 134     }
 135     else { # binary operator
 136       return _eq_sql($left->[1][0], $right->[1][0])  # left operand
 137           && _eq_sql($left->[1][1], $right->[1][1]); # right operand
 138     }
 139   }
 140 }
 141
 142
 143 sub parse {
 144   my $s = shift;
 145
 146   # tokenize string, and remove all optional whitespace
 147   my $tokens = [];
 148   foreach my $token (split $tokenizer_re, $s) {
 149     $token =~ s/\s+/ /g;
 150     $token =~ s/\s+([^\w\s])/$1/g;
 151     $token =~ s/([^\w\s])\s+/$1/g;
 152     push @$tokens, $token if $token !~ /^$/;
 153   }
 154
 155   my $tree = _recurse_parse($tokens, PARSE_TOP_LEVEL);
 156   return $tree;
 157 }
 158
 159 sub _recurse_parse {
 160   my ($tokens, $state) = @_;
 161
 162   my $left;
 163   while (1) { # left-associative parsing
 164
 165     my $lookahead = $tokens->[0];
 166     return $left if !defined($lookahead)
 167       || ($state == PARSE_IN_PARENS && $lookahead eq ')')
 168       || ($state == PARSE_IN_EXPR && grep { $lookahead =~ /^$_$/xi }
 169             '\)', @expression_terminator_sql_keywords
 170          );
 171
 172     my $token = shift @$tokens;
 173
 174     # nested expression in ()
 175     if ($token eq '(') {
 176       my $right = _recurse_parse($tokens, PARSE_IN_PARENS);
 177       $token = shift @$tokens   or croak "missing ')'";
 178       $token eq ')'             or croak "unexpected token : $token";
 179       $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
 180                     : [PAREN  => $right];
 181     }
 182     # AND/OR
 183     elsif ($token eq 'AND' || $token eq 'OR')  {
 184       my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
 185       $left = [$token => [$left, $right]];
 186     }
 187     # expression terminator keywords (as they start a new expression)
 188     elsif (grep { $token =~ /^$_$/xi } @expression_terminator_sql_keywords) {
 189       my $right = _recurse_parse($tokens, PARSE_IN_EXPR);
 190       $left = $left ? [CONCAT => [$left, [CONCAT => [[EXPR => $token], [PAREN => $right]]]]]
 191                     : [CONCAT => [[EXPR => $token], [PAREN  => $right]]];
 192     }
 193     # leaf expression
 194     else {
 195       $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
 196                     : [EXPR   => $token];
 197     }
 198   }
 199 }
 200
 201
 202
 203 sub unparse {
 204   my $tree = shift;
 205   my $dispatch = {
 206     EXPR   => sub {$tree->[1]                                   },
 207     PAREN  => sub {"(" . unparse($tree->[1]) . ")"              },
 208     CONCAT => sub {join " ",     map {unparse($_)} @{$tree->[1]}},
 209     AND    => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
 210     OR     => sub {join " OR ",  map {unparse($_)} @{$tree->[1]}},
 211    };
 212   $dispatch->{$tree->[0]}->();
 213 }
 214
 215
 216 1;
 217
 218
 219 __END__
 220
 221 =head1 NAME
 222
 223 SQL::Abstract::Test - Helper function for testing SQL::Abstract
 224
 225 =head1 SYNOPSIS
 226
 227   use SQL::Abstract;
 228   use Test::More;
 229   use SQL::Abstract::Test import => ['is_same_sql_bind'];
 230
 231   my ($sql, @bind) = SQL::Abstract->new->select(%args);
 232   is_same_sql_bind($given_sql,    \@given_bind,
 233                    $expected_sql, \@expected_bind, $test_msg);
 234
 235 =head1 DESCRIPTION
 236
 237 This module is only intended for authors of tests on
 238 L<SQL::Abstract|SQL::Abstract> and related modules;
 239 it exports functions for comparing two SQL statements
 240 and their bound values.
 241
 242 The SQL comparison is performed on I<abstract syntax>,
 243 ignoring differences in spaces or in levels of parentheses.
 244 Therefore the tests will pass as long as the semantics
 245 is preserved, even if the surface syntax has changed.
 246
 247 B<Disclaimer> : this is only a half-cooked semantic equivalence;
 248 parsing is simple-minded, and comparison of SQL abstract syntax trees
 249 ignores commutativity or associativity of AND/OR operators, Morgan
 250 laws, etc.
 251
 252 =head1 FUNCTIONS
 253
 254 =head2 is_same_sql_bind
 255
 256   is_same_sql_bind($given_sql,    \@given_bind,
 257                    $expected_sql, \@expected_bind, $test_msg);
 258
 259 Compares given and expected pairs of C<($sql, \@bind)>, and calls
 260 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the
 261 test fails, a detailed diagnostic is printed. For clients which use
 262 L<Test::Build>, this is the only function that needs to be
 263 imported.
 264
 265 =head2 eq_sql
 266
 267   my $is_same = eq_sql($given_sql, $expected_sql);
 268
 269 Compares the abstract syntax of two SQL statements.  If the result is
 270 false, global variable L</sql_differ> will contain the SQL portion
 271 where a difference was encountered; this is useful for printing diagnostics.
 272
 273 =head2 eq_bind
 274
 275   my $is_same = eq_sql(\@given_bind, \@expected_bind);
 276
 277 Compares two lists of bind values, taking into account
 278 the fact that some of the values may be
 279 arrayrefs (see L<SQL::Abstract/bindtype>).
 280
 281 =head1 GLOBAL VARIABLES
 282
 283 =head2 case_sensitive
 284
 285 If true, SQL comparisons will be case-sensitive. Default is false;
 286
 287 =head2 sql_differ
 288
 289 When L</eq_sql> returns false, the global variable
 290 C<$sql_differ> contains the SQL portion
 291 where a difference was encountered.
 292
 293
 294 =head1 SEE ALSO
 295
 296 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
 297
 298 =head1 AUTHORS
 299
 300 Laurent Dami, E<lt>laurent.dami AT etat  geneve  chE<gt>
 301
 302 Norbert Buchmuller <norbi@nix.hu>
 303
 304 =head1 COPYRIGHT AND LICENSE
 305
 306 Copyright 2008 by Laurent Dami.
 307
 308 This library is free software; you can redistribute it and/or modify
 309 it under the same terms as Perl itself.