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 sub is_same_sql_bind {
  20   my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
  21
  22   # compare
  23   my $tree1     = parse($sql1);
  24   my $tree2     = parse($sql2);
  25   my $same_sql  = eq_sql($tree1, $tree2);
  26   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
  27
  28   # call Test::Builder::ok
  29   $tb->ok($same_sql && $same_bind, $msg);
  30
  31   # add debugging info
  32   if (!$same_sql) {
  33     $tb->diag("SQL expressions differ\n"
  34         ."     got: $sql1\n"
  35         ."expected: $sql2\n"
  36         ."differing in :\n$sql_differ\n"
  37         );
  38   }
  39   if (!$same_bind) {
  40     $tb->diag("BIND values differ\n"
  41         ."     got: " . Dumper($bind_ref1)
  42         ."expected: " . Dumper($bind_ref2)
  43         );
  44   }
  45 }
  46
  47 sub eq_bind {
  48   my ($bind_ref1, $bind_ref2) = @_;
  49
  50   return eq_deeply($bind_ref1, $bind_ref2);
  51 }
  52
  53 sub eq_sql {
  54   my ($left, $right) = @_;
  55
  56   # ignore top-level parentheses
  57   while ($left->[0]  eq 'PAREN') {$left  = $left->[1] }
  58   while ($right->[0] eq 'PAREN') {$right = $right->[1]}
  59
  60   # if operators are different
  61   if ($left->[0] ne $right->[0]) {
  62     $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
  63       unparse($left),
  64       unparse($right);
  65     return 0;
  66   }
  67   # elsif operators are identical, compare operands
  68   else {
  69     if ($left->[0] eq 'EXPR' ) { # unary operator
  70       (my $l = " $left->[1] " ) =~ s/\s+/ /g;
  71       (my $r = " $right->[1] ") =~ s/\s+/ /g;
  72       my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
  73       $sql_differ = "[$left->[1]] != [$right->[1]]\n" if not $eq;
  74       return $eq;
  75     }
  76     else { # binary operator
  77       return eq_sql($left->[1][0], $right->[1][0])  # left operand
  78           && eq_sql($left->[1][1], $right->[1][1]); # right operand
  79     }
  80   }
  81 }
  82
  83
  84 sub parse {
  85   my $s = shift;
  86
  87   # tokenize string
  88   my $tokens = [grep {!/^\s*$/} split /\s*(\(|\)|\bAND\b|\bOR\b)\s*/, $s];
  89
  90   my $tree = _recurse_parse($tokens);
  91   return $tree;
  92 }
  93
  94 sub _recurse_parse {
  95   my $tokens = shift;
  96
  97   my $left;
  98   while (1) { # left-associative parsing
  99
 100     my $lookahead = $tokens->[0];
 101     return $left if !defined($lookahead) || $lookahead eq ')';
 102
 103     my $token = shift @$tokens;
 104
 105     # nested expression in ()
 106     if ($token eq '(') {
 107       my $right = _recurse_parse($tokens);
 108       $token = shift @$tokens   or croak "missing ')'";
 109       $token eq ')'             or croak "unexpected token : $token";
 110       $left = $left ? [CONCAT => [$left, [PAREN => $right]]]
 111                     : [PAREN  => $right];
 112     }
 113     # AND/OR
 114     elsif ($token eq 'AND' || $token eq 'OR')  {
 115       my $right = _recurse_parse($tokens);
 116       $left = [$token => [$left, $right]];
 117     }
 118     # leaf expression
 119     else {
 120       $left = $left ? [CONCAT => [$left, [EXPR => $token]]]
 121                     : [EXPR   => $token];
 122     }
 123   }
 124 }
 125
 126
 127
 128 sub unparse {
 129   my $tree = shift;
 130   my $dispatch = {
 131     EXPR   => sub {$tree->[1]                                   },
 132     PAREN  => sub {"(" . unparse($tree->[1]) . ")"              },
 133     CONCAT => sub {join " ",     map {unparse($_)} @{$tree->[1]}},
 134     AND    => sub {join " AND ", map {unparse($_)} @{$tree->[1]}},
 135     OR     => sub {join " OR ",  map {unparse($_)} @{$tree->[1]}},
 136    };
 137   $dispatch->{$tree->[0]}->();
 138 }
 139
 140
 141 1;
 142
 143
 144 __END__
 145
 146 =head1 NAME
 147
 148 SQL::Abstract::Test - Helper function for testing SQL::Abstract
 149
 150 =head1 SYNOPSIS
 151
 152   use SQL::Abstract;
 153   use Test::More;
 154   use SQL::Abstract::Test import => ['is_same_sql_bind'];
 155
 156   my ($sql, @bind) = SQL::Abstract->new->select(%args);
 157   is_same_sql_bind($given_sql,    \@given_bind,
 158                    $expected_sql, \@expected_bind, $test_msg);
 159
 160 =head1 DESCRIPTION
 161
 162 This module is only intended for authors of tests on
 163 L<SQL::Abstract|SQL::Abstract> and related modules;
 164 it exports functions for comparing two SQL statements
 165 and their bound values.
 166
 167 The SQL comparison is performed on I<abstract syntax>,
 168 ignoring differences in spaces or in levels of parentheses.
 169 Therefore the tests will pass as long as the semantics
 170 is preserved, even if the surface syntax has changed.
 171
 172 B<Disclaimer> : this is only a half-cooked semantic equivalence;
 173 parsing is simple-minded, and comparison of SQL abstract syntax trees
 174 ignores commutativity or associativity of AND/OR operators, Morgan
 175 laws, etc.
 176
 177 =head1 FUNCTIONS
 178
 179 =head2 is_same_sql_bind
 180
 181   is_same_sql_bind($given_sql,    \@given_bind,
 182                    $expected_sql, \@expected_bind, $test_msg);
 183
 184 Compares given and expected pairs of C<($sql, \@bind)>, and calls
 185 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the
 186 test fails, a detailed diagnostic is printed. For clients which use
 187 L<Test::Build>, this is the only function that needs to be
 188 imported.
 189
 190 =head2 eq_sql
 191
 192   my $is_same = eq_sql($given_sql, $expected_sql);
 193
 194 Compares the abstract syntax of two SQL statements.  If the result is
 195 false, global variable L</sql_differ> will contain the SQL portion
 196 where a difference was encountered; this is useful for printing diagnostics.
 197
 198 =head2 eq_bind
 199
 200   my $is_same = eq_sql(\@given_bind, \@expected_bind);
 201
 202 Compares two lists of bind values, taking into account
 203 the fact that some of the values may be
 204 arrayrefs (see L<SQL::Abstract/bindtype>).
 205
 206 =head1 GLOBAL VARIABLES
 207
 208 =head2 case_sensitive
 209
 210 If true, SQL comparisons will be case-sensitive. Default is false;
 211
 212 =head2 sql_differ
 213
 214 When L</eq_sql> returns false, the global variable
 215 C<$sql_differ> contains the SQL portion
 216 where a difference was encountered.
 217
 218
 219 =head1 SEE ALSO
 220
 221 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
 222
 223 =head1 AUTHOR
 224
 225 Laurent Dami, E<lt>laurent.dami AT etat  geneve  chE<gt>
 226
 227 =head1 COPYRIGHT AND LICENSE
 228
 229 Copyright 2008 by Laurent Dami.
 230
 231 This library is free software; you can redistribute it and/or modify
 232 it under the same terms as Perl itself.