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