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