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   local $Data::Dumper::Deepcopy = 1;
 111
 112   return Dumper($bind_ref1) eq Dumper($bind_ref2);
 113 }
 114
 115 sub eq_sql {
 116   my ($sql1, $sql2) = @_;
 117
 118   # parse
 119   my $tree1 = $sqlat->parse($sql1);
 120   my $tree2 = $sqlat->parse($sql2);
 121
 122   undef $sql_differ;
 123   return 1 if _eq_sql($tree1, $tree2);
 124 }
 125
 126 sub _eq_sql {
 127   my ($left, $right) = @_;
 128
 129   # one is defined the other not
 130   if ( (defined $left) xor (defined $right) ) {
 131     $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse ($_) : 'N/A' } ($left, $right) );
 132     return 0;
 133   }
 134
 135   # one is undefined, then so is the other
 136   elsif (not defined $left) {
 137     return 1;
 138   }
 139
 140   # both are empty
 141   elsif (@$left == 0 and @$right == 0) {
 142     return 1;
 143   }
 144
 145   # one is empty
 146   if (@$left == 0 or @$right == 0) {
 147     $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse ($_) : 'N/A'} ($left, $right) );
 148     return 0;
 149   }
 150
 151   # one is a list, the other is an op with a list
 152   elsif (ref $left->[0] xor ref $right->[0]) {
 153     $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
 154       { ref $_ ? $sqlat->unparse ($_) : $_ }
 155       ($left->[0], $right->[0], $left, $right)
 156     );
 157     return 0;
 158   }
 159
 160   # both are lists
 161   elsif (ref $left->[0]) {
 162     for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
 163       if (not _eq_sql ($left->[$i], $right->[$i]) ) {
 164         if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
 165           $sql_differ ||= '';
 166           $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
 167           $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
 168         }
 169         return 0;
 170       }
 171     }
 172     return 1;
 173   }
 174
 175   # both are ops
 176   else {
 177
 178     # unroll parenthesis if possible/allowed
 179     unless ( $parenthesis_significant ) {
 180       $sqlat->_parenthesis_unroll($_) for $left, $right;
 181     }
 182
 183     if ( $left->[0] ne $right->[0] ) {
 184       $sql_differ = sprintf "OP [$left->[0]] != [$right->[0]] in\nleft: %s\nright: %s\n",
 185         $sqlat->unparse($left),
 186         $sqlat->unparse($right)
 187       ;
 188       return 0;
 189     }
 190
 191     # literals have a different arg-sig
 192     elsif ($left->[0] eq '-LITERAL') {
 193       (my $l = " $left->[1][0] " ) =~ s/\s+/ /g;
 194       (my $r = " $right->[1][0] ") =~ s/\s+/ /g;
 195       my $eq = $case_sensitive ? $l eq $r : uc($l) eq uc($r);
 196       $sql_differ = "[$l] != [$r]\n" if not $eq;
 197       return $eq;
 198     }
 199
 200     # if operators are identical, compare operands
 201     else {
 202       my $eq = _eq_sql($left->[1], $right->[1]);
 203       $sql_differ ||= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) ) if not $eq;
 204       return $eq;
 205     }
 206   }
 207 }
 208
 209 sub parse { $sqlat->parse(@_) }
 210 1;
 211
 212
 213 __END__
 214
 215 =head1 NAME
 216
 217 SQL::Abstract::Test - Helper function for testing SQL::Abstract
 218
 219 =head1 SYNOPSIS
 220
 221   use SQL::Abstract;
 222   use Test::More;
 223   use SQL::Abstract::Test import => [qw/
 224     is_same_sql_bind is_same_sql is_same_bind
 225     eq_sql_bind eq_sql eq_bind
 226   /];
 227
 228   my ($sql, @bind) = SQL::Abstract->new->select(%args);
 229
 230   is_same_sql_bind($given_sql,    \@given_bind,
 231                    $expected_sql, \@expected_bind, $test_msg);
 232
 233   is_same_sql($given_sql, $expected_sql, $test_msg);
 234   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 235
 236   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 237                             $expected_sql, \@expected_bind);
 238
 239   my $sql_same = eq_sql($given_sql, $expected_sql);
 240   my $bind_same = eq_bind(\@given_bind, \@expected_bind);
 241
 242 =head1 DESCRIPTION
 243
 244 This module is only intended for authors of tests on
 245 L<SQL::Abstract|SQL::Abstract> and related modules;
 246 it exports functions for comparing two SQL statements
 247 and their bound values.
 248
 249 The SQL comparison is performed on I<abstract syntax>,
 250 ignoring differences in spaces or in levels of parentheses.
 251 Therefore the tests will pass as long as the semantics
 252 is preserved, even if the surface syntax has changed.
 253
 254 B<Disclaimer> : the semantic equivalence handling is pretty limited.
 255 A lot of effort goes into distinguishing significant from
 256 non-significant parenthesis, including AND/OR operator associativity.
 257 Currently this module does not support commutativity and more
 258 intelligent transformations like Morgan laws, etc.
 259
 260 For a good overview of what this test framework is capable of refer
 261 to C<t/10test.t>
 262
 263 =head1 FUNCTIONS
 264
 265 =head2 is_same_sql_bind
 266
 267   is_same_sql_bind($given_sql,    \@given_bind,
 268                    $expected_sql, \@expected_bind, $test_msg);
 269
 270 Compares given and expected pairs of C<($sql, \@bind)>, and calls
 271 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
 272 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
 273 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
 274 L</is_same_bind>) that needs to be imported.
 275
 276 =head2 is_same_sql
 277
 278   is_same_sql($given_sql, $expected_sql, $test_msg);
 279
 280 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
 281 the result, with C<$test_msg> as message. If the test fails, a detailed
 282 diagnostic is printed. For clients which use L<Test::More>, this is the one of
 283 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
 284 that needs to be imported.
 285
 286 =head2 is_same_bind
 287
 288   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 289
 290 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
 291 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
 292 is printed. For clients which use L<Test::More>, this is the one of the three
 293 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
 294 to be imported.
 295
 296 =head2 eq_sql_bind
 297
 298   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 299                             $expected_sql, \@expected_bind);
 300
 301 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
 302 L</is_same_sql_bind>, but it just returns a boolean value and does not print
 303 diagnostics or talk to L<Test::Builder>.
 304
 305 =head2 eq_sql
 306
 307   my $is_same = eq_sql($given_sql, $expected_sql);
 308
 309 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
 310 but it just returns a boolean value and does not print diagnostics or talk to
 311 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
 312 will contain the SQL portion where a difference was encountered; this is useful
 313 for printing diagnostics.
 314
 315 =head2 eq_bind
 316
 317   my $is_same = eq_sql(\@given_bind, \@expected_bind);
 318
 319 Compares two lists of bind values, taking into account the fact that some of
 320 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
 321 L</is_same_bind>, but it just returns a boolean value and does not print
 322 diagnostics or talk to L<Test::Builder>.
 323
 324 =head1 GLOBAL VARIABLES
 325
 326 =head2 $case_sensitive
 327
 328 If true, SQL comparisons will be case-sensitive. Default is false;
 329
 330 =head2 $parenthesis_significant
 331
 332 If true, SQL comparison will preserve and report difference in nested
 333 parenthesis. Useful while testing C<IN (( x ))> vs C<IN ( x )>.
 334 Defaults to false;
 335
 336 =head2 $sql_differ
 337
 338 When L</eq_sql> returns false, the global variable
 339 C<$sql_differ> contains the SQL portion
 340 where a difference was encountered.
 341
 342
 343 =head1 SEE ALSO
 344
 345 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
 346
 347 =head1 AUTHORS
 348
 349 Laurent Dami, E<lt>laurent.dami AT etat  geneve  chE<gt>
 350
 351 Norbert Buchmuller <norbi@nix.hu>
 352
 353 Peter Rabbitson <ribasushi@cpan.org>
 354
 355 =head1 COPYRIGHT AND LICENSE
 356
 357 Copyright 2008 by Laurent Dami.
 358
 359 This library is free software; you can redistribute it and/or modify
 360 it under the same terms as Perl itself.