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 Test::Builder;
   8 use SQL::Abstract::Tree;
   9
  10 our @EXPORT_OK = qw/&is_same_sql_bind &is_same_sql &is_same_bind
  11                     &eq_sql_bind &eq_sql &eq_bind
  12                     $case_sensitive $sql_differ/;
  13
  14 my $sqlat = SQL::Abstract::Tree->new;
  15
  16 our $case_sensitive = 0;
  17 our $parenthesis_significant = 0;
  18 our $sql_differ; # keeps track of differing portion between SQLs
  19 our $tb = __PACKAGE__->builder;
  20
  21 sub is_same_sql_bind {
  22   my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
  23
  24   # compare
  25   my $same_sql  = eq_sql($sql1, $sql2);
  26   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
  27
  28   # call Test::Builder::ok
  29   my $ret = $tb->ok($same_sql && $same_bind, $msg);
  30
  31   # add debugging info
  32   if (!$same_sql) {
  33     _sql_differ_diag($sql1, $sql2);
  34   }
  35   if (!$same_bind) {
  36     _bind_differ_diag($bind_ref1, $bind_ref2);
  37   }
  38
  39   # pass ok() result further
  40   return $ret;
  41 }
  42
  43 sub is_same_sql {
  44   my ($sql1, $sql2, $msg) = @_;
  45
  46   # compare
  47   my $same_sql  = eq_sql($sql1, $sql2);
  48
  49   # call Test::Builder::ok
  50   my $ret = $tb->ok($same_sql, $msg);
  51
  52   # add debugging info
  53   if (!$same_sql) {
  54     _sql_differ_diag($sql1, $sql2);
  55   }
  56
  57   # pass ok() result further
  58   return $ret;
  59 }
  60
  61 sub is_same_bind {
  62   my ($bind_ref1, $bind_ref2, $msg) = @_;
  63
  64   # compare
  65   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
  66
  67   # call Test::Builder::ok
  68   my $ret = $tb->ok($same_bind, $msg);
  69
  70   # add debugging info
  71   if (!$same_bind) {
  72     _bind_differ_diag($bind_ref1, $bind_ref2);
  73   }
  74
  75   # pass ok() result further
  76   return $ret;
  77 }
  78
  79 sub _sql_differ_diag {
  80   my ($sql1, $sql2) = @_;
  81
  82   $tb->diag("SQL expressions differ\n"
  83       ."     got: $sql1\n"
  84       ."expected: $sql2\n"
  85       ."differing in :\n$sql_differ\n"
  86       );
  87 }
  88
  89 sub _bind_differ_diag {
  90   my ($bind_ref1, $bind_ref2) = @_;
  91
  92   $tb->diag("BIND values differ\n"
  93       ."     got: " . Dumper($bind_ref1)
  94       ."expected: " . Dumper($bind_ref2)
  95       );
  96 }
  97
  98 sub eq_sql_bind {
  99   my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
 100
 101   return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
 102 }
 103
 104
 105 sub eq_bind {
 106   my ($bind_ref1, $bind_ref2) = @_;
 107
 108   local $Data::Dumper::Useqq = 1;
 109   local $Data::Dumper::Sortkeys = 1;
 110
 111   return Dumper($bind_ref1) eq Dumper($bind_ref2);
 112 }
 113
 114 sub eq_sql {
 115   my ($sql1, $sql2) = @_;
 116
 117   # parse
 118   my $tree1 = $sqlat->parse($sql1);
 119   my $tree2 = $sqlat->parse($sql2);
 120
 121   return 1 if _eq_sql($tree1, $tree2);
 122 }
 123
 124 sub _eq_sql {
 125   my ($left, $right) = @_;
 126
 127   # one is defined the other not
 128   if ( (defined $left) xor (defined $right) ) {
 129     return 0;
 130   }
 131   # one is undefined, then so is the other
 132   elsif (not defined $left) {
 133     return 1;
 134   }
 135   # different amount of elements
 136   elsif (@$left != @$right) {
 137     return 0;
 138   }
 139   # one is empty - so is the other
 140   elsif (@$left == 0) {
 141     return 1;
 142   }
 143   # one is a list, the other is an op with a list
 144   elsif (ref $left->[0] xor ref $right->[0]) {
 145     $sql_differ = sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
 146     return 0;
 147   }
 148   # one is a list, so is the other
 149   elsif (ref $left->[0]) {
 150     for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
 151       return 0 if (not _eq_sql ($left->[$i], $right->[$i]) );
 152     }
 153     return 1;
 154   }
 155   # both are an op-list combo
 156   else {
 157
 158     # unroll parenthesis if possible/allowed
 159     $parenthesis_significant || $sqlat->_parenthesis_unroll($_) for $left, $right;
 160
 161     # if operators are different
 162     if ( $left->[0] ne $right->[0] ) {
 163       $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
 164         $sqlat->unparse($left),
 165         $sqlat->unparse($right);
 166       return 0;
 167     }
 168     # elsif operators are identical, compare operands
 169     else {
 170       if ($left->[0] eq 'LITERAL' ) { # unary
 171         (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
 172         (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
 173         my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
 174         $sql_differ = "[$l] != [$r]\n" if not $eq;
 175         return $eq;
 176       }
 177       else {
 178         my $eq = _eq_sql($left->[1], $right->[1]);
 179         $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
 180         return $eq;
 181       }
 182     }
 183   }
 184 }
 185
 186 sub parse { $sqlat->parse(@_) }
 187 1;
 188
 189
 190 __END__
 191
 192 =head1 NAME
 193
 194 SQL::Abstract::Test - Helper function for testing SQL::Abstract
 195
 196 =head1 SYNOPSIS
 197
 198   use SQL::Abstract;
 199   use Test::More;
 200   use SQL::Abstract::Test import => [qw/
 201     is_same_sql_bind is_same_sql is_same_bind
 202     eq_sql_bind eq_sql eq_bind
 203   /];
 204
 205   my ($sql, @bind) = SQL::Abstract->new->select(%args);
 206
 207   is_same_sql_bind($given_sql,    \@given_bind,
 208                    $expected_sql, \@expected_bind, $test_msg);
 209
 210   is_same_sql($given_sql, $expected_sql, $test_msg);
 211   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 212
 213   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 214                             $expected_sql, \@expected_bind);
 215
 216   my $sql_same = eq_sql($given_sql, $expected_sql);
 217   my $bind_same = eq_bind(\@given_bind, \@expected_bind);
 218
 219 =head1 DESCRIPTION
 220
 221 This module is only intended for authors of tests on
 222 L<SQL::Abstract|SQL::Abstract> and related modules;
 223 it exports functions for comparing two SQL statements
 224 and their bound values.
 225
 226 The SQL comparison is performed on I<abstract syntax>,
 227 ignoring differences in spaces or in levels of parentheses.
 228 Therefore the tests will pass as long as the semantics
 229 is preserved, even if the surface syntax has changed.
 230
 231 B<Disclaimer> : the semantic equivalence handling is pretty limited.
 232 A lot of effort goes into distinguishing significant from
 233 non-significant parenthesis, including AND/OR operator associativity.
 234 Currently this module does not support commutativity and more
 235 intelligent transformations like Morgan laws, etc.
 236
 237 For a good overview of what this test framework is capable of refer
 238 to C<t/10test.t>
 239
 240 =head1 FUNCTIONS
 241
 242 =head2 is_same_sql_bind
 243
 244   is_same_sql_bind($given_sql,    \@given_bind,
 245                    $expected_sql, \@expected_bind, $test_msg);
 246
 247 Compares given and expected pairs of C<($sql, \@bind)>, and calls
 248 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
 249 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
 250 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
 251 L</is_same_bind>) that needs to be imported.
 252
 253 =head2 is_same_sql
 254
 255   is_same_sql($given_sql, $expected_sql, $test_msg);
 256
 257 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
 258 the result, with C<$test_msg> as message. If the test fails, a detailed
 259 diagnostic is printed. For clients which use L<Test::More>, this is the one of
 260 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
 261 that needs to be imported.
 262
 263 =head2 is_same_bind
 264
 265   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 266
 267 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
 268 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
 269 is printed. For clients which use L<Test::More>, this is the one of the three
 270 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
 271 to be imported.
 272
 273 =head2 eq_sql_bind
 274
 275   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 276                             $expected_sql, \@expected_bind);
 277
 278 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
 279 L</is_same_sql_bind>, but it just returns a boolean value and does not print
 280 diagnostics or talk to L<Test::Builder>.
 281
 282 =head2 eq_sql
 283
 284   my $is_same = eq_sql($given_sql, $expected_sql);
 285
 286 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
 287 but it just returns a boolean value and does not print diagnostics or talk to
 288 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
 289 will contain the SQL portion where a difference was encountered; this is useful
 290 for printing diagnostics.
 291
 292 =head2 eq_bind
 293
 294   my $is_same = eq_sql(\@given_bind, \@expected_bind);
 295
 296 Compares two lists of bind values, taking into account the fact that some of
 297 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
 298 L</is_same_bind>, but it just returns a boolean value and does not print
 299 diagnostics or talk to L<Test::Builder>.
 300
 301 =head1 GLOBAL VARIABLES
 302
 303 =head2 $case_sensitive
 304
 305 If true, SQL comparisons will be case-sensitive. Default is false;
 306
 307 =head2 $parenthesis_significant
 308
 309 If true, SQL comparison will preserve and report difference in nested
 310 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
 311
 312 =head2 $sql_differ
 313
 314 When L</eq_sql> returns false, the global variable
 315 C<$sql_differ> contains the SQL portion
 316 where a difference was encountered.
 317
 318
 319 =head1 SEE ALSO
 320
 321 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
 322
 323 =head1 AUTHORS
 324
 325 Laurent Dami, E<lt>laurent.dami AT etat  geneve  chE<gt>
 326
 327 Norbert Buchmuller <norbi@nix.hu>
 328
 329 Peter Rabbitson <ribasushi@cpan.org>
 330
 331 =head1 COPYRIGHT AND LICENSE
 332
 333 Copyright 2008 by Laurent Dami.
 334
 335 This library is free software; you can redistribute it and/or modify
 336 it under the same terms as Perl itself.