lib/SQL/Abstract/Test.pm

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