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