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