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