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