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 # All of these keywords allow their parameters to be specified with or without parenthesis without changing the semantics
  22 my @unrollable_ops = (
  23   'ON',
  24   'WHERE',
  25   'GROUP \s+ BY',
  26   'HAVING',
  27   'ORDER \s+ BY',
  28 );
  29
  30 sub is_same_sql_bind {
  31   my ($sql1, $bind_ref1, $sql2, $bind_ref2, $msg) = @_;
  32
  33   # compare
  34   my $same_sql  = eq_sql($sql1, $sql2);
  35   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
  36
  37   # call Test::Builder::ok
  38   my $ret = $tb->ok($same_sql && $same_bind, $msg);
  39
  40   # add debugging info
  41   if (!$same_sql) {
  42     _sql_differ_diag($sql1, $sql2);
  43   }
  44   if (!$same_bind) {
  45     _bind_differ_diag($bind_ref1, $bind_ref2);
  46   }
  47
  48   # pass ok() result further
  49   return $ret;
  50 }
  51
  52 sub is_same_sql {
  53   my ($sql1, $sql2, $msg) = @_;
  54
  55   # compare
  56   my $same_sql  = eq_sql($sql1, $sql2);
  57
  58   # call Test::Builder::ok
  59   my $ret = $tb->ok($same_sql, $msg);
  60
  61   # add debugging info
  62   if (!$same_sql) {
  63     _sql_differ_diag($sql1, $sql2);
  64   }
  65
  66   # pass ok() result further
  67   return $ret;
  68 }
  69
  70 sub is_same_bind {
  71   my ($bind_ref1, $bind_ref2, $msg) = @_;
  72
  73   # compare
  74   my $same_bind = eq_bind($bind_ref1, $bind_ref2);
  75
  76   # call Test::Builder::ok
  77   my $ret = $tb->ok($same_bind, $msg);
  78
  79   # add debugging info
  80   if (!$same_bind) {
  81     _bind_differ_diag($bind_ref1, $bind_ref2);
  82   }
  83
  84   # pass ok() result further
  85   return $ret;
  86 }
  87
  88 sub _sql_differ_diag {
  89   my ($sql1, $sql2) = @_;
  90
  91   $tb->diag("SQL expressions differ\n"
  92       ."     got: $sql1\n"
  93       ."expected: $sql2\n"
  94       ."differing in :\n$sql_differ\n"
  95       );
  96 }
  97
  98 sub _bind_differ_diag {
  99   my ($bind_ref1, $bind_ref2) = @_;
 100
 101   $tb->diag("BIND values differ\n"
 102       ."     got: " . Dumper($bind_ref1)
 103       ."expected: " . Dumper($bind_ref2)
 104       );
 105 }
 106
 107 sub eq_sql_bind {
 108   my ($sql1, $bind_ref1, $sql2, $bind_ref2) = @_;
 109
 110   return eq_sql($sql1, $sql2) && eq_bind($bind_ref1, $bind_ref2);
 111 }
 112
 113
 114 sub eq_bind {
 115   my ($bind_ref1, $bind_ref2) = @_;
 116
 117   local $Data::Dumper::Useqq = 1;
 118   local $Data::Dumper::Sortkeys = 1;
 119
 120   return Dumper($bind_ref1) eq Dumper($bind_ref2);
 121 }
 122
 123 sub eq_sql {
 124   my ($sql1, $sql2) = @_;
 125
 126   # parse
 127   my $tree1 = $sqlat->parse($sql1);
 128   my $tree2 = $sqlat->parse($sql2);
 129
 130   return 1 if _eq_sql($tree1, $tree2);
 131 }
 132
 133 sub _eq_sql {
 134   my ($left, $right) = @_;
 135
 136   # one is defined the other not
 137   if ( (defined $left) xor (defined $right) ) {
 138     return 0;
 139   }
 140   # one is undefined, then so is the other
 141   elsif (not defined $left) {
 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_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 _parenthesis_unroll {
 188   my $ast = shift;
 189
 190   return if $parenthesis_significant;
 191   return unless (ref $ast and ref $ast->[1]);
 192
 193   my $changes;
 194   do {
 195     my @children;
 196     $changes = 0;
 197
 198     for my $child (@{$ast->[1]}) {
 199       if (not ref $child or not $child->[0] eq 'PAREN') {
 200         push @children, $child;
 201         next;
 202       }
 203
 204       # unroll nested parenthesis
 205       while ($child->[1][0][0] eq 'PAREN') {
 206         $child = $child->[1][0];
 207         $changes++;
 208       }
 209
 210       # if the parenthesis are wrapped around an AND/OR matching the parent AND/OR - open the parenthesis up and merge the list
 211       if (
 212         ( $ast->[0] eq 'AND' or $ast->[0] eq 'OR')
 213             and
 214           $child->[1][0][0] eq $ast->[0]
 215       ) {
 216         push @children, @{$child->[1][0][1]};
 217         $changes++;
 218       }
 219
 220       # if the parent operator explcitly allows it nuke the parenthesis
 221       elsif ( grep { $ast->[0] =~ /^ $_ $/xi } @unrollable_ops ) {
 222         push @children, $child->[1][0];
 223         $changes++;
 224       }
 225
 226       # only one LITERAL element in the parenthesis
 227       elsif (
 228         @{$child->[1]} == 1 && $child->[1][0][0] eq 'LITERAL'
 229       ) {
 230         push @children, $child->[1][0];
 231         $changes++;
 232       }
 233
 234       # only one element in the parenthesis which is a binary op with two LITERAL sub-children
 235       elsif (
 236         @{$child->[1]} == 1
 237           and
 238         grep { $child->[1][0][0] =~ /^ $_ $/xi } (SQL::Abstract::Tree::_binary_op_keywords())
 239           and
 240         $child->[1][0][1][0][0] eq 'LITERAL'
 241           and
 242         $child->[1][0][1][1][0] eq 'LITERAL'
 243       ) {
 244         push @children, $child->[1][0];
 245         $changes++;
 246       }
 247
 248       # otherwise no more mucking for this pass
 249       else {
 250         push @children, $child;
 251       }
 252     }
 253
 254     $ast->[1] = \@children;
 255
 256   } while ($changes);
 257
 258 }
 259
 260 1;
 261
 262
 263 __END__
 264
 265 =head1 NAME
 266
 267 SQL::Abstract::Test - Helper function for testing SQL::Abstract
 268
 269 =head1 SYNOPSIS
 270
 271   use SQL::Abstract;
 272   use Test::More;
 273   use SQL::Abstract::Test import => [qw/
 274     is_same_sql_bind is_same_sql is_same_bind
 275     eq_sql_bind eq_sql eq_bind
 276   /];
 277
 278   my ($sql, @bind) = SQL::Abstract->new->select(%args);
 279
 280   is_same_sql_bind($given_sql,    \@given_bind,
 281                    $expected_sql, \@expected_bind, $test_msg);
 282
 283   is_same_sql($given_sql, $expected_sql, $test_msg);
 284   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 285
 286   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 287                             $expected_sql, \@expected_bind);
 288
 289   my $sql_same = eq_sql($given_sql, $expected_sql);
 290   my $bind_same = eq_bind(\@given_bind, \@expected_bind);
 291
 292 =head1 DESCRIPTION
 293
 294 This module is only intended for authors of tests on
 295 L<SQL::Abstract|SQL::Abstract> and related modules;
 296 it exports functions for comparing two SQL statements
 297 and their bound values.
 298
 299 The SQL comparison is performed on I<abstract syntax>,
 300 ignoring differences in spaces or in levels of parentheses.
 301 Therefore the tests will pass as long as the semantics
 302 is preserved, even if the surface syntax has changed.
 303
 304 B<Disclaimer> : the semantic equivalence handling is pretty limited.
 305 A lot of effort goes into distinguishing significant from
 306 non-significant parenthesis, including AND/OR operator associativity.
 307 Currently this module does not support commutativity and more
 308 intelligent transformations like Morgan laws, etc.
 309
 310 For a good overview of what this test framework is capable of refer
 311 to C<t/10test.t>
 312
 313 =head1 FUNCTIONS
 314
 315 =head2 is_same_sql_bind
 316
 317   is_same_sql_bind($given_sql,    \@given_bind,
 318                    $expected_sql, \@expected_bind, $test_msg);
 319
 320 Compares given and expected pairs of C<($sql, \@bind)>, and calls
 321 L<Test::Builder/ok> on the result, with C<$test_msg> as message. If the test
 322 fails, a detailed diagnostic is printed. For clients which use L<Test::More>,
 323 this is the one of the three functions (L</is_same_sql_bind>, L</is_same_sql>,
 324 L</is_same_bind>) that needs to be imported.
 325
 326 =head2 is_same_sql
 327
 328   is_same_sql($given_sql, $expected_sql, $test_msg);
 329
 330 Compares given and expected SQL statements, and calls L<Test::Builder/ok> on
 331 the result, with C<$test_msg> as message. If the test fails, a detailed
 332 diagnostic is printed. For clients which use L<Test::More>, this is the one of
 333 the three functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>)
 334 that needs to be imported.
 335
 336 =head2 is_same_bind
 337
 338   is_same_bind(\@given_bind, \@expected_bind, $test_msg);
 339
 340 Compares given and expected bind values, and calls L<Test::Builder/ok> on the
 341 result, with C<$test_msg> as message. If the test fails, a detailed diagnostic
 342 is printed. For clients which use L<Test::More>, this is the one of the three
 343 functions (L</is_same_sql_bind>, L</is_same_sql>, L</is_same_bind>) that needs
 344 to be imported.
 345
 346 =head2 eq_sql_bind
 347
 348   my $is_same = eq_sql_bind($given_sql,    \@given_bind,
 349                             $expected_sql, \@expected_bind);
 350
 351 Compares given and expected pairs of C<($sql, \@bind)>. Similar to
 352 L</is_same_sql_bind>, but it just returns a boolean value and does not print
 353 diagnostics or talk to L<Test::Builder>.
 354
 355 =head2 eq_sql
 356
 357   my $is_same = eq_sql($given_sql, $expected_sql);
 358
 359 Compares the abstract syntax of two SQL statements. Similar to L</is_same_sql>,
 360 but it just returns a boolean value and does not print diagnostics or talk to
 361 L<Test::Builder>. If the result is false, the global variable L</$sql_differ>
 362 will contain the SQL portion where a difference was encountered; this is useful
 363 for printing diagnostics.
 364
 365 =head2 eq_bind
 366
 367   my $is_same = eq_sql(\@given_bind, \@expected_bind);
 368
 369 Compares two lists of bind values, taking into account the fact that some of
 370 the values may be arrayrefs (see L<SQL::Abstract/bindtype>). Similar to
 371 L</is_same_bind>, but it just returns a boolean value and does not print
 372 diagnostics or talk to L<Test::Builder>.
 373
 374 =head1 GLOBAL VARIABLES
 375
 376 =head2 $case_sensitive
 377
 378 If true, SQL comparisons will be case-sensitive. Default is false;
 379
 380 =head2 $parenthesis_significant
 381
 382 If true, SQL comparison will preserve and report difference in nested
 383 parenthesis. Useful for testing the C<-nest> modifier. Defaults to false;
 384
 385 =head2 $sql_differ
 386
 387 When L</eq_sql> returns false, the global variable
 388 C<$sql_differ> contains the SQL portion
 389 where a difference was encountered.
 390
 391
 392 =head1 SEE ALSO
 393
 394 L<SQL::Abstract>, L<Test::More>, L<Test::Builder>.
 395
 396 =head1 AUTHORS
 397
 398 Laurent Dami, E<lt>laurent.dami AT etat  geneve  chE<gt>
 399
 400 Norbert Buchmuller <norbi@nix.hu>
 401
 402 Peter Rabbitson <ribasushi@cpan.org>
 403
 404 =head1 COPYRIGHT AND LICENSE
 405
 406 Copyright 2008 by Laurent Dami.
 407
 408 This library is free software; you can redistribute it and/or modify
 409 it under the same terms as Perl itself.