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 $order_by_asc_significant = 0;
  20
  21 our $sql_differ; # keeps track of differing portion between SQLs
  22 our $tb = __PACKAGE__->builder;
  23
  24 sub is_same_sql_bind {
  25   my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
  26
  27   # compare
  28   my $same_sql  = eq_sql($sql1, $sql2);
  29   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
  30
  31   # call Test::Builder::ok
  32   my $ret = $tb->ok($same_sql && $same_bind, $msg);
  33
  34   # add debugging info
  35   if (!$same_sql) {
  36     _sql_differ_diag($sql1, $sql2);
  37   }
  38   if (!$same_bind) {
  39     _bind_differ_diag($bind_ref1, $bind_ref2);
  40   }
  41
  42   # pass ok() result further
  43   return $ret;
  44 }
  45
  46 sub is_same_sql {
  47   my ($sql1, $sql2, $msg) = @_;
  48
  49   # compare
  50   my $same_sql  = eq_sql($sql1, $sql2);
  51
  52   # call Test::Builder::ok
  53   my $ret = $tb->ok($same_sql, $msg);
  54
  55   # add debugging info
  56   if (!$same_sql) {
  57     _sql_differ_diag($sql1, $sql2);
  58   }
  59
  60   # pass ok() result further
  61   return $ret;
  62 }
  63
  64 sub is_same_bind {
  65   my ($bind_ref1, $bind_ref2, $msg) = @_;
  66
  67   # compare
  68   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
  69
  70   # call Test::Builder::ok
  71   my $ret = $tb->ok($same_bind, $msg);
  72
  73   # add debugging info
  74   if (!$same_bind) {
  75     _bind_differ_diag($bind_ref1, $bind_ref2);
  76   }
  77
  78   # pass ok() result further
  79   return $ret;
  80 }
  81
  82 sub _sql_differ_diag {
  83   my ($sql1, $sql2) = @_;
  84
  85   $tb->diag("SQL expressions differ\n"
  86       ."     got: $sql1\n"
  87       ."expected: $sql2\n"
  88       ."differing in :\n$sql_differ\n"
  89       );
  90 }
  91
  92 sub _bind_differ_diag {
  93   my ($bind_ref1, $bind_ref2) = @_;
  94
  95   $tb->diag("BIND values differ\n"
  96       ."     got: " . Dumper($bind_ref1)
  97       ."expected: " . Dumper($bind_ref2)
  98       );
  99 }
 100
 101 sub eq_sql_bind {
 102   my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
 103
 104   return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
 105 }
 106
 107
 108 sub eq_bind { goto &Test::Deep::eq_deeply };
 109
 110 sub eq_sql {
 111   my ($sql1, $sql2) = @_;
 112
 113   # parse
 114   my $tree1 = $sqlat->parse($sql1);
 115   my $tree2 = $sqlat->parse($sql2);
 116
 117   undef $sql_differ;
 118   return 1 if _eq_sql($tree1, $tree2);
 119 }
 120
 121 sub _eq_sql {
 122   my ($left, $right) = @_;
 123
 124   # one is defined the other not
 125   if ( (defined $left) xor (defined $right) ) {
 126     $sql_differ = sprintf ("[%s] != [%s]\n", map { defined $_ ? $sqlat->unparse ($_) : 'N/A' } ($left, $right) );
 127     return 0;
 128   }
 129
 130   # one is undefined, then so is the other
 131   elsif (not defined $left) {
 132     return 1;
 133   }
 134
 135   # both are empty
 136   elsif (@$left == 0 and @$right == 0) {
 137     return 1;
 138   }
 139
 140   # one is empty
 141   if (@$left == 0 or @$right == 0) {
 142     $sql_differ = sprintf ("left: %s\nright: %s\n", map { @$_ ? $sqlat->unparse ($_) : 'N/A'} ($left, $right) );
 143     return 0;
 144   }
 145
 146   # one is a list, the other is an op with a list
 147   elsif (ref $left->[0] xor ref $right->[0]) {
 148     $sql_differ = sprintf ("[%s] != [%s]\nleft: %s\nright: %s\n", map
 149       { ref $_ ? $sqlat->unparse ($_) : $_ }
 150       ($left->[0], $right->[0], $left, $right)
 151     );
 152     return 0;
 153   }
 154
 155   # both are lists
 156   elsif (ref $left->[0]) {
 157     for (my $i = 0; $i <= $#$left or $i <= $#$right; $i++ ) {
 158       if (not _eq_sql ($left->[$i], $right->[$i]) ) {
 159         if (! $sql_differ or $sql_differ !~ /left\:\s .+ right:\s/xs) {
 160           $sql_differ ||= '';
 161           $sql_differ .= "\n" unless $sql_differ =~ /\n\z/;
 162           $sql_differ .= sprintf ("left: %s\nright: %s\n", map { $sqlat->unparse ($_) } ($left, $right) );
 163         }
 164         return 0;
 165       }
 166     }
 167     return 1;
 168   }
 169
 170   # both are ops
 171   else {
 172
 173     # unroll parenthesis if possible/allowed
 174     unless ( $parenthesis_significant ) {
 175       $sqlat->_parenthesis_unroll($_) for $left, $right;
 176     }
 177
 178     # unroll ASC order by's
 179     unless ($order_by_asc_significant) {
 180       $sqlat->_strip_asc_from_order_by($_) 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 $order_by_asc_significant
 337
 338 If true SQL comparison will consider C<ORDER BY foo ASC> and
 339 C<ORDER BY foo> to be different. Default is false;
 340
 341 =head2 $sql_differ
 342
 343 When L</eq_sql> returns false, the global variable
 344 C<$sql_differ> contains the SQL portion
 345 where a difference was encountered.
 346
 347
 348 =head1 SEE ALSO
 349
 350 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
 351
 352 =head1 AUTHORS
 353
 354 Laurent Dami, E<lt>laurent.dami AT etat  geneve  chE<gt>
 355
 356 Norbert Buchmuller <norbi@nix.hu>
 357
 358 Peter Rabbitson <ribasushi@cpan.org>
 359
 360 =head1 COPYRIGHT AND LICENSE
 361
 362 Copyright 2008 by Laurent Dami.
 363
 364 This library is free software; you can redistribute it and/or modify
 365 it under the same terms as Perl itself.